diff options
| author | shmel1k <[email protected]> | 2022-09-02 12:44:59 +0300 |
|---|---|---|
| committer | shmel1k <[email protected]> | 2022-09-02 12:44:59 +0300 |
| commit | 90d450f74722da7859d6f510a869f6c6908fd12f (patch) | |
| tree | 538c718dedc76cdfe37ad6d01ff250dd930d9278 /contrib/libs/cblas | |
| parent | 01f64c1ecd0d4ffa9e3a74478335f1745f26cc75 (diff) | |
[] add metering mode to CLI
Diffstat (limited to 'contrib/libs/cblas')
319 files changed, 61638 insertions, 0 deletions
diff --git a/contrib/libs/cblas/COPYING b/contrib/libs/cblas/COPYING new file mode 100644 index 00000000000..d7bf9538203 --- /dev/null +++ b/contrib/libs/cblas/COPYING @@ -0,0 +1,36 @@ +Copyright (c) 1992-2008 The University of Tennessee. All rights reserved. + +$COPYRIGHT$ + +Additional copyrights may follow + +$HEADER$ + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer listed + in this license in the documentation and/or other materials + provided with the distribution. + +- Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/contrib/libs/cblas/blaswrap.h b/contrib/libs/cblas/blaswrap.h new file mode 100644 index 00000000000..4780b4001ea --- /dev/null +++ b/contrib/libs/cblas/blaswrap.h @@ -0,0 +1,160 @@ +/* CLAPACK 3.0 BLAS wrapper macros + * Feb 5, 2000 + */ + +#ifndef __BLASWRAP_H +#define __BLASWRAP_H + +#ifndef NO_BLAS_WRAP + +/* BLAS1 routines */ +#define srotg_ f2c_srotg +#define crotg_ f2c_crotg +#define drotg_ f2c_drotg +#define zrotg_ f2c_zrotg +#define srotmg_ f2c_srotmg +#define drotmg_ f2c_drotmg +#define srot_ f2c_srot +#define drot_ f2c_drot +#define srotm_ f2c_srotm +#define drotm_ f2c_drotm +#define sswap_ f2c_sswap +#define dswap_ f2c_dswap +#define cswap_ f2c_cswap +#define zswap_ f2c_zswap +#define sscal_ f2c_sscal +#define dscal_ f2c_dscal +#define cscal_ f2c_cscal +#define zscal_ f2c_zscal +#define csscal_ f2c_csscal +#define zdscal_ f2c_zdscal +#define scopy_ f2c_scopy +#define dcopy_ f2c_dcopy +#define ccopy_ f2c_ccopy +#define zcopy_ f2c_zcopy +#define saxpy_ f2c_saxpy +#define daxpy_ f2c_daxpy +#define caxpy_ f2c_caxpy +#define zaxpy_ f2c_zaxpy +#define sdot_ f2c_sdot +#define ddot_ f2c_ddot +#define cdotu_ f2c_cdotu +#define zdotu_ f2c_zdotu +#define cdotc_ f2c_cdotc +#define zdotc_ f2c_zdotc +#define snrm2_ f2c_snrm2 +#define dnrm2_ f2c_dnrm2 +#define scnrm2_ f2c_scnrm2 +#define dznrm2_ f2c_dznrm2 +#define sasum_ f2c_sasum +#define dasum_ f2c_dasum +#define scasum_ f2c_scasum +#define dzasum_ f2c_dzasum +#define isamax_ f2c_isamax +#define idamax_ f2c_idamax +#define icamax_ f2c_icamax +#define izamax_ f2c_izamax + +/* BLAS2 routines */ +#define sgemv_ f2c_sgemv +#define dgemv_ f2c_dgemv +#define cgemv_ f2c_cgemv +#define zgemv_ f2c_zgemv +#define sgbmv_ f2c_sgbmv +#define dgbmv_ f2c_dgbmv +#define cgbmv_ f2c_cgbmv +#define zgbmv_ f2c_zgbmv +#define chemv_ f2c_chemv +#define zhemv_ f2c_zhemv +#define chbmv_ f2c_chbmv +#define zhbmv_ f2c_zhbmv +#define chpmv_ f2c_chpmv +#define zhpmv_ f2c_zhpmv +#define ssymv_ f2c_ssymv +#define dsymv_ f2c_dsymv +#define ssbmv_ f2c_ssbmv +#define dsbmv_ f2c_dsbmv +#define sspmv_ f2c_sspmv +#define dspmv_ f2c_dspmv +#define strmv_ f2c_strmv +#define dtrmv_ f2c_dtrmv +#define ctrmv_ f2c_ctrmv +#define ztrmv_ f2c_ztrmv +#define stbmv_ f2c_stbmv +#define dtbmv_ f2c_dtbmv +#define ctbmv_ f2c_ctbmv +#define ztbmv_ f2c_ztbmv +#define stpmv_ f2c_stpmv +#define dtpmv_ f2c_dtpmv +#define ctpmv_ f2c_ctpmv +#define ztpmv_ f2c_ztpmv +#define strsv_ f2c_strsv +#define dtrsv_ f2c_dtrsv +#define ctrsv_ f2c_ctrsv +#define ztrsv_ f2c_ztrsv +#define stbsv_ f2c_stbsv +#define dtbsv_ f2c_dtbsv +#define ctbsv_ f2c_ctbsv +#define ztbsv_ f2c_ztbsv +#define stpsv_ f2c_stpsv +#define dtpsv_ f2c_dtpsv +#define ctpsv_ f2c_ctpsv +#define ztpsv_ f2c_ztpsv +#define sger_ f2c_sger +#define dger_ f2c_dger +#define cgeru_ f2c_cgeru +#define zgeru_ f2c_zgeru +#define cgerc_ f2c_cgerc +#define zgerc_ f2c_zgerc +#define cher_ f2c_cher +#define zher_ f2c_zher +#define chpr_ f2c_chpr +#define zhpr_ f2c_zhpr +#define cher2_ f2c_cher2 +#define zher2_ f2c_zher2 +#define chpr2_ f2c_chpr2 +#define zhpr2_ f2c_zhpr2 +#define ssyr_ f2c_ssyr +#define dsyr_ f2c_dsyr +#define sspr_ f2c_sspr +#define dspr_ f2c_dspr +#define ssyr2_ f2c_ssyr2 +#define dsyr2_ f2c_dsyr2 +#define sspr2_ f2c_sspr2 +#define dspr2_ f2c_dspr2 + +/* BLAS3 routines */ +#define sgemm_ f2c_sgemm +#define dgemm_ f2c_dgemm +#define cgemm_ f2c_cgemm +#define zgemm_ f2c_zgemm +#define ssymm_ f2c_ssymm +#define dsymm_ f2c_dsymm +#define csymm_ f2c_csymm +#define zsymm_ f2c_zsymm +#define chemm_ f2c_chemm +#define zhemm_ f2c_zhemm +#define ssyrk_ f2c_ssyrk +#define dsyrk_ f2c_dsyrk +#define csyrk_ f2c_csyrk +#define zsyrk_ f2c_zsyrk +#define cherk_ f2c_cherk +#define zherk_ f2c_zherk +#define ssyr2k_ f2c_ssyr2k +#define dsyr2k_ f2c_dsyr2k +#define csyr2k_ f2c_csyr2k +#define zsyr2k_ f2c_zsyr2k +#define cher2k_ f2c_cher2k +#define zher2k_ f2c_zher2k +#define strmm_ f2c_strmm +#define dtrmm_ f2c_dtrmm +#define ctrmm_ f2c_ctrmm +#define ztrmm_ f2c_ztrmm +#define strsm_ f2c_strsm +#define dtrsm_ f2c_dtrsm +#define ctrsm_ f2c_ctrsm +#define ztrsm_ f2c_ztrsm + +#endif /* NO_BLAS_WRAP */ + +#endif /* __BLASWRAP_H */ diff --git a/contrib/libs/cblas/caxpy.c b/contrib/libs/cblas/caxpy.c new file mode 100644 index 00000000000..fe01b4ecd74 --- /dev/null +++ b/contrib/libs/cblas/caxpy.c @@ -0,0 +1,103 @@ +/* caxpy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int caxpy_(integer *n, complex *ca, complex *cx, integer * + incx, complex *cy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1, q__2; + + /* Local variables */ + integer i__, ix, iy; + extern doublereal scabs1_(complex *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CAXPY constant times a vector plus a vector. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (scabs1_(ca) == 0.f) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + i__4 = ix; + q__2.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__2.i = ca->r * cx[ + i__4].i + ca->i * cx[i__4].r; + q__1.r = cy[i__3].r + q__2.r, q__1.i = cy[i__3].i + q__2.i; + cy[i__2].r = q__1.r, cy[i__2].i = q__1.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + q__2.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__2.i = ca->r * cx[ + i__4].i + ca->i * cx[i__4].r; + q__1.r = cy[i__3].r + q__2.r, q__1.i = cy[i__3].i + q__2.i; + cy[i__2].r = q__1.r, cy[i__2].i = q__1.i; +/* L30: */ + } + return 0; +} /* caxpy_ */ diff --git a/contrib/libs/cblas/cblas.h b/contrib/libs/cblas/cblas.h new file mode 100644 index 00000000000..f91557e74d4 --- /dev/null +++ b/contrib/libs/cblas/cblas.h @@ -0,0 +1,575 @@ +#ifndef CBLAS_H +#define CBLAS_H +#include <stddef.h> + +/* + * Enumerated and derived types + */ +#define CBLAS_INDEX size_t /* this may vary between platforms */ + +enum CBLAS_ORDER {CblasRowMajor=101, CblasColMajor=102}; +enum CBLAS_TRANSPOSE {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113}; +enum CBLAS_UPLO {CblasUpper=121, CblasLower=122}; +enum CBLAS_DIAG {CblasNonUnit=131, CblasUnit=132}; +enum CBLAS_SIDE {CblasLeft=141, CblasRight=142}; + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * =========================================================================== + * Prototypes for level 1 BLAS functions (complex are recast as routines) + * =========================================================================== + */ +float cblas_sdsdot(const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY); +double cblas_dsdot(const int N, const float *X, const int incX, const float *Y, + const int incY); +float cblas_sdot(const int N, const float *X, const int incX, + const float *Y, const int incY); +double cblas_ddot(const int N, const double *X, const int incX, + const double *Y, const int incY); + +/* + * Functions having prefixes Z and C only + */ +void cblas_cdotu_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu); +void cblas_cdotc_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc); + +void cblas_zdotu_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu); +void cblas_zdotc_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc); + + +/* + * Functions having prefixes S D SC DZ + */ +float cblas_snrm2(const int N, const float *X, const int incX); +float cblas_sasum(const int N, const float *X, const int incX); + +double cblas_dnrm2(const int N, const double *X, const int incX); +double cblas_dasum(const int N, const double *X, const int incX); + +float cblas_scnrm2(const int N, const void *X, const int incX); +float cblas_scasum(const int N, const void *X, const int incX); + +double cblas_dznrm2(const int N, const void *X, const int incX); +double cblas_dzasum(const int N, const void *X, const int incX); + + +/* + * Functions having standard 4 prefixes (S D C Z) + */ +CBLAS_INDEX cblas_isamax(const int N, const float *X, const int incX); +CBLAS_INDEX cblas_idamax(const int N, const double *X, const int incX); +CBLAS_INDEX cblas_icamax(const int N, const void *X, const int incX); +CBLAS_INDEX cblas_izamax(const int N, const void *X, const int incX); + +/* + * =========================================================================== + * Prototypes for level 1 BLAS routines + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (s, d, c, z) + */ +void cblas_sswap(const int N, float *X, const int incX, + float *Y, const int incY); +void cblas_scopy(const int N, const float *X, const int incX, + float *Y, const int incY); +void cblas_saxpy(const int N, const float alpha, const float *X, + const int incX, float *Y, const int incY); + +void cblas_dswap(const int N, double *X, const int incX, + double *Y, const int incY); +void cblas_dcopy(const int N, const double *X, const int incX, + double *Y, const int incY); +void cblas_daxpy(const int N, const double alpha, const double *X, + const int incX, double *Y, const int incY); + +void cblas_cswap(const int N, void *X, const int incX, + void *Y, const int incY); +void cblas_ccopy(const int N, const void *X, const int incX, + void *Y, const int incY); +void cblas_caxpy(const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY); + +void cblas_zswap(const int N, void *X, const int incX, + void *Y, const int incY); +void cblas_zcopy(const int N, const void *X, const int incX, + void *Y, const int incY); +void cblas_zaxpy(const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY); + + +/* + * Routines with S and D prefix only + */ +void cblas_srotg(float *a, float *b, float *c, float *s); +void cblas_srotmg(float *d1, float *d2, float *b1, const float b2, float *P); +void cblas_srot(const int N, float *X, const int incX, + float *Y, const int incY, const float c, const float s); +void cblas_srotm(const int N, float *X, const int incX, + float *Y, const int incY, const float *P); + +void cblas_drotg(double *a, double *b, double *c, double *s); +void cblas_drotmg(double *d1, double *d2, double *b1, const double b2, double *P); +void cblas_drot(const int N, double *X, const int incX, + double *Y, const int incY, const double c, const double s); +void cblas_drotm(const int N, double *X, const int incX, + double *Y, const int incY, const double *P); + + +/* + * Routines with S D C Z CS and ZD prefixes + */ +void cblas_sscal(const int N, const float alpha, float *X, const int incX); +void cblas_dscal(const int N, const double alpha, double *X, const int incX); +void cblas_cscal(const int N, const void *alpha, void *X, const int incX); +void cblas_zscal(const int N, const void *alpha, void *X, const int incX); +void cblas_csscal(const int N, const float alpha, void *X, const int incX); +void cblas_zdscal(const int N, const double alpha, void *X, const int incX); + +/* + * =========================================================================== + * Prototypes for level 2 BLAS + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (S, D, C, Z) + */ +void cblas_sgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY); +void cblas_sgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const float alpha, + const float *A, const int lda, const float *X, + const int incX, const float beta, float *Y, const int incY); +void cblas_strmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *A, const int lda, + float *X, const int incX); +void cblas_stbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX); +void cblas_stpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX); +void cblas_strsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *A, const int lda, float *X, + const int incX); +void cblas_stbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX); +void cblas_stpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX); + +void cblas_dgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY); +void cblas_dgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const double alpha, + const double *A, const int lda, const double *X, + const int incX, const double beta, double *Y, const int incY); +void cblas_dtrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *A, const int lda, + double *X, const int incX); +void cblas_dtbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX); +void cblas_dtpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX); +void cblas_dtrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *A, const int lda, double *X, + const int incX); +void cblas_dtbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX); +void cblas_dtpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX); + +void cblas_cgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY); +void cblas_cgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const void *alpha, + const void *A, const int lda, const void *X, + const int incX, const void *beta, void *Y, const int incY); +void cblas_ctrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX); +void cblas_ctbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ctpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); +void cblas_ctrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX); +void cblas_ctbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ctpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); + +void cblas_zgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY); +void cblas_zgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const void *alpha, + const void *A, const int lda, const void *X, + const int incX, const void *beta, void *Y, const int incY); +void cblas_ztrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX); +void cblas_ztbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ztpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); +void cblas_ztrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX); +void cblas_ztbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ztpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); + + +/* + * Routines with S and D prefixes only + */ +void cblas_ssymv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_ssbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const int K, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_sspmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *Ap, + const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_sger(const enum CBLAS_ORDER order, const int M, const int N, + const float alpha, const float *X, const int incX, + const float *Y, const int incY, float *A, const int lda); +void cblas_ssyr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *A, const int lda); +void cblas_sspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *Ap); +void cblas_ssyr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A, + const int lda); +void cblas_sspr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A); + +void cblas_dsymv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *A, + const int lda, const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dsbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const int K, const double alpha, const double *A, + const int lda, const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dspmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *Ap, + const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dger(const enum CBLAS_ORDER order, const int M, const int N, + const double alpha, const double *X, const int incX, + const double *Y, const int incY, double *A, const int lda); +void cblas_dsyr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *A, const int lda); +void cblas_dspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *Ap); +void cblas_dsyr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A, + const int lda); +void cblas_dspr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A); + + +/* + * Routines with C and Z prefixes only + */ +void cblas_chemv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_chbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const int K, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_chpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *Ap, + const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_cgeru(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_cgerc(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_cher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, const int incX, + void *A, const int lda); +void cblas_chpr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, + const int incX, void *A); +void cblas_cher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_chpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *Ap); + +void cblas_zhemv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zhbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const int K, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zhpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *Ap, + const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zgeru(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zgerc(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, const int incX, + void *A, const int lda); +void cblas_zhpr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, + const int incX, void *A); +void cblas_zher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *Ap); + +/* + * =========================================================================== + * Prototypes for level 3 BLAS + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (S, D, C, Z) + */ +void cblas_sgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc); +void cblas_ssymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc); +void cblas_ssyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float beta, float *C, const int ldc); +void cblas_ssyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc); +void cblas_strmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb); +void cblas_strsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb); + +void cblas_dgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc); +void cblas_dsymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc); +void cblas_dsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double beta, double *C, const int ldc); +void cblas_dsyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc); +void cblas_dtrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb); +void cblas_dtrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb); + +void cblas_cgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); +void cblas_csymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_csyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc); +void cblas_csyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_ctrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); +void cblas_ctrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); + +void cblas_zgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); +void cblas_zsymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_zsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc); +void cblas_zsyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_ztrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); +void cblas_ztrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); + + +/* + * Routines with prefixes C and Z only + */ +void cblas_chemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_cherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const void *A, const int lda, + const float beta, void *C, const int ldc); +void cblas_cher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const float beta, + void *C, const int ldc); + +void cblas_zhemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_zherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const void *A, const int lda, + const double beta, void *C, const int ldc); +void cblas_zher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const double beta, + void *C, const int ldc); + +void cblas_xerbla(int p, const char *rout, const char *form, ...); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/contrib/libs/cblas/cblas_f77.h b/contrib/libs/cblas/cblas_f77.h new file mode 100644 index 00000000000..18435cd301b --- /dev/null +++ b/contrib/libs/cblas/cblas_f77.h @@ -0,0 +1,701 @@ +/* + * cblas_f77.h + * Written by Keita Teranishi + * + * Updated by Jeff Horner + * Merged cblas_f77.h and cblas_fortran_header.h + */ + +#ifndef CBLAS_F77_H +#define CBLAS_f77_H + +#ifdef CRAY + #include <fortran.h> + #define F77_CHAR _fcd + #define C2F_CHAR(a) ( _cptofcd( (a), 1 ) ) + #define C2F_STR(a, i) ( _cptofcd( (a), (i) ) ) + #define F77_STRLEN(a) (_fcdlen) +#endif + +#ifdef WeirdNEC + #define F77_INT long +#endif + +#ifdef F77_CHAR + #define FCHAR F77_CHAR +#else + #define FCHAR char * +#endif + +#ifdef F77_INT + #define FINT const F77_INT * + #define FINT2 F77_INT * +#else + #define FINT const int * + #define FINT2 int * +#endif + +#if defined(ADD_) +/* + * Level 1 BLAS + */ +#define F77_xerbla xerbla_ + #define F77_srotg srotg_ + #define F77_srotmg srotmg_ + #define F77_srot srot_ + #define F77_srotm srotm_ + #define F77_drotg drotg_ + #define F77_drotmg drotmg_ + #define F77_drot drot_ + #define F77_drotm drotm_ + #define F77_sswap sswap_ + #define F77_scopy scopy_ + #define F77_saxpy saxpy_ + #define F77_isamax_sub isamaxsub_ + #define F77_dswap dswap_ + #define F77_dcopy dcopy_ + #define F77_daxpy daxpy_ + #define F77_idamax_sub idamaxsub_ + #define F77_cswap cswap_ + #define F77_ccopy ccopy_ + #define F77_caxpy caxpy_ + #define F77_icamax_sub icamaxsub_ + #define F77_zswap zswap_ + #define F77_zcopy zcopy_ + #define F77_zaxpy zaxpy_ + #define F77_izamax_sub izamaxsub_ + #define F77_sdot_sub sdotsub_ + #define F77_ddot_sub ddotsub_ + #define F77_dsdot_sub dsdotsub_ + #define F77_sscal sscal_ + #define F77_dscal dscal_ + #define F77_cscal cscal_ + #define F77_zscal zscal_ + #define F77_csscal csscal_ + #define F77_zdscal zdscal_ + #define F77_cdotu_sub cdotusub_ + #define F77_cdotc_sub cdotcsub_ + #define F77_zdotu_sub zdotusub_ + #define F77_zdotc_sub zdotcsub_ + #define F77_snrm2_sub snrm2sub_ + #define F77_sasum_sub sasumsub_ + #define F77_dnrm2_sub dnrm2sub_ + #define F77_dasum_sub dasumsub_ + #define F77_scnrm2_sub scnrm2sub_ + #define F77_scasum_sub scasumsub_ + #define F77_dznrm2_sub dznrm2sub_ + #define F77_dzasum_sub dzasumsub_ + #define F77_sdsdot_sub sdsdotsub_ +/* + * Level 2 BLAS + */ + #define F77_ssymv ssymv_ + #define F77_ssbmv ssbmv_ + #define F77_sspmv sspmv_ + #define F77_sger sger_ + #define F77_ssyr ssyr_ + #define F77_sspr sspr_ + #define F77_ssyr2 ssyr2_ + #define F77_sspr2 sspr2_ + #define F77_dsymv dsymv_ + #define F77_dsbmv dsbmv_ + #define F77_dspmv dspmv_ + #define F77_dger dger_ + #define F77_dsyr dsyr_ + #define F77_dspr dspr_ + #define F77_dsyr2 dsyr2_ + #define F77_dspr2 dspr2_ + #define F77_chemv chemv_ + #define F77_chbmv chbmv_ + #define F77_chpmv chpmv_ + #define F77_cgeru cgeru_ + #define F77_cgerc cgerc_ + #define F77_cher cher_ + #define F77_chpr chpr_ + #define F77_cher2 cher2_ + #define F77_chpr2 chpr2_ + #define F77_zhemv zhemv_ + #define F77_zhbmv zhbmv_ + #define F77_zhpmv zhpmv_ + #define F77_zgeru zgeru_ + #define F77_zgerc zgerc_ + #define F77_zher zher_ + #define F77_zhpr zhpr_ + #define F77_zher2 zher2_ + #define F77_zhpr2 zhpr2_ + #define F77_sgemv sgemv_ + #define F77_sgbmv sgbmv_ + #define F77_strmv strmv_ + #define F77_stbmv stbmv_ + #define F77_stpmv stpmv_ + #define F77_strsv strsv_ + #define F77_stbsv stbsv_ + #define F77_stpsv stpsv_ + #define F77_dgemv dgemv_ + #define F77_dgbmv dgbmv_ + #define F77_dtrmv dtrmv_ + #define F77_dtbmv dtbmv_ + #define F77_dtpmv dtpmv_ + #define F77_dtrsv dtrsv_ + #define F77_dtbsv dtbsv_ + #define F77_dtpsv dtpsv_ + #define F77_cgemv cgemv_ + #define F77_cgbmv cgbmv_ + #define F77_ctrmv ctrmv_ + #define F77_ctbmv ctbmv_ + #define F77_ctpmv ctpmv_ + #define F77_ctrsv ctrsv_ + #define F77_ctbsv ctbsv_ + #define F77_ctpsv ctpsv_ + #define F77_zgemv zgemv_ + #define F77_zgbmv zgbmv_ + #define F77_ztrmv ztrmv_ + #define F77_ztbmv ztbmv_ + #define F77_ztpmv ztpmv_ + #define F77_ztrsv ztrsv_ + #define F77_ztbsv ztbsv_ + #define F77_ztpsv ztpsv_ +/* + * Level 3 BLAS + */ + #define F77_chemm chemm_ + #define F77_cherk cherk_ + #define F77_cher2k cher2k_ + #define F77_zhemm zhemm_ + #define F77_zherk zherk_ + #define F77_zher2k zher2k_ + #define F77_sgemm sgemm_ + #define F77_ssymm ssymm_ + #define F77_ssyrk ssyrk_ + #define F77_ssyr2k ssyr2k_ + #define F77_strmm strmm_ + #define F77_strsm strsm_ + #define F77_dgemm dgemm_ + #define F77_dsymm dsymm_ + #define F77_dsyrk dsyrk_ + #define F77_dsyr2k dsyr2k_ + #define F77_dtrmm dtrmm_ + #define F77_dtrsm dtrsm_ + #define F77_cgemm cgemm_ + #define F77_csymm csymm_ + #define F77_csyrk csyrk_ + #define F77_csyr2k csyr2k_ + #define F77_ctrmm ctrmm_ + #define F77_ctrsm ctrsm_ + #define F77_zgemm zgemm_ + #define F77_zsymm zsymm_ + #define F77_zsyrk zsyrk_ + #define F77_zsyr2k zsyr2k_ + #define F77_ztrmm ztrmm_ + #define F77_ztrsm ztrsm_ +#elif defined(UPCASE) +/* + * Level 1 BLAS + */ +#define F77_xerbla XERBLA + #define F77_srotg SROTG + #define F77_srotmg SROTMG + #define F77_srot SROT + #define F77_srotm SROTM + #define F77_drotg DROTG + #define F77_drotmg DROTMG + #define F77_drot DROT + #define F77_drotm DROTM + #define F77_sswap SSWAP + #define F77_scopy SCOPY + #define F77_saxpy SAXPY + #define F77_isamax_sub ISAMAXSUB + #define F77_dswap DSWAP + #define F77_dcopy DCOPY + #define F77_daxpy DAXPY + #define F77_idamax_sub IDAMAXSUB + #define F77_cswap CSWAP + #define F77_ccopy CCOPY + #define F77_caxpy CAXPY + #define F77_icamax_sub ICAMAXSUB + #define F77_zswap ZSWAP + #define F77_zcopy ZCOPY + #define F77_zaxpy ZAXPY + #define F77_izamax_sub IZAMAXSUB + #define F77_sdot_sub SDOTSUB + #define F77_ddot_sub DDOTSUB + #define F77_dsdot_sub DSDOTSUB + #define F77_sscal SSCAL + #define F77_dscal DSCAL + #define F77_cscal CSCAL + #define F77_zscal ZSCAL + #define F77_csscal CSSCAL + #define F77_zdscal ZDSCAL + #define F77_cdotu_sub CDOTUSUB + #define F77_cdotc_sub CDOTCSUB + #define F77_zdotu_sub ZDOTUSUB + #define F77_zdotc_sub ZDOTCSUB + #define F77_snrm2_sub SNRM2SUB + #define F77_sasum_sub SASUMSUB + #define F77_dnrm2_sub DNRM2SUB + #define F77_dasum_sub DASUMSUB + #define F77_scnrm2_sub SCNRM2SUB + #define F77_scasum_sub SCASUMSUB + #define F77_dznrm2_sub DZNRM2SUB + #define F77_dzasum_sub DZASUMSUB + #define F77_sdsdot_sub SDSDOTSUB +/* + * Level 2 BLAS + */ + #define F77_ssymv SSYMV + #define F77_ssbmv SSBMV + #define F77_sspmv SSPMV + #define F77_sger SGER + #define F77_ssyr SSYR + #define F77_sspr SSPR + #define F77_ssyr2 SSYR2 + #define F77_sspr2 SSPR2 + #define F77_dsymv DSYMV + #define F77_dsbmv DSBMV + #define F77_dspmv DSPMV + #define F77_dger DGER + #define F77_dsyr DSYR + #define F77_dspr DSPR + #define F77_dsyr2 DSYR2 + #define F77_dspr2 DSPR2 + #define F77_chemv CHEMV + #define F77_chbmv CHBMV + #define F77_chpmv CHPMV + #define F77_cgeru CGERU + #define F77_cgerc CGERC + #define F77_cher CHER + #define F77_chpr CHPR + #define F77_cher2 CHER2 + #define F77_chpr2 CHPR2 + #define F77_zhemv ZHEMV + #define F77_zhbmv ZHBMV + #define F77_zhpmv ZHPMV + #define F77_zgeru ZGERU + #define F77_zgerc ZGERC + #define F77_zher ZHER + #define F77_zhpr ZHPR + #define F77_zher2 ZHER2 + #define F77_zhpr2 ZHPR2 + #define F77_sgemv SGEMV + #define F77_sgbmv SGBMV + #define F77_strmv STRMV + #define F77_stbmv STBMV + #define F77_stpmv STPMV + #define F77_strsv STRSV + #define F77_stbsv STBSV + #define F77_stpsv STPSV + #define F77_dgemv DGEMV + #define F77_dgbmv DGBMV + #define F77_dtrmv DTRMV + #define F77_dtbmv DTBMV + #define F77_dtpmv DTPMV + #define F77_dtrsv DTRSV + #define F77_dtbsv DTBSV + #define F77_dtpsv DTPSV + #define F77_cgemv CGEMV + #define F77_cgbmv CGBMV + #define F77_ctrmv CTRMV + #define F77_ctbmv CTBMV + #define F77_ctpmv CTPMV + #define F77_ctrsv CTRSV + #define F77_ctbsv CTBSV + #define F77_ctpsv CTPSV + #define F77_zgemv ZGEMV + #define F77_zgbmv ZGBMV + #define F77_ztrmv ZTRMV + #define F77_ztbmv ZTBMV + #define F77_ztpmv ZTPMV + #define F77_ztrsv ZTRSV + #define F77_ztbsv ZTBSV + #define F77_ztpsv ZTPSV +/* + * Level 3 BLAS + */ + #define F77_chemm CHEMM + #define F77_cherk CHERK + #define F77_cher2k CHER2K + #define F77_zhemm ZHEMM + #define F77_zherk ZHERK + #define F77_zher2k ZHER2K + #define F77_sgemm SGEMM + #define F77_ssymm SSYMM + #define F77_ssyrk SSYRK + #define F77_ssyr2k SSYR2K + #define F77_strmm STRMM + #define F77_strsm STRSM + #define F77_dgemm DGEMM + #define F77_dsymm DSYMM + #define F77_dsyrk DSYRK + #define F77_dsyr2k DSYR2K + #define F77_dtrmm DTRMM + #define F77_dtrsm DTRSM + #define F77_cgemm CGEMM + #define F77_csymm CSYMM + #define F77_csyrk CSYRK + #define F77_csyr2k CSYR2K + #define F77_ctrmm CTRMM + #define F77_ctrsm CTRSM + #define F77_zgemm ZGEMM + #define F77_zsymm ZSYMM + #define F77_zsyrk ZSYRK + #define F77_zsyr2k ZSYR2K + #define F77_ztrmm ZTRMM + #define F77_ztrsm ZTRSM +#elif defined(NOCHANGE) +/* + * Level 1 BLAS + */ +#define F77_xerbla xerbla + #define F77_srotg srotg + #define F77_srotmg srotmg + #define F77_srot srot + #define F77_srotm srotm + #define F77_drotg drotg + #define F77_drotmg drotmg + #define F77_drot drot + #define F77_drotm drotm + #define F77_sswap sswap + #define F77_scopy scopy + #define F77_saxpy saxpy + #define F77_isamax_sub isamaxsub + #define F77_dswap dswap + #define F77_dcopy dcopy + #define F77_daxpy daxpy + #define F77_idamax_sub idamaxsub + #define F77_cswap cswap + #define F77_ccopy ccopy + #define F77_caxpy caxpy + #define F77_icamax_sub icamaxsub + #define F77_zswap zswap + #define F77_zcopy zcopy + #define F77_zaxpy zaxpy + #define F77_izamax_sub izamaxsub + #define F77_sdot_sub sdotsub + #define F77_ddot_sub ddotsub + #define F77_dsdot_sub dsdotsub + #define F77_sscal sscal + #define F77_dscal dscal + #define F77_cscal cscal + #define F77_zscal zscal + #define F77_csscal csscal + #define F77_zdscal zdscal + #define F77_cdotu_sub cdotusub + #define F77_cdotc_sub cdotcsub + #define F77_zdotu_sub zdotusub + #define F77_zdotc_sub zdotcsub + #define F77_snrm2_sub snrm2sub + #define F77_sasum_sub sasumsub + #define F77_dnrm2_sub dnrm2sub + #define F77_dasum_sub dasumsub + #define F77_scnrm2_sub scnrm2sub + #define F77_scasum_sub scasumsub + #define F77_dznrm2_sub dznrm2sub + #define F77_dzasum_sub dzasumsub + #define F77_sdsdot_sub sdsdotsub +/* + * Level 2 BLAS + */ + #define F77_ssymv ssymv + #define F77_ssbmv ssbmv + #define F77_sspmv sspmv + #define F77_sger sger + #define F77_ssyr ssyr + #define F77_sspr sspr + #define F77_ssyr2 ssyr2 + #define F77_sspr2 sspr2 + #define F77_dsymv dsymv + #define F77_dsbmv dsbmv + #define F77_dspmv dspmv + #define F77_dger dger + #define F77_dsyr dsyr + #define F77_dspr dspr + #define F77_dsyr2 dsyr2 + #define F77_dspr2 dspr2 + #define F77_chemv chemv + #define F77_chbmv chbmv + #define F77_chpmv chpmv + #define F77_cgeru cgeru + #define F77_cgerc cgerc + #define F77_cher cher + #define F77_chpr chpr + #define F77_cher2 cher2 + #define F77_chpr2 chpr2 + #define F77_zhemv zhemv + #define F77_zhbmv zhbmv + #define F77_zhpmv zhpmv + #define F77_zgeru zgeru + #define F77_zgerc zgerc + #define F77_zher zher + #define F77_zhpr zhpr + #define F77_zher2 zher2 + #define F77_zhpr2 zhpr2 + #define F77_sgemv sgemv + #define F77_sgbmv sgbmv + #define F77_strmv strmv + #define F77_stbmv stbmv + #define F77_stpmv stpmv + #define F77_strsv strsv + #define F77_stbsv stbsv + #define F77_stpsv stpsv + #define F77_dgemv dgemv + #define F77_dgbmv dgbmv + #define F77_dtrmv dtrmv + #define F77_dtbmv dtbmv + #define F77_dtpmv dtpmv + #define F77_dtrsv dtrsv + #define F77_dtbsv dtbsv + #define F77_dtpsv dtpsv + #define F77_cgemv cgemv + #define F77_cgbmv cgbmv + #define F77_ctrmv ctrmv + #define F77_ctbmv ctbmv + #define F77_ctpmv ctpmv + #define F77_ctrsv ctrsv + #define F77_ctbsv ctbsv + #define F77_ctpsv ctpsv + #define F77_zgemv zgemv + #define F77_zgbmv zgbmv + #define F77_ztrmv ztrmv + #define F77_ztbmv ztbmv + #define F77_ztpmv ztpmv + #define F77_ztrsv ztrsv + #define F77_ztbsv ztbsv + #define F77_ztpsv ztpsv +/* + * Level 3 BLAS + */ + #define F77_chemm chemm + #define F77_cherk cherk + #define F77_cher2k cher2k + #define F77_zhemm zhemm + #define F77_zherk zherk + #define F77_zher2k zher2k + #define F77_sgemm sgemm + #define F77_ssymm ssymm + #define F77_ssyrk ssyrk + #define F77_ssyr2k ssyr2k + #define F77_strmm strmm + #define F77_strsm strsm + #define F77_dgemm dgemm + #define F77_dsymm dsymm + #define F77_dsyrk dsyrk + #define F77_dsyr2k dsyr2k + #define F77_dtrmm dtrmm + #define F77_dtrsm dtrsm + #define F77_cgemm cgemm + #define F77_csymm csymm + #define F77_csyrk csyrk + #define F77_csyr2k csyr2k + #define F77_ctrmm ctrmm + #define F77_ctrsm ctrsm + #define F77_zgemm zgemm + #define F77_zsymm zsymm + #define F77_zsyrk zsyrk + #define F77_zsyr2k zsyr2k + #define F77_ztrmm ztrmm + #define F77_ztrsm ztrsm +#endif + +#ifdef __cplusplus +extern "C" { +#endif + + void F77_xerbla(FCHAR, void *); +/* + * Level 1 Fortran Prototypes + */ + +/* Single Precision */ + + void F77_srot(FINT, float *, FINT, float *, FINT, const float *, const float *); + void F77_srotg(float *,float *,float *,float *); + void F77_srotm( FINT, float *, FINT, float *, FINT, const float *); + void F77_srotmg(float *,float *,float *,const float *, float *); + void F77_sswap( FINT, float *, FINT, float *, FINT); + void F77_scopy( FINT, const float *, FINT, float *, FINT); + void F77_saxpy( FINT, const float *, const float *, FINT, float *, FINT); + void F77_sdot_sub(FINT, const float *, FINT, const float *, FINT, float *); + void F77_sdsdot_sub( FINT, const float *, const float *, FINT, const float *, FINT, float *); + void F77_sscal( FINT, const float *, float *, FINT); + void F77_snrm2_sub( FINT, const float *, FINT, float *); + void F77_sasum_sub( FINT, const float *, FINT, float *); + void F77_isamax_sub( FINT, const float * , FINT, FINT2); + +/* Double Precision */ + + void F77_drot(FINT, double *, FINT, double *, FINT, const double *, const double *); + void F77_drotg(double *,double *,double *,double *); + void F77_drotm( FINT, double *, FINT, double *, FINT, const double *); + void F77_drotmg(double *,double *,double *,const double *, double *); + void F77_dswap( FINT, double *, FINT, double *, FINT); + void F77_dcopy( FINT, const double *, FINT, double *, FINT); + void F77_daxpy( FINT, const double *, const double *, FINT, double *, FINT); + void F77_dswap( FINT, double *, FINT, double *, FINT); + void F77_dsdot_sub(FINT, const float *, FINT, const float *, FINT, double *); + void F77_ddot_sub( FINT, const double *, FINT, const double *, FINT, double *); + void F77_dscal( FINT, const double *, double *, FINT); + void F77_dnrm2_sub( FINT, const double *, FINT, double *); + void F77_dasum_sub( FINT, const double *, FINT, double *); + void F77_idamax_sub( FINT, const double * , FINT, FINT2); + +/* Single Complex Precision */ + + void F77_cswap( FINT, void *, FINT, void *, FINT); + void F77_ccopy( FINT, const void *, FINT, void *, FINT); + void F77_caxpy( FINT, const void *, const void *, FINT, void *, FINT); + void F77_cswap( FINT, void *, FINT, void *, FINT); + void F77_cdotc_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_cdotu_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_cscal( FINT, const void *, void *, FINT); + void F77_icamax_sub( FINT, const void *, FINT, FINT2); + void F77_csscal( FINT, const float *, void *, FINT); + void F77_scnrm2_sub( FINT, const void *, FINT, float *); + void F77_scasum_sub( FINT, const void *, FINT, float *); + +/* Double Complex Precision */ + + void F77_zswap( FINT, void *, FINT, void *, FINT); + void F77_zcopy( FINT, const void *, FINT, void *, FINT); + void F77_zaxpy( FINT, const void *, const void *, FINT, void *, FINT); + void F77_zswap( FINT, void *, FINT, void *, FINT); + void F77_zdotc_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_zdotu_sub( FINT, const void *, FINT, const void *, FINT, void *); + void F77_zdscal( FINT, const double *, void *, FINT); + void F77_zscal( FINT, const void *, void *, FINT); + void F77_dznrm2_sub( FINT, const void *, FINT, double *); + void F77_dzasum_sub( FINT, const void *, FINT, double *); + void F77_izamax_sub( FINT, const void *, FINT, FINT2); + +/* + * Level 2 Fortran Prototypes + */ + +/* Single Precision */ + + void F77_sgemv(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_sgbmv(FCHAR, FINT, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssymv(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssbmv(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_sspmv(FCHAR, FINT, const float *, const float *, const float *, FINT, const float *, float *, FINT); + void F77_strmv( FCHAR, FCHAR, FCHAR, FINT, const float *, FINT, float *, FINT); + void F77_stbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, FINT, float *, FINT); + void F77_strsv( FCHAR, FCHAR, FCHAR, FINT, const float *, FINT, float *, FINT); + void F77_stbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, FINT, float *, FINT); + void F77_stpmv( FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT); + void F77_stpsv( FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT); + void F77_sger( FINT, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT); + void F77_ssyr(FCHAR, FINT, const float *, const float *, FINT, float *, FINT); + void F77_sspr(FCHAR, FINT, const float *, const float *, FINT, float *); + void F77_sspr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *); + void F77_ssyr2(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT); + +/* Double Precision */ + + void F77_dgemv(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dgbmv(FCHAR, FINT, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsymv(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsbmv(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dspmv(FCHAR, FINT, const double *, const double *, const double *, FINT, const double *, double *, FINT); + void F77_dtrmv( FCHAR, FCHAR, FCHAR, FINT, const double *, FINT, double *, FINT); + void F77_dtbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, FINT, double *, FINT); + void F77_dtrsv( FCHAR, FCHAR, FCHAR, FINT, const double *, FINT, double *, FINT); + void F77_dtbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, FINT, double *, FINT); + void F77_dtpmv( FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT); + void F77_dtpsv( FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT); + void F77_dger( FINT, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT); + void F77_dsyr(FCHAR, FINT, const double *, const double *, FINT, double *, FINT); + void F77_dspr(FCHAR, FINT, const double *, const double *, FINT, double *); + void F77_dspr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *); + void F77_dsyr2(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT); + +/* Single Complex Precision */ + + void F77_cgemv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_cgbmv(FCHAR, FINT, FINT, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_chemv(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_chbmv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_chpmv(FCHAR, FINT, const void *, const void *, const void *, FINT, const void *, void *, FINT); + void F77_ctrmv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ctbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ctpmv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *, FINT); + void F77_ctrsv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ctbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ctpsv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *,FINT); + void F77_cgerc( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_cgeru( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_cher(FCHAR, FINT, const float *, const void *, FINT, void *, FINT); + void F77_cher2(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_chpr(FCHAR, FINT, const float *, const void *, FINT, void *); + void F77_chpr2(FCHAR, FINT, const float *, const void *, FINT, const void *, FINT, void *); + +/* Double Complex Precision */ + + void F77_zgemv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zgbmv(FCHAR, FINT, FINT, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zhemv(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zhbmv(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT); + void F77_zhpmv(FCHAR, FINT, const void *, const void *, const void *, FINT, const void *, void *, FINT); + void F77_ztrmv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ztbmv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ztpmv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *, FINT); + void F77_ztrsv( FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT); + void F77_ztbsv( FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT); + void F77_ztpsv( FCHAR, FCHAR, FCHAR, FINT, const void *, void *,FINT); + void F77_zgerc( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_zgeru( FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_zher(FCHAR, FINT, const double *, const void *, FINT, void *, FINT); + void F77_zher2(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT); + void F77_zhpr(FCHAR, FINT, const double *, const void *, FINT, void *); + void F77_zhpr2(FCHAR, FINT, const double *, const void *, FINT, const void *, FINT, void *); + +/* + * Level 3 Fortran Prototypes + */ + +/* Single Precision */ + + void F77_sgemm(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssymm(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ssyrk(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT); + void F77_ssyr2k(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_strmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + void F77_strsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + +/* Double Precision */ + + void F77_dgemm(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsymm(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dsyrk(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT); + void F77_dsyr2k(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_dtrmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + void F77_dtrsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + +/* Single Complex Precision */ + + void F77_cgemm(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_csymm(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_chemm(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_csyrk(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT); + void F77_cherk(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT); + void F77_csyr2k(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_cher2k(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT); + void F77_ctrmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + void F77_ctrsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT); + +/* Double Complex Precision */ + + void F77_zgemm(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zsymm(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zhemm(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zsyrk(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT); + void F77_zherk(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT); + void F77_zsyr2k(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_zher2k(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT); + void F77_ztrmm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + void F77_ztrsm(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT); + +#ifdef __cplusplus +} +#endif + +#endif /* CBLAS_F77_H */ diff --git a/contrib/libs/cblas/cblas_interface/cblas_caxpy.c b/contrib/libs/cblas/cblas_interface/cblas_caxpy.c new file mode 100644 index 00000000000..7579aa707aa --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_caxpy.c @@ -0,0 +1,22 @@ +/* + * cblas_caxpy.c + * + * The program is a C interface to caxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_caxpy( const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_caxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ccopy.c b/contrib/libs/cblas/cblas_interface/cblas_ccopy.c new file mode 100644 index 00000000000..b7bc428473a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ccopy.c @@ -0,0 +1,22 @@ +/* + * cblas_ccopy.c + * + * The program is a C interface to ccopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ccopy( const int N, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_ccopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cdotc_sub.c b/contrib/libs/cblas/cblas_interface/cblas_cdotc_sub.c new file mode 100644 index 00000000000..d6086814e2d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cdotc_sub.c @@ -0,0 +1,23 @@ +/* + * cblas_cdotc_sub.c + * + * The program is a C interface to cdotc. + * It calls the fortran wrapper before calling cdotc. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cdotc_sub( const int N, const void *X, const int incX, + const void *Y, const int incY,void *dotc) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_cdotc_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotc); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cdotu_sub.c b/contrib/libs/cblas/cblas_interface/cblas_cdotu_sub.c new file mode 100644 index 00000000000..d06e4e5fa93 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cdotu_sub.c @@ -0,0 +1,23 @@ +/* + * cblas_cdotu_sub.f + * + * The program is a C interface to cdotu. + * It calls the forteran wrapper before calling cdotu. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cdotu_sub( const int N, const void *X, + const int incX, const void *Y, const int incY,void *dotu) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_cdotu_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotu); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cgbmv.c b/contrib/libs/cblas/cblas_interface/cblas_cgbmv.c new file mode 100644 index 00000000000..e61a31a4abf --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cgbmv.c @@ -0,0 +1,165 @@ +/* + * cblas_cgbmv.c + * The program is a C interface of cgbmv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incx + #define F77_incY incY +#endif + int n=0, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_cgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, + A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(float)); + tx = x; + + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if( incY > 0 ) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + } + else x = (float *) X; + + + } + else + { + cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + else + F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, + A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY); + if (TransA == CblasConjTrans) + { + if (x != X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_cgbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cgemm.c b/contrib/libs/cblas/cblas_interface/cblas_cgemm.c new file mode 100644 index 00000000000..dee4696eed3 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cgemm.c @@ -0,0 +1,109 @@ +/* + * + * cblas_cgemm.c + * This program is a C interface to cgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_cgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_cgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_cgemm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cgemv.c b/contrib/libs/cblas/cblas_interface/cblas_cgemv.c new file mode 100644 index 00000000000..5e4509a4f1e --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cgemv.c @@ -0,0 +1,162 @@ +/* + * cblas_cgemv.c + * The program is a C interface of cgemv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + + int n=0, i=0, incx=incX; + const float *xx= (const float *)X; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0; + const float *stx = x; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_cgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *( (const float *) alpha ); + ALPHA[1]= -( *( (const float *) alpha+1) ); + BETA[0]= *( (const float *) beta ); + BETA[1]= -( *( (const float *) beta+1 ) ); + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(float)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + F77_incX = 1; + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + stx = x; + } + else stx = (const float *)X; + } + else + { + cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_cgemv(F77_TA, &F77_N, &F77_M, ALPHA, A, &F77_lda, stx, + &F77_incX, BETA, Y, &F77_incY); + else + F77_cgemv(F77_TA, &F77_N, &F77_M, alpha, A, &F77_lda, x, + &F77_incX, beta, Y, &F77_incY); + + if (TransA == CblasConjTrans) + { + if (x != (const float *)X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_cgemv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cgerc.c b/contrib/libs/cblas/cblas_interface/cblas_cgerc.c new file mode 100644 index 00000000000..29ccde63a8b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cgerc.c @@ -0,0 +1,84 @@ +/* + * cblas_cgerc.c + * The program is a C interface to cgerc. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgerc(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incy + #define F77_lda lda +#endif + + int n, i, tincy, incy=incY; + float *y=(float *)Y, *yy=(float *)Y, *ty, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + F77_cgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (N > 0) + { + n = N << 1; + y = malloc(n*sizeof(float)); + + ty = y; + if( incY > 0 ) { + i = incY << 1; + tincy = 2; + st= y+n; + } else { + i = incY *(-2); + tincy = -2; + st = y-2; + y +=(n-2); + } + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += i; + } + while (y != st); + y = ty; + + #ifdef F77_INT + F77_incY = 1; + #else + incy = 1; + #endif + } + else y = (float *) Y; + + F77_cgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, + &F77_lda); + if(Y!=y) + free(y); + + } else cblas_xerbla(1, "cblas_cgerc", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cgeru.c b/contrib/libs/cblas/cblas_interface/cblas_cgeru.c new file mode 100644 index 00000000000..549eae3cf4c --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cgeru.c @@ -0,0 +1,45 @@ +/* + * cblas_cgeru.c + * The program is a C interface to cgeru. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cgeru(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + + if (order == CblasColMajor) + { + F77_cgeru( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + F77_cgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + } + else cblas_xerbla(1, "cblas_cgeru","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_chbmv.c b/contrib/libs/cblas/cblas_interface/cblas_chbmv.c new file mode 100644 index 00000000000..3f33e69c214 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_chbmv.c @@ -0,0 +1,159 @@ +/* + * cblas_chbmv.c + * The program is a C interface to chbmv + * + * Keita Teranishi 5/18/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +#include <stdio.h> +#include <stdlib.h> +void cblas_chbmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo,const int N,const int K, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (float *) X; + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chbmv(F77_UL, &F77_N, &F77_K, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_chbmv","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( order == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_chemm.c b/contrib/libs/cblas/cblas_interface/cblas_chemm.c new file mode 100644 index 00000000000..89b80f5dc33 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_chemm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_chemm.c + * This program is a C interface to chemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_chemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_chemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_chemm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_chemv.c b/contrib/libs/cblas/cblas_interface/cblas_chemv.c new file mode 100644 index 00000000000..f36a00d78ec --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_chemv.c @@ -0,0 +1,160 @@ +/* + * cblas_chemv.c + * The program is a C interface to chemv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chemv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n=0, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (float *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, + BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_chemv","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( order == CblasRowMajor ) + { + RowMajorStrg = 1; + if ( X != x ) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cher.c b/contrib/libs/cblas/cblas_interface/cblas_cher.c new file mode 100644 index 00000000000..3332868ad7c --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cher.c @@ -0,0 +1,116 @@ +/* + * cblas_cher.c + * The program is a C interface to cher. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, const int incX + ,void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + float *x=(float *)X, *xx=(float *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_cher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (float *) X; + F77_cher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); + } else + { + cblas_xerbla(1, "cblas_cher","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cher2.c b/contrib/libs/cblas/cblas_interface/cblas_cher2.c new file mode 100644 index 00000000000..1bcdd3a6dd7 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cher2.c @@ -0,0 +1,152 @@ +/* + * cblas_cher2.c + * The program is a C interface to cher2. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, tincx, tincy, incx=incX, incy=incY; + float *x=(float *)X, *xx=(float *)X, *y=(float *)Y, + *yy=(float *)Y, *tx, *ty, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_cher2(F77_UL, &F77_N, alpha, X, &F77_incX, + Y, &F77_incY, A, &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + y = malloc(n*sizeof(float)); + tx = x; + ty = y; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + stx= x+n; + } else { + i = incX *(-2); + tincx = -2; + stx = x-2; + x +=(n-2); + } + + if( incY > 0 ) { + j = incY << 1; + tincy = 2; + sty= y+n; + } else { + j = incY *(-2); + tincy = -2; + sty = y-2; + y +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != stx); + + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += j; + } + while (y != sty); + + x=tx; + y=ty; + + #ifdef F77_INT + F77_incX = 1; + F77_incY = 1; + #else + incx = 1; + incy = 1; + #endif + } else + { + x = (float *) X; + y = (float *) Y; + } + F77_cher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, + &F77_incX, A, &F77_lda); + } else + { + cblas_xerbla(1, "cblas_cher2","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cher2k.c b/contrib/libs/cblas/cblas_interface/cblas_cher2k.c new file mode 100644 index 00000000000..b4082ef2358 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cher2k.c @@ -0,0 +1,111 @@ +/* + * + * cblas_cher2k.c + * This program is a C interface to cher2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const float beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + float ALPHA[2]; + const float *alp=(float *)alpha; + + CBLAS_CallFromC = 1; + RowMajorStrg = 0; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_cher2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + F77_cher2k(F77_UL,F77_TR, &F77_N, &F77_K, ALPHA, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_cher2k", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cherk.c b/contrib/libs/cblas/cblas_interface/cblas_cherk.c new file mode 100644 index 00000000000..fd0e09b43b0 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cherk.c @@ -0,0 +1,105 @@ +/* + * + * cblas_cherk.c + * This program is a C interface to cherk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const void *A, const int lda, + const float beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_cherk", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_chpmv.c b/contrib/libs/cblas/cblas_interface/cblas_chpmv.c new file mode 100644 index 00000000000..c805756ebd5 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_chpmv.c @@ -0,0 +1,160 @@ +/* + * cblas_chpmv.c + * The program is a C interface of chpmv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chpmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo,const int N, + const void *alpha, const void *AP, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta; + float ALPHA[2],BETA[2]; + int tincY, tincx; + float *x=(float *)X, *y=(float *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_chpmv(F77_UL, &F77_N, alpha, AP, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (float *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n", Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_chpmv(F77_UL, &F77_N, ALPHA, + AP, x, &F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_chpmv","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( order == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_chpr.c b/contrib/libs/cblas/cblas_interface/cblas_chpr.c new file mode 100644 index 00000000000..9b39f38bdff --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_chpr.c @@ -0,0 +1,115 @@ +/* + * cblas_chpr.c + * The program is a C interface to chpr. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chpr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, + const int incX, void *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + float *x=(float *)X, *xx=(float *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_chpr(F77_UL, &F77_N, &alpha, X, &F77_incX, A); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (float *) X; + + F77_chpr(F77_UL, &F77_N, &alpha, x, &F77_incX, A); + + } else + { + cblas_xerbla(1, "cblas_chpr","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_chpr2.c b/contrib/libs/cblas/cblas_interface/cblas_chpr2.c new file mode 100644 index 00000000000..e43077db6a6 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_chpr2.c @@ -0,0 +1,149 @@ +/* + * cblas_chpr2.c + * The program is a C interface to chpr2. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_chpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N,const void *alpha, const void *X, + const int incX,const void *Y, const int incY, void *Ap) + +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, tincx, tincy, incx=incX, incy=incY; + float *x=(float *)X, *xx=(float *)X, *y=(float *)Y, + *yy=(float *)Y, *tx, *ty, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_chpr2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_chpr2","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(float)); + y = malloc(n*sizeof(float)); + tx = x; + ty = y; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + stx= x+n; + } else { + i = incX *(-2); + tincx = -2; + stx = x-2; + x +=(n-2); + } + + if( incY > 0 ) { + j = incY << 1; + tincy = 2; + sty= y+n; + } else { + j = incY *(-2); + tincy = -2; + sty = y-2; + y +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != stx); + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += j; + } + while (y != sty); + + x=tx; + y=ty; + + #ifdef F77_INT + F77_incX = 1; + F77_incY = 1; + #else + incx = 1; + incy = 1; + #endif + + } else + { + x = (float *) X; + y = (void *) Y; + } + F77_chpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap); + } else + { + cblas_xerbla(1, "cblas_chpr2","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cscal.c b/contrib/libs/cblas/cblas_interface/cblas_cscal.c new file mode 100644 index 00000000000..a23e6ee5771 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cscal.c @@ -0,0 +1,21 @@ +/* + * cblas_cscal.c + * + * The program is a C interface to cscal.f. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cscal( const int N, const void *alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_cscal( &F77_N, alpha, X, &F77_incX); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_csscal.c b/contrib/libs/cblas/cblas_interface/cblas_csscal.c new file mode 100644 index 00000000000..39983fe071b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_csscal.c @@ -0,0 +1,21 @@ +/* + * cblas_csscal.c + * + * The program is a C interface to csscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csscal( const int N, const float alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_csscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_cswap.c b/contrib/libs/cblas/cblas_interface/cblas_cswap.c new file mode 100644 index 00000000000..12728207273 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_cswap.c @@ -0,0 +1,22 @@ +/* + * cblas_cswap.c + * + * The program is a C interface to cswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_cswap( const int N, void *X, const int incX, void *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_cswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_csymm.c b/contrib/libs/cblas/cblas_interface/cblas_csymm.c new file mode 100644 index 00000000000..4db34e346d3 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_csymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_csymm.c + * This program is a C interface to csymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_csymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_csymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_csymm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_csymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_csymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_csymm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_csymm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_csyr2k.c b/contrib/libs/cblas/cblas_interface/cblas_csyr2k.c new file mode 100644 index 00000000000..5ca3f34cda4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_csyr2k.c @@ -0,0 +1,108 @@ +/* + * + * cblas_csyr2k.c + * This program is a C interface to csyr2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_csyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_csyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_csyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_csyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_csyr2k", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_csyrk.c b/contrib/libs/cblas/cblas_interface/cblas_csyrk.c new file mode 100644 index 00000000000..3f0bb07eac2 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_csyrk.c @@ -0,0 +1,108 @@ +/* + * + * cblas_csyrk.c + * This program is a C interface to csyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_csyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_csyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_csyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_csyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_csyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_csyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_csyrk", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} + diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctbmv.c b/contrib/libs/cblas/cblas_interface/cblas_ctbmv.c new file mode 100644 index 00000000000..7845cc8284d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctbmv.c @@ -0,0 +1,158 @@ +/* + * cblas_ctbmv.c + * The program is a C interface to ctbmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0, *x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x+= i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctbsv.c b/contrib/libs/cblas/cblas_interface/cblas_ctbsv.c new file mode 100644 index 00000000000..ab4646b5469 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctbsv.c @@ -0,0 +1,162 @@ +/* + * cblas_ctbsv.c + * The program is a C interface to ctbsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x+= i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctbsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctpmv.c b/contrib/libs/cblas/cblas_interface/cblas_ctpmv.c new file mode 100644 index 00000000000..7a4d63af22a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctpmv.c @@ -0,0 +1,152 @@ +/* + * cblas_ctpmv.c + * The program is a C interface to ctpmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x += i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctpmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctpsv.c b/contrib/libs/cblas/cblas_interface/cblas_ctpsv.c new file mode 100644 index 00000000000..d39687cbf9f --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctpsv.c @@ -0,0 +1,157 @@ +/* + * cblas_ctpsv.c + * The program is a C interface to ctpsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0, *x=(float*)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctpsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctrmm.c b/contrib/libs/cblas/cblas_interface/cblas_ctrmm.c new file mode 100644 index 00000000000..d70bfd308a9 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctrmm.c @@ -0,0 +1,144 @@ +/* + * + * cblas_ctrmm.c + * This program is a C interface to ctrmm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight ) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ctrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper ) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ctrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else cblas_xerbla(5, "cblas_ctrmm", + "Illegal Diag setting, %d\n", Diag); + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight ) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ctrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper ) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ctrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ctrmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ctrmm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctrmv.c b/contrib/libs/cblas/cblas_interface/cblas_ctrmv.c new file mode 100644 index 00000000000..3d284388ce8 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctrmv.c @@ -0,0 +1,155 @@ +/* + * cblas_ctrmv.c + * The program is a C interface to ctrmv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + st = x + n; + do + { + x[1] = -x[1]; + x+= i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + x[1] = -x[1]; + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctrmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctrsm.c b/contrib/libs/cblas/cblas_interface/cblas_ctrsm.c new file mode 100644 index 00000000000..00c592d56ae --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctrsm.c @@ -0,0 +1,155 @@ +/* + * + * cblas_ctrsm.c + * This program is a C interface to ctrsm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ctrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ctrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ctrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ctrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, + &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ctrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ctrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ctrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ctrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + + F77_ctrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ctrsm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ctrsv.c b/contrib/libs/cblas/cblas_interface/cblas_ctrsv.c new file mode 100644 index 00000000000..39ff644cbdf --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ctrsv.c @@ -0,0 +1,156 @@ +/* + * cblas_ctrsv.c + * The program is a C interface to ctrsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ctrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + float *st=0,*x=(float *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + x++; + st=x+n; + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ctrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ctrsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dasum.c b/contrib/libs/cblas/cblas_interface/cblas_dasum.c new file mode 100644 index 00000000000..1a3667f2d7b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dasum.c @@ -0,0 +1,23 @@ +/* + * cblas_dasum.c + * + * The program is a C interface to dasum. + * It calls the fortran wrapper before calling dasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dasum( const int N, const double *X, const int incX) +{ + double asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_daxpy.c b/contrib/libs/cblas/cblas_interface/cblas_daxpy.c new file mode 100644 index 00000000000..3678137fb75 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_daxpy.c @@ -0,0 +1,22 @@ +/* + * cblas_daxpy.c + * + * The program is a C interface to daxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_daxpy( const int N, const double alpha, const double *X, + const int incX, double *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_daxpy( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dcopy.c b/contrib/libs/cblas/cblas_interface/cblas_dcopy.c new file mode 100644 index 00000000000..422a55e5175 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dcopy.c @@ -0,0 +1,22 @@ +/* + * cblas_dcopy.c + * + * The program is a C interface to dcopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dcopy( const int N, const double *X, + const int incX, double *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_dcopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ddot.c b/contrib/libs/cblas/cblas_interface/cblas_ddot.c new file mode 100644 index 00000000000..d7734340314 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ddot.c @@ -0,0 +1,25 @@ +/* + * cblas_ddot.c + * + * The program is a C interface to ddot. + * It calls the fortran wrapper before calling ddot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_ddot( const int N, const double *X, + const int incX, const double *Y, const int incY) +{ + double dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_ddot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dgbmv.c b/contrib/libs/cblas/cblas_interface/cblas_dgbmv.c new file mode 100644 index 00000000000..33c481db11b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dgbmv.c @@ -0,0 +1,81 @@ +/* + * + * cblas_dgbmv.c + * This program is a C interface to dgbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_dgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, + A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_dgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dgbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dgemm.c b/contrib/libs/cblas/cblas_interface/cblas_dgemm.c new file mode 100644 index 00000000000..d02ac16b32e --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dgemm.c @@ -0,0 +1,109 @@ +/* + * + * cblas_dgemm.c + * This program is a C interface to dgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_dgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_dgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, &alpha, A, + &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_dgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_dgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, &alpha, B, + &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dgemm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dgemv.c b/contrib/libs/cblas/cblas_interface/cblas_dgemv.c new file mode 100644 index 00000000000..9062f3eed4a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dgemv.c @@ -0,0 +1,78 @@ +/* + * + * cblas_dgemv.c + * This program is a C interface to dgemv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_dgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, + &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_dgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_dgemv(F77_TA, &F77_N, &F77_M, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dgemv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dger.c b/contrib/libs/cblas/cblas_interface/cblas_dger.c new file mode 100644 index 00000000000..b2b805b4f7b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dger.c @@ -0,0 +1,47 @@ +/* + * + * cblas_dger.c + * This program is a C interface to dger. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dger(const enum CBLAS_ORDER order, const int M, const int N, + const double alpha, const double *X, const int incX, + const double *Y, const int incY, double *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + F77_dger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + F77_dger( &F77_N, &F77_M ,&alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + + } + else cblas_xerbla(1, "cblas_dger", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dnrm2.c b/contrib/libs/cblas/cblas_interface/cblas_dnrm2.c new file mode 100644 index 00000000000..fe46ad4849c --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dnrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_dnrm2.c + * + * The program is a C interface to dnrm2. + * It calls the fortranwrapper before calling dnrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dnrm2( const int N, const double *X, const int incX) +{ + double nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dnrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_drot.c b/contrib/libs/cblas/cblas_interface/cblas_drot.c new file mode 100644 index 00000000000..51dc4ad5ef5 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_drot.c @@ -0,0 +1,23 @@ +/* + * cblas_drot.c + * + * The program is a C interface to drot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drot(const int N, double *X, const int incX, + double *Y, const int incY, const double c, const double s) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_drot(&F77_N, X, &F77_incX, Y, &F77_incY, &c, &s); + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_drotg.c b/contrib/libs/cblas/cblas_interface/cblas_drotg.c new file mode 100644 index 00000000000..0cbbd8bc0ba --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_drotg.c @@ -0,0 +1,14 @@ +/* + * cblas_drotg.c + * + * The program is a C interface to drotg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drotg( double *a, double *b, double *c, double *s) +{ + F77_drotg(a,b,c,s); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_drotm.c b/contrib/libs/cblas/cblas_interface/cblas_drotm.c new file mode 100644 index 00000000000..ebe20ad6277 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_drotm.c @@ -0,0 +1,14 @@ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drotm( const int N, double *X, const int incX, double *Y, + const int incY, const double *P) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_drotm( &F77_N, X, &F77_incX, Y, &F77_incY, P); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_drotmg.c b/contrib/libs/cblas/cblas_interface/cblas_drotmg.c new file mode 100644 index 00000000000..13a2208e5f6 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_drotmg.c @@ -0,0 +1,15 @@ +/* + * cblas_drotmg.c + * + * The program is a C interface to drotmg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_drotmg( double *d1, double *d2, double *b1, + const double b2, double *p) +{ + F77_drotmg(d1,d2,b1,&b2,p); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsbmv.c b/contrib/libs/cblas/cblas_interface/cblas_dsbmv.c new file mode 100644 index 00000000000..95b61820fc5 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsbmv.c @@ -0,0 +1,77 @@ +/* + * + * cblas_dsbmv.c + * This program is a C interface to dsbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsbmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsbmv(F77_UL, &F77_N, &F77_K, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dsbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dscal.c b/contrib/libs/cblas/cblas_interface/cblas_dscal.c new file mode 100644 index 00000000000..bd04de77d69 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dscal.c @@ -0,0 +1,21 @@ +/* + * cblas_dscal.c + * + * The program is a C interface to dscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dscal( const int N, const double alpha, double *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsdot.c b/contrib/libs/cblas/cblas_interface/cblas_dsdot.c new file mode 100644 index 00000000000..52cd877a203 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsdot.c @@ -0,0 +1,25 @@ +/* + * cblas_dsdot.c + * + * The program is a C interface to dsdot. + * It calls fthe fortran wrapper before calling dsdot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dsdot( const int N, const float *X, + const int incX, const float *Y, const int incY) +{ + double dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_dsdot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dspmv.c b/contrib/libs/cblas/cblas_interface/cblas_dspmv.c new file mode 100644 index 00000000000..dd1544f9cf9 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dspmv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_dspmv.c + * This program is a C interface to dspmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dspmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, + const double alpha, const double *AP, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dspmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspmv(F77_UL, &F77_N, &alpha, AP, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dspmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspmv(F77_UL, &F77_N, &alpha, + AP, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dspmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dspr.c b/contrib/libs/cblas/cblas_interface/cblas_dspr.c new file mode 100644 index 00000000000..c6300391cb4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dspr.c @@ -0,0 +1,70 @@ +/* + * + * cblas_dspr.c + * This program is a C interface to dspr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *Ap) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + } else cblas_xerbla(1, "cblas_dspr", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dspr2.c b/contrib/libs/cblas/cblas_interface/cblas_dspr2.c new file mode 100644 index 00000000000..4f1e7805a04 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dspr2.c @@ -0,0 +1,70 @@ +/* + * cblas_dspr2.c + * The program is a C interface to dspr2. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dspr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + } else cblas_xerbla(1, "cblas_dspr2", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dswap.c b/contrib/libs/cblas/cblas_interface/cblas_dswap.c new file mode 100644 index 00000000000..9ae5bb93c08 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dswap.c @@ -0,0 +1,22 @@ +/* + * cblas_dswap.c + * + * The program is a C interface to dswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dswap( const int N, double *X, const int incX, double *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_dswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsymm.c b/contrib/libs/cblas/cblas_interface/cblas_dsymm.c new file mode 100644 index 00000000000..8b50e9a40b6 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_dsymm.c + * This program is a C interface to dsymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_dsymm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_dsymm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_dsymm(F77_SD, F77_UL, &F77_M, &F77_N, &alpha, A, &F77_lda, + B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_dsymm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dsymm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_dsymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, + &F77_ldb, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dsymm","Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsymv.c b/contrib/libs/cblas/cblas_interface/cblas_dsymv.c new file mode 100644 index 00000000000..020adc91d3d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsymv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_dsymv.c + * This program is a C interface to dsymv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsymv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsymv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsymv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsymv(F77_UL, &F77_N, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_dsymv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsyr.c b/contrib/libs/cblas/cblas_interface/cblas_dsyr.c new file mode 100644 index 00000000000..0d200834817 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsyr.c @@ -0,0 +1,71 @@ +/* + * + * cblas_dsyr.c + * This program is a C interface to dsyr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_lda lda +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + } else cblas_xerbla(1, "cblas_dsyr", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsyr2.c b/contrib/libs/cblas/cblas_interface/cblas_dsyr2.c new file mode 100644 index 00000000000..fe4a2920eda --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsyr2.c @@ -0,0 +1,76 @@ +/* + * + * cblas_dsyr2.c + * This program is a C interface to dsyr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A, + const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77__lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dsyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dsyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dsyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else cblas_xerbla(1, "cblas_dsyr2", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsyr2k.c b/contrib/libs/cblas/cblas_interface/cblas_dsyr2k.c new file mode 100644 index 00000000000..e50dc11cc94 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsyr2k.c @@ -0,0 +1,109 @@ +/* + * + * cblas_dsyr2k.c + * This program is a C interface to dsyr2k. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_dsyr2k","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_dsyr2k","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dsyr2k","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_dsyr2k","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, + &F77_ldb, &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dsyr2k","Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dsyrk.c b/contrib/libs/cblas/cblas_interface/cblas_dsyrk.c new file mode 100644 index 00000000000..469f930df33 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dsyrk.c @@ -0,0 +1,108 @@ +/* + * + * cblas_dsyrk.c + * This program is a C interface to dsyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double beta, double *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_dsyrk","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_dsyrk","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dsyrk","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_dsyrk","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dsyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_dsyrk","Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} + diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtbmv.c b/contrib/libs/cblas/cblas_interface/cblas_dtbmv.c new file mode 100644 index 00000000000..491f11d4754 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtbmv.c @@ -0,0 +1,122 @@ +/* + * cblas_dtbmv.c + * The program is a C interface to dtbmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + } + else cblas_xerbla(1, "cblas_dtbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtbsv.c b/contrib/libs/cblas/cblas_interface/cblas_dtbsv.c new file mode 100644 index 00000000000..664822fea49 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtbsv.c @@ -0,0 +1,122 @@ +/* + * cblas_dtbsv.c + * The program is a C interface to dtbsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_dtbsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtpmv.c b/contrib/libs/cblas/cblas_interface/cblas_dtpmv.c new file mode 100644 index 00000000000..5b96a2b495c --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtpmv.c @@ -0,0 +1,117 @@ +/* + * cblas_dtpmv.c + * The program is a C interface to dtpmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + } + else cblas_xerbla(1, "cblas_dtpmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtpsv.c b/contrib/libs/cblas/cblas_interface/cblas_dtpsv.c new file mode 100644 index 00000000000..5555c2174eb --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtpsv.c @@ -0,0 +1,118 @@ +/* + * cblas_dtpsv.c + * The program is a C interface to dtpsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + } + else cblas_xerbla(1, "cblas_dtpsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtrmm.c b/contrib/libs/cblas/cblas_interface/cblas_dtrmm.c new file mode 100644 index 00000000000..32a5d2bc919 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtrmm.c @@ -0,0 +1,148 @@ +/* + * + * cblas_dtrmm.c + * This program is a C interface to dtrmm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_dtrmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_dtrmm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrmm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrmm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_dtrmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_dtrmm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrmm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrmm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_dtrmm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtrmv.c b/contrib/libs/cblas/cblas_interface/cblas_dtrmv.c new file mode 100644 index 00000000000..cce150709b8 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtrmv.c @@ -0,0 +1,122 @@ +/* + * + * cblas_dtrmv.c + * This program is a C interface to sgemv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *A, const int lda, + double *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } else cblas_xerbla(1, "cblas_dtrmv", "Illegal order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtrsm.c b/contrib/libs/cblas/cblas_interface/cblas_dtrsm.c new file mode 100644 index 00000000000..4f47cb193cc --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtrsm.c @@ -0,0 +1,153 @@ +/* + * + * cblas_dtrsm.c + * This program is a C interface to dtrsm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb) + +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if ( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_dtrsm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower) UL='L'; + else + { + cblas_xerbla(3, "cblas_dtrsm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( TransA == CblasTrans ) TA='T'; + else if ( TransA == CblasConjTrans) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrsm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrsm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, + A, &F77_lda, B, &F77_ldb); + } + else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if ( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_dtrsm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower) UL='U'; + else + { + cblas_xerbla(3, "cblas_dtrsm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( TransA == CblasTrans ) TA='T'; + else if ( TransA == CblasConjTrans) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_dtrsm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if ( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit) DI='N'; + else + { + cblas_xerbla(5, "cblas_dtrsm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_dtrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_dtrsm","Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dtrsv.c b/contrib/libs/cblas/cblas_interface/cblas_dtrsv.c new file mode 100644 index 00000000000..7299d17d52e --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dtrsv.c @@ -0,0 +1,121 @@ +/* + * cblas_dtrsv.c + * The program is a C interface to dtrsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_dtrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const double *A, const int lda, double *X, + const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_dtrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_dtrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_dtrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_dtrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_dtrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_dtrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_dtrsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dzasum.c b/contrib/libs/cblas/cblas_interface/cblas_dzasum.c new file mode 100644 index 00000000000..b32f573e5fc --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dzasum.c @@ -0,0 +1,23 @@ +/* + * cblas_dzasum.c + * + * The program is a C interface to dzasum. + * It calls the fortran wrapper before calling dzasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dzasum( const int N, const void *X, const int incX) +{ + double asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dzasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_dznrm2.c b/contrib/libs/cblas/cblas_interface/cblas_dznrm2.c new file mode 100644 index 00000000000..dfa2bfc8370 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_dznrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_dznrm2.c + * + * The program is a C interface to dznrm2. + * It calls the fortran wrapper before calling dznrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +double cblas_dznrm2( const int N, const void *X, const int incX) +{ + double nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_dznrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_globals.c b/contrib/libs/cblas/cblas_interface/cblas_globals.c new file mode 100644 index 00000000000..ebcd74db3f4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_globals.c @@ -0,0 +1,2 @@ +int CBLAS_CallFromC=0; +int RowMajorStrg=0; diff --git a/contrib/libs/cblas/cblas_interface/cblas_icamax.c b/contrib/libs/cblas/cblas_interface/cblas_icamax.c new file mode 100644 index 00000000000..f0cdbdb3e7a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_icamax.c @@ -0,0 +1,23 @@ +/* + * cblas_icamax.c + * + * The program is a C interface to icamax. + * It calls the fortran wrapper before calling icamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_icamax( const int N, const void *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_icamax_sub( &F77_N, X, &F77_incX, &iamax); + return iamax ? iamax-1 : 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_idamax.c b/contrib/libs/cblas/cblas_interface/cblas_idamax.c new file mode 100644 index 00000000000..abb70b53cce --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_idamax.c @@ -0,0 +1,23 @@ +/* + * cblas_idamax.c + * + * The program is a C interface to idamax. + * It calls the fortran wrapper before calling idamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_idamax( const int N, const double *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_idamax_sub( &F77_N, X, &F77_incX, &iamax); + return iamax ? iamax-1 : 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_isamax.c b/contrib/libs/cblas/cblas_interface/cblas_isamax.c new file mode 100644 index 00000000000..bfd74e8f9c8 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_isamax.c @@ -0,0 +1,23 @@ +/* + * cblas_isamax.c + * + * The program is a C interface to isamax. + * It calls the fortran wrapper before calling isamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_isamax( const int N, const float *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_isamax_sub( &F77_N, X, &F77_incX, &iamax); + return iamax ? iamax-1 : 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_izamax.c b/contrib/libs/cblas/cblas_interface/cblas_izamax.c new file mode 100644 index 00000000000..21fdc396fd4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_izamax.c @@ -0,0 +1,23 @@ +/* + * cblas_izamax.c + * + * The program is a C interface to izamax. + * It calls the fortran wrapper before calling izamax. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +CBLAS_INDEX cblas_izamax( const int N, const void *X, const int incX) +{ + int iamax; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_izamax_sub( &F77_N, X, &F77_incX, &iamax); + return (iamax ? iamax-1 : 0); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sasum.c b/contrib/libs/cblas/cblas_interface/cblas_sasum.c new file mode 100644 index 00000000000..7d4c32cf9ed --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sasum.c @@ -0,0 +1,23 @@ +/* + * cblas_sasum.c + * + * The program is a C interface to sasum. + * It calls the fortran wrapper before calling sasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_sasum( const int N, const float *X, const int incX) +{ + float asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_sasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_saxpy.c b/contrib/libs/cblas/cblas_interface/cblas_saxpy.c new file mode 100644 index 00000000000..2eee8e06e4b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_saxpy.c @@ -0,0 +1,23 @@ +/* + * cblas_saxpy.c + * + * The program is a C interface to saxpy. + * It calls the fortran wrapper before calling saxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_saxpy( const int N, const float alpha, const float *X, + const int incX, float *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_saxpy( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_scasum.c b/contrib/libs/cblas/cblas_interface/cblas_scasum.c new file mode 100644 index 00000000000..e1fa53090ad --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_scasum.c @@ -0,0 +1,23 @@ +/* + * cblas_scasum.c + * + * The program is a C interface to scasum. + * It calls the fortran wrapper before calling scasum. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_scasum( const int N, const void *X, const int incX) +{ + float asum; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_scasum_sub( &F77_N, X, &F77_incX, &asum); + return asum; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_scnrm2.c b/contrib/libs/cblas/cblas_interface/cblas_scnrm2.c new file mode 100644 index 00000000000..fa48454ed5d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_scnrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_scnrm2.c + * + * The program is a C interface to scnrm2. + * It calls the fortran wrapper before calling scnrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_scnrm2( const int N, const void *X, const int incX) +{ + float nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_scnrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_scopy.c b/contrib/libs/cblas/cblas_interface/cblas_scopy.c new file mode 100644 index 00000000000..7796959f333 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_scopy.c @@ -0,0 +1,22 @@ +/* + * cblas_scopy.c + * + * The program is a C interface to scopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_scopy( const int N, const float *X, + const int incX, float *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_scopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sdot.c b/contrib/libs/cblas/cblas_interface/cblas_sdot.c new file mode 100644 index 00000000000..baf859272bb --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sdot.c @@ -0,0 +1,25 @@ +/* + * cblas_sdot.c + * + * The program is a C interface to sdot. + * It calls the fortran wrapper before calling sdot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_sdot( const int N, const float *X, + const int incX, const float *Y, const int incY) +{ + float dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_sdot_sub( &F77_N, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sdsdot.c b/contrib/libs/cblas/cblas_interface/cblas_sdsdot.c new file mode 100644 index 00000000000..b824849b99a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sdsdot.c @@ -0,0 +1,25 @@ +/* + * cblas_sdsdot.c + * + * The program is a C interface to sdsdot. + * It calls the fortran wrapper before calling sdsdot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_sdsdot( const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY) +{ + float dot; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_sdsdot_sub( &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, &dot); + return dot; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sgbmv.c b/contrib/libs/cblas/cblas_interface/cblas_sgbmv.c new file mode 100644 index 00000000000..0af607f20b2 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sgbmv.c @@ -0,0 +1,83 @@ +/* + * + * cblas_sgbmv.c + * This program is a C interface to sgbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_sgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, &alpha, + A, &F77_lda, X, &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_sgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, &alpha, + A ,&F77_lda, X, &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_sgbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sgemm.c b/contrib/libs/cblas/cblas_interface/cblas_sgemm.c new file mode 100644 index 00000000000..73a06e5e16d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sgemm.c @@ -0,0 +1,110 @@ +/* + * + * cblas_sgemm.c + * This program is a C interface to sgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if( Order == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_sgemm", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_sgemm", + "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_sgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_sgemm", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_sgemm", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_sgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } else + cblas_xerbla(1, "cblas_sgemm", + "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sgemv.c b/contrib/libs/cblas/cblas_interface/cblas_sgemv.c new file mode 100644 index 00000000000..45b71964849 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sgemv.c @@ -0,0 +1,78 @@ +/* + * + * cblas_sgemv.c + * This program is a C interface to sgemv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_sgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgemv(F77_TA, &F77_M, &F77_N, &alpha, A, &F77_lda, X, &F77_incX, + &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(2, "cblas_sgemv", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_sgemv(F77_TA, &F77_N, &F77_M, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_sgemv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sger.c b/contrib/libs/cblas/cblas_interface/cblas_sger.c new file mode 100644 index 00000000000..368940c74d0 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sger.c @@ -0,0 +1,46 @@ +/* + * + * cblas_sger.c + * This program is a C interface to sger. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sger(const enum CBLAS_ORDER order, const int M, const int N, + const float alpha, const float *X, const int incX, + const float *Y, const int incY, float *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + F77_sger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + F77_sger( &F77_N, &F77_M, &alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + } + else cblas_xerbla(1, "cblas_sger", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_snrm2.c b/contrib/libs/cblas/cblas_interface/cblas_snrm2.c new file mode 100644 index 00000000000..18161b4fa79 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_snrm2.c @@ -0,0 +1,23 @@ +/* + * cblas_snrm2.c + * + * The program is a C interface to snrm2. + * It calls the fortran wrapper before calling snrm2. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +float cblas_snrm2( const int N, const float *X, const int incX) +{ + float nrm2; +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_snrm2_sub( &F77_N, X, &F77_incX, &nrm2); + return nrm2; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_srot.c b/contrib/libs/cblas/cblas_interface/cblas_srot.c new file mode 100644 index 00000000000..cbd1c8c90a9 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_srot.c @@ -0,0 +1,22 @@ +/* + * cblas_srot.c + * + * The program is a C interface to srot. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srot( const int N, float *X, const int incX, float *Y, + const int incY, const float c, const float s) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_srot(&F77_N, X, &F77_incX, Y, &F77_incY, &c, &s); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_srotg.c b/contrib/libs/cblas/cblas_interface/cblas_srotg.c new file mode 100644 index 00000000000..f6460048d09 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_srotg.c @@ -0,0 +1,14 @@ +/* + * cblas_srotg.c + * + * The program is a C interface to srotg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srotg( float *a, float *b, float *c, float *s) +{ + F77_srotg(a,b,c,s); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_srotm.c b/contrib/libs/cblas/cblas_interface/cblas_srotm.c new file mode 100644 index 00000000000..49674645448 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_srotm.c @@ -0,0 +1,22 @@ +/* + * cblas_srotm.c + * + * The program is a C interface to srotm. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srotm( const int N, float *X, const int incX, float *Y, + const int incY, const float *P) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_srotm( &F77_N, X, &F77_incX, Y, &F77_incY, P); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_srotmg.c b/contrib/libs/cblas/cblas_interface/cblas_srotmg.c new file mode 100644 index 00000000000..04f978b405c --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_srotmg.c @@ -0,0 +1,15 @@ +/* + * cblas_srotmg.c + * + * The program is a C interface to srotmg. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_srotmg( float *d1, float *d2, float *b1, + const float b2, float *p) +{ + F77_srotmg(d1,d2,b1,&b2,p); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssbmv.c b/contrib/libs/cblas/cblas_interface/cblas_ssbmv.c new file mode 100644 index 00000000000..7a18630b617 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssbmv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_ssbmv.c + * This program is a C interface to ssbmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const int K, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + }else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssbmv(F77_UL, &F77_N, &F77_K, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_ssbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sscal.c b/contrib/libs/cblas/cblas_interface/cblas_sscal.c new file mode 100644 index 00000000000..1f09abe7a42 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sscal.c @@ -0,0 +1,21 @@ +/* + * cblas_sscal.c + * + * The program is a C interface to sscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sscal( const int N, const float alpha, float *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_sscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sspmv.c b/contrib/libs/cblas/cblas_interface/cblas_sspmv.c new file mode 100644 index 00000000000..aa4a287eb70 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sspmv.c @@ -0,0 +1,73 @@ +/* + * + * cblas_sspmv.c + * This program is a C interface to sspmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sspmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, + const float alpha, const float *AP, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspmv(F77_UL, &F77_N, &alpha, AP, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_sspmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspmv(F77_UL, &F77_N, &alpha, + AP, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_sspmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sspr.c b/contrib/libs/cblas/cblas_interface/cblas_sspr.c new file mode 100644 index 00000000000..c8517ac1cd3 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sspr.c @@ -0,0 +1,72 @@ +/* + * + * cblas_sspr.c + * This program is a C interface to sspr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *Ap) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_sspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_sspr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspr(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); + } else cblas_xerbla(1, "cblas_sspr", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sspr2.c b/contrib/libs/cblas/cblas_interface/cblas_sspr2.c new file mode 100644 index 00000000000..4f5afcd85d4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sspr2.c @@ -0,0 +1,71 @@ +/* + * + * cblas_sspr2.c + * This program is a C interface to sspr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sspr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_sspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_sspr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_sspr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A); + } else cblas_xerbla(1, "cblas_sspr2", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_sswap.c b/contrib/libs/cblas/cblas_interface/cblas_sswap.c new file mode 100644 index 00000000000..b74d8469c30 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_sswap.c @@ -0,0 +1,22 @@ +/* + * cblas_sswap.c + * + * The program is a C interface to sswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_sswap( const int N, float *X, const int incX, float *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_sswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssymm.c b/contrib/libs/cblas/cblas_interface/cblas_ssymm.c new file mode 100644 index 00000000000..a3b160105d9 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssymm.c @@ -0,0 +1,108 @@ +/* + * + * cblas_ssymm.c + * This program is a C interface to ssymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ssymm", + "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ssymm", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_ssymm(F77_SD, F77_UL, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ssymm", + "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ssymm", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_ssymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_ssymm", + "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssymv.c b/contrib/libs/cblas/cblas_interface/cblas_ssymv.c new file mode 100644 index 00000000000..89f5cc0cc63 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssymv.c @@ -0,0 +1,76 @@ +/* + * + * cblas_ssymv.c + * This program is a C interface to ssymv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssymv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssymv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssymv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssymv(F77_UL, &F77_N, &alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else cblas_xerbla(1, "cblas_ssymv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssyr.c b/contrib/libs/cblas/cblas_interface/cblas_ssyr.c new file mode 100644 index 00000000000..4e58dba4172 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssyr.c @@ -0,0 +1,70 @@ +/* + * + * cblas_ssyr.c + * This program is a C interface to ssyr. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_lda lda +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssyr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssyr(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + } else cblas_xerbla(1, "cblas_ssyr", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssyr2.c b/contrib/libs/cblas/cblas_interface/cblas_ssyr2.c new file mode 100644 index 00000000000..1d990cd413a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssyr2.c @@ -0,0 +1,76 @@ +/* + * + * cblas_ssyr2.c + * This program is a C interface to ssyr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A, + const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77__lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else cblas_xerbla(1, "cblas_ssyr2", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssyr2k.c b/contrib/libs/cblas/cblas_interface/cblas_ssyr2k.c new file mode 100644 index 00000000000..871dd21a120 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssyr2k.c @@ -0,0 +1,111 @@ +/* + * + * cblas_ssyr2k.c + * This program is a C interface to ssyr2k. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_ssyr2k", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_ssyr2k", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ssyr2k", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_ssyr2k", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_ssyr2k", + "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ssyrk.c b/contrib/libs/cblas/cblas_interface/cblas_ssyrk.c new file mode 100644 index 00000000000..4992c9b266d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ssyrk.c @@ -0,0 +1,110 @@ +/* + * + * cblas_ssyrk.c + * This program is a C interface to ssyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ssyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float beta, float *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_ssyrk", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_ssyrk", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ssyrk", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_ssyrk", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_ssyrk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_ssyrk", + "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} + diff --git a/contrib/libs/cblas/cblas_interface/cblas_stbmv.c b/contrib/libs/cblas/cblas_interface/cblas_stbmv.c new file mode 100644 index 00000000000..9e84bc01988 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_stbmv.c @@ -0,0 +1,122 @@ +/* + * cblas_stbmv.c + * This program is a C interface to stbmv. + * Written by Keita Teranishi + * 3/3/1998 + */ +#include "cblas.h" +#include "cblas_f77.h" + +void cblas_stbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_stbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_stbsv.c b/contrib/libs/cblas/cblas_interface/cblas_stbsv.c new file mode 100644 index 00000000000..fc190897089 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_stbsv.c @@ -0,0 +1,122 @@ +/* + * cblas_stbsv.c + * The program is a C interface to stbsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_stbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_stbsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_stpmv.c b/contrib/libs/cblas/cblas_interface/cblas_stpmv.c new file mode 100644 index 00000000000..8f7fd6acd96 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_stpmv.c @@ -0,0 +1,118 @@ +/* + * + * cblas_stpmv.c + * This program is a C interface to stpmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_stpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + } + else cblas_xerbla(1, "cblas_stpmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_stpsv.c b/contrib/libs/cblas/cblas_interface/cblas_stpsv.c new file mode 100644 index 00000000000..acc5f1d5caf --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_stpsv.c @@ -0,0 +1,118 @@ +/* + * cblas_stpsv.c + * The program is a C interface to stpsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_stpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_stpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_stpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_stpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_stpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_stpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_stpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_stpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + } + else cblas_xerbla(1, "cblas_stpsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_strmm.c b/contrib/libs/cblas/cblas_interface/cblas_strmm.c new file mode 100644 index 00000000000..9f8ce198dce --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_strmm.c @@ -0,0 +1,148 @@ +/* + * + * cblas_strmm.c + * This program is a C interface to strmm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_strmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_strmm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strmm","Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_strmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_strmm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_strmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strmm","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } +#ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); +#endif + F77_strmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_strmm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_strmv.c b/contrib/libs/cblas/cblas_interface/cblas_strmv.c new file mode 100644 index 00000000000..5a85b1dafbf --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_strmv.c @@ -0,0 +1,122 @@ +/* + * + * cblas_strmv.c + * This program is a C interface to strmv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *A, const int lda, + float *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_strmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_strsm.c b/contrib/libs/cblas/cblas_interface/cblas_strsm.c new file mode 100644 index 00000000000..5dc3e0bc0d7 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_strsm.c @@ -0,0 +1,143 @@ +/* + * + * cblas_strsm.c + * This program is a C interface to strsm. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb) + +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_N=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_strsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_strsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_strsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_strsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_strsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_strsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_strsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_strsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_strsm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_strsv.c b/contrib/libs/cblas/cblas_interface/cblas_strsv.c new file mode 100644 index 00000000000..a0509aebd67 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_strsv.c @@ -0,0 +1,121 @@ +/* + * cblas_strsv.c + * The program is a C interface to strsv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_strsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const float *A, const int lda, float *X, + const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_strsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_strsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_strsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) TA = 'N'; + else + { + cblas_xerbla(3, "cblas_strsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_strsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_strsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else cblas_xerbla(1, "cblas_strsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_xerbla.c b/contrib/libs/cblas/cblas_interface/cblas_xerbla.c new file mode 100644 index 00000000000..3a2bfe6e3bd --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_xerbla.c @@ -0,0 +1,68 @@ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <stdarg.h> +#include "cblas.h" +#include "cblas_f77.h" + +void cblas_xerbla(int info, const char *rout, const char *form, ...) +{ + extern int RowMajorStrg; + char empty[1] = ""; + va_list argptr; + + va_start(argptr, form); + + if (RowMajorStrg) + { + if (strstr(rout,"gemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + else if (info == 11) info = 9; + else if (info == 9 ) info = 11; + } + else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) + { + if (info == 5 ) info = 4; + else if (info == 4 ) info = 5; + } + else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0) + { + if (info == 7 ) info = 6; + else if (info == 6 ) info = 7; + } + else if (strstr(rout,"gemv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + } + else if (strstr(rout,"gbmv") != 0) + { + if (info == 4) info = 3; + else if (info == 3) info = 4; + else if (info == 6) info = 5; + else if (info == 5) info = 6; + } + else if (strstr(rout,"ger") != 0) + { + if (info == 3) info = 2; + else if (info == 2) info = 3; + else if (info == 8) info = 6; + else if (info == 6) info = 8; + } + else if ( (strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0) + && strstr(rout,"her2k") == 0 ) + { + if (info == 8) info = 6; + else if (info == 6) info = 8; + } + } + if (info) + fprintf(stderr, "Parameter %d to routine %s was incorrect\n", info, rout); + vfprintf(stderr, form, argptr); + va_end(argptr); + if (info && !info) + F77_xerbla(empty, &info); /* Force link of our F77 error handler */ + exit(-1); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zaxpy.c b/contrib/libs/cblas/cblas_interface/cblas_zaxpy.c new file mode 100644 index 00000000000..f63c4c39bc0 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zaxpy.c @@ -0,0 +1,22 @@ +/* + * cblas_zaxpy.c + * + * The program is a C interface to zaxpy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zaxpy( const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zaxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zcopy.c b/contrib/libs/cblas/cblas_interface/cblas_zcopy.c new file mode 100644 index 00000000000..a16be28e7e4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zcopy.c @@ -0,0 +1,22 @@ +/* + * cblas_zcopy.c + * + * The program is a C interface to zcopy. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zcopy( const int N, const void *X, + const int incX, void *Y, const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zcopy( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zdotc_sub.c b/contrib/libs/cblas/cblas_interface/cblas_zdotc_sub.c new file mode 100644 index 00000000000..29dec6c5767 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zdotc_sub.c @@ -0,0 +1,24 @@ +/* + * cblas_zdotc_sub.c + * + * The program is a C interface to zdotc. + * It calls the fortran wrapper before calling zdotc. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zdotc_sub( const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zdotc_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotc); + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zdotu_sub.c b/contrib/libs/cblas/cblas_interface/cblas_zdotu_sub.c new file mode 100644 index 00000000000..48a14bf3d4a --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zdotu_sub.c @@ -0,0 +1,24 @@ +/* + * cblas_zdotu_sub.c + * + * The program is a C interface to zdotu. + * It calls the fortran wrapper before calling zdotu. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zdotu_sub( const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zdotu_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotu); + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zdscal.c b/contrib/libs/cblas/cblas_interface/cblas_zdscal.c new file mode 100644 index 00000000000..788365befa6 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zdscal.c @@ -0,0 +1,21 @@ +/* + * cblas_zdscal.c + * + * The program is a C interface to zdscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zdscal( const int N, const double alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_zdscal( &F77_N, &alpha, X, &F77_incX); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zgbmv.c b/contrib/libs/cblas/cblas_interface/cblas_zgbmv.c new file mode 100644 index 00000000000..fb3cabb4005 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zgbmv.c @@ -0,0 +1,166 @@ +/* + * cblas_zgbmv.c + * The program is a C interface of zgbmv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgbmv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; + F77_INT F77_KL=KL,F77_KU=KU; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_KL KL + #define F77_KU KU + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_zgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha, + A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(double)); + tx = x; + + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if( incY > 0 ) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + } + else x = (double *) X; + + + } + else + { + cblas_xerbla(2, "cblas_zgbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + else + F77_zgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha, + A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY); + if (TransA == CblasConjTrans) + { + if (x != X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_zgbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zgemm.c b/contrib/libs/cblas/cblas_interface/cblas_zgemm.c new file mode 100644 index 00000000000..f344d838763 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zgemm.c @@ -0,0 +1,109 @@ +/* + * + * cblas_zgemm.c + * This program is a C interface to zgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc) +{ + char TA, TB; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB; +#else + #define F77_TA &TA + #define F77_TB &TB +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_zgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(3, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_zgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + cblas_xerbla(2, "cblas_zgemm","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(2, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + #endif + + F77_zgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zgemm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zgemv.c b/contrib/libs/cblas/cblas_interface/cblas_zgemv.c new file mode 100644 index 00000000000..355d7ef30f0 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zgemv.c @@ -0,0 +1,164 @@ +/* + * cblas_zgemv.c + * The program is a C interface of zgemv + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgemv(const enum CBLAS_ORDER order, + const enum CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char TA; +#ifdef F77_CHAR + F77_CHAR F77_TA; +#else + #define F77_TA &TA +#endif +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + + if (order == CblasColMajor) + { + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(2, "cblas_zgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + F77_zgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + TA = 'N'; + if (M > 0) + { + n = M << 1; + x = malloc(n*sizeof(double)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + + y++; + + if (N > 0) + { + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } + } + else x = (double *) X; + } + else + { + cblas_xerbla(2, "cblas_zgemv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + #endif + if (TransA == CblasConjTrans) + F77_zgemv(F77_TA, &F77_N, &F77_M, ALPHA, A, &F77_lda, x, + &F77_incX, BETA, Y, &F77_incY); + else + F77_zgemv(F77_TA, &F77_N, &F77_M, alpha, A, &F77_lda, x, + &F77_incX, beta, Y, &F77_incY); + + if (TransA == CblasConjTrans) + { + if (x != (double *)X) free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + } + else cblas_xerbla(1, "cblas_zgemv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zgerc.c b/contrib/libs/cblas/cblas_interface/cblas_zgerc.c new file mode 100644 index 00000000000..2acde748e41 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zgerc.c @@ -0,0 +1,84 @@ +/* + * cblas_zgerc.c + * The program is a C interface to zgerc. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgerc(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incy + #define F77_lda lda +#endif + + int n, i, tincy, incy=incY; + double *y=(double *)Y, *yy=(double *)Y, *ty, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + F77_zgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (N > 0) + { + n = N << 1; + y = malloc(n*sizeof(double)); + + ty = y; + if( incY > 0 ) { + i = incY << 1; + tincy = 2; + st= y+n; + } else { + i = incY *(-2); + tincy = -2; + st = y-2; + y +=(n-2); + } + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += i; + } + while (y != st); + y = ty; + + #ifdef F77_INT + F77_incY = 1; + #else + incy = 1; + #endif + } + else y = (double *) Y; + + F77_zgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, + &F77_lda); + if(Y!=y) + free(y); + + } else cblas_xerbla(1, "cblas_zgerc", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zgeru.c b/contrib/libs/cblas/cblas_interface/cblas_zgeru.c new file mode 100644 index 00000000000..464ca1539ea --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zgeru.c @@ -0,0 +1,44 @@ +/* + * cblas_zgeru.c + * The program is a C interface to zgeru. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zgeru(const enum CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_M M + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if (order == CblasColMajor) + { + F77_zgeru( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + F77_zgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, + &F77_lda); + } + else cblas_xerbla(1, "cblas_zgeru", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zhbmv.c b/contrib/libs/cblas/cblas_interface/cblas_zhbmv.c new file mode 100644 index 00000000000..de4b96a9b05 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zhbmv.c @@ -0,0 +1,159 @@ +/* + * cblas_zhbmv.c + * The program is a C interface to zhbmv + * + * Keita Teranishi 5/18/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +#include <stdio.h> +#include <stdlib.h> +void cblas_zhbmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo,const int N,const int K, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhbmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (double *) X; + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhbmv(F77_UL, &F77_N, &F77_K, ALPHA, + A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_zhbmv","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( order == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zhemm.c b/contrib/libs/cblas/cblas_interface/cblas_zhemm.c new file mode 100644 index 00000000000..2eb0951d2be --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zhemm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_zhemm.c + * This program is a C interface to zhemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zhemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zhemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zhemm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zhemv.c b/contrib/libs/cblas/cblas_interface/cblas_zhemv.c new file mode 100644 index 00000000000..29cee1f20ba --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zhemv.c @@ -0,0 +1,160 @@ +/* + * cblas_zhemv.c + * The program is a C interface to zhemv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhemv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_zhemv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX, + beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (double *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhemv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX, + BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_zhemv","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( order == CblasRowMajor ) + { + RowMajorStrg = 1; + if ( X != x ) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zher.c b/contrib/libs/cblas/cblas_interface/cblas_zher.c new file mode 100644 index 00000000000..f688992bf47 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zher.c @@ -0,0 +1,110 @@ +/* + * cblas_zher.c + * The program is a C interface to zher. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, const int incX + ,void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + double *x=(double *)X, *xx=(double *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + tx = x; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (double *) X; + F77_zher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); + } else cblas_xerbla(1, "cblas_zher", "Illegal Order setting, %d\n", order); + if(X!=x) + free(x); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zher2.c b/contrib/libs/cblas/cblas_interface/cblas_zher2.c new file mode 100644 index 00000000000..fa0547453b4 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zher2.c @@ -0,0 +1,153 @@ +/* + * cblas_zher2.c + * The program is a C interface to zher2. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, tincx, tincy, incx=incX, incy=incY; + double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, + *yy=(double *)Y, *tx, *ty, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zher2(F77_UL, &F77_N, alpha, X, &F77_incX, + Y, &F77_incY, A, &F77_lda); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + y = malloc(n*sizeof(double)); + tx = x; + ty = y; + if( incX > 0 ) { + i = incX << 1 ; + tincx = 2; + stx= x+n; + } else { + i = incX *(-2); + tincx = -2; + stx = x-2; + x +=(n-2); + } + + if( incY > 0 ) { + j = incY << 1; + tincy = 2; + sty= y+n; + } else { + j = incY *(-2); + tincy = -2; + sty = y-2; + y +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != stx); + + do + { + *y = *yy; + y[1] = -yy[1]; + y += tincy ; + yy += j; + } + while (y != sty); + + x=tx; + y=ty; + + #ifdef F77_INT + F77_incX = 1; + F77_incY = 1; + #else + incx = 1; + incy = 1; + #endif + } else + { + x = (double *) X; + y = (double *) Y; + } + F77_zher2(F77_UL, &F77_N, alpha, y, &F77_incY, x, + &F77_incX, A, &F77_lda); + } + else + { + cblas_xerbla(1, "cblas_zher2", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zher2k.c b/contrib/libs/cblas/cblas_interface/cblas_zher2k.c new file mode 100644 index 00000000000..abd0a4ddcb2 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zher2k.c @@ -0,0 +1,110 @@ +/* + * + * cblas_zher2k.c + * This program is a C interface to zher2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const double beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + double ALPHA[2]; + const double *alp=(double *)alpha; + + CBLAS_CallFromC = 1; + RowMajorStrg = 0; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zher2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(2, "cblas_zher2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_zher2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + F77_zher2k(F77_UL,F77_TR, &F77_N, &F77_K, ALPHA, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else cblas_xerbla(1, "cblas_zher2k", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zherk.c b/contrib/libs/cblas/cblas_interface/cblas_zherk.c new file mode 100644 index 00000000000..a867788f343 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zherk.c @@ -0,0 +1,105 @@ +/* + * + * cblas_zherk.c + * This program is a C interface to zherk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const void *A, const int lda, + const double beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zherk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='C'; + else + { + cblas_xerbla(3, "cblas_zherk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + &beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zherk", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zhpmv.c b/contrib/libs/cblas/cblas_interface/cblas_zhpmv.c new file mode 100644 index 00000000000..289eb78066b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zhpmv.c @@ -0,0 +1,160 @@ +/* + * cblas_zhpmv.c + * The program is a C interface of zhpmv + * + * Keita Teranishi 5/18/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhpmv(const enum CBLAS_ORDER order, + const enum CBLAS_UPLO Uplo,const int N, + const void *alpha, const void *AP, + const void *X, const int incX, const void *beta, + void *Y, const int incY) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incY +#endif + int n, i=0, incx=incX; + const double *xx= (double *)X, *alp= (double *)alpha, *bet = (double *)beta; + double ALPHA[2],BETA[2]; + int tincY, tincx; + double *x=(double *)X, *y=(double *)Y, *st=0, *tx; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpmv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_zhpmv(F77_UL, &F77_N, alpha, AP, X, + &F77_incX, beta, Y, &F77_incY); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + ALPHA[0]= *alp; + ALPHA[1]= -alp[1]; + BETA[0]= *bet; + BETA[1]= -bet[1]; + + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + + + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + + if(incY > 0) + tincY = incY; + else + tincY = -incY; + y++; + + i = tincY << 1; + n = i * N ; + st = y + n; + do { + *y = -(*y); + y += i; + } while(y != st); + y -= n; + } else + x = (double *) X; + + + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpmv","Illegal Uplo setting, %d\n", Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zhpmv(F77_UL, &F77_N, ALPHA, + AP, x, &F77_incX, BETA, Y, &F77_incY); + } + else + { + cblas_xerbla(1, "cblas_zhpmv","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if ( order == CblasRowMajor ) + { + RowMajorStrg = 1; + if(X!=x) + free(x); + if (N > 0) + { + do + { + *y = -(*y); + y += i; + } + while (y != st); + } + } + + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zhpr.c b/contrib/libs/cblas/cblas_interface/cblas_zhpr.c new file mode 100644 index 00000000000..5517c22d565 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zhpr.c @@ -0,0 +1,115 @@ +/* + * cblas_zhpr.c + * The program is a C interface to zhpr. + * + * Keita Teranishi 3/23/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhpr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, + const int incX, void *A) +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incx +#endif + int n, i, tincx, incx=incX; + double *x=(double *)X, *xx=(double *)X, *tx, *st; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zhpr(F77_UL, &F77_N, &alpha, X, &F77_incX, A); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + tx = x; + if( incX > 0 ) { + i = incX << 1; + tincx = 2; + st= x+n; + } else { + i = incX *(-2); + tincx = -2; + st = x-2; + x +=(n-2); + } + do + { + *x = *xx; + x[1] = -xx[1]; + x += tincx ; + xx += i; + } + while (x != st); + x=tx; + #ifdef F77_INT + F77_incX = 1; + #else + incx = 1; + #endif + } + else x = (double *) X; + + F77_zhpr(F77_UL, &F77_N, &alpha, x, &F77_incX, A); + + } else + { + cblas_xerbla(1, "cblas_zhpr","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zhpr2.c b/contrib/libs/cblas/cblas_interface/cblas_zhpr2.c new file mode 100644 index 00000000000..69b9f14a90b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zhpr2.c @@ -0,0 +1,150 @@ +/* + * cblas_zhpr2.c + * The program is a C interface to zhpr2. + * + * Keita Teranishi 5/20/98 + * + */ +#include <stdio.h> +#include <stdlib.h> +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const int N,const void *alpha, const void *X, + const int incX,const void *Y, const int incY, void *Ap) + +{ + char UL; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incx + #define F77_incY incy +#endif + int n, i, j, incx=incX, incy=incY; + double *x=(double *)X, *xx=(double *)X, *y=(double *)Y, + *yy=(double *)Y, *stx, *sty; + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zhpr2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap); + + } else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + if (N > 0) + { + n = N << 1; + x = malloc(n*sizeof(double)); + y = malloc(n*sizeof(double)); + stx = x + n; + sty = y + n; + if( incX > 0 ) + i = incX << 1; + else + i = incX *(-2); + + if( incY > 0 ) + j = incY << 1; + else + j = incY *(-2); + do + { + *x = *xx; + x[1] = -xx[1]; + x += 2; + xx += i; + } while (x != stx); + do + { + *y = *yy; + y[1] = -yy[1]; + y += 2; + yy += j; + } + while (y != sty); + x -= n; + y -= n; + + #ifdef F77_INT + if(incX > 0 ) + F77_incX = 1; + else + F77_incX = -1; + + if(incY > 0 ) + F77_incY = 1; + else + F77_incY = -1; + + #else + if(incX > 0 ) + incx = 1; + else + incx = -1; + + if(incY > 0 ) + incy = 1; + else + incy = -1; + #endif + + } else + { + x = (double *) X; + y = (void *) Y; + } + F77_zhpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap); + } + else + { + cblas_xerbla(1, "cblas_zhpr2","Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(X!=x) + free(x); + if(Y!=y) + free(y); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zscal.c b/contrib/libs/cblas/cblas_interface/cblas_zscal.c new file mode 100644 index 00000000000..37b319f38f7 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zscal.c @@ -0,0 +1,21 @@ +/* + * cblas_zscal.c + * + * The program is a C interface to zscal. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zscal( const int N, const void *alpha, void *X, + const int incX) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + F77_zscal( &F77_N, alpha, X, &F77_incX); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zswap.c b/contrib/libs/cblas/cblas_interface/cblas_zswap.c new file mode 100644 index 00000000000..dfde2cbd01d --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zswap.c @@ -0,0 +1,22 @@ +/* + * cblas_zswap.c + * + * The program is a C interface to zswap. + * + * Written by Keita Teranishi. 2/11/1998 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zswap( const int N, void *X, const int incX, void *Y, + const int incY) +{ +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY +#endif + F77_zswap( &F77_N, X, &F77_incX, Y, &F77_incY); +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zsymm.c b/contrib/libs/cblas/cblas_interface/cblas_zsymm.c new file mode 100644 index 00000000000..91aa67d3b04 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zsymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_zsymm.c + * This program is a C interface to zsymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zsymm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_zsymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_zsymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zsymm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_zsymm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zsymm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_zsymm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zsymm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zsyr2k.c b/contrib/libs/cblas/cblas_interface/cblas_zsyr2k.c new file mode 100644 index 00000000000..def7239ba1c --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zsyr2k.c @@ -0,0 +1,108 @@ +/* + * + * cblas_zsyr2k.c + * This program is a C interface to zsyr2k. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zsyr2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zsyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zsyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + B, &F77_ldb, beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zsyr2k", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_zsyr2k", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyr2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zsyr2k", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_zsyrk.c b/contrib/libs/cblas/cblas_interface/cblas_zsyrk.c new file mode 100644 index 00000000000..7968f904175 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_zsyrk.c @@ -0,0 +1,107 @@ +/* + * + * cblas_zsyrk.c + * This program is a C interface to zsyrk. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_zsyrk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc) +{ + char UL, TR; +#ifdef F77_CHAR + F77_CHAR F77_TR, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(2, "cblas_zsyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + cblas_xerbla(3, "cblas_zsyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_zsyrk", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + cblas_xerbla(3, "cblas_zsyrk", "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_zsyrk(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, + beta, C, &F77_ldc); + } + else cblas_xerbla(1, "cblas_zsyrk", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztbmv.c b/contrib/libs/cblas/cblas_interface/cblas_ztbmv.c new file mode 100644 index 00000000000..b3dde438132 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztbmv.c @@ -0,0 +1,158 @@ +/* + * cblas_ztbmv.c + * The program is a C interface to ztbmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztbmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0, *x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x+= i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztbmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztbmv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztbmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztbsv.c b/contrib/libs/cblas/cblas_interface/cblas_ztbsv.c new file mode 100644 index 00000000000..e3532b35aed --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztbsv.c @@ -0,0 +1,162 @@ +/* + * cblas_ztbsv.c + * The program is a C interface to ztbsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztbsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_K=K, F77_incX=incX; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztbsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztbsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztbsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztbsv( F77_UL, F77_TA, F77_DI, &F77_N, &F77_K, A, &F77_lda, X, + &F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x+= i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztbsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztpmv.c b/contrib/libs/cblas/cblas_interface/cblas_ztpmv.c new file mode 100644 index 00000000000..f29b7bb32ae --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztpmv.c @@ -0,0 +1,152 @@ +/* + * cblas_ztpmv.c + * The program is a C interface to ztpmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztpmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztpmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x += i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztpmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztpmv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztpmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztpsv.c b/contrib/libs/cblas/cblas_interface/cblas_ztpsv.c new file mode 100644 index 00000000000..4c72808b0ed --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztpsv.c @@ -0,0 +1,157 @@ +/* + * cblas_ztpsv.c + * The program is a C interface to ztpsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX; +#else + #define F77_N N + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0, *x=(double*)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztpsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + + x++; + + st=x+n; + + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztpsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztpsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztpsv( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX); + + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztpsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztrmm.c b/contrib/libs/cblas/cblas_interface/cblas_ztrmm.c new file mode 100644 index 00000000000..caeaefa1ede --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztrmm.c @@ -0,0 +1,149 @@ +/* + * + * cblas_ztrmm.c + * This program is a C interface to ztrmm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + if( Side == CblasRight ) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Uplo == CblasUpper ) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight ) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ztrmm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper ) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ztrmm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans ) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrmm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrmm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztrmm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ztrmm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztrmv.c b/contrib/libs/cblas/cblas_interface/cblas_ztrmv.c new file mode 100644 index 00000000000..c9345afaa39 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztrmv.c @@ -0,0 +1,156 @@ +/* + * cblas_ztrmv.c + * The program is a C interface to ztrmv. + * + * Keita Teranishi 5/20/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrmv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX) + +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztrmv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if(incX > 0) + tincX = incX; + else + tincX = -incX; + i = tincX << 1; + n = i * N; + x++; + st = x + n; + do + { + *x = -(*x); + x += i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztrmv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrmv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztrmv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztrsm.c b/contrib/libs/cblas/cblas_interface/cblas_ztrsm.c new file mode 100644 index 00000000000..08375d81533 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztrsm.c @@ -0,0 +1,155 @@ +/* + * + * cblas_ztrsm.c + * This program is a C interface to ztrsm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrsm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, + const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, + const enum CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb) +{ + char UL, TA, SD, DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_SD, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_SD &SD + #define F77_DI &DI +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( Order == CblasColMajor ) + { + + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + cblas_xerbla(2, "cblas_ztrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + cblas_xerbla(3, "cblas_ztrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + F77_ztrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_M, &F77_N, alpha, A, + &F77_lda, B, &F77_ldb); + } else if (Order == CblasRowMajor) + { + RowMajorStrg = 1; + + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + cblas_xerbla(2, "cblas_ztrsm", "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + cblas_xerbla(3, "cblas_ztrsm", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( TransA == CblasTrans) TA ='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + cblas_xerbla(4, "cblas_ztrsm", "Illegal Trans setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Diag == CblasUnit ) DI='U'; + else if ( Diag == CblasNonUnit ) DI='N'; + else + { + cblas_xerbla(5, "cblas_ztrsm", "Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_SD = C2F_CHAR(&SD); + F77_DI = C2F_CHAR(&DI); + #endif + + + F77_ztrsm(F77_SD, F77_UL, F77_TA, F77_DI, &F77_N, &F77_M, alpha, A, + &F77_lda, B, &F77_ldb); + } + else cblas_xerbla(1, "cblas_ztrsm", "Illegal Order setting, %d\n", Order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cblas_ztrsv.c b/contrib/libs/cblas/cblas_interface/cblas_ztrsv.c new file mode 100644 index 00000000000..621399ba04f --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cblas_ztrsv.c @@ -0,0 +1,156 @@ +/* + * cblas_ztrsv.c + * The program is a C interface to ztrsv. + * + * Keita Teranishi 3/23/98 + * + */ +#include "cblas.h" +#include "cblas_f77.h" +void cblas_ztrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, + const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX) +{ + char TA; + char UL; + char DI; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL, F77_DI; +#else + #define F77_TA &TA + #define F77_UL &UL + #define F77_DI &DI +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX +#endif + int n, i=0, tincX; + double *st=0,*x=(double *)X; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (order == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (TransA == CblasNoTrans) TA = 'N'; + else if (TransA == CblasTrans) TA = 'T'; + else if (TransA == CblasConjTrans) TA = 'C'; + else + { + cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + } + else if (order == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (TransA == CblasNoTrans) TA = 'T'; + else if (TransA == CblasTrans) TA = 'N'; + else if (TransA == CblasConjTrans) + { + TA = 'N'; + if ( N > 0) + { + if ( incX > 0 ) + tincX = incX; + else + tincX = -incX; + + n = N*2*(tincX); + x++; + st=x+n; + i = tincX << 1; + do + { + *x = -(*x); + x+=i; + } + while (x != st); + x -= n; + } + } + else + { + cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if (Diag == CblasUnit) DI = 'U'; + else if (Diag == CblasNonUnit) DI = 'N'; + else + { + cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TA = C2F_CHAR(&TA); + F77_DI = C2F_CHAR(&DI); + #endif + F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, + &F77_incX); + if (TransA == CblasConjTrans) + { + if (N > 0) + { + do + { + *x = -(*x); + x += i; + } + while (x != st); + } + } + } + else cblas_xerbla(1, "cblas_ztrsv", "Illegal Order setting, %d\n", order); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/contrib/libs/cblas/cblas_interface/cdotcsub.c b/contrib/libs/cblas/cblas_interface/cdotcsub.c new file mode 100644 index 00000000000..483a17b6791 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cdotcsub.c @@ -0,0 +1,41 @@ +/* ./cdotcsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* cdotcsub.f */ + +/* The program is a fortran wrapper for cdotc. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int cdotcsub_(integer *n, complex *x, integer *incx, complex + *y, integer *incy, complex *dotc) +{ + /* System generated locals */ + complex q__1; + + /* Local variables */ + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + cdotc_(&q__1, n, &x[1], incx, &y[1], incy); + dotc->r = q__1.r, dotc->i = q__1.i; + return 0; +} /* cdotcsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/cdotusub.c b/contrib/libs/cblas/cblas_interface/cdotusub.c new file mode 100644 index 00000000000..00ea66c1d26 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/cdotusub.c @@ -0,0 +1,41 @@ +/* ./cdotusub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* cdotusub.f */ + +/* The program is a fortran wrapper for cdotu. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int cdotusub_(integer *n, complex *x, integer *incx, complex + *y, integer *incy, complex *dotu) +{ + /* System generated locals */ + complex q__1; + + /* Local variables */ + extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer + *, complex *, integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + cdotu_(&q__1, n, &x[1], incx, &y[1], incy); + dotu->r = q__1.r, dotu->i = q__1.i; + return 0; +} /* cdotusub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/dasumsub.c b/contrib/libs/cblas/cblas_interface/dasumsub.c new file mode 100644 index 00000000000..8588f266147 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/dasumsub.c @@ -0,0 +1,34 @@ +/* ./dasumsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* dasumsun.f */ + +/* The program is a fortran wrapper for dasum.. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int dasumsub_(integer *n, doublereal *x, integer *incx, + doublereal *asum) +{ + extern doublereal dasum_(integer *, doublereal *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *asum = dasum_(n, &x[1], incx); + return 0; +} /* dasumsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/ddotsub.c b/contrib/libs/cblas/cblas_interface/ddotsub.c new file mode 100644 index 00000000000..bac0bbaaaa2 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/ddotsub.c @@ -0,0 +1,36 @@ +/* ./ddotsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* ddotsub.f */ + +/* The program is a fortran wrapper for ddot. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int ddotsub_(integer *n, doublereal *x, integer *incx, + doublereal *y, integer *incy, doublereal *dot) +{ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + *dot = ddot_(n, &x[1], incx, &y[1], incy); + return 0; +} /* ddotsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/dnrm2sub.c b/contrib/libs/cblas/cblas_interface/dnrm2sub.c new file mode 100644 index 00000000000..2a43286be08 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/dnrm2sub.c @@ -0,0 +1,34 @@ +/* ./dnrm2sub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* dnrm2sub.f */ + +/* The program is a fortran wrapper for dnrm2. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int dnrm2sub_(integer *n, doublereal *x, integer *incx, + doublereal *nrm2) +{ + extern doublereal dnrm2_(integer *, doublereal *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *nrm2 = dnrm2_(n, &x[1], incx); + return 0; +} /* dnrm2sub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/dsdotsub.c b/contrib/libs/cblas/cblas_interface/dsdotsub.c new file mode 100644 index 00000000000..ffa291e5abf --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/dsdotsub.c @@ -0,0 +1,35 @@ +/* ./dsdotsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* dsdotsub.f */ + +/* The program is a fortran wrapper for dsdot. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int dsdotsub_(integer *n, real *x, integer *incx, real *y, + integer *incy, doublereal *dot) +{ + extern doublereal dsdot_(integer *, real *, integer *, real *, integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + *dot = dsdot_(n, &x[1], incx, &y[1], incy); + return 0; +} /* dsdotsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/dzasumsub.c b/contrib/libs/cblas/cblas_interface/dzasumsub.c new file mode 100644 index 00000000000..10a60ce9663 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/dzasumsub.c @@ -0,0 +1,34 @@ +/* ./dzasumsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* dzasumsub.f */ + +/* The program is a fortran wrapper for dzasum. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int dzasumsub_(integer *n, doublecomplex *x, integer *incx, + doublereal *asum) +{ + extern doublereal dzasum_(integer *, doublecomplex *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *asum = dzasum_(n, &x[1], incx); + return 0; +} /* dzasumsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/dznrm2sub.c b/contrib/libs/cblas/cblas_interface/dznrm2sub.c new file mode 100644 index 00000000000..6b9f8237442 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/dznrm2sub.c @@ -0,0 +1,34 @@ +/* ./dznrm2sub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* dznrm2sub.f */ + +/* The program is a fortran wrapper for dznrm2. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int dznrm2sub_(integer *n, doublecomplex *x, integer *incx, + doublereal *nrm2) +{ + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *nrm2 = dznrm2_(n, &x[1], incx); + return 0; +} /* dznrm2sub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/icamaxsub.c b/contrib/libs/cblas/cblas_interface/icamaxsub.c new file mode 100644 index 00000000000..932348cce75 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/icamaxsub.c @@ -0,0 +1,34 @@ +/* ./icamaxsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* icamaxsub.f */ + +/* The program is a fortran wrapper for icamax. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int icamaxsub_(integer *n, complex *x, integer *incx, + integer *iamax) +{ + extern integer icamax_(integer *, complex *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *iamax = icamax_(n, &x[1], incx); + return 0; +} /* icamaxsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/idamaxsub.c b/contrib/libs/cblas/cblas_interface/idamaxsub.c new file mode 100644 index 00000000000..32163edd3b9 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/idamaxsub.c @@ -0,0 +1,34 @@ +/* ./idamaxsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* icamaxsub.f */ + +/* The program is a fortran wrapper for idamax. */ +/* Witten by Keita Teranishi. 2/22/1998 */ + +/* Subroutine */ int idamaxsub_(integer *n, doublereal *x, integer *incx, + integer *iamax) +{ + extern integer idamax_(integer *, doublereal *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *iamax = idamax_(n, &x[1], incx); + return 0; +} /* idamaxsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/isamaxsub.c b/contrib/libs/cblas/cblas_interface/isamaxsub.c new file mode 100644 index 00000000000..c937f5902e3 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/isamaxsub.c @@ -0,0 +1,34 @@ +/* ./isamaxsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* isamaxsub.f */ + +/* The program is a fortran wrapper for isamax. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int isamaxsub_(integer *n, real *x, integer *incx, integer * + iamax) +{ + extern integer isamax_(integer *, real *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *iamax = isamax_(n, &x[1], incx); + return 0; +} /* isamaxsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/izamaxsub.c b/contrib/libs/cblas/cblas_interface/izamaxsub.c new file mode 100644 index 00000000000..1e6af907d38 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/izamaxsub.c @@ -0,0 +1,34 @@ +/* ./izamaxsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* izamaxsub.f */ + +/* The program is a fortran wrapper for izamax. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int izamaxsub_(integer *n, doublecomplex *x, integer *incx, + integer *iamax) +{ + extern integer izamax_(integer *, doublecomplex *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *iamax = izamax_(n, &x[1], incx); + return 0; +} /* izamaxsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/sasumsub.c b/contrib/libs/cblas/cblas_interface/sasumsub.c new file mode 100644 index 00000000000..d8d0efca403 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/sasumsub.c @@ -0,0 +1,33 @@ +/* ./sasumsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* sasumsub.f */ + +/* The program is a fortran wrapper for sasum. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int sasumsub_(integer *n, real *x, integer *incx, real *asum) +{ + extern doublereal sasum_(integer *, real *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *asum = sasum_(n, &x[1], incx); + return 0; +} /* sasumsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/scasumsub.c b/contrib/libs/cblas/cblas_interface/scasumsub.c new file mode 100644 index 00000000000..35297da9b42 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/scasumsub.c @@ -0,0 +1,34 @@ +/* ./scasumsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* scasumsub.f */ + +/* The program is a fortran wrapper for scasum. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int scasumsub_(integer *n, complex *x, integer *incx, real * + asum) +{ + extern doublereal scasum_(integer *, complex *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *asum = scasum_(n, &x[1], incx); + return 0; +} /* scasumsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/scnrm2sub.c b/contrib/libs/cblas/cblas_interface/scnrm2sub.c new file mode 100644 index 00000000000..48a56884698 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/scnrm2sub.c @@ -0,0 +1,34 @@ +/* ./scnrm2sub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* scnrm2sub.f */ + +/* The program is a fortran wrapper for scnrm2. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int scnrm2sub_(integer *n, complex *x, integer *incx, real * + nrm2) +{ + extern doublereal scnrm2_(integer *, complex *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *nrm2 = scnrm2_(n, &x[1], incx); + return 0; +} /* scnrm2sub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/sdotsub.c b/contrib/libs/cblas/cblas_interface/sdotsub.c new file mode 100644 index 00000000000..db0e7e4f049 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/sdotsub.c @@ -0,0 +1,35 @@ +/* ./sdotsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* sdotsub.f */ + +/* The program is a fortran wrapper for sdot. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int sdotsub_(integer *n, real *x, integer *incx, real *y, + integer *incy, real *dot) +{ + extern doublereal sdot_(integer *, real *, integer *, real *, integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + *dot = sdot_(n, &x[1], incx, &y[1], incy); + return 0; +} /* sdotsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/sdsdotsub.c b/contrib/libs/cblas/cblas_interface/sdsdotsub.c new file mode 100644 index 00000000000..c1c72c0103b --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/sdsdotsub.c @@ -0,0 +1,36 @@ +/* ./sdsdotsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* sdsdotsub.f */ + +/* The program is a fortran wrapper for sdsdot. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int sdsdotsub_(integer *n, real *x, integer *incx, real *y, + integer *incy, real *dot) +{ + extern doublereal sdsdot_(integer *, real *, integer *, real *, integer *) + ; + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + *dot = sdsdot_(n, &x[1], incx, &y[1], incy); + return 0; +} /* sdsdotsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/snrm2sub.c b/contrib/libs/cblas/cblas_interface/snrm2sub.c new file mode 100644 index 00000000000..4f3e379d9cd --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/snrm2sub.c @@ -0,0 +1,33 @@ +/* ./snrm2sub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* snrm2sub.f */ + +/* The program is a fortran wrapper for snrm2. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int snrm2sub_(integer *n, real *x, integer *incx, real *nrm2) +{ + extern doublereal snrm2_(integer *, real *, integer *); + + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + *nrm2 = snrm2_(n, &x[1], incx); + return 0; +} /* snrm2sub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/zdotcsub.c b/contrib/libs/cblas/cblas_interface/zdotcsub.c new file mode 100644 index 00000000000..86ae8860633 --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/zdotcsub.c @@ -0,0 +1,41 @@ +/* ./zdotcsub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* zdotcsub.f */ + +/* The program is a fortran wrapper for zdotc. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int zdotcsub_(integer *n, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublecomplex *dotc) +{ + /* System generated locals */ + doublecomplex z__1; + + /* Local variables */ + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + zdotc_(&z__1, n, &x[1], incx, &y[1], incy); + dotc->r = z__1.r, dotc->i = z__1.i; + return 0; +} /* zdotcsub_ */ + diff --git a/contrib/libs/cblas/cblas_interface/zdotusub.c b/contrib/libs/cblas/cblas_interface/zdotusub.c new file mode 100644 index 00000000000..06166c37bda --- /dev/null +++ b/contrib/libs/cblas/cblas_interface/zdotusub.c @@ -0,0 +1,41 @@ +/* ./zdotusub.f -- translated by f2c (version 20100827). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* zdotusub.f */ + +/* The program is a fortran wrapper for zdotu. */ +/* Witten by Keita Teranishi. 2/11/1998 */ + +/* Subroutine */ int zdotusub_(integer *n, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublecomplex *dotu) +{ + /* System generated locals */ + doublecomplex z__1; + + /* Local variables */ + extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + + + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + zdotu_(&z__1, n, &x[1], incx, &y[1], incy); + dotu->r = z__1.r, dotu->i = z__1.i; + return 0; +} /* zdotusub_ */ + diff --git a/contrib/libs/cblas/ccopy.c b/contrib/libs/cblas/ccopy.c new file mode 100644 index 00000000000..32e9952ce26 --- /dev/null +++ b/contrib/libs/cblas/ccopy.c @@ -0,0 +1,88 @@ +/* ccopy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ccopy_(integer *n, complex *cx, integer *incx, complex * + cy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, ix, iy; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CCOPY copies a vector x to a vector y. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = ix; + cy[i__2].r = cx[i__3].r, cy[i__2].i = cx[i__3].i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + cy[i__2].r = cx[i__3].r, cy[i__2].i = cx[i__3].i; +/* L30: */ + } + return 0; +} /* ccopy_ */ diff --git a/contrib/libs/cblas/cdotc.c b/contrib/libs/cblas/cdotc.c new file mode 100644 index 00000000000..a471573da41 --- /dev/null +++ b/contrib/libs/cblas/cdotc.c @@ -0,0 +1,106 @@ +/* cdotc.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Complex */ VOID cdotc_(complex * ret_val, integer *n, complex *cx, integer + *incx, complex *cy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, ix, iy; + complex ctemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* forms the dot product of two vectors, conjugating the first */ +/* vector. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + ctemp.r = 0.f, ctemp.i = 0.f; + ret_val->r = 0.f, ret_val->i = 0.f; + if (*n <= 0) { + return ; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + r_cnjg(&q__3, &cx[ix]); + i__2 = iy; + q__2.r = q__3.r * cy[i__2].r - q__3.i * cy[i__2].i, q__2.i = q__3.r * + cy[i__2].i + q__3.i * cy[i__2].r; + q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i; + ctemp.r = q__1.r, ctemp.i = q__1.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + r_cnjg(&q__3, &cx[i__]); + i__2 = i__; + q__2.r = q__3.r * cy[i__2].r - q__3.i * cy[i__2].i, q__2.i = q__3.r * + cy[i__2].i + q__3.i * cy[i__2].r; + q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i; + ctemp.r = q__1.r, ctemp.i = q__1.i; +/* L30: */ + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; +} /* cdotc_ */ diff --git a/contrib/libs/cblas/cdotu.c b/contrib/libs/cblas/cdotu.c new file mode 100644 index 00000000000..3aa48a29445 --- /dev/null +++ b/contrib/libs/cblas/cdotu.c @@ -0,0 +1,100 @@ +/* cdotu.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Complex */ VOID cdotu_(complex * ret_val, integer *n, complex *cx, integer + *incx, complex *cy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + complex q__1, q__2; + + /* Local variables */ + integer i__, ix, iy; + complex ctemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CDOTU forms the dot product of two vectors. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + ctemp.r = 0.f, ctemp.i = 0.f; + ret_val->r = 0.f, ret_val->i = 0.f; + if (*n <= 0) { + return ; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + i__3 = iy; + q__2.r = cx[i__2].r * cy[i__3].r - cx[i__2].i * cy[i__3].i, q__2.i = + cx[i__2].r * cy[i__3].i + cx[i__2].i * cy[i__3].r; + q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i; + ctemp.r = q__1.r, ctemp.i = q__1.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__2.r = cx[i__2].r * cy[i__3].r - cx[i__2].i * cy[i__3].i, q__2.i = + cx[i__2].r * cy[i__3].i + cx[i__2].i * cy[i__3].r; + q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i; + ctemp.r = q__1.r, ctemp.i = q__1.i; +/* L30: */ + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; +} /* cdotu_ */ diff --git a/contrib/libs/cblas/cgbmv.c b/contrib/libs/cblas/cgbmv.c new file mode 100644 index 00000000000..ec04382a296 --- /dev/null +++ b/contrib/libs/cblas/cgbmv.c @@ -0,0 +1,477 @@ +/* cgbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cgbmv_(char *trans, integer *m, integer *n, integer *kl, + integer *ku, complex *alpha, complex *a, integer *lda, complex *x, + integer *incx, complex *beta, complex *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info; + complex temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CGBMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */ + +/* y := alpha*conjg( A' )*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* KL - INTEGER. */ +/* On entry, KL specifies the number of sub-diagonals of the */ +/* matrix A. KL must satisfy 0 .le. KL. */ +/* Unchanged on exit. */ + +/* KU - INTEGER. */ +/* On entry, KU specifies the number of super-diagonals of the */ +/* matrix A. KU must satisfy 0 .le. KU. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading ( kl + ku + 1 ) by n part of the */ +/* array A must contain the matrix of coefficients, supplied */ +/* column by column, with the leading diagonal of the matrix in */ +/* row ( ku + 1 ) of the array, the first super-diagonal */ +/* starting at position 2 in row ku, the first sub-diagonal */ +/* starting at position 1 in row ( ku + 2 ), and so on. */ +/* Elements in the array A that do not correspond to elements */ +/* in the band matrix (such as the top left ku by ku triangle) */ +/* are not referenced. */ +/* The following program segment will transfer a band matrix */ +/* from conventional full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* K = KU + 1 - J */ +/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */ +/* A( K + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( kl + ku + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0) { + info = 4; + } else if (*ku < 0) { + info = 5; + } else if (*lda < *kl + *ku + 1) { + info = 8; + } else if (*incx == 0) { + info = 10; + } else if (*incy == 0) { + info = 13; + } + if (info != 0) { + xerbla_("CGBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r + == 1.f && beta->i == 0.f)) { + return 0; + } + + noconj = lsame_(trans, "T"); + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the band part of A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + kup1 = *ku + 1; + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = i__; + i__3 = i__; + i__5 = k + i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = jx; + if (x[i__4].r != 0.f || x[i__4].i != 0.f) { + i__4 = jx; + q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, + q__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4] + .r; + temp.r = q__1.r, temp.i = q__1.i; + iy = ky; + k = kup1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = iy; + i__2 = iy; + i__5 = k + i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + + q__2.i; + y[i__4].r = q__1.r, y[i__4].i = q__1.i; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + if (j > *ku) { + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0.f, temp.i = 0.f; + k = kup1 - j; + if (noconj) { +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + i__3 = k + i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + } else { +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + r_cnjg(&q__3, &a[k + i__ + j * a_dim1]); + i__2 = i__; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[i__2] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + } + i__4 = jy; + i__2 = jy; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i = + alpha->r * temp.i + alpha->i * temp.r; + q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; + y[i__4].r = q__1.r, y[i__4].i = q__1.i; + jy += *incy; +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0.f, temp.i = 0.f; + ix = kx; + k = kup1 - j; + if (noconj) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = k + i__ + j * a_dim1; + i__2 = ix; + q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2] + .i, q__2.i = a[i__4].r * x[i__2].i + a[i__4] + .i * x[i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L120: */ + } + } else { +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + r_cnjg(&q__3, &a[k + i__ + j * a_dim1]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L130: */ + } + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i = + alpha->r * temp.i + alpha->i * temp.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jy += *incy; + if (j > *ku) { + kx += *incx; + } +/* L140: */ + } + } + } + + return 0; + +/* End of CGBMV . */ + +} /* cgbmv_ */ diff --git a/contrib/libs/cblas/cgemm.c b/contrib/libs/cblas/cgemm.c new file mode 100644 index 00000000000..7568b5cbfe8 --- /dev/null +++ b/contrib/libs/cblas/cgemm.c @@ -0,0 +1,697 @@ +/* cgemm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cgemm_(char *transa, char *transb, integer *m, integer * + n, integer *k, complex *alpha, complex *a, integer *lda, complex *b, + integer *ldb, complex *beta, complex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, l, info; + logical nota, notb; + complex temp; + logical conja, conjb; + integer ncola; + extern logical lsame_(char *, char *); + integer nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CGEMM performs one of the matrix-matrix operations */ + +/* C := alpha*op( A )*op( B ) + beta*C, */ + +/* where op( X ) is one of */ + +/* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), */ + +/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */ +/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n', op( A ) = A. */ + +/* TRANSA = 'T' or 't', op( A ) = A'. */ + +/* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). */ + +/* Unchanged on exit. */ + +/* TRANSB - CHARACTER*1. */ +/* On entry, TRANSB specifies the form of op( B ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSB = 'N' or 'n', op( B ) = B. */ + +/* TRANSB = 'T' or 't', op( B ) = B'. */ + +/* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix */ +/* op( A ) and of the matrix C. M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix */ +/* op( B ) and the number of columns of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of columns of the matrix */ +/* op( A ) and the number of rows of the matrix op( B ). K must */ +/* be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANSA = 'N' or 'n', and is m otherwise. */ +/* Before entry with TRANSA = 'N' or 'n', the leading m by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by m part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */ +/* n when TRANSB = 'N' or 'n', and is k otherwise. */ +/* Before entry with TRANSB = 'N' or 'n', the leading k by n */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading n by k part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */ +/* LDB must be at least max( 1, k ), otherwise LDB must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n matrix */ +/* ( alpha*op( A )*op( B ) + beta*C ). */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NOTA and NOTB as true if A and B respectively are not */ +/* conjugated or transposed, set CONJA and CONJB as true if A and */ +/* B respectively are to be transposed but not conjugated and set */ +/* NROWA, NCOLA and NROWB as the number of rows and columns of A */ +/* and the number of rows of B respectively. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + nota = lsame_(transa, "N"); + notb = lsame_(transb, "N"); + conja = lsame_(transa, "C"); + conjb = lsame_(transb, "C"); + if (nota) { + nrowa = *m; + ncola = *k; + } else { + nrowa = *k; + ncola = *m; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + +/* Test the input parameters. */ + + info = 0; + if (! nota && ! conja && ! lsame_(transa, "T")) { + info = 1; + } else if (! notb && ! conjb && ! lsame_(transb, "T")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < max(1,nrowa)) { + info = 8; + } else if (*ldb < max(1,nrowb)) { + info = 10; + } else if (*ldc < max(1,*m)) { + info = 13; + } + if (info != 0) { + xerbla_("CGEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) + && (beta->r == 1.f && beta->i == 0.f)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + q__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (notb) { + if (nota) { + +/* Form C := alpha*A*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L50: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L60: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * b_dim1; + if (b[i__3].r != 0.f || b[i__3].i != 0.f) { + i__3 = l + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L70: */ + } + } +/* L80: */ + } +/* L90: */ + } + } else if (conja) { + +/* Form C := alpha*conjg( A' )*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, + q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L110: */ + } +/* L120: */ + } + } else { + +/* Form C := alpha*A'*B + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L130: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L140: */ + } +/* L150: */ + } + } + } else if (nota) { + if (conjb) { + +/* Form C := alpha*A*conjg( B' ) + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L160: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L170: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + if (b[i__3].r != 0.f || b[i__3].i != 0.f) { + r_cnjg(&q__2, &b[j + l * b_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, + q__1.i = alpha->r * q__2.i + alpha->i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L180: */ + } + } +/* L190: */ + } +/* L200: */ + } + } else { + +/* Form C := alpha*A*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L210: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L220: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + if (b[i__3].r != 0.f || b[i__3].i != 0.f) { + i__3 = j + l * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L230: */ + } + } +/* L240: */ + } +/* L250: */ + } + } + } else if (conja) { + if (conjb) { + +/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + r_cnjg(&q__4, &b[j + l * b_dim1]); + q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i = + q__3.r * q__4.i + q__3.i * q__4.r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L260: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L270: */ + } +/* L280: */ + } + } else { + +/* Form C := alpha*conjg( A' )*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = j + l * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, + q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L290: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L300: */ + } +/* L310: */ + } + } + } else { + if (conjb) { + +/* Form C := alpha*A'*conjg( B' ) + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + r_cnjg(&q__3, &b[j + l * b_dim1]); + q__2.r = a[i__4].r * q__3.r - a[i__4].i * q__3.i, + q__2.i = a[i__4].r * q__3.i + a[i__4].i * + q__3.r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L320: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L330: */ + } +/* L340: */ + } + } else { + +/* Form C := alpha*A'*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = j + l * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L350: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L360: */ + } +/* L370: */ + } + } + } + + return 0; + +/* End of CGEMM . */ + +} /* cgemm_ */ diff --git a/contrib/libs/cblas/cgemv.c b/contrib/libs/cblas/cgemv.c new file mode 100644 index 00000000000..bca57983f50 --- /dev/null +++ b/contrib/libs/cblas/cgemv.c @@ -0,0 +1,411 @@ +/* cgemv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cgemv_(char *trans, integer *m, integer *n, complex * + alpha, complex *a, integer *lda, complex *x, integer *incx, complex * + beta, complex *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + complex temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CGEMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */ + +/* y := alpha*conjg( A' )*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry with BETA non-zero, the incremented array Y */ +/* must contain the vector y. On exit, Y is overwritten by the */ +/* updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < max(1,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("CGEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r + == 1.f && beta->i == 0.f)) { + return 0; + } + + noconj = lsame_(trans, "T"); + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + iy += *incy; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0.f, temp.i = 0.f; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i = + alpha->r * temp.i + alpha->i * temp.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jy += *incy; +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0.f, temp.i = 0.f; + ix = kx; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ix; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L120: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L130: */ + } + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i = + alpha->r * temp.i + alpha->i * temp.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jy += *incy; +/* L140: */ + } + } + } + + return 0; + +/* End of CGEMV . */ + +} /* cgemv_ */ diff --git a/contrib/libs/cblas/cgerc.c b/contrib/libs/cblas/cgerc.c new file mode 100644 index 00000000000..378b9a716f7 --- /dev/null +++ b/contrib/libs/cblas/cgerc.c @@ -0,0 +1,217 @@ +/* cgerc.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cgerc_(integer *m, integer *n, complex *alpha, complex * + x, integer *incx, complex *y, integer *incy, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + complex temp; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CGERC performs the rank 1 operation */ + +/* A := alpha*x*conjg( y' ) + A, */ + +/* where alpha is a scalar, x is an m element vector, y is an n element */ +/* vector and A is an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the m */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. On exit, A is */ +/* overwritten by the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("CGERC ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0.f || y[i__2].i != 0.f) { + r_cnjg(&q__2, &y[jy]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0.f || y[i__2].i != 0.f) { + r_cnjg(&q__2, &y[jy]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of CGERC . */ + +} /* cgerc_ */ diff --git a/contrib/libs/cblas/cgeru.c b/contrib/libs/cblas/cgeru.c new file mode 100644 index 00000000000..ad87262030b --- /dev/null +++ b/contrib/libs/cblas/cgeru.c @@ -0,0 +1,214 @@ +/* cgeru.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cgeru_(integer *m, integer *n, complex *alpha, complex * + x, integer *incx, complex *y, integer *incy, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2; + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + complex temp; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CGERU performs the rank 1 operation */ + +/* A := alpha*x*y' + A, */ + +/* where alpha is a scalar, x is an m element vector, y is an n element */ +/* vector and A is an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the m */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. On exit, A is */ +/* overwritten by the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("CGERU ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0.f || y[i__2].i != 0.f) { + i__2 = jy; + q__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, q__1.i = + alpha->r * y[i__2].i + alpha->i * y[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0.f || y[i__2].i != 0.f) { + i__2 = jy; + q__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, q__1.i = + alpha->r * y[i__2].i + alpha->i * y[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of CGERU . */ + +} /* cgeru_ */ diff --git a/contrib/libs/cblas/chbmv.c b/contrib/libs/cblas/chbmv.c new file mode 100644 index 00000000000..81e5da74838 --- /dev/null +++ b/contrib/libs/cblas/chbmv.c @@ -0,0 +1,483 @@ +/* chbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex * + alpha, complex *a, integer *lda, complex *x, integer *incx, complex * + beta, complex *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, l, ix, iy, jx, jy, kx, ky, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHBMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n hermitian band matrix, with k super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the band matrix A is being supplied as */ +/* follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* being supplied. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* being supplied. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of super-diagonals of the */ +/* matrix A. K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the hermitian matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer the upper */ +/* triangular part of a hermitian band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the hermitian matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer the lower */ +/* triangular part of a hermitian band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set and are assumed to be zero. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*k < 0) { + info = 3; + } else if (*lda < *k + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("CHBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && + beta->i == 0.f)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array A */ +/* are accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when upper triangle of A is stored. */ + + kplus1 = *k + 1; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = i__; + i__3 = i__; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__2 = i__; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i = + q__3.r * x[i__2].i + q__3.i * x[i__2].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L50: */ + } + i__4 = j; + i__2 = j; + i__3 = kplus1 + j * a_dim1; + r__1 = a[i__3].r; + q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; + q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__4].r = q__1.r, y[i__4].i = q__1.i; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = jx; + q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i = + alpha->r * x[i__4].i + alpha->i * x[i__4].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + ix = kx; + iy = ky; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = iy; + i__2 = iy; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; + y[i__4].r = q__1.r, y[i__4].i = q__1.i; + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__4 = ix; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = + q__3.r * x[i__4].i + q__3.i * x[i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__3 = jy; + i__4 = jy; + i__2 = kplus1 + j * a_dim1; + r__1 = a[i__2].r; + q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; + q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + jx += *incx; + jy += *incy; + if (j > *k) { + kx += *incx; + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y when lower triangle of A is stored. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = j; + q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = + alpha->r * x[i__3].i + alpha->i * x[i__3].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = j; + i__4 = j; + i__2 = j * a_dim1 + 1; + r__1 = a[i__2].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__2 = i__; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; + y[i__4].r = q__1.r, y[i__4].i = q__1.i; + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__4 = i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = + q__3.r * x[i__4].i + q__3.i * x[i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L90: */ + } + i__3 = j; + i__4 = j; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = jx; + q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i = + alpha->r * x[i__3].i + alpha->i * x[i__3].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = jy; + i__4 = jy; + i__2 = j * a_dim1 + 1; + r__1 = a[i__2].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + l = 1 - j; + ix = jx; + iy = jy; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + ix += *incx; + iy += *incy; + i__4 = iy; + i__2 = iy; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i; + y[i__4].r = q__1.r, y[i__4].i = q__1.i; + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__4 = ix; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = + q__3.r * x[i__4].i + q__3.i * x[i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L110: */ + } + i__3 = jy; + i__4 = jy; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of CHBMV . */ + +} /* chbmv_ */ diff --git a/contrib/libs/cblas/chemm.c b/contrib/libs/cblas/chemm.c new file mode 100644 index 00000000000..7404e5da97c --- /dev/null +++ b/contrib/libs/cblas/chemm.c @@ -0,0 +1,495 @@ +/* chemm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n, + complex *alpha, complex *a, integer *lda, complex *b, integer *ldb, + complex *beta, complex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + real r__1; + complex q__1, q__2, q__3, q__4, q__5; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHEMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is an hermitian matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the hermitian matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the hermitian matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* hermitian matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* hermitian matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix C. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix C. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the hermitian matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the hermitian matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the hermitian */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the hermitian matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the hermitian matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the hermitian */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n updated */ +/* matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,*m)) { + info = 9; + } else if (*ldc < max(1,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("CHEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r + == 1.f && beta->i == 0.f)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + q__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + j * c_dim1; + i__5 = k + j * c_dim1; + i__6 = k + i__ * a_dim1; + q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i, + q__2.i = temp1.r * a[i__6].i + temp1.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; + i__4 = k + j * b_dim1; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i, + q__2.i = b[i__4].r * q__3.i + b[i__4].i * + q__3.r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L50: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + i__ * a_dim1; + r__1 = a[i__4].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + i__5 = i__ + i__ * a_dim1; + r__1 = a[i__5].r; + q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; + q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, + q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + j * c_dim1; + i__4 = k + j * c_dim1; + i__5 = k + i__ * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[ + i__5].r; + q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i + + q__2.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + i__3 = k + j * b_dim1; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i, + q__2.i = b[i__3].r * q__3.i + b[i__3].i * + q__3.r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L80: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = i__ + j * c_dim1; + i__3 = i__ + i__ * a_dim1; + r__1 = a[i__3].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__2].r = q__1.r, c__[i__2].i = q__1.i; + } else { + i__2 = i__ + j * c_dim1; + i__3 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3] + .i, q__3.i = beta->r * c__[i__3].i + beta->i * + c__[i__3].r; + i__4 = i__ + i__ * a_dim1; + r__1 = a[i__4].r; + q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; + q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + c__[i__2].r = q__1.r, c__[i__2].i = q__1.i; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + r__1 = a[i__2].r; + q__1.r = r__1 * alpha->r, q__1.i = r__1 * alpha->i; + temp1.r = q__1.r, temp1.i = q__1.i; + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i, + q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4] + .r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + q__2.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + i__5 = i__ + j * b_dim1; + q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i, + q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5] + .r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + i__3 = k + j * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + } else { + r_cnjg(&q__2, &a[j + k * a_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + r_cnjg(&q__2, &a[j + k * a_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + } else { + i__3 = k + j * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of CHEMM . */ + +} /* chemm_ */ diff --git a/contrib/libs/cblas/chemv.c b/contrib/libs/cblas/chemv.c new file mode 100644 index 00000000000..163cecaf95d --- /dev/null +++ b/contrib/libs/cblas/chemv.c @@ -0,0 +1,433 @@ +/* chemv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int chemv_(char *uplo, integer *n, complex *alpha, complex * + a, integer *lda, complex *x, integer *incx, complex *beta, complex *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHEMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n hermitian matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of A is not referenced. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set and are assumed to be zero. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < max(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("CHEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && + beta->i == 0.f)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when A is stored in upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L50: */ + } + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + r__1 = a[i__4].r; + q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + r__1 = a[i__4].r; + q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } else { + +/* Form y when A is stored in lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + r__1 = a[i__4].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L90: */ + } + i__2 = j; + i__3 = j; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + r__1 = a[i__4].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L110: */ + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of CHEMV . */ + +} /* chemv_ */ diff --git a/contrib/libs/cblas/cher.c b/contrib/libs/cblas/cher.c new file mode 100644 index 00000000000..933de87e048 --- /dev/null +++ b/contrib/libs/cblas/cher.c @@ -0,0 +1,338 @@ +/* cher.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cher_(char *uplo, integer *n, real *alpha, complex *x, + integer *incx, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + complex q__1, q__2; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHER performs the hermitian rank 1 operation */ + +/* A := alpha*x*conjg( x' ) + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n hermitian matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*lda < max(1,*n)) { + info = 7; + } + if (info != 0) { + xerbla_("CHER ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in upper triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[j]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L10: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[jx]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } + jx += *incx; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in lower triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[j]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L50: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[jx]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + + q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L70: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } + jx += *incx; +/* L80: */ + } + } + } + + return 0; + +/* End of CHER . */ + +} /* cher_ */ diff --git a/contrib/libs/cblas/cher2.c b/contrib/libs/cblas/cher2.c new file mode 100644 index 00000000000..2de3bab9409 --- /dev/null +++ b/contrib/libs/cblas/cher2.c @@ -0,0 +1,446 @@ +/* cher2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cher2_(char *uplo, integer *n, complex *alpha, complex * + x, integer *incx, complex *y, integer *incy, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHER2 performs the hermitian rank 2 operation */ + +/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an n */ +/* by n hermitian matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*n)) { + info = 9; + } + if (info != 0) { + xerbla_("CHER2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[j]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = j; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i + + q__3.i; + i__6 = i__; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L10: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[jy]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = jx; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i + + q__3.i; + i__6 = iy; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + ix += *incx; + iy += *incy; +/* L30: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } + jx += *incx; + jy += *incy; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[j]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = j; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i + + q__3.i; + i__6 = i__; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L50: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[jy]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = jx; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = a[i__3].r + q__1.r; + a[i__2].r = r__1, a[i__2].i = 0.f; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i + + q__3.i; + i__6 = iy; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L70: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; + } + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } + + return 0; + +/* End of CHER2 . */ + +} /* cher2_ */ diff --git a/contrib/libs/cblas/cher2k.c b/contrib/libs/cblas/cher2k.c new file mode 100644 index 00000000000..c5f2d999c19 --- /dev/null +++ b/contrib/libs/cblas/cher2k.c @@ -0,0 +1,671 @@ +/* cher2k.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cher2k_(char *uplo, char *trans, integer *n, integer *k, + complex *alpha, complex *a, integer *lda, complex *b, integer *ldb, + real *beta, complex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + real r__1; + complex q__1, q__2, q__3, q__4, q__5, q__6; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, l, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHER2K performs one of the hermitian rank 2k operations */ + +/* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, */ + +/* or */ + +/* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, */ + +/* where alpha and beta are scalars with beta real, C is an n by n */ +/* hermitian matrix and A and B are n by k matrices in the first case */ +/* and k by n matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + */ +/* conjg( alpha )*B*conjg( A' ) + */ +/* beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + */ +/* conjg( alpha )*conjg( B' )*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'C' or 'c', K specifies the number of rows of the */ +/* matrices A and B. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. */ +/* Ed Anderson, Cray Research Inc. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,nrowa)) { + info = 9; + } else if (*ldc < max(1,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("CHER2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && *beta == + 1.f) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + if (upper) { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; +/* L40: */ + } + } + } else { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + */ +/* C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L90: */ + } + } else if (*beta != 1.f) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L100: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != + 0.f || b[i__4].i != 0.f)) { + r_cnjg(&q__2, &b[j + l * b_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, + q__1.i = alpha->r * q__2.i + alpha->i * + q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__3 = j + l * a_dim1; + q__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__2.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, q__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5] + .i + q__3.i; + i__7 = i__ + l * b_dim1; + q__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, q__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + + q__4.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L110: */ + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + q__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + q__2.i = a[i__5].r * temp1.i + a[i__5].i * + temp1.r; + i__6 = j + l * b_dim1; + q__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + q__3.i = b[i__6].r * temp2.i + b[i__6].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = c__[i__4].r + q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L140: */ + } + } else if (*beta != 1.f) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L150: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != + 0.f || b[i__4].i != 0.f)) { + r_cnjg(&q__2, &b[j + l * b_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, + q__1.i = alpha->r * q__2.i + alpha->i * + q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__3 = j + l * a_dim1; + q__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__2.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, q__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5] + .i + q__3.i; + i__7 = i__ + l * b_dim1; + q__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, q__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + + q__4.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L160: */ + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + q__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + q__2.i = a[i__5].r * temp1.i + a[i__5].i * + temp1.r; + i__6 = j + l * b_dim1; + q__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + q__3.i = b[i__6].r * temp2.i + b[i__6].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = c__[i__4].r + q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + */ +/* C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1.r = 0.f, temp1.i = 0.f; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, + q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] + .r; + q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i; + temp1.r = q__1.r, temp1.i = q__1.i; + r_cnjg(&q__3, &b[l + i__ * b_dim1]); + i__4 = l + j * a_dim1; + q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i, + q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4] + .r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L190: */ + } + if (i__ == j) { + if (*beta == 0.f) { + i__3 = j + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + r_cnjg(&q__4, alpha); + q__3.r = q__4.r * temp2.r - q__4.i * temp2.i, + q__3.i = q__4.r * temp2.i + q__4.i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + + q__3.i; + r__1 = q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + r_cnjg(&q__4, alpha); + q__3.r = q__4.r * temp2.r - q__4.i * temp2.i, + q__3.i = q__4.r * temp2.i + q__4.i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + + q__3.i; + r__1 = *beta * c__[i__4].r + q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } + } else { + if (*beta == 0.f) { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + r_cnjg(&q__4, alpha); + q__3.r = q__4.r * temp2.r - q__4.i * temp2.i, + q__3.i = q__4.r * temp2.i + q__4.i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__3.r = *beta * c__[i__4].r, q__3.i = *beta * + c__[i__4].i; + q__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + + q__4.i; + r_cnjg(&q__6, alpha); + q__5.r = q__6.r * temp2.r - q__6.i * temp2.i, + q__5.i = q__6.r * temp2.i + q__6.i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + + q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1.r = 0.f, temp1.i = 0.f; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i, + q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4] + .r; + q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i; + temp1.r = q__1.r, temp1.i = q__1.i; + r_cnjg(&q__3, &b[l + i__ * b_dim1]); + i__4 = l + j * a_dim1; + q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i, + q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4] + .r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L220: */ + } + if (i__ == j) { + if (*beta == 0.f) { + i__3 = j + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + r_cnjg(&q__4, alpha); + q__3.r = q__4.r * temp2.r - q__4.i * temp2.i, + q__3.i = q__4.r * temp2.i + q__4.i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + + q__3.i; + r__1 = q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + r_cnjg(&q__4, alpha); + q__3.r = q__4.r * temp2.r - q__4.i * temp2.i, + q__3.i = q__4.r * temp2.i + q__4.i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + + q__3.i; + r__1 = *beta * c__[i__4].r + q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } + } else { + if (*beta == 0.f) { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + r_cnjg(&q__4, alpha); + q__3.r = q__4.r * temp2.r - q__4.i * temp2.i, + q__3.i = q__4.r * temp2.i + q__4.i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__3.r = *beta * c__[i__4].r, q__3.i = *beta * + c__[i__4].i; + q__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + + q__4.i; + r_cnjg(&q__6, alpha); + q__5.r = q__6.r * temp2.r - q__6.i * temp2.i, + q__5.i = q__6.r * temp2.i + q__6.i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + + q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of CHER2K. */ + +} /* cher2k_ */ diff --git a/contrib/libs/cblas/cherk.c b/contrib/libs/cblas/cherk.c new file mode 100644 index 00000000000..fae90fb3b17 --- /dev/null +++ b/contrib/libs/cblas/cherk.c @@ -0,0 +1,533 @@ +/* cherk.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cherk_(char *uplo, char *trans, integer *n, integer *k, + real *alpha, complex *a, integer *lda, real *beta, complex *c__, + integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + real r__1; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, l, info; + complex temp; + extern logical lsame_(char *, char *); + integer nrowa; + real rtemp; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHERK performs one of the hermitian rank k operations */ + +/* C := alpha*A*conjg( A' ) + beta*C, */ + +/* or */ + +/* C := alpha*conjg( A' )*A + beta*C, */ + +/* where alpha and beta are real scalars, C is an n by n hermitian */ +/* matrix and A is an n by k matrix in the first case and a k by n */ +/* matrix in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'C' or 'c', K specifies the number of rows of the */ +/* matrix A. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. */ +/* Ed Anderson, Cray Research Inc. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldc < max(1,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("CHERK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.f) { + if (upper) { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; +/* L40: */ + } + } + } else { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*conjg( A' ) + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L90: */ + } + } else if (*beta != 1.f) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L100: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + r_cnjg(&q__2, &a[j + l * a_dim1]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L110: */ + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = i__ + l * a_dim1; + q__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__1.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + r__1 = c__[i__4].r + q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L140: */ + } + } else if (*beta != 1.f) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L150: */ + } + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + r_cnjg(&q__2, &a[j + l * a_dim1]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + q__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__1.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + r__1 = c__[i__4].r + q__1.r; + c__[i__3].r = r__1, c__[i__3].i = 0.f; + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*conjg( A' )*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = l + j * a_dim1; + q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i, + q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L190: */ + } + if (*beta == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = *alpha * temp.r, q__1.i = *alpha * temp.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = *alpha * temp.r, q__2.i = *alpha * temp.i; + i__4 = i__ + j * c_dim1; + q__3.r = *beta * c__[i__4].r, q__3.i = *beta * c__[ + i__4].i; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L200: */ + } + rtemp = 0.f; + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + r_cnjg(&q__3, &a[l + j * a_dim1]); + i__3 = l + j * a_dim1; + q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i = + q__3.r * a[i__3].i + q__3.i * a[i__3].r; + q__1.r = rtemp + q__2.r, q__1.i = q__2.i; + rtemp = q__1.r; +/* L210: */ + } + if (*beta == 0.f) { + i__2 = j + j * c_dim1; + r__1 = *alpha * rtemp; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *alpha * rtemp + *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } +/* L220: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + rtemp = 0.f; + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + r_cnjg(&q__3, &a[l + j * a_dim1]); + i__3 = l + j * a_dim1; + q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i = + q__3.r * a[i__3].i + q__3.i * a[i__3].r; + q__1.r = rtemp + q__2.r, q__1.i = q__2.i; + rtemp = q__1.r; +/* L230: */ + } + if (*beta == 0.f) { + i__2 = j + j * c_dim1; + r__1 = *alpha * rtemp; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + r__1 = *alpha * rtemp + *beta * c__[i__3].r; + c__[i__2].r = r__1, c__[i__2].i = 0.f; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + r_cnjg(&q__3, &a[l + i__ * a_dim1]); + i__4 = l + j * a_dim1; + q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i, + q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4] + .r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L240: */ + } + if (*beta == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = *alpha * temp.r, q__1.i = *alpha * temp.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = *alpha * temp.r, q__2.i = *alpha * temp.i; + i__4 = i__ + j * c_dim1; + q__3.r = *beta * c__[i__4].r, q__3.i = *beta * c__[ + i__4].i; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L250: */ + } +/* L260: */ + } + } + } + + return 0; + +/* End of CHERK . */ + +} /* cherk_ */ diff --git a/contrib/libs/cblas/chpmv.c b/contrib/libs/cblas/chpmv.c new file mode 100644 index 00000000000..29d580adb8c --- /dev/null +++ b/contrib/libs/cblas/chpmv.c @@ -0,0 +1,434 @@ +/* chpmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex * + ap, complex *x, integer *incx, complex *beta, complex *y, integer * + incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHPMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n hermitian matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set and are assumed to be zero. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --y; + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 6; + } else if (*incy == 0) { + info = 9; + } + if (info != 0) { + xerbla_("CHPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && + beta->i == 0.f)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + +/* First form y := beta*y. */ + + if (beta->r != 1.f || beta->i != 0.f) { + if (*incy == 1) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0.f, y[i__2].i = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0.f, y[i__2].i = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + q__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form y when AP contains the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &ap[k]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ++k; +/* L50: */ + } + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + r__1 = ap[i__4].r; + q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + kk += j; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = iy; + i__4 = iy; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &ap[k]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__2 = jy; + i__3 = jy; + i__4 = kk + j - 1; + r__1 = ap[i__4].r; + q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i; + q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i; + q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; + kk += j; +/* L80: */ + } + } + } else { + +/* Form y when AP contains the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = j; + i__3 = j; + i__4 = kk; + r__1 = ap[i__4].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &ap[k]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; + ++k; +/* L90: */ + } + i__2 = j; + i__3 = j; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + kk += *n - j + 1; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = jy; + i__3 = jy; + i__4 = kk; + r__1 = ap[i__4].r; + q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = k; + q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i; + y[i__3].r = q__1.r, y[i__3].i = q__1.i; + r_cnjg(&q__3, &ap[k]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i = + q__3.r * x[i__3].i + q__3.i * x[i__3].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L110: */ + } + i__2 = jy; + i__3 = jy; + q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i; + y[i__2].r = q__1.r, y[i__2].i = q__1.i; + jx += *incx; + jy += *incy; + kk += *n - j + 1; +/* L120: */ + } + } + } + + return 0; + +/* End of CHPMV . */ + +} /* chpmv_ */ diff --git a/contrib/libs/cblas/chpr.c b/contrib/libs/cblas/chpr.c new file mode 100644 index 00000000000..2622f05531f --- /dev/null +++ b/contrib/libs/cblas/chpr.c @@ -0,0 +1,339 @@ +/* chpr.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int chpr_(char *uplo, integer *n, real *alpha, complex *x, + integer *incx, complex *ap) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + real r__1; + complex q__1, q__2; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHPR performs the hermitian rank 1 operation */ + +/* A := alpha*x*conjg( x' ) + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n hermitian matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } + if (info != 0) { + xerbla_("CHPR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[j]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++k; +/* L10: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = j; + q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[jx]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = jx; + q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[j]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = kk; + i__3 = kk; + i__4 = j; + q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++k; +/* L50: */ + } + } else { + i__2 = kk; + i__3 = kk; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + r_cnjg(&q__2, &x[jx]); + q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = kk; + i__3 = kk; + i__4 = jx; + q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = k; + i__5 = ix; + q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + q__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i + + q__2.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; +/* L70: */ + } + } else { + i__2 = kk; + i__3 = kk; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + jx += *incx; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of CHPR . */ + +} /* chpr_ */ diff --git a/contrib/libs/cblas/chpr2.c b/contrib/libs/cblas/chpr2.c new file mode 100644 index 00000000000..f16950a3e43 --- /dev/null +++ b/contrib/libs/cblas/chpr2.c @@ -0,0 +1,447 @@ +/* chpr2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int chpr2_(char *uplo, integer *n, complex *alpha, complex * + x, integer *incx, complex *y, integer *incy, complex *ap) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5, i__6; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CHPR2 performs the hermitian rank 2 operation */ + +/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an */ +/* n by n hermitian matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --y; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } + if (info != 0) { + xerbla_("CHPR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[j]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = j; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i + + q__3.i; + i__6 = i__; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++k; +/* L10: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = j; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + kk += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[jy]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = jx; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + i__5 = ix; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i + + q__3.i; + i__6 = iy; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ix += *incx; + iy += *incy; +/* L30: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = jx; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + jx += *incx; + jy += *incy; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[j]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = j; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = kk; + i__3 = kk; + i__4 = j; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i + + q__3.i; + i__6 = i__; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; + ++k; +/* L50: */ + } + } else { + i__2 = kk; + i__3 = kk; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f + || y[i__3].i != 0.f)) { + r_cnjg(&q__2, &y[jy]); + q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = + alpha->r * q__2.i + alpha->i * q__2.r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__2 = jx; + q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + r_cnjg(&q__1, &q__2); + temp2.r = q__1.r, temp2.i = q__1.i; + i__2 = kk; + i__3 = kk; + i__4 = jx; + q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + q__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + q__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + r__1 = ap[i__3].r + q__1.r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + i__3 = k; + i__4 = k; + i__5 = ix; + q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + q__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i + + q__3.i; + i__6 = iy; + q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + q__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + ap[i__3].r = q__1.r, ap[i__3].i = q__1.i; +/* L70: */ + } + } else { + i__2 = kk; + i__3 = kk; + r__1 = ap[i__3].r; + ap[i__2].r = r__1, ap[i__2].i = 0.f; + } + jx += *incx; + jy += *incy; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of CHPR2 . */ + +} /* chpr2_ */ diff --git a/contrib/libs/cblas/crotg.c b/contrib/libs/cblas/crotg.c new file mode 100644 index 00000000000..8edb25ea229 --- /dev/null +++ b/contrib/libs/cblas/crotg.c @@ -0,0 +1,72 @@ +/* crotg.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int crotg_(complex *ca, complex *cb, real *c__, complex *s) +{ + /* System generated locals */ + real r__1, r__2; + complex q__1, q__2, q__3; + + /* Builtin functions */ + double c_abs(complex *), sqrt(doublereal); + void r_cnjg(complex *, complex *); + + /* Local variables */ + real norm; + complex alpha; + real scale; + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CROTG determines a complex Givens rotation. */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + if (c_abs(ca) != 0.f) { + goto L10; + } + *c__ = 0.f; + s->r = 1.f, s->i = 0.f; + ca->r = cb->r, ca->i = cb->i; + goto L20; +L10: + scale = c_abs(ca) + c_abs(cb); + q__1.r = ca->r / scale, q__1.i = ca->i / scale; +/* Computing 2nd power */ + r__1 = c_abs(&q__1); + q__2.r = cb->r / scale, q__2.i = cb->i / scale; +/* Computing 2nd power */ + r__2 = c_abs(&q__2); + norm = scale * sqrt(r__1 * r__1 + r__2 * r__2); + r__1 = c_abs(ca); + q__1.r = ca->r / r__1, q__1.i = ca->i / r__1; + alpha.r = q__1.r, alpha.i = q__1.i; + *c__ = c_abs(ca) / norm; + r_cnjg(&q__3, cb); + q__2.r = alpha.r * q__3.r - alpha.i * q__3.i, q__2.i = alpha.r * q__3.i + + alpha.i * q__3.r; + q__1.r = q__2.r / norm, q__1.i = q__2.i / norm; + s->r = q__1.r, s->i = q__1.i; + q__1.r = norm * alpha.r, q__1.i = norm * alpha.i; + ca->r = q__1.r, ca->i = q__1.i; +L20: + return 0; +} /* crotg_ */ diff --git a/contrib/libs/cblas/cscal.c b/contrib/libs/cblas/cscal.c new file mode 100644 index 00000000000..7c22710d044 --- /dev/null +++ b/contrib/libs/cblas/cscal.c @@ -0,0 +1,81 @@ +/* cscal.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cscal_(integer *n, complex *ca, complex *cx, integer * + incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1; + + /* Local variables */ + integer i__, nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* scales a vector by a constant. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --cx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + i__4 = i__; + q__1.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__1.i = ca->r * cx[ + i__4].i + ca->i * cx[i__4].r; + cx[i__3].r = q__1.r, cx[i__3].i = q__1.i; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + +L20: + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__1 = i__; + i__3 = i__; + q__1.r = ca->r * cx[i__3].r - ca->i * cx[i__3].i, q__1.i = ca->r * cx[ + i__3].i + ca->i * cx[i__3].r; + cx[i__1].r = q__1.r, cx[i__1].i = q__1.i; +/* L30: */ + } + return 0; +} /* cscal_ */ diff --git a/contrib/libs/cblas/csrot.c b/contrib/libs/cblas/csrot.c new file mode 100644 index 00000000000..0010a2af915 --- /dev/null +++ b/contrib/libs/cblas/csrot.c @@ -0,0 +1,153 @@ +/* csrot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int csrot_(integer *n, complex *cx, integer *incx, complex * + cy, integer *incy, real *c__, real *s) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1, q__2, q__3; + + /* Local variables */ + integer i__, ix, iy; + complex ctemp; + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Applies a plane rotation, where the cos and sin (c and s) are real */ +/* and the vectors cx and cy are complex. */ +/* jack dongarra, linpack, 3/11/78. */ + +/* Arguments */ +/* ========== */ + +/* N (input) INTEGER */ +/* On entry, N specifies the order of the vectors cx and cy. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* CX (input) COMPLEX array, dimension at least */ +/* ( 1 + ( N - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array CX must contain the n */ +/* element vector cx. On exit, CX is overwritten by the updated */ +/* vector cx. */ + +/* INCX (input) INTEGER */ +/* On entry, INCX specifies the increment for the elements of */ +/* CX. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* CY (input) COMPLEX array, dimension at least */ +/* ( 1 + ( N - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array CY must contain the n */ +/* element vector cy. On exit, CY is overwritten by the updated */ +/* vector cy. */ + +/* INCY (input) INTEGER */ +/* On entry, INCY specifies the increment for the elements of */ +/* CY. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* C (input) REAL */ +/* On entry, C specifies the cosine, cos. */ +/* Unchanged on exit. */ + +/* S (input) REAL */ +/* On entry, S specifies the sine, sin. */ +/* Unchanged on exit. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i; + i__3 = iy; + q__3.r = *s * cy[i__3].r, q__3.i = *s * cy[i__3].i; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__2 = iy; + i__3 = iy; + q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i; + i__4 = ix; + q__3.r = *s * cx[i__4].r, q__3.i = *s * cx[i__4].i; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + cy[i__2].r = q__1.r, cy[i__2].i = q__1.i; + i__2 = ix; + cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i; + i__3 = i__; + q__3.r = *s * cy[i__3].r, q__3.i = *s * cy[i__3].i; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__2 = i__; + i__3 = i__; + q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i; + i__4 = i__; + q__3.r = *s * cx[i__4].r, q__3.i = *s * cx[i__4].i; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + cy[i__2].r = q__1.r, cy[i__2].i = q__1.i; + i__2 = i__; + cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; +/* L30: */ + } + return 0; +} /* csrot_ */ diff --git a/contrib/libs/cblas/csscal.c b/contrib/libs/cblas/csscal.c new file mode 100644 index 00000000000..f849d23c712 --- /dev/null +++ b/contrib/libs/cblas/csscal.c @@ -0,0 +1,88 @@ +/* csscal.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int csscal_(integer *n, real *sa, complex *cx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + real r__1, r__2; + complex q__1; + + /* Builtin functions */ + double r_imag(complex *); + + /* Local variables */ + integer i__, nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* scales a complex vector by a real constant. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --cx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + i__4 = i__; + r__1 = *sa * cx[i__4].r; + r__2 = *sa * r_imag(&cx[i__]); + q__1.r = r__1, q__1.i = r__2; + cx[i__3].r = q__1.r, cx[i__3].i = q__1.i; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + +L20: + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__1 = i__; + i__3 = i__; + r__1 = *sa * cx[i__3].r; + r__2 = *sa * r_imag(&cx[i__]); + q__1.r = r__1, q__1.i = r__2; + cx[i__1].r = q__1.r, cx[i__1].i = q__1.i; +/* L30: */ + } + return 0; +} /* csscal_ */ diff --git a/contrib/libs/cblas/cswap.c b/contrib/libs/cblas/cswap.c new file mode 100644 index 00000000000..b007f86a708 --- /dev/null +++ b/contrib/libs/cblas/cswap.c @@ -0,0 +1,93 @@ +/* cswap.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int cswap_(integer *n, complex *cx, integer *incx, complex * + cy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, ix, iy; + complex ctemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* interchanges two vectors. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + ctemp.r = cx[i__2].r, ctemp.i = cx[i__2].i; + i__2 = ix; + i__3 = iy; + cx[i__2].r = cy[i__3].r, cx[i__2].i = cy[i__3].i; + i__2 = iy; + cy[i__2].r = ctemp.r, cy[i__2].i = ctemp.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + ctemp.r = cx[i__2].r, ctemp.i = cx[i__2].i; + i__2 = i__; + i__3 = i__; + cx[i__2].r = cy[i__3].r, cx[i__2].i = cy[i__3].i; + i__2 = i__; + cy[i__2].r = ctemp.r, cy[i__2].i = ctemp.i; +/* L30: */ + } + return 0; +} /* cswap_ */ diff --git a/contrib/libs/cblas/csymm.c b/contrib/libs/cblas/csymm.c new file mode 100644 index 00000000000..595b8673250 --- /dev/null +++ b/contrib/libs/cblas/csymm.c @@ -0,0 +1,495 @@ +/* csymm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int csymm_(char *side, char *uplo, integer *m, integer *n, + complex *alpha, complex *a, integer *lda, complex *b, integer *ldb, + complex *beta, complex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + complex q__1, q__2, q__3, q__4, q__5; + + /* Local variables */ + integer i__, j, k, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CSYMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is a symmetric matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the symmetric matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the symmetric matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix C. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix C. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n updated */ +/* matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,*m)) { + info = 9; + } else if (*ldc < max(1,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("CSYMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r + == 1.f && beta->i == 0.f)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + q__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + j * c_dim1; + i__5 = k + j * c_dim1; + i__6 = k + i__ * a_dim1; + q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i, + q__2.i = temp1.r * a[i__6].i + temp1.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; + i__4 = k + j * b_dim1; + i__5 = k + i__ * a_dim1; + q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] + .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4] + .i * a[i__5].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L50: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + i__ * a_dim1; + q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, + q__2.i = temp1.r * a[i__4].i + temp1.i * a[ + i__4].r; + q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + i__5 = i__ + i__ * a_dim1; + q__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__4.i = temp1.r * a[i__5].i + temp1.i * a[ + i__5].r; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; + q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, + q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + temp2.r = 0.f, temp2.i = 0.f; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + j * c_dim1; + i__4 = k + j * c_dim1; + i__5 = k + i__ * a_dim1; + q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + q__2.i = temp1.r * a[i__5].i + temp1.i * a[ + i__5].r; + q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i + + q__2.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + i__3 = k + j * b_dim1; + i__4 = k + i__ * a_dim1; + q__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4] + .i, q__2.i = b[i__3].r * a[i__4].i + b[i__3] + .i * a[i__4].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L80: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = i__ + j * c_dim1; + i__3 = i__ + i__ * a_dim1; + q__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, + q__2.i = temp1.r * a[i__3].i + temp1.i * a[ + i__3].r; + q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__2].r = q__1.r, c__[i__2].i = q__1.i; + } else { + i__2 = i__ + j * c_dim1; + i__3 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3] + .i, q__3.i = beta->r * c__[i__3].i + beta->i * + c__[i__3].r; + i__4 = i__ + i__ * a_dim1; + q__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, + q__4.i = temp1.r * a[i__4].i + temp1.i * a[ + i__4].r; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; + q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + c__[i__2].r = q__1.r, c__[i__2].i = q__1.i; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, q__1.i = + alpha->r * a[i__2].i + alpha->i * a[i__2].r; + temp1.r = q__1.r, temp1.i = q__1.i; + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i, + q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4] + .r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + q__2.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + i__5 = i__ + j * b_dim1; + q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i, + q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5] + .r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + i__3 = k + j * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + } else { + i__3 = j + k * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + i__3 = j + k * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + } else { + i__3 = k + j * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = q__1.r, temp1.i = q__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of CSYMM . */ + +} /* csymm_ */ diff --git a/contrib/libs/cblas/csyr2k.c b/contrib/libs/cblas/csyr2k.c new file mode 100644 index 00000000000..782867892ee --- /dev/null +++ b/contrib/libs/cblas/csyr2k.c @@ -0,0 +1,537 @@ +/* csyr2k.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int csyr2k_(char *uplo, char *trans, integer *n, integer *k, + complex *alpha, complex *a, integer *lda, complex *b, integer *ldb, + complex *beta, complex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + complex q__1, q__2, q__3, q__4, q__5; + + /* Local variables */ + integer i__, j, l, info; + complex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CSYR2K performs one of the symmetric rank 2k operations */ + +/* C := alpha*A*B' + alpha*B*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*B + alpha*B'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A and B are n by k matrices in the first case and k by n */ +/* matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ +/* beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'T' or 't', K specifies the number of rows of the */ +/* matrices A and B. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,nrowa)) { + info = 9; + } else if (*ldc < max(1,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("CSYR2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && ( + beta->r == 1.f && beta->i == 0.f)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + if (upper) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*B' + alpha*B*A' + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L90: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != + 0.f || b[i__4].i != 0.f)) { + i__3 = j + l * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__3 = j + l * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp2.r = q__1.r, temp2.i = q__1.i; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, q__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5] + .i + q__3.i; + i__7 = i__ + l * b_dim1; + q__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, q__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + + q__4.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L140: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != + 0.f || b[i__4].i != 0.f)) { + i__3 = j + l * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp1.r = q__1.r, temp1.i = q__1.i; + i__3 = j + l * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp2.r = q__1.r, temp2.i = q__1.i; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, q__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5] + .i + q__3.i; + i__7 = i__ + l * b_dim1; + q__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, q__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + + q__4.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*B + alpha*B'*A + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1.r = 0.f, temp1.i = 0.f; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i; + temp1.r = q__1.r, temp1.i = q__1.i; + i__4 = l + i__ * b_dim1; + i__5 = l + j * a_dim1; + q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] + .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4] + .i * a[i__5].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L190: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; + q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1.r = 0.f, temp1.i = 0.f; + temp2.r = 0.f, temp2.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i; + temp1.r = q__1.r, temp1.i = q__1.i; + i__4 = l + i__ * b_dim1; + i__5 = l + j * a_dim1; + q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] + .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4] + .i * a[i__5].r; + q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; + temp2.r = q__1.r, temp2.i = q__1.i; +/* L220: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + q__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; + q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + q__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of CSYR2K. */ + +} /* csyr2k_ */ diff --git a/contrib/libs/cblas/csyrk.c b/contrib/libs/cblas/csyrk.c new file mode 100644 index 00000000000..fdc86929572 --- /dev/null +++ b/contrib/libs/cblas/csyrk.c @@ -0,0 +1,457 @@ +/* csyrk.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int csyrk_(char *uplo, char *trans, integer *n, integer *k, + complex *alpha, complex *a, integer *lda, complex *beta, complex *c__, + integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + complex q__1, q__2, q__3; + + /* Local variables */ + integer i__, j, l, info; + complex temp; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CSYRK performs one of the symmetric rank k operations */ + +/* C := alpha*A*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A is an n by k matrix in the first case and a k by n matrix */ +/* in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'T' or 't', K specifies the number of rows of the */ +/* matrix A. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldc < max(1,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("CSYRK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && ( + beta->r == 1.f && beta->i == 0.f)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + if (upper) { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (beta->r == 0.f && beta->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*A' + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L90: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + i__3 = j + l * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0.f && beta->i == 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0.f, c__[i__3].i = 0.f; +/* L140: */ + } + } else if (beta->r != 1.f || beta->i != 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + i__3 = j + l * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + q__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + q__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5] + .i + q__2.i; + c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * a_dim1; + q__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5] + .i, q__2.i = a[i__4].r * a[i__5].i + a[i__4] + .i * a[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L190: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp.r = 0.f, temp.i = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * a_dim1; + q__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5] + .i, q__2.i = a[i__4].r * a[i__5].i + a[i__4] + .i * a[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L220: */ + } + if (beta->r == 0.f && beta->i == 0.f) { + i__3 = i__ + j * c_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * c_dim1; + q__2.r = alpha->r * temp.r - alpha->i * temp.i, + q__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, q__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of CSYRK . */ + +} /* csyrk_ */ diff --git a/contrib/libs/cblas/ctbmv.c b/contrib/libs/cblas/ctbmv.c new file mode 100644 index 00000000000..cbaf63578be --- /dev/null +++ b/contrib/libs/cblas/ctbmv.c @@ -0,0 +1,641 @@ +/* ctbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, complex *a, integer *lda, complex *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTBMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("CTBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = i__; + i__3 = i__; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; +/* L10: */ + } + if (nounit) { + i__4 = j; + i__2 = j; + i__3 = kplus1 + j * a_dim1; + q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, q__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__4].r = q__1.r, x[i__4].i = q__1.i; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = jx; + if (x[i__4].r != 0.f || x[i__4].i != 0.f) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = ix; + i__2 = ix; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i + + q__2.i; + x[i__4].r = q__1.r, x[i__4].i = q__1.i; + ix += *incx; +/* L30: */ + } + if (nounit) { + i__3 = jx; + i__4 = jx; + i__2 = kplus1 + j * a_dim1; + q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[ + i__2].i, q__1.i = x[i__4].r * a[i__2].i + + x[i__4].i * a[i__2].r; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } + } + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { + i__1 = i__; + i__3 = i__; + i__2 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + q__2.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + + q__2.i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; +/* L50: */ + } + if (nounit) { + i__4 = j; + i__1 = j; + i__3 = j * a_dim1 + 1; + q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[ + i__3].i, q__1.i = x[i__1].r * a[i__3].i + + x[i__1].i * a[i__3].r; + x[i__4].r = q__1.r, x[i__4].i = q__1.i; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__4 = jx; + if (x[i__4].r != 0.f || x[i__4].i != 0.f) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { + i__4 = ix; + i__1 = ix; + i__2 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + q__2.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i + + q__2.i; + x[i__4].r = q__1.r, x[i__4].i = q__1.i; + ix -= *incx; +/* L70: */ + } + if (nounit) { + i__3 = jx; + i__4 = jx; + i__1 = j * a_dim1 + 1; + q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[ + i__1].i, q__1.i = x[i__4].r * a[i__1].i + + x[i__4].i * a[i__1].r; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } + } + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x or x := conjg( A' )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__3 = j; + temp.r = x[i__3].r, temp.i = x[i__3].i; + l = kplus1 - j; + if (noconj) { + if (nounit) { + i__3 = kplus1 + j * a_dim1; + q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + q__1.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + i__4 = l + i__ + j * a_dim1; + i__1 = i__; + q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ + i__1].i, q__2.i = a[i__4].r * x[i__1].i + + a[i__4].i * x[i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__4 = i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + } + i__3 = j; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L110: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__3 = jx; + temp.r = x[i__3].r, temp.i = x[i__3].i; + kx -= *incx; + ix = kx; + l = kplus1 - j; + if (noconj) { + if (nounit) { + i__3 = kplus1 + j * a_dim1; + q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + q__1.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + i__4 = l + i__ + j * a_dim1; + i__1 = ix; + q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ + i__1].i, q__2.i = a[i__4].r * x[i__1].i + + a[i__4].i * x[i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L120: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__4 = ix; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L130: */ + } + } + i__3 = jx; + x[i__3].r = temp.r, x[i__3].i = temp.i; + jx -= *incx; +/* L140: */ + } + } + } else { + if (*incx == 1) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + i__4 = j; + temp.r = x[i__4].r, temp.i = x[i__4].i; + l = 1 - j; + if (noconj) { + if (nounit) { + i__4 = j * a_dim1 + 1; + q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + q__1.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + i__1 = l + i__ + j * a_dim1; + i__2 = i__; + q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, q__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L150: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[j * a_dim1 + 1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__1 = i__; + q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, + q__2.i = q__3.r * x[i__1].i + q__3.i * x[ + i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L160: */ + } + } + i__4 = j; + x[i__4].r = temp.r, x[i__4].i = temp.i; +/* L170: */ + } + } else { + jx = kx; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + kx += *incx; + ix = kx; + l = 1 - j; + if (noconj) { + if (nounit) { + i__4 = j * a_dim1 + 1; + q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + q__1.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + i__1 = l + i__ + j * a_dim1; + i__2 = ix; + q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, q__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L180: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[j * a_dim1 + 1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__1 = ix; + q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, + q__2.i = q__3.r * x[i__1].i + q__3.i * x[ + i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L190: */ + } + } + i__4 = jx; + x[i__4].r = temp.r, x[i__4].i = temp.i; + jx += *incx; +/* L200: */ + } + } + } + } + + return 0; + +/* End of CTBMV . */ + +} /* ctbmv_ */ diff --git a/contrib/libs/cblas/ctbsv.c b/contrib/libs/cblas/ctbsv.c new file mode 100644 index 00000000000..0f47dfba029 --- /dev/null +++ b/contrib/libs/cblas/ctbsv.c @@ -0,0 +1,609 @@ +/* ctbsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctbsv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, complex *a, integer *lda, complex *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTBSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */ +/* diagonals. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' conjg( A' )*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("CTBSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed by sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + l = kplus1 - j; + if (nounit) { + i__1 = j; + c_div(&q__1, &x[j], &a[kplus1 + j * a_dim1]); + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + q__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i - + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; +/* L10: */ + } + } +/* L20: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + kx -= *incx; + i__1 = jx; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + ix = kx; + l = kplus1 - j; + if (nounit) { + i__1 = jx; + c_div(&q__1, &x[jx], &a[kplus1 + j * a_dim1]); + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + i__2 = ix; + i__3 = ix; + i__4 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + q__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i - + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + ix -= *incx; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + l = 1 - j; + if (nounit) { + i__2 = j; + c_div(&q__1, &x[j], &a[j * a_dim1 + 1]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i - + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + kx += *incx; + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + ix = kx; + l = 1 - j; + if (nounit) { + i__2 = jx; + c_div(&q__1, &x[jx], &a[j * a_dim1 + 1]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = ix; + i__4 = ix; + i__5 = l + i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i - + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x or x := inv( conjg( A') )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + l = kplus1 - j; + if (noconj) { +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = l + i__ + j * a_dim1; + i__3 = i__; + q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[ + i__3].i, q__2.i = a[i__2].r * x[i__3].i + + a[i__2].i * x[i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[kplus1 + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__4 = i__; + q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, + q__2.i = q__3.r * x[i__4].i + q__3.i * x[ + i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + if (nounit) { + r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__3 = j; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L110: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = jx; + temp.r = x[i__3].r, temp.i = x[i__3].i; + ix = kx; + l = kplus1 - j; + if (noconj) { +/* Computing MAX */ + i__3 = 1, i__4 = j - *k; + i__2 = j - 1; + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + i__3 = l + i__ + j * a_dim1; + i__4 = ix; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, q__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L120: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[kplus1 + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__2 = ix; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L130: */ + } + if (nounit) { + r_cnjg(&q__2, &a[kplus1 + j * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__4 = jx; + x[i__4].r = temp.r, x[i__4].i = temp.i; + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L140: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + l = 1 - j; + if (noconj) { +/* Computing MIN */ + i__1 = *n, i__4 = j + *k; + i__2 = j + 1; + for (i__ = min(i__1,i__4); i__ >= i__2; --i__) { + i__1 = l + i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__1].r * x[i__4].r - a[i__1].i * x[ + i__4].i, q__2.i = a[i__1].r * x[i__4].i + + a[i__1].i * x[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L150: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[j * a_dim1 + 1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { +/* Computing MIN */ + i__2 = *n, i__1 = j + *k; + i__4 = j + 1; + for (i__ = min(i__2,i__1); i__ >= i__4; --i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__2 = i__; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L160: */ + } + if (nounit) { + r_cnjg(&q__2, &a[j * a_dim1 + 1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__4 = j; + x[i__4].r = temp.r, x[i__4].i = temp.i; +/* L170: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + ix = kx; + l = 1 - j; + if (noconj) { +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__1 = j + 1; + for (i__ = min(i__4,i__2); i__ >= i__1; --i__) { + i__4 = l + i__ + j * a_dim1; + i__2 = ix; + q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[ + i__2].i, q__2.i = a[i__4].r * x[i__2].i + + a[i__4].i * x[i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L180: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[j * a_dim1 + 1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { +/* Computing MIN */ + i__1 = *n, i__4 = j + *k; + i__2 = j + 1; + for (i__ = min(i__1,i__4); i__ >= i__2; --i__) { + r_cnjg(&q__3, &a[l + i__ + j * a_dim1]); + i__1 = ix; + q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, + q__2.i = q__3.r * x[i__1].i + q__3.i * x[ + i__1].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L190: */ + } + if (nounit) { + r_cnjg(&q__2, &a[j * a_dim1 + 1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L200: */ + } + } + } + } + + return 0; + +/* End of CTBSV . */ + +} /* ctbsv_ */ diff --git a/contrib/libs/cblas/ctpmv.c b/contrib/libs/cblas/ctpmv.c new file mode 100644 index 00000000000..1a28e954445 --- /dev/null +++ b/contrib/libs/cblas/ctpmv.c @@ -0,0 +1,571 @@ +/* ctpmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctpmv_(char *uplo, char *trans, char *diag, integer *n, + complex *ap, complex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTPMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("CTPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x:= A*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, q__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i + + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + ++k; +/* L10: */ + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + q__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ + i__4].i, q__1.i = x[i__3].r * ap[i__4].i + + x[i__3].i * ap[i__4].r; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = ix; + i__4 = ix; + i__5 = k; + q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, q__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i + + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = kk + j - 1; + q__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ + i__4].i, q__1.i = x[i__3].r * ap[i__4].i + + x[i__3].i * ap[i__4].r; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = k; + q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, q__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + --k; +/* L50: */ + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = kk - *n + j; + q__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ + i__3].i, q__1.i = x[i__2].r * ap[i__3].i + + x[i__2].i * ap[i__3].r; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + } + kk -= *n - j + 1; +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = ix; + i__3 = ix; + i__4 = k; + q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, q__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + ix -= *incx; +/* L70: */ + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = kk - *n + j; + q__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ + i__3].i, q__1.i = x[i__2].r * ap[i__3].i + + x[i__2].i * ap[i__3].r; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + } + jx -= *incx; + kk -= *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x or x := conjg( A' )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + if (noconj) { + if (nounit) { + i__1 = kk; + q__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] + .i, q__1.i = temp.r * ap[i__1].i + temp.i + * ap[i__1].r; + temp.r = q__1.r, temp.i = q__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = k; + i__2 = i__; + q__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[ + i__2].i, q__2.i = ap[i__1].r * x[i__2].i + + ap[i__1].i * x[i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + --k; +/* L90: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &ap[kk]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + r_cnjg(&q__3, &ap[k]); + i__1 = i__; + q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, + q__2.i = q__3.r * x[i__1].i + q__3.i * x[ + i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + --k; +/* L100: */ + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= j; +/* L110: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = kk; + q__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] + .i, q__1.i = temp.r * ap[i__1].i + temp.i + * ap[i__1].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = k; + i__3 = ix; + q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, q__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L120: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &ap[kk]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + r_cnjg(&q__3, &ap[k]); + i__2 = ix; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L130: */ + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= j; +/* L140: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + if (noconj) { + if (nounit) { + i__2 = kk; + q__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] + .i, q__1.i = temp.r * ap[i__2].i + temp.i + * ap[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, q__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ++k; +/* L150: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &ap[kk]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &ap[k]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ++k; +/* L160: */ + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += *n - j + 1; +/* L170: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = kk; + q__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] + .i, q__1.i = temp.r * ap[i__2].i + temp.i + * ap[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = ix; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, q__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L180: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &ap[kk]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + r_cnjg(&q__3, &ap[k]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L190: */ + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += *n - j + 1; +/* L200: */ + } + } + } + } + + return 0; + +/* End of CTPMV . */ + +} /* ctpmv_ */ diff --git a/contrib/libs/cblas/ctpsv.c b/contrib/libs/cblas/ctpsv.c new file mode 100644 index 00000000000..2e810f674ce --- /dev/null +++ b/contrib/libs/cblas/ctpsv.c @@ -0,0 +1,539 @@ +/* ctpsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctpsv_(char *uplo, char *trans, char *diag, integer *n, + complex *ap, complex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTPSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix, supplied in packed form. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' conjg( A' )*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("CTPSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + if (nounit) { + i__1 = j; + c_div(&q__1, &x[j], &ap[kk]); + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__; + i__2 = i__; + i__3 = k; + q__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3] + .i, q__2.i = temp.r * ap[i__3].i + temp.i + * ap[i__3].r; + q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i - + q__2.i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + --k; +/* L10: */ + } + } + kk -= j; +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + if (nounit) { + i__1 = jx; + c_div(&q__1, &x[jx], &ap[kk]); + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = ix; + i__3 = ix; + i__4 = k; + q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, q__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i - + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; +/* L30: */ + } + } + jx -= *incx; + kk -= j; +/* L40: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + if (nounit) { + i__2 = j; + c_div(&q__1, &x[j], &ap[kk]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, q__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i - + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + ++k; +/* L50: */ + } + } + kk += *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + if (nounit) { + i__2 = jx; + c_div(&q__1, &x[jx], &ap[kk]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = ix; + i__4 = ix; + i__5 = k; + q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, q__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i - + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L70: */ + } + } + jx += *incx; + kk += *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, q__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ++k; +/* L90: */ + } + if (nounit) { + c_div(&q__1, &temp, &ap[kk + j - 1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &ap[k]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ++k; +/* L100: */ + } + if (nounit) { + r_cnjg(&q__2, &ap[kk + j - 1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += j; +/* L110: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + if (noconj) { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = ix; + q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, q__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L120: */ + } + if (nounit) { + c_div(&q__1, &temp, &ap[kk + j - 1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + r_cnjg(&q__3, &ap[k]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L130: */ + } + if (nounit) { + r_cnjg(&q__2, &ap[kk + j - 1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += j; +/* L140: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = k; + i__3 = i__; + q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, q__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + --k; +/* L150: */ + } + if (nounit) { + c_div(&q__1, &temp, &ap[kk - *n + j]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + r_cnjg(&q__3, &ap[k]); + i__2 = i__; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + --k; +/* L160: */ + } + if (nounit) { + r_cnjg(&q__2, &ap[kk - *n + j]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= *n - j + 1; +/* L170: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + if (noconj) { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = k; + i__3 = ix; + q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, q__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L180: */ + } + if (nounit) { + c_div(&q__1, &temp, &ap[kk - *n + j]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + r_cnjg(&q__3, &ap[k]); + i__2 = ix; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L190: */ + } + if (nounit) { + r_cnjg(&q__2, &ap[kk - *n + j]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= *n - j + 1; +/* L200: */ + } + } + } + } + + return 0; + +/* End of CTPSV . */ + +} /* ctpsv_ */ diff --git a/contrib/libs/cblas/ctrmm.c b/contrib/libs/cblas/ctrmm.c new file mode 100644 index 00000000000..2b1f231ed6a --- /dev/null +++ b/contrib/libs/cblas/ctrmm.c @@ -0,0 +1,688 @@ +/* ctrmm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctrmm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, complex *alpha, complex *a, integer *lda, + complex *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, info; + complex temp; + extern logical lsame_(char *, char *); + logical lside; + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTRMM performs one of the matrix-matrix operations */ + +/* B := alpha*op( A )*B, or B := alpha*B*op( A ) */ + +/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) multiplies B from */ +/* the left or right as follows: */ + +/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */ + +/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B, and on exit is overwritten by the */ +/* transformed matrix. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + noconj = lsame_(transa, "T"); + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("CTRMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*A*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * b_dim1; + if (b[i__3].r != 0.f || b[i__3].i != 0.f) { + i__3 = k + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, q__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * a_dim1; + q__2.r = temp.r * a[i__6].r - temp.i * a[i__6] + .i, q__2.i = temp.r * a[i__6].i + + temp.i * a[i__6].r; + q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5] + .i + q__2.i; + b[i__4].r = q__1.r, b[i__4].i = q__1.i; +/* L30: */ + } + if (nounit) { + i__3 = k + k * a_dim1; + q__1.r = temp.r * a[i__3].r - temp.i * a[i__3] + .i, q__1.i = temp.r * a[i__3].i + + temp.i * a[i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__3 = k + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; + } +/* L40: */ + } +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + i__2 = k + j * b_dim1; + if (b[i__2].r != 0.f || b[i__2].i != 0.f) { + i__2 = k + j * b_dim1; + q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2] + .i, q__1.i = alpha->r * b[i__2].i + + alpha->i * b[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = k + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; + if (nounit) { + i__2 = k + j * b_dim1; + i__3 = k + j * b_dim1; + i__4 = k + k * a_dim1; + q__1.r = b[i__3].r * a[i__4].r - b[i__3].i * + a[i__4].i, q__1.i = b[i__3].r * a[ + i__4].i + b[i__3].i * a[i__4].r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5] + .i, q__2.i = temp.r * a[i__5].i + + temp.i * a[i__5].r; + q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4] + .i + q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L60: */ + } + } +/* L70: */ + } +/* L80: */ + } + } + } else { + +/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + temp.r = b[i__2].r, temp.i = b[i__2].i; + if (noconj) { + if (nounit) { + i__2 = i__ + i__ * a_dim1; + q__1.r = temp.r * a[i__2].r - temp.i * a[i__2] + .i, q__1.i = temp.r * a[i__2].i + + temp.i * a[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * a_dim1; + i__4 = k + j * b_dim1; + q__2.r = a[i__3].r * b[i__4].r - a[i__3].i * + b[i__4].i, q__2.i = a[i__3].r * b[ + i__4].i + a[i__3].i * b[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[i__ + i__ * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__3 = k + j * b_dim1; + q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3] + .i, q__2.i = q__3.r * b[i__3].i + + q__3.i * b[i__3].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + } + i__2 = i__ + j * b_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L110: */ + } +/* L120: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + temp.r = b[i__3].r, temp.i = b[i__3].i; + if (noconj) { + if (nounit) { + i__3 = i__ + i__ * a_dim1; + q__1.r = temp.r * a[i__3].r - temp.i * a[i__3] + .i, q__1.i = temp.r * a[i__3].i + + temp.i * a[i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * + b[i__5].i, q__2.i = a[i__4].r * b[ + i__5].i + a[i__4].i * b[i__5].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L130: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[i__ + i__ * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__4 = k + j * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4] + .i, q__2.i = q__3.r * b[i__4].i + + q__3.i * b[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L140: */ + } + } + i__3 = i__ + j * b_dim1; + q__1.r = alpha->r * temp.r - alpha->i * temp.i, + q__1.i = alpha->r * temp.i + alpha->i * + temp.r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L150: */ + } +/* L160: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*A. */ + + if (upper) { + for (j = *n; j >= 1; --j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__1 = j + j * a_dim1; + q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + q__1.i = temp.r * a[i__1].i + temp.i * a[i__1] + .r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + q__1.i = temp.r * b[i__3].i + temp.i * b[i__3] + .r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L170: */ + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k + j * a_dim1; + if (a[i__2].r != 0.f || a[i__2].i != 0.f) { + i__2 = k + j * a_dim1; + q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2] + .i, q__1.i = alpha->r * a[i__2].i + + alpha->i * a[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + q__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, q__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4] + .i + q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L180: */ + } + } +/* L190: */ + } +/* L200: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__2 = j + j * a_dim1; + q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + q__1.i = temp.r * a[i__2].i + temp.i * a[i__2] + .r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + q__1.i = temp.r * b[i__4].i + temp.i * b[i__4] + .r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L210: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + i__3 = k + j * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + i__3 = k + j * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3] + .i, q__1.i = alpha->r * a[i__3].i + + alpha->i * a[i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, q__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5] + .i + q__2.i; + b[i__4].r = q__1.r, b[i__4].i = q__1.i; +/* L220: */ + } + } +/* L230: */ + } +/* L240: */ + } + } + } else { + +/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */ + + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + k * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + if (noconj) { + i__3 = j + k * a_dim1; + q__1.r = alpha->r * a[i__3].r - alpha->i * a[ + i__3].i, q__1.i = alpha->r * a[i__3] + .i + alpha->i * a[i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + } else { + r_cnjg(&q__2, &a[j + k * a_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * + q__2.i, q__1.i = alpha->r * q__2.i + + alpha->i * q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, q__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5] + .i + q__2.i; + b[i__4].r = q__1.r, b[i__4].i = q__1.i; +/* L250: */ + } + } +/* L260: */ + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__2 = k + k * a_dim1; + q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + q__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } else { + r_cnjg(&q__2, &a[k + k * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + } + if (temp.r != 1.f || temp.i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + q__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L270: */ + } + } +/* L280: */ + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + if (a[i__2].r != 0.f || a[i__2].i != 0.f) { + if (noconj) { + i__2 = j + k * a_dim1; + q__1.r = alpha->r * a[i__2].r - alpha->i * a[ + i__2].i, q__1.i = alpha->r * a[i__2] + .i + alpha->i * a[i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } else { + r_cnjg(&q__2, &a[j + k * a_dim1]); + q__1.r = alpha->r * q__2.r - alpha->i * + q__2.i, q__1.i = alpha->r * q__2.i + + alpha->i * q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + q__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, q__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4] + .i + q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L290: */ + } + } +/* L300: */ + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__1 = k + k * a_dim1; + q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + q__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = q__1.r, temp.i = q__1.i; + } else { + r_cnjg(&q__2, &a[k + k * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + } + if (temp.r != 1.f || temp.i != 0.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + q__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L310: */ + } + } +/* L320: */ + } + } + } + } + + return 0; + +/* End of CTRMM . */ + +} /* ctrmm_ */ diff --git a/contrib/libs/cblas/ctrmv.c b/contrib/libs/cblas/ctrmv.c new file mode 100644 index 00000000000..9380189d239 --- /dev/null +++ b/contrib/libs/cblas/ctrmv.c @@ -0,0 +1,554 @@ +/* ctrmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctrmv_(char *uplo, char *trans, char *diag, integer *n, + complex *a, integer *lda, complex *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTRMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("CTRMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i + + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L10: */ + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + q__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ + i__4].i, q__1.i = x[i__3].r * a[i__4].i + + x[i__3].i * a[i__4].r; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = ix; + i__4 = ix; + i__5 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i + + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + ix += *incx; +/* L30: */ + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = j + j * a_dim1; + q__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ + i__4].i, q__1.i = x[i__3].r * a[i__4].i + + x[i__3].i * a[i__4].r; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + } + jx += *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + q__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; +/* L50: */ + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = j + j * a_dim1; + q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, q__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = ix; + i__3 = ix; + i__4 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + q__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i + + q__2.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + ix -= *incx; +/* L70: */ + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = j + j * a_dim1; + q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, q__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + } + jx -= *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x or x := conjg( A' )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + q__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = q__1.r, temp.i = q__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__ + j * a_dim1; + i__2 = i__; + q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, q__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__1 = i__; + q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, + q__2.i = q__3.r * x[i__1].i + q__3.i * x[ + i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; +/* L110: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + q__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = q__1.r, temp.i = q__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + i__1 = i__ + j * a_dim1; + i__2 = ix; + q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, q__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L120: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__1 = ix; + q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i, + q__2.i = q__3.r * x[i__1].i + q__3.i * x[ + i__1].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L130: */ + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; +/* L140: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + q__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, q__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L150: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L160: */ + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; +/* L170: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + q__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = i__ + j * a_dim1; + i__4 = ix; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, q__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L180: */ + } + } else { + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + q__1.r = temp.r * q__2.r - temp.i * q__2.i, + q__1.i = temp.r * q__2.i + temp.i * + q__2.r; + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r + q__2.r, q__1.i = temp.i + + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L190: */ + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; +/* L200: */ + } + } + } + } + + return 0; + +/* End of CTRMV . */ + +} /* ctrmv_ */ diff --git a/contrib/libs/cblas/ctrsm.c b/contrib/libs/cblas/ctrsm.c new file mode 100644 index 00000000000..ec893f619a3 --- /dev/null +++ b/contrib/libs/cblas/ctrsm.c @@ -0,0 +1,698 @@ +/* ctrsm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; + +/* Subroutine */ int ctrsm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, complex *alpha, complex *a, integer *lda, + complex *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, + i__6, i__7; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, k, info; + complex temp; + extern logical lsame_(char *, char *); + logical lside; + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTRSM solves one of the matrix equations */ + +/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ + +/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */ + +/* The matrix X is overwritten on B. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) appears on the left */ +/* or right of X as follows: */ + +/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ + +/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX . */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the right-hand side matrix B, and on exit is */ +/* overwritten by the solution matrix X. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + noconj = lsame_(transa, "T"); + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("CTRSM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0.f && alpha->i == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*inv( A )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (alpha->r != 1.f || alpha->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, q__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L30: */ + } + } + for (k = *m; k >= 1; --k) { + i__2 = k + j * b_dim1; + if (b[i__2].r != 0.f || b[i__2].i != 0.f) { + if (nounit) { + i__2 = k + j * b_dim1; + c_div(&q__1, &b[k + j * b_dim1], &a[k + k * + a_dim1]); + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = k + j * b_dim1; + i__6 = i__ + k * a_dim1; + q__2.r = b[i__5].r * a[i__6].r - b[i__5].i * + a[i__6].i, q__2.i = b[i__5].r * a[ + i__6].i + b[i__5].i * a[i__6].r; + q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4] + .i - q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L40: */ + } + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (alpha->r != 1.f || alpha->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, q__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L70: */ + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * b_dim1; + if (b[i__3].r != 0.f || b[i__3].i != 0.f) { + if (nounit) { + i__3 = k + j * b_dim1; + c_div(&q__1, &b[k + j * b_dim1], &a[k + k * + a_dim1]); + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = k + j * b_dim1; + i__7 = i__ + k * a_dim1; + q__2.r = b[i__6].r * a[i__7].r - b[i__6].i * + a[i__7].i, q__2.i = b[i__6].r * a[ + i__7].i + b[i__6].i * a[i__7].r; + q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5] + .i - q__2.i; + b[i__4].r = q__1.r, b[i__4].i = q__1.i; +/* L80: */ + } + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form B := alpha*inv( A' )*B */ +/* or B := alpha*inv( conjg( A' ) )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + q__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp.r = q__1.r, temp.i = q__1.i; + if (noconj) { + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * + b[i__5].i, q__2.i = a[i__4].r * b[ + i__5].i + a[i__4].i * b[i__5].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L110: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[i__ + i__ * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__4 = k + j * b_dim1; + q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4] + .i, q__2.i = q__3.r * b[i__4].i + + q__3.i * b[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L120: */ + } + if (nounit) { + r_cnjg(&q__2, &a[i__ + i__ * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__3 = i__ + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; +/* L130: */ + } +/* L140: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, + q__1.i = alpha->r * b[i__2].i + alpha->i * b[ + i__2].r; + temp.r = q__1.r, temp.i = q__1.i; + if (noconj) { + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + i__ * a_dim1; + i__4 = k + j * b_dim1; + q__2.r = a[i__3].r * b[i__4].r - a[i__3].i * + b[i__4].i, q__2.i = a[i__3].r * b[ + i__4].i + a[i__3].i * b[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L150: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[i__ + i__ * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__3 = k + j * b_dim1; + q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3] + .i, q__2.i = q__3.r * b[i__3].i + + q__3.i * b[i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L160: */ + } + if (nounit) { + r_cnjg(&q__2, &a[i__ + i__ * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__2 = i__ + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; +/* L170: */ + } +/* L180: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*inv( A ). */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (alpha->r != 1.f || alpha->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, q__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L190: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = k + j * a_dim1; + i__7 = i__ + k * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * + b[i__7].i, q__2.i = a[i__6].r * b[ + i__7].i + a[i__6].i * b[i__7].r; + q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5] + .i - q__2.i; + b[i__4].r = q__1.r, b[i__4].i = q__1.i; +/* L200: */ + } + } +/* L210: */ + } + if (nounit) { + c_div(&q__1, &c_b1, &a[j + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + q__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L220: */ + } + } +/* L230: */ + } + } else { + for (j = *n; j >= 1; --j) { + if (alpha->r != 1.f || alpha->i != 0.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, q__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L240: */ + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + i__2 = k + j * a_dim1; + if (a[i__2].r != 0.f || a[i__2].i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = k + j * a_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = a[i__5].r * b[i__6].r - a[i__5].i * + b[i__6].i, q__2.i = a[i__5].r * b[ + i__6].i + a[i__5].i * b[i__6].r; + q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4] + .i - q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L250: */ + } + } +/* L260: */ + } + if (nounit) { + c_div(&q__1, &c_b1, &a[j + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + q__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L270: */ + } + } +/* L280: */ + } + } + } else { + +/* Form B := alpha*B*inv( A' ) */ +/* or B := alpha*B*inv( conjg( A' ) ). */ + + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + if (noconj) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } else { + r_cnjg(&q__2, &a[k + k * a_dim1]); + c_div(&q__1, &c_b1, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + q__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L290: */ + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + if (a[i__2].r != 0.f || a[i__2].i != 0.f) { + if (noconj) { + i__2 = j + k * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + } else { + r_cnjg(&q__1, &a[j + k * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + q__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, q__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4] + .i - q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L300: */ + } + } +/* L310: */ + } + if (alpha->r != 1.f || alpha->i != 0.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, q__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; +/* L320: */ + } + } +/* L330: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + if (noconj) { + c_div(&q__1, &c_b1, &a[k + k * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } else { + r_cnjg(&q__2, &a[k + k * a_dim1]); + c_div(&q__1, &c_b1, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + q__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L340: */ + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + i__3 = j + k * a_dim1; + if (a[i__3].r != 0.f || a[i__3].i != 0.f) { + if (noconj) { + i__3 = j + k * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + } else { + r_cnjg(&q__1, &a[j + k * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + q__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, q__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5] + .i - q__2.i; + b[i__4].r = q__1.r, b[i__4].i = q__1.i; +/* L350: */ + } + } +/* L360: */ + } + if (alpha->r != 1.f || alpha->i != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, q__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L370: */ + } + } +/* L380: */ + } + } + } + } + + return 0; + +/* End of CTRSM . */ + +} /* ctrsm_ */ diff --git a/contrib/libs/cblas/ctrsv.c b/contrib/libs/cblas/ctrsv.c new file mode 100644 index 00000000000..9c46cacbcc2 --- /dev/null +++ b/contrib/libs/cblas/ctrsv.c @@ -0,0 +1,523 @@ +/* ctrsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ctrsv_(char *uplo, char *trans, char *diag, integer *n, + complex *a, integer *lda, complex *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1, q__2, q__3; + + /* Builtin functions */ + void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *); + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + complex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CTRSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' conjg( A' )*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("CTRSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + if (nounit) { + i__1 = j; + c_div(&q__1, &x[j], &a[j + j * a_dim1]); + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__; + i__2 = i__; + i__3 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + q__2.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i - + q__2.i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0.f || x[i__1].i != 0.f) { + if (nounit) { + i__1 = jx; + c_div(&q__1, &x[jx], &a[j + j * a_dim1]); + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + i__1 = ix; + i__2 = ix; + i__3 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + q__2.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i - + q__2.i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + if (nounit) { + i__2 = j; + c_div(&q__1, &x[j], &a[j + j * a_dim1]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i - + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0.f || x[i__2].i != 0.f) { + if (nounit) { + i__2 = jx; + c_div(&q__1, &x[jx], &a[j + j * a_dim1]); + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = ix; + i__4 = ix; + i__5 = i__ + j * a_dim1; + q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + q__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i - + q__2.i; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, q__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L90: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[j + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = i__; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L100: */ + } + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; +/* L110: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ix = kx; + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ix; + q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, q__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L120: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[j + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__3 = ix; + q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, + q__2.i = q__3.r * x[i__3].i + q__3.i * x[ + i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix += *incx; +/* L130: */ + } + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; +/* L140: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__ + j * a_dim1; + i__3 = i__; + q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[ + i__3].i, q__2.i = a[i__2].r * x[i__3].i + + a[i__2].i * x[i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L150: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[j + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__2 = i__; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; +/* L160: */ + } + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; +/* L170: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + ix = kx; + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__ + j * a_dim1; + i__3 = ix; + q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[ + i__3].i, q__2.i = a[i__2].r * x[i__3].i + + a[i__2].i * x[i__3].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L180: */ + } + if (nounit) { + c_div(&q__1, &temp, &a[j + j * a_dim1]); + temp.r = q__1.r, temp.i = q__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + r_cnjg(&q__3, &a[i__ + j * a_dim1]); + i__2 = ix; + q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, + q__2.i = q__3.r * x[i__2].i + q__3.i * x[ + i__2].r; + q__1.r = temp.r - q__2.r, q__1.i = temp.i - + q__2.i; + temp.r = q__1.r, temp.i = q__1.i; + ix -= *incx; +/* L190: */ + } + if (nounit) { + r_cnjg(&q__2, &a[j + j * a_dim1]); + c_div(&q__1, &temp, &q__2); + temp.r = q__1.r, temp.i = q__1.i; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; +/* L200: */ + } + } + } + } + + return 0; + +/* End of CTRSV . */ + +} /* ctrsv_ */ diff --git a/contrib/libs/cblas/dasum.c b/contrib/libs/cblas/dasum.c new file mode 100644 index 00000000000..6e5f54cef3a --- /dev/null +++ b/contrib/libs/cblas/dasum.c @@ -0,0 +1,101 @@ +/* dasum.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal dasum_(integer *n, doublereal *dx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer i__, m, mp1; + doublereal dtemp; + integer nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* takes the sum of the absolute values. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dx; + + /* Function Body */ + ret_val = 0.; + dtemp = 0.; + if (*n <= 0 || *incx <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dtemp += (d__1 = dx[i__], abs(d__1)); +/* L10: */ + } + ret_val = dtemp; + return ret_val; + +/* code for increment equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 6; + if (m == 0) { + goto L40; + } + i__2 = m; + for (i__ = 1; i__ <= i__2; ++i__) { + dtemp += (d__1 = dx[i__], abs(d__1)); +/* L30: */ + } + if (*n < 6) { + goto L60; + } +L40: + mp1 = m + 1; + i__2 = *n; + for (i__ = mp1; i__ <= i__2; i__ += 6) { + dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], + abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ + + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = + dx[i__ + 5], abs(d__6)); +/* L50: */ + } +L60: + ret_val = dtemp; + return ret_val; +} /* dasum_ */ diff --git a/contrib/libs/cblas/daxpy.c b/contrib/libs/cblas/daxpy.c new file mode 100644 index 00000000000..d6ef82815be --- /dev/null +++ b/contrib/libs/cblas/daxpy.c @@ -0,0 +1,107 @@ +/* daxpy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, + integer *incx, doublereal *dy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* constant times a vector plus a vector. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*da == 0.) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] += *da * dx[ix]; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 4; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] += *da * dx[i__]; +/* L30: */ + } + if (*n < 4) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 4) { + dy[i__] += *da * dx[i__]; + dy[i__ + 1] += *da * dx[i__ + 1]; + dy[i__ + 2] += *da * dx[i__ + 2]; + dy[i__ + 3] += *da * dx[i__ + 3]; +/* L50: */ + } + return 0; +} /* daxpy_ */ diff --git a/contrib/libs/cblas/dcabs1.c b/contrib/libs/cblas/dcabs1.c new file mode 100644 index 00000000000..0e926f0a449 --- /dev/null +++ b/contrib/libs/cblas/dcabs1.c @@ -0,0 +1,36 @@ +/* dcabs1.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal dcabs1_(doublecomplex *z__) +{ + /* System generated locals */ + doublereal ret_val, d__1, d__2; + + /* Builtin functions */ + double d_imag(doublecomplex *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. */ +/* Purpose */ +/* ======= */ + +/* DCABS1 computes absolute value of a double complex number */ + +/* .. Intrinsic Functions .. */ + + ret_val = (d__1 = z__->r, abs(d__1)) + (d__2 = d_imag(z__), abs(d__2)); + return ret_val; +} /* dcabs1_ */ diff --git a/contrib/libs/cblas/dcopy.c b/contrib/libs/cblas/dcopy.c new file mode 100644 index 00000000000..9033cceef21 --- /dev/null +++ b/contrib/libs/cblas/dcopy.c @@ -0,0 +1,107 @@ +/* dcopy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* copies a vector, x, to a vector, y. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 7; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] = dx[i__]; +/* L30: */ + } + if (*n < 7) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 7) { + dy[i__] = dx[i__]; + dy[i__ + 1] = dx[i__ + 1]; + dy[i__ + 2] = dx[i__ + 2]; + dy[i__ + 3] = dx[i__ + 3]; + dy[i__ + 4] = dx[i__ + 4]; + dy[i__ + 5] = dx[i__ + 5]; + dy[i__ + 6] = dx[i__ + 6]; +/* L50: */ + } + return 0; +} /* dcopy_ */ diff --git a/contrib/libs/cblas/ddot.c b/contrib/libs/cblas/ddot.c new file mode 100644 index 00000000000..331fe0ab290 --- /dev/null +++ b/contrib/libs/cblas/ddot.c @@ -0,0 +1,110 @@ +/* ddot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, + integer *incy) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + doublereal dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* forms the dot product of two vectors. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + ret_val = 0.; + dtemp = 0.; + if (*n <= 0) { + return ret_val; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[ix] * dy[iy]; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val = dtemp; + return ret_val; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 5; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[i__] * dy[i__]; +/* L30: */ + } + if (*n < 5) { + goto L60; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[ + i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + + 4] * dy[i__ + 4]; +/* L50: */ + } +L60: + ret_val = dtemp; + return ret_val; +} /* ddot_ */ diff --git a/contrib/libs/cblas/dgbmv.c b/contrib/libs/cblas/dgbmv.c new file mode 100644 index 00000000000..d734d2791ef --- /dev/null +++ b/contrib/libs/cblas/dgbmv.c @@ -0,0 +1,369 @@ +/* dgbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl, + integer *ku, doublereal *alpha, doublereal *a, integer *lda, + doublereal *x, integer *incx, doublereal *beta, doublereal *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info; + doublereal temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* KL - INTEGER. */ +/* On entry, KL specifies the number of sub-diagonals of the */ +/* matrix A. KL must satisfy 0 .le. KL. */ +/* Unchanged on exit. */ + +/* KU - INTEGER. */ +/* On entry, KU specifies the number of super-diagonals of the */ +/* matrix A. KU must satisfy 0 .le. KU. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading ( kl + ku + 1 ) by n part of the */ +/* array A must contain the matrix of coefficients, supplied */ +/* column by column, with the leading diagonal of the matrix in */ +/* row ( ku + 1 ) of the array, the first super-diagonal */ +/* starting at position 2 in row ku, the first sub-diagonal */ +/* starting at position 1 in row ( ku + 2 ), and so on. */ +/* Elements in the array A that do not correspond to elements */ +/* in the band matrix (such as the top left ku by ku triangle) */ +/* are not referenced. */ +/* The following program segment will transfer a band matrix */ +/* from conventional full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* K = KU + 1 - J */ +/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */ +/* A( K + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( kl + ku + 1 ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0) { + info = 4; + } else if (*ku < 0) { + info = 5; + } else if (*lda < *kl + *ku + 1) { + info = 8; + } else if (*incx == 0) { + info = 10; + } else if (*incy == 0) { + info = 13; + } + if (info != 0) { + xerbla_("DGBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the band part of A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + kup1 = *ku + 1; + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + y[i__] += temp * a[k + i__ + j * a_dim1]; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + iy = ky; + k = kup1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + y[iy] += temp * a[k + i__ + j * a_dim1]; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + if (j > *ku) { + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + k = kup1 - j; +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + temp += a[k + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L100: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + temp += a[k + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + y[jy] += *alpha * temp; + jy += *incy; + if (j > *ku) { + kx += *incx; + } +/* L120: */ + } + } + } + + return 0; + +/* End of DGBMV . */ + +} /* dgbmv_ */ diff --git a/contrib/libs/cblas/dgemm.c b/contrib/libs/cblas/dgemm.c new file mode 100644 index 00000000000..b802cb0fbd2 --- /dev/null +++ b/contrib/libs/cblas/dgemm.c @@ -0,0 +1,389 @@ +/* dgemm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer * + n, integer *k, doublereal *alpha, doublereal *a, integer *lda, + doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, + integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, l, info; + logical nota, notb; + doublereal temp; + integer ncola; + extern logical lsame_(char *, char *); + integer nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEMM performs one of the matrix-matrix operations */ + +/* C := alpha*op( A )*op( B ) + beta*C, */ + +/* where op( X ) is one of */ + +/* op( X ) = X or op( X ) = X', */ + +/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */ +/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n', op( A ) = A. */ + +/* TRANSA = 'T' or 't', op( A ) = A'. */ + +/* TRANSA = 'C' or 'c', op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* TRANSB - CHARACTER*1. */ +/* On entry, TRANSB specifies the form of op( B ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSB = 'N' or 'n', op( B ) = B. */ + +/* TRANSB = 'T' or 't', op( B ) = B'. */ + +/* TRANSB = 'C' or 'c', op( B ) = B'. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix */ +/* op( A ) and of the matrix C. M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix */ +/* op( B ) and the number of columns of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of columns of the matrix */ +/* op( A ) and the number of rows of the matrix op( B ). K must */ +/* be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANSA = 'N' or 'n', and is m otherwise. */ +/* Before entry with TRANSA = 'N' or 'n', the leading m by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by m part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */ +/* n when TRANSB = 'N' or 'n', and is k otherwise. */ +/* Before entry with TRANSB = 'N' or 'n', the leading k by n */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading n by k part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */ +/* LDB must be at least max( 1, k ), otherwise LDB must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n matrix */ +/* ( alpha*op( A )*op( B ) + beta*C ). */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NOTA and NOTB as true if A and B respectively are not */ +/* transposed and set NROWA, NCOLA and NROWB as the number of rows */ +/* and columns of A and the number of rows of B respectively. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + nota = lsame_(transa, "N"); + notb = lsame_(transb, "N"); + if (nota) { + nrowa = *m; + ncola = *k; + } else { + nrowa = *k; + ncola = *m; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + +/* Test the input parameters. */ + + info = 0; + if (! nota && ! lsame_(transa, "C") && ! lsame_( + transa, "T")) { + info = 1; + } else if (! notb && ! lsame_(transb, "C") && ! + lsame_(transb, "T")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < max(1,nrowa)) { + info = 8; + } else if (*ldb < max(1,nrowb)) { + info = 10; + } else if (*ldc < max(1,*m)) { + info = 13; + } + if (info != 0) { + xerbla_("DGEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And if alpha.eq.zero. */ + + if (*alpha == 0.) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (notb) { + if (nota) { + +/* Form C := alpha*A*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L50: */ + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L60: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (b[l + j * b_dim1] != 0.) { + temp = *alpha * b[l + j * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L70: */ + } + } +/* L80: */ + } +/* L90: */ + } + } else { + +/* Form C := alpha*A'*B + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; +/* L100: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L110: */ + } +/* L120: */ + } + } + } else { + if (nota) { + +/* Form C := alpha*A*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L130: */ + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L140: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (b[j + l * b_dim1] != 0.) { + temp = *alpha * b[j + l * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L150: */ + } + } +/* L160: */ + } +/* L170: */ + } + } else { + +/* Form C := alpha*A'*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; +/* L180: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L190: */ + } +/* L200: */ + } + } + } + + return 0; + +/* End of DGEMM . */ + +} /* dgemm_ */ diff --git a/contrib/libs/cblas/dgemv.c b/contrib/libs/cblas/dgemv.c new file mode 100644 index 00000000000..b82a5b3654d --- /dev/null +++ b/contrib/libs/cblas/dgemv.c @@ -0,0 +1,312 @@ +/* dgemv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal * + alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, + doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublereal temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry with BETA non-zero, the incremented array Y */ +/* must contain the vector y. On exit, Y is overwritten by the */ +/* updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < max(1,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("DGEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp * a[i__ + j * a_dim1]; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp * a[i__ + j * a_dim1]; + iy += *incy; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L100: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of DGEMV . */ + +} /* dgemv_ */ diff --git a/contrib/libs/cblas/dger.c b/contrib/libs/cblas/dger.c new file mode 100644 index 00000000000..085833b90cf --- /dev/null +++ b/contrib/libs/cblas/dger.c @@ -0,0 +1,194 @@ +/* dger.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *y, integer *incy, + doublereal *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + doublereal temp; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGER performs the rank 1 operation */ + +/* A := alpha*x*y' + A, */ + +/* where alpha is a scalar, x is an m element vector, y is an n element */ +/* vector and A is an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the m */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. On exit, A is */ +/* overwritten by the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("DGER ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0.) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of DGER . */ + +} /* dger_ */ diff --git a/contrib/libs/cblas/dnrm2.c b/contrib/libs/cblas/dnrm2.c new file mode 100644 index 00000000000..8c50ff5ddda --- /dev/null +++ b/contrib/libs/cblas/dnrm2.c @@ -0,0 +1,95 @@ +/* dnrm2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal dnrm2_(integer *n, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + integer ix; + doublereal ssq, norm, scale, absxi; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DNRM2 returns the euclidean norm of a vector via the function */ +/* name, so that */ + +/* DNRM2 := sqrt( x'*x ) */ + + +/* -- This version written on 25-October-1982. */ +/* Modified on 14-October-1993 to inline the call to DLASSQ. */ +/* Sven Hammarling, Nag Ltd. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n < 1 || *incx < 1) { + norm = 0.; + } else if (*n == 1) { + norm = abs(x[1]); + } else { + scale = 0.; + ssq = 1.; +/* The following loop is equivalent to this call to the LAPACK */ +/* auxiliary routine: */ +/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ + + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.) { + absxi = (d__1 = x[ix], abs(d__1)); + if (scale < absxi) { +/* Computing 2nd power */ + d__1 = scale / absxi; + ssq = ssq * (d__1 * d__1) + 1.; + scale = absxi; + } else { +/* Computing 2nd power */ + d__1 = absxi / scale; + ssq += d__1 * d__1; + } + } +/* L10: */ + } + norm = scale * sqrt(ssq); + } + + ret_val = norm; + return ret_val; + +/* End of DNRM2. */ + +} /* dnrm2_ */ diff --git a/contrib/libs/cblas/drot.c b/contrib/libs/cblas/drot.c new file mode 100644 index 00000000000..d4bc6bde4d6 --- /dev/null +++ b/contrib/libs/cblas/drot.c @@ -0,0 +1,86 @@ +/* drot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy, doublereal *c__, doublereal *s) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ix, iy; + doublereal dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* applies a plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[ix] + *s * dy[iy]; + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; + dx[ix] = dtemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[i__] + *s * dy[i__]; + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; + dx[i__] = dtemp; +/* L30: */ + } + return 0; +} /* drot_ */ diff --git a/contrib/libs/cblas/drotg.c b/contrib/libs/cblas/drotg.c new file mode 100644 index 00000000000..b2d9aa4affc --- /dev/null +++ b/contrib/libs/cblas/drotg.c @@ -0,0 +1,79 @@ +/* drotg.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Table of constant values */ + +static doublereal c_b4 = 1.; + +/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__, + doublereal *s) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal), d_sign(doublereal *, doublereal *); + + /* Local variables */ + doublereal r__, z__, roe, scale; + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* construct givens plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + roe = *db; + if (abs(*da) > abs(*db)) { + roe = *da; + } + scale = abs(*da) + abs(*db); + if (scale != 0.) { + goto L10; + } + *c__ = 1.; + *s = 0.; + r__ = 0.; + z__ = 0.; + goto L20; +L10: +/* Computing 2nd power */ + d__1 = *da / scale; +/* Computing 2nd power */ + d__2 = *db / scale; + r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2); + r__ = d_sign(&c_b4, &roe) * r__; + *c__ = *da / r__; + *s = *db / r__; + z__ = 1.; + if (abs(*da) > abs(*db)) { + z__ = *s; + } + if (abs(*db) >= abs(*da) && *c__ != 0.) { + z__ = 1. / *c__; + } +L20: + *da = r__; + *db = z__; + return 0; +} /* drotg_ */ diff --git a/contrib/libs/cblas/drotm.c b/contrib/libs/cblas/drotm.c new file mode 100644 index 00000000000..90815c2e880 --- /dev/null +++ b/contrib/libs/cblas/drotm.c @@ -0,0 +1,215 @@ +/* drotm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy, doublereal *dparam) +{ + /* Initialized data */ + + static doublereal zero = 0.; + static doublereal two = 2.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__; + doublereal w, z__; + integer kx, ky; + doublereal dh11, dh12, dh21, dh22, dflag; + integer nsteps; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ + +/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ +/* (DY**T) */ + +/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ +/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ +/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ + +/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ +/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* number of elements in input vector(s) */ + +/* DX (input/output) DOUBLE PRECISION array, dimension N */ +/* double precision vector with N elements */ + +/* INCX (input) INTEGER */ +/* storage spacing between elements of DX */ + +/* DY (input/output) DOUBLE PRECISION array, dimension N */ +/* double precision vector with N elements */ + +/* INCY (input) INTEGER */ +/* storage spacing between elements of DY */ + +/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ +/* DPARAM(1)=DFLAG */ +/* DPARAM(2)=DH11 */ +/* DPARAM(3)=DH21 */ +/* DPARAM(4)=DH12 */ +/* DPARAM(5)=DH22 */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --dparam; + --dy; + --dx; + + /* Function Body */ +/* .. */ + + dflag = dparam[1]; + if (*n <= 0 || dflag + two == zero) { + goto L140; + } + if (! (*incx == *incy && *incx > 0)) { + goto L70; + } + + nsteps = *n * *incx; + if (dflag < 0.) { + goto L50; + } else if (dflag == 0) { + goto L10; + } else { + goto L30; + } +L10: + dh12 = dparam[4]; + dh21 = dparam[3]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w + z__ * dh12; + dy[i__] = w * dh21 + z__; +/* L20: */ + } + goto L140; +L30: + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__; + dy[i__] = -w + dh22 * z__; +/* L40: */ + } + goto L140; +L50: + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__ * dh12; + dy[i__] = w * dh21 + z__ * dh22; +/* L60: */ + } + goto L140; +L70: + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (dflag < 0.) { + goto L120; + } else if (dflag == 0) { + goto L80; + } else { + goto L100; + } +L80: + dh12 = dparam[4]; + dh21 = dparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w + z__ * dh12; + dy[ky] = w * dh21 + z__; + kx += *incx; + ky += *incy; +/* L90: */ + } + goto L140; +L100: + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__; + dy[ky] = -w + dh22 * z__; + kx += *incx; + ky += *incy; +/* L110: */ + } + goto L140; +L120: + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__ * dh12; + dy[ky] = w * dh21 + z__ * dh22; + kx += *incx; + ky += *incy; +/* L130: */ + } +L140: + return 0; +} /* drotm_ */ diff --git a/contrib/libs/cblas/drotmg.c b/contrib/libs/cblas/drotmg.c new file mode 100644 index 00000000000..94694170bda --- /dev/null +++ b/contrib/libs/cblas/drotmg.c @@ -0,0 +1,293 @@ +/* drotmg.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal * + dx1, doublereal *dy1, doublereal *dparam) +{ + /* Initialized data */ + + static doublereal zero = 0.; + static doublereal one = 1.; + static doublereal two = 2.; + static doublereal gam = 4096.; + static doublereal gamsq = 16777216.; + static doublereal rgamsq = 5.9604645e-8; + + /* Format strings */ + static char fmt_120[] = ""; + static char fmt_150[] = ""; + static char fmt_180[] = ""; + static char fmt_210[] = ""; + + /* System generated locals */ + doublereal d__1; + + /* Local variables */ + doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22; + integer igo; + doublereal dflag, dtemp; + + /* Assigned format variables */ + static char *igo_fmt; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ +/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ +/* DY2)**T. */ +/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ + +/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ +/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ +/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ +/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ + +/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ +/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ +/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ + + +/* Arguments */ +/* ========= */ + +/* DD1 (input/output) DOUBLE PRECISION */ + +/* DD2 (input/output) DOUBLE PRECISION */ + +/* DX1 (input/output) DOUBLE PRECISION */ + +/* DY1 (input) DOUBLE PRECISION */ + +/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ +/* DPARAM(1)=DFLAG */ +/* DPARAM(2)=DH11 */ +/* DPARAM(3)=DH21 */ +/* DPARAM(4)=DH12 */ +/* DPARAM(5)=DH22 */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Data statements .. */ + + /* Parameter adjustments */ + --dparam; + + /* Function Body */ +/* .. */ + if (! (*dd1 < zero)) { + goto L10; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L10: +/* CASE-DD1-NONNEGATIVE */ + dp2 = *dd2 * *dy1; + if (! (dp2 == zero)) { + goto L20; + } + dflag = -two; + goto L260; +/* REGULAR-CASE.. */ +L20: + dp1 = *dd1 * *dx1; + dq2 = dp2 * *dy1; + dq1 = dp1 * *dx1; + + if (! (abs(dq1) > abs(dq2))) { + goto L40; + } + dh21 = -(*dy1) / *dx1; + dh12 = dp2 / dp1; + + du = one - dh12 * dh21; + + if (! (du <= zero)) { + goto L30; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L30: + dflag = zero; + *dd1 /= du; + *dd2 /= du; + *dx1 *= du; +/* GO SCALE-CHECK.. */ + goto L100; +L40: + if (! (dq2 < zero)) { + goto L50; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L50: + dflag = one; + dh11 = dp1 / dp2; + dh22 = *dx1 / *dy1; + du = one + dh11 * dh22; + dtemp = *dd2 / du; + *dd2 = *dd1 / du; + *dd1 = dtemp; + *dx1 = *dy1 * du; +/* GO SCALE-CHECK */ + goto L100; +/* PROCEDURE..ZERO-H-D-AND-DX1.. */ +L60: + dflag = -one; + dh11 = zero; + dh12 = zero; + dh21 = zero; + dh22 = zero; + + *dd1 = zero; + *dd2 = zero; + *dx1 = zero; +/* RETURN.. */ + goto L220; +/* PROCEDURE..FIX-H.. */ +L70: + if (! (dflag >= zero)) { + goto L90; + } + + if (! (dflag == zero)) { + goto L80; + } + dh11 = one; + dh22 = one; + dflag = -one; + goto L90; +L80: + dh21 = -one; + dh12 = one; + dflag = -one; +L90: + switch (igo) { + case 0: goto L120; + case 1: goto L150; + case 2: goto L180; + case 3: goto L210; + } +/* PROCEDURE..SCALE-CHECK */ +L100: +L110: + if (! (*dd1 <= rgamsq)) { + goto L130; + } + if (*dd1 == zero) { + goto L160; + } + igo = 0; + igo_fmt = fmt_120; +/* FIX-H.. */ + goto L70; +L120: +/* Computing 2nd power */ + d__1 = gam; + *dd1 *= d__1 * d__1; + *dx1 /= gam; + dh11 /= gam; + dh12 /= gam; + goto L110; +L130: +L140: + if (! (*dd1 >= gamsq)) { + goto L160; + } + igo = 1; + igo_fmt = fmt_150; +/* FIX-H.. */ + goto L70; +L150: +/* Computing 2nd power */ + d__1 = gam; + *dd1 /= d__1 * d__1; + *dx1 *= gam; + dh11 *= gam; + dh12 *= gam; + goto L140; +L160: +L170: + if (! (abs(*dd2) <= rgamsq)) { + goto L190; + } + if (*dd2 == zero) { + goto L220; + } + igo = 2; + igo_fmt = fmt_180; +/* FIX-H.. */ + goto L70; +L180: +/* Computing 2nd power */ + d__1 = gam; + *dd2 *= d__1 * d__1; + dh21 /= gam; + dh22 /= gam; + goto L170; +L190: +L200: + if (! (abs(*dd2) >= gamsq)) { + goto L220; + } + igo = 3; + igo_fmt = fmt_210; +/* FIX-H.. */ + goto L70; +L210: +/* Computing 2nd power */ + d__1 = gam; + *dd2 /= d__1 * d__1; + dh21 *= gam; + dh22 *= gam; + goto L200; +L220: + if (dflag < 0.) { + goto L250; + } else if (dflag == 0) { + goto L230; + } else { + goto L240; + } +L230: + dparam[3] = dh21; + dparam[4] = dh12; + goto L260; +L240: + dparam[2] = dh11; + dparam[5] = dh22; + goto L260; +L250: + dparam[2] = dh11; + dparam[3] = dh21; + dparam[4] = dh12; + dparam[5] = dh22; +L260: + dparam[1] = dflag; + return 0; +} /* drotmg_ */ diff --git a/contrib/libs/cblas/dsbmv.c b/contrib/libs/cblas/dsbmv.c new file mode 100644 index 00000000000..bdce6df4500 --- /dev/null +++ b/contrib/libs/cblas/dsbmv.c @@ -0,0 +1,364 @@ +/* dsbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal * + alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, + doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, iy, jx, jy, kx, ky, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric band matrix, with k super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the band matrix A is being supplied as */ +/* follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* being supplied. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* being supplied. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of super-diagonals of the */ +/* matrix A. K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the symmetric matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer the upper */ +/* triangular part of a symmetric band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the symmetric matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer the lower */ +/* triangular part of a symmetric band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*k < 0) { + info = 3; + } else if (*lda < *k + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("DSBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array A */ +/* are accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when upper triangle of A is stored. */ + + kplus1 = *k + 1; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + y[i__] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[i__]; +/* L50: */ + } + y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + y[iy] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * + temp2; + jx += *incx; + jy += *incy; + if (j > *k) { + kx += *incx; + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y when lower triangle of A is stored. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * a[j * a_dim1 + 1]; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + y[i__] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[j] += *alpha * temp2; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * a[j * a_dim1 + 1]; + l = 1 - j; + ix = jx; + iy = jy; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of DSBMV . */ + +} /* dsbmv_ */ diff --git a/contrib/libs/cblas/dscal.c b/contrib/libs/cblas/dscal.c new file mode 100644 index 00000000000..11548be8665 --- /dev/null +++ b/contrib/libs/cblas/dscal.c @@ -0,0 +1,96 @@ +/* dscal.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, + integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, m, mp1, nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ +/* * */ +/* scales a vector by a constant. */ +/* uses unrolled loops for increment equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dx[i__] = *da * dx[i__]; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 5; + if (m == 0) { + goto L40; + } + i__2 = m; + for (i__ = 1; i__ <= i__2; ++i__) { + dx[i__] = *da * dx[i__]; +/* L30: */ + } + if (*n < 5) { + return 0; + } +L40: + mp1 = m + 1; + i__2 = *n; + for (i__ = mp1; i__ <= i__2; i__ += 5) { + dx[i__] = *da * dx[i__]; + dx[i__ + 1] = *da * dx[i__ + 1]; + dx[i__ + 2] = *da * dx[i__ + 2]; + dx[i__ + 3] = *da * dx[i__ + 3]; + dx[i__ + 4] = *da * dx[i__ + 4]; +/* L50: */ + } + return 0; +} /* dscal_ */ diff --git a/contrib/libs/cblas/dsdot.c b/contrib/libs/cblas/dsdot.c new file mode 100644 index 00000000000..26e66df9e51 --- /dev/null +++ b/contrib/libs/cblas/dsdot.c @@ -0,0 +1,135 @@ +/* dsdot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer * + incy) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val; + + /* Local variables */ + integer i__, ns, kx, ky; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* AUTHORS */ +/* ======= */ +/* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */ +/* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */ + +/* Purpose */ +/* ======= */ +/* Compute the inner product of two vectors with extended */ +/* precision accumulation and result. */ + +/* Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */ +/* DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), */ +/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */ +/* defined in a similar way using INCY. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* number of elements in input vector(s) */ + +/* SX (input) REAL array, dimension(N) */ +/* single precision vector with N elements */ + +/* INCX (input) INTEGER */ +/* storage spacing between elements of SX */ + +/* SY (input) REAL array, dimension(N) */ +/* single precision vector with N elements */ + +/* INCY (input) INTEGER */ +/* storage spacing between elements of SY */ + +/* DSDOT (output) DOUBLE PRECISION */ +/* DSDOT double precision dot product (zero if N.LE.0) */ + +/* REFERENCES */ +/* ========== */ + +/* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */ +/* Krogh, Basic linear algebra subprograms for Fortran */ +/* usage, Algorithm No. 539, Transactions on Mathematical */ +/* Software 5, 3 (September 1979), pp. 308-323. */ + +/* REVISION HISTORY (YYMMDD) */ +/* ========================== */ + +/* 791001 DATE WRITTEN */ +/* 890831 Modified array declarations. (WRB) */ +/* 890831 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* 070118 Reformat to LAPACK style (JL) */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + ret_val = 0.; + if (*n <= 0) { + return ret_val; + } + if (*incx == *incy && *incx > 0) { + goto L20; + } + +/* Code for unequal or nonpositive increments. */ + + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ret_val += (doublereal) sx[kx] * (doublereal) sy[ky]; + kx += *incx; + ky += *incy; +/* L10: */ + } + return ret_val; + +/* Code for equal, positive, non-unit increments. */ + +L20: + ns = *n * *incx; + i__1 = ns; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + ret_val += (doublereal) sx[i__] * (doublereal) sy[i__]; +/* L30: */ + } + return ret_val; +} /* dsdot_ */ diff --git a/contrib/libs/cblas/dspmv.c b/contrib/libs/cblas/dspmv.c new file mode 100644 index 00000000000..24861dcb39a --- /dev/null +++ b/contrib/libs/cblas/dspmv.c @@ -0,0 +1,312 @@ +/* dspmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, + doublereal *ap, doublereal *x, integer *incx, doublereal *beta, + doublereal *y, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --y; + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 6; + } else if (*incy == 0) { + info = 9; + } + if (info != 0) { + xerbla_("DSPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form y when AP contains the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * ap[k]; + temp2 += ap[k] * x[i__]; + ++k; +/* L50: */ + } + y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; + kk += j; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + y[iy] += temp1 * ap[k]; + temp2 += ap[k] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; + jx += *incx; + jy += *incy; + kk += j; +/* L80: */ + } + } + } else { + +/* Form y when AP contains the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * ap[kk]; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * ap[k]; + temp2 += ap[k] * x[i__]; + ++k; +/* L90: */ + } + y[j] += *alpha * temp2; + kk += *n - j + 1; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * ap[kk]; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * ap[k]; + temp2 += ap[k] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; + kk += *n - j + 1; +/* L120: */ + } + } + } + + return 0; + +/* End of DSPMV . */ + +} /* dspmv_ */ diff --git a/contrib/libs/cblas/dspr.c b/contrib/libs/cblas/dspr.c new file mode 100644 index 00000000000..7aa62e42beb --- /dev/null +++ b/contrib/libs/cblas/dspr.c @@ -0,0 +1,237 @@ +/* dspr.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *ap) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPR performs the symmetric rank 1 operation */ + +/* A := alpha*x*x' + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } + if (info != 0) { + xerbla_("DSPR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + k = kk; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[k] += x[i__] * temp; + ++k; +/* L10: */ + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = kx; + i__2 = kk + j - 1; + for (k = kk; k <= i__2; ++k) { + ap[k] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + k = kk; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[k] += x[i__] * temp; + ++k; +/* L50: */ + } + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = jx; + i__2 = kk + *n - j; + for (k = kk; k <= i__2; ++k) { + ap[k] += x[ix] * temp; + ix += *incx; +/* L70: */ + } + } + jx += *incx; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of DSPR . */ + +} /* dspr_ */ diff --git a/contrib/libs/cblas/dspr2.c b/contrib/libs/cblas/dspr2.c new file mode 100644 index 00000000000..61e753254f1 --- /dev/null +++ b/contrib/libs/cblas/dspr2.c @@ -0,0 +1,270 @@ +/* dspr2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *y, integer *incy, + doublereal *ap) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPR2 performs the symmetric rank 2 operation */ + +/* A := alpha*x*y' + alpha*y*x' + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an */ +/* n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --y; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } + if (info != 0) { + xerbla_("DSPR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + k = kk; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; + ++k; +/* L10: */ + } + } + kk += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = kk + j - 1; + for (k = kk; k <= i__2; ++k) { + ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L30: */ + } + } + jx += *incx; + jy += *incy; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + k = kk; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; + ++k; +/* L50: */ + } + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk; k <= i__2; ++k) { + ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + jy += *incy; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of DSPR2 . */ + +} /* dspr2_ */ diff --git a/contrib/libs/cblas/dswap.c b/contrib/libs/cblas/dswap.c new file mode 100644 index 00000000000..27a303e607a --- /dev/null +++ b/contrib/libs/cblas/dswap.c @@ -0,0 +1,114 @@ +/* dswap.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + doublereal dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* interchanges two vectors. */ +/* uses unrolled loops for increments equal one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[ix]; + dx[ix] = dy[iy]; + dy[iy] = dtemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 3; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; +/* L30: */ + } + if (*n < 3) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 3) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; + dtemp = dx[i__ + 1]; + dx[i__ + 1] = dy[i__ + 1]; + dy[i__ + 1] = dtemp; + dtemp = dx[i__ + 2]; + dx[i__ + 2] = dy[i__ + 2]; + dy[i__ + 2] = dtemp; +/* L50: */ + } + return 0; +} /* dswap_ */ diff --git a/contrib/libs/cblas/dsymm.c b/contrib/libs/cblas/dsymm.c new file mode 100644 index 00000000000..e5dcd5db930 --- /dev/null +++ b/contrib/libs/cblas/dsymm.c @@ -0,0 +1,362 @@ +/* dsymm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, k, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is a symmetric matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the symmetric matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the symmetric matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix C. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix C. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n updated */ +/* matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,*m)) { + info = 9; + } else if (*ldc < max(1,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("DSYMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; +/* L50: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; +/* L80: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * a[j + j * a_dim1]; + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * b[i__ + j * b_dim1]; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[k + j * a_dim1]; + } else { + temp1 = *alpha * a[j + k * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[j + k * a_dim1]; + } else { + temp1 = *alpha * a[k + j * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of DSYMM . */ + +} /* dsymm_ */ diff --git a/contrib/libs/cblas/dsymv.c b/contrib/libs/cblas/dsymv.c new file mode 100644 index 00000000000..a557f1db8c8 --- /dev/null +++ b/contrib/libs/cblas/dsymv.c @@ -0,0 +1,313 @@ +/* dsymv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, + doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal + *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < max(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("DSYMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when A is stored in upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; +/* L50: */ + } + y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } else { + +/* Form y when A is stored in lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * a[j + j * a_dim1]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[j] += *alpha * temp2; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * a[j + j * a_dim1]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of DSYMV . */ + +} /* dsymv_ */ diff --git a/contrib/libs/cblas/dsyr.c b/contrib/libs/cblas/dsyr.c new file mode 100644 index 00000000000..fa15dcdbe5d --- /dev/null +++ b/contrib/libs/cblas/dsyr.c @@ -0,0 +1,238 @@ +/* dsyr.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYR performs the symmetric rank 1 operation */ + +/* A := alpha*x*x' + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*lda < max(1,*n)) { + info = 7; + } + if (info != 0) { + xerbla_("DSYR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in upper triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = kx; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jx += *incx; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in lower triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + + return 0; + +/* End of DSYR . */ + +} /* dsyr_ */ diff --git a/contrib/libs/cblas/dsyr2.c b/contrib/libs/cblas/dsyr2.c new file mode 100644 index 00000000000..d9dca76ff6c --- /dev/null +++ b/contrib/libs/cblas/dsyr2.c @@ -0,0 +1,275 @@ +/* dsyr2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, + doublereal *x, integer *incx, doublereal *y, integer *incy, + doublereal *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYR2 performs the symmetric rank 2 operation */ + +/* A := alpha*x*y' + alpha*y*x' + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an n */ +/* by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*n)) { + info = 9; + } + if (info != 0) { + xerbla_("DSYR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; +/* L10: */ + } + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L30: */ + } + } + jx += *incx; + jy += *incy; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; +/* L50: */ + } + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } + + return 0; + +/* End of DSYR2 . */ + +} /* dsyr2_ */ diff --git a/contrib/libs/cblas/dsyr2k.c b/contrib/libs/cblas/dsyr2k.c new file mode 100644 index 00000000000..cbd684508ae --- /dev/null +++ b/contrib/libs/cblas/dsyr2k.c @@ -0,0 +1,407 @@ +/* dsyr2k.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, l, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYR2K performs one of the symmetric rank 2k operations */ + +/* C := alpha*A*B' + alpha*B*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*B + alpha*B'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A and B are n by k matrices in the first case and k by n */ +/* matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ +/* beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ +/* of rows of the matrices A and B. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,nrowa)) { + info = 9; + } else if (*ldc < max(1,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("DSYR2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*B' + alpha*B*A' + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L90: */ + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L140: */ + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*B + alpha*B'*A + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; +/* L190: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; +/* L220: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of DSYR2K. */ + +} /* dsyr2k_ */ diff --git a/contrib/libs/cblas/dsyrk.c b/contrib/libs/cblas/dsyrk.c new file mode 100644 index 00000000000..393880daaa5 --- /dev/null +++ b/contrib/libs/cblas/dsyrk.c @@ -0,0 +1,372 @@ +/* dsyrk.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, + doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, + doublereal *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, info; + doublereal temp; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYRK performs one of the symmetric rank k operations */ + +/* C := alpha*A*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A is an n by k matrix in the first case and a k by n matrix */ +/* in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ +/* of rows of the matrix A. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldc < max(1,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("DSYRK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*A' + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L90: */ + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L140: */ + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; +/* L190: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; +/* L220: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of DSYRK . */ + +} /* dsyrk_ */ diff --git a/contrib/libs/cblas/dtbmv.c b/contrib/libs/cblas/dtbmv.c new file mode 100644 index 00000000000..2095d82a7a1 --- /dev/null +++ b/contrib/libs/cblas/dtbmv.c @@ -0,0 +1,422 @@ +/* dtbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := A'*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("DTBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + x[i__] += temp * a[l + i__ + j * a_dim1]; +/* L10: */ + } + if (nounit) { + x[j] *= a[kplus1 + j * a_dim1]; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + x[ix] += temp * a[l + i__ + j * a_dim1]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= a[kplus1 + j * a_dim1]; + } + } + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { + x[i__] += temp * a[l + i__ + j * a_dim1]; +/* L50: */ + } + if (nounit) { + x[j] *= a[j * a_dim1 + 1]; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { + x[ix] += temp * a[l + i__ + j * a_dim1]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= a[j * a_dim1 + 1]; + } + } + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + l = kplus1 - j; + if (nounit) { + temp *= a[kplus1 + j * a_dim1]; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + temp += a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + x[j] = temp; +/* L100: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + kx -= *incx; + ix = kx; + l = kplus1 - j; + if (nounit) { + temp *= a[kplus1 + j * a_dim1]; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + temp += a[l + i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + temp = x[j]; + l = 1 - j; + if (nounit) { + temp *= a[j * a_dim1 + 1]; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + temp += a[l + i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + x[j] = temp; +/* L140: */ + } + } else { + jx = kx; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + temp = x[jx]; + kx += *incx; + ix = kx; + l = 1 - j; + if (nounit) { + temp *= a[j * a_dim1 + 1]; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + temp += a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L150: */ + } + x[jx] = temp; + jx += *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTBMV . */ + +} /* dtbmv_ */ diff --git a/contrib/libs/cblas/dtbsv.c b/contrib/libs/cblas/dtbsv.c new file mode 100644 index 00000000000..dd40400a49b --- /dev/null +++ b/contrib/libs/cblas/dtbsv.c @@ -0,0 +1,426 @@ +/* dtbsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */ +/* diagonals. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' A'*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("DTBSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed by sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + l = kplus1 - j; + if (nounit) { + x[j] /= a[kplus1 + j * a_dim1]; + } + temp = x[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + x[i__] -= temp * a[l + i__ + j * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + kx -= *incx; + if (x[jx] != 0.) { + ix = kx; + l = kplus1 - j; + if (nounit) { + x[jx] /= a[kplus1 + j * a_dim1]; + } + temp = x[jx]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + x[ix] -= temp * a[l + i__ + j * a_dim1]; + ix -= *incx; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + l = 1 - j; + if (nounit) { + x[j] /= a[j * a_dim1 + 1]; + } + temp = x[j]; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[l + i__ + j * a_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + kx += *incx; + if (x[jx] != 0.) { + ix = kx; + l = 1 - j; + if (nounit) { + x[jx] /= a[j * a_dim1 + 1]; + } + temp = x[jx]; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[ix] -= temp * a[l + i__ + j * a_dim1]; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A')*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + temp -= a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + if (nounit) { + temp /= a[kplus1 + j * a_dim1]; + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + temp -= a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= a[kplus1 + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L120: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { + temp -= a[l + i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + if (nounit) { + temp /= a[j * a_dim1 + 1]; + } + x[j] = temp; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { + temp -= a[l + i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= a[j * a_dim1 + 1]; + } + x[jx] = temp; + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTBSV . */ + +} /* dtbsv_ */ diff --git a/contrib/libs/cblas/dtpmv.c b/contrib/libs/cblas/dtpmv.c new file mode 100644 index 00000000000..4bd5e70b466 --- /dev/null +++ b/contrib/libs/cblas/dtpmv.c @@ -0,0 +1,357 @@ +/* dtpmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n, + doublereal *ap, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := A'*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("DTPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x:= A*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * ap[k]; + ++k; +/* L10: */ + } + if (nounit) { + x[j] *= ap[kk + j - 1]; + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + x[ix] += temp * ap[k]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= ap[kk + j - 1]; + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * ap[k]; + --k; +/* L50: */ + } + if (nounit) { + x[j] *= ap[kk - *n + j]; + } + } + kk -= *n - j + 1; +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + x[ix] += temp * ap[k]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= ap[kk - *n + j]; + } + } + jx -= *incx; + kk -= *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= ap[kk]; + } + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + temp += ap[k] * x[i__]; + --k; +/* L90: */ + } + x[j] = temp; + kk -= j; +/* L100: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= ap[kk]; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + temp += ap[k] * x[ix]; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; + kk -= j; +/* L120: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= ap[kk]; + } + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += ap[k] * x[i__]; + ++k; +/* L130: */ + } + x[j] = temp; + kk += *n - j + 1; +/* L140: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= ap[kk]; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + temp += ap[k] * x[ix]; +/* L150: */ + } + x[jx] = temp; + jx += *incx; + kk += *n - j + 1; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTPMV . */ + +} /* dtpmv_ */ diff --git a/contrib/libs/cblas/dtpsv.c b/contrib/libs/cblas/dtpsv.c new file mode 100644 index 00000000000..525424560fb --- /dev/null +++ b/contrib/libs/cblas/dtpsv.c @@ -0,0 +1,360 @@ +/* dtpsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n, + doublereal *ap, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix, supplied in packed form. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' A'*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("DTPSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= ap[kk]; + } + temp = x[j]; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * ap[k]; + --k; +/* L10: */ + } + } + kk -= j; +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= ap[kk]; + } + temp = x[jx]; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + x[ix] -= temp * ap[k]; +/* L30: */ + } + } + jx -= *incx; + kk -= j; +/* L40: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= ap[kk]; + } + temp = x[j]; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * ap[k]; + ++k; +/* L50: */ + } + } + kk += *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= ap[kk]; + } + temp = x[jx]; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + x[ix] -= temp * ap[k]; +/* L70: */ + } + } + jx += *incx; + kk += *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= ap[k] * x[i__]; + ++k; +/* L90: */ + } + if (nounit) { + temp /= ap[kk + j - 1]; + } + x[j] = temp; + kk += j; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + temp -= ap[k] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= ap[kk + j - 1]; + } + x[jx] = temp; + jx += *incx; + kk += j; +/* L120: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= ap[k] * x[i__]; + --k; +/* L130: */ + } + if (nounit) { + temp /= ap[kk - *n + j]; + } + x[j] = temp; + kk -= *n - j + 1; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + temp -= ap[k] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= ap[kk - *n + j]; + } + x[jx] = temp; + jx -= *incx; + kk -= *n - j + 1; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTPSV . */ + +} /* dtpsv_ */ diff --git a/contrib/libs/cblas/dtrmm.c b/contrib/libs/cblas/dtrmm.c new file mode 100644 index 00000000000..4bf834f5509 --- /dev/null +++ b/contrib/libs/cblas/dtrmm.c @@ -0,0 +1,453 @@ +/* dtrmm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublereal *alpha, doublereal *a, integer * + lda, doublereal *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, info; + doublereal temp; + logical lside; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRMM performs one of the matrix-matrix operations */ + +/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */ + +/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A'. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) multiplies B from */ +/* the left or right as follows: */ + +/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */ + +/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B, and on exit is overwritten by the */ +/* transformed matrix. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("DTRMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*A*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; +/* L30: */ + } + if (nounit) { + temp *= a[k + k * a_dim1]; + } + b[k + j * b_dim1] = temp; + } +/* L40: */ + } +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + b[k + j * b_dim1] = temp; + if (nounit) { + b[k + j * b_dim1] *= a[k + k * a_dim1]; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; +/* L60: */ + } + } +/* L70: */ + } +/* L80: */ + } + } + } else { + +/* Form B := alpha*A'*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L90: */ + } + b[i__ + j * b_dim1] = *alpha * temp; +/* L100: */ + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L120: */ + } + b[i__ + j * b_dim1] = *alpha * temp; +/* L130: */ + } +/* L140: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*A. */ + + if (upper) { + for (j = *n; j >= 1; --j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L150: */ + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L190: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L200: */ + } + } +/* L210: */ + } +/* L220: */ + } + } + } else { + +/* Form B := alpha*B*A'. */ + + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L230: */ + } + } +/* L240: */ + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L250: */ + } + } +/* L260: */ + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L270: */ + } + } +/* L280: */ + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L290: */ + } + } +/* L300: */ + } + } + } + } + + return 0; + +/* End of DTRMM . */ + +} /* dtrmm_ */ diff --git a/contrib/libs/cblas/dtrmv.c b/contrib/libs/cblas/dtrmv.c new file mode 100644 index 00000000000..3acaa6d24be --- /dev/null +++ b/contrib/libs/cblas/dtrmv.c @@ -0,0 +1,345 @@ +/* dtrmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, + doublereal *a, integer *lda, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := A'*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("DTRMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * a[i__ + j * a_dim1]; +/* L10: */ + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx += *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * a[i__ + j * a_dim1]; +/* L50: */ + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx -= *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + x[j] = temp; +/* L140: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +/* L150: */ + } + x[jx] = temp; + jx += *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTRMV . */ + +} /* dtrmv_ */ diff --git a/contrib/libs/cblas/dtrsm.c b/contrib/libs/cblas/dtrsm.c new file mode 100644 index 00000000000..84ee3e71726 --- /dev/null +++ b/contrib/libs/cblas/dtrsm.c @@ -0,0 +1,490 @@ +/* dtrsm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublereal *alpha, doublereal *a, integer * + lda, doublereal *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, info; + doublereal temp; + logical lside; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRSM solves one of the matrix equations */ + +/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ + +/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A'. */ + +/* The matrix X is overwritten on B. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) appears on the left */ +/* or right of X as follows: */ + +/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ + +/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the right-hand side matrix B, and on exit is */ +/* overwritten by the solution matrix X. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("DTRSM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*inv( A )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L30: */ + } + } + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; +/* L40: */ + } + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L70: */ + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; +/* L80: */ + } + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form B := alpha*inv( A' )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L110: */ + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L140: */ + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; +/* L150: */ + } +/* L160: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*inv( A ). */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L170: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; +/* L180: */ + } + } +/* L190: */ + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L200: */ + } + } +/* L210: */ + } + } else { + for (j = *n; j >= 1; --j) { + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L220: */ + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; +/* L230: */ + } + } +/* L240: */ + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L250: */ + } + } +/* L260: */ + } + } + } else { + +/* Form B := alpha*B*inv( A' ). */ + + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L270: */ + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; +/* L280: */ + } + } +/* L290: */ + } + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; +/* L300: */ + } + } +/* L310: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L320: */ + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; +/* L330: */ + } + } +/* L340: */ + } + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; +/* L350: */ + } + } +/* L360: */ + } + } + } + } + + return 0; + +/* End of DTRSM . */ + +} /* dtrsm_ */ diff --git a/contrib/libs/cblas/dtrsv.c b/contrib/libs/cblas/dtrsv.c new file mode 100644 index 00000000000..ef9f1b44c7d --- /dev/null +++ b/contrib/libs/cblas/dtrsv.c @@ -0,0 +1,348 @@ +/* dtrsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n, + doublereal *a, integer *lda, doublereal *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + doublereal temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' A'*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - DOUBLE PRECISION array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("DTRSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx -= *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTRSV . */ + +} /* dtrsv_ */ diff --git a/contrib/libs/cblas/dzasum.c b/contrib/libs/cblas/dzasum.c new file mode 100644 index 00000000000..6a9354455fc --- /dev/null +++ b/contrib/libs/cblas/dzasum.c @@ -0,0 +1,80 @@ +/* dzasum.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val; + + /* Local variables */ + integer i__, ix; + doublereal stemp; + extern doublereal dcabs1_(doublecomplex *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* takes the sum of the absolute values. */ +/* jack dongarra, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ + /* Parameter adjustments */ + --zx; + + /* Function Body */ + ret_val = 0.; + stemp = 0.; + if (*n <= 0 || *incx <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp += dcabs1_(&zx[ix]); + ix += *incx; +/* L10: */ + } + ret_val = stemp; + return ret_val; + +/* code for increment equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp += dcabs1_(&zx[i__]); +/* L30: */ + } + ret_val = stemp; + return ret_val; +} /* dzasum_ */ diff --git a/contrib/libs/cblas/dznrm2.c b/contrib/libs/cblas/dznrm2.c new file mode 100644 index 00000000000..e6235447b27 --- /dev/null +++ b/contrib/libs/cblas/dznrm2.c @@ -0,0 +1,108 @@ +/* dznrm2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal ret_val, d__1; + + /* Builtin functions */ + double d_imag(doublecomplex *), sqrt(doublereal); + + /* Local variables */ + integer ix; + doublereal ssq, temp, norm, scale; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DZNRM2 returns the euclidean norm of a vector via the function */ +/* name, so that */ + +/* DZNRM2 := sqrt( conjg( x' )*x ) */ + + +/* -- This version written on 25-October-1982. */ +/* Modified on 14-October-1993 to inline the call to ZLASSQ. */ +/* Sven Hammarling, Nag Ltd. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n < 1 || *incx < 1) { + norm = 0.; + } else { + scale = 0.; + ssq = 1.; +/* The following loop is equivalent to this call to the LAPACK */ +/* auxiliary routine: */ +/* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) */ + + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + if (x[i__3].r != 0.) { + i__3 = ix; + temp = (d__1 = x[i__3].r, abs(d__1)); + if (scale < temp) { +/* Computing 2nd power */ + d__1 = scale / temp; + ssq = ssq * (d__1 * d__1) + 1.; + scale = temp; + } else { +/* Computing 2nd power */ + d__1 = temp / scale; + ssq += d__1 * d__1; + } + } + if (d_imag(&x[ix]) != 0.) { + temp = (d__1 = d_imag(&x[ix]), abs(d__1)); + if (scale < temp) { +/* Computing 2nd power */ + d__1 = scale / temp; + ssq = ssq * (d__1 * d__1) + 1.; + scale = temp; + } else { +/* Computing 2nd power */ + d__1 = temp / scale; + ssq += d__1 * d__1; + } + } +/* L10: */ + } + norm = scale * sqrt(ssq); + } + + ret_val = norm; + return ret_val; + +/* End of DZNRM2. */ + +} /* dznrm2_ */ diff --git a/contrib/libs/cblas/icamax.c b/contrib/libs/cblas/icamax.c new file mode 100644 index 00000000000..30a6277e53a --- /dev/null +++ b/contrib/libs/cblas/icamax.c @@ -0,0 +1,93 @@ +/* icamax.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +integer icamax_(integer *n, complex *cx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + + /* Local variables */ + integer i__, ix; + real smax; + extern doublereal scabs1_(complex *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ + /* Parameter adjustments */ + --cx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + smax = scabs1_(&cx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (scabs1_(&cx[ix]) <= smax) { + goto L5; + } + ret_val = i__; + smax = scabs1_(&cx[ix]); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + smax = scabs1_(&cx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (scabs1_(&cx[i__]) <= smax) { + goto L30; + } + ret_val = i__; + smax = scabs1_(&cx[i__]); +L30: + ; + } + return ret_val; +} /* icamax_ */ diff --git a/contrib/libs/cblas/idamax.c b/contrib/libs/cblas/idamax.c new file mode 100644 index 00000000000..9b9636a2ded --- /dev/null +++ b/contrib/libs/cblas/idamax.c @@ -0,0 +1,93 @@ +/* idamax.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +integer idamax_(integer *n, doublereal *dx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + doublereal d__1; + + /* Local variables */ + integer i__, ix; + doublereal dmax__; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + dmax__ = abs(dx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[ix], abs(d__1)) <= dmax__) { + goto L5; + } + ret_val = i__; + dmax__ = (d__1 = dx[ix], abs(d__1)); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + dmax__ = abs(dx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[i__], abs(d__1)) <= dmax__) { + goto L30; + } + ret_val = i__; + dmax__ = (d__1 = dx[i__], abs(d__1)); +L30: + ; + } + return ret_val; +} /* idamax_ */ diff --git a/contrib/libs/cblas/isamax.c b/contrib/libs/cblas/isamax.c new file mode 100644 index 00000000000..227005442df --- /dev/null +++ b/contrib/libs/cblas/isamax.c @@ -0,0 +1,93 @@ +/* isamax.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +integer isamax_(integer *n, real *sx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + real r__1; + + /* Local variables */ + integer i__, ix; + real smax; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + smax = dabs(sx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((r__1 = sx[ix], dabs(r__1)) <= smax) { + goto L5; + } + ret_val = i__; + smax = (r__1 = sx[ix], dabs(r__1)); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + smax = dabs(sx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((r__1 = sx[i__], dabs(r__1)) <= smax) { + goto L30; + } + ret_val = i__; + smax = (r__1 = sx[i__], dabs(r__1)); +L30: + ; + } + return ret_val; +} /* isamax_ */ diff --git a/contrib/libs/cblas/izamax.c b/contrib/libs/cblas/izamax.c new file mode 100644 index 00000000000..b4bd3c3409c --- /dev/null +++ b/contrib/libs/cblas/izamax.c @@ -0,0 +1,93 @@ +/* izamax.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +integer izamax_(integer *n, doublecomplex *zx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + + /* Local variables */ + integer i__, ix; + doublereal smax; + extern doublereal dcabs1_(doublecomplex *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, 1/15/85. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ + /* Parameter adjustments */ + --zx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + smax = dcabs1_(&zx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (dcabs1_(&zx[ix]) <= smax) { + goto L5; + } + ret_val = i__; + smax = dcabs1_(&zx[ix]); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + smax = dcabs1_(&zx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (dcabs1_(&zx[i__]) <= smax) { + goto L30; + } + ret_val = i__; + smax = dcabs1_(&zx[i__]); +L30: + ; + } + return ret_val; +} /* izamax_ */ diff --git a/contrib/libs/cblas/lsame.c b/contrib/libs/cblas/lsame.c new file mode 100644 index 00000000000..0648674fa8c --- /dev/null +++ b/contrib/libs/cblas/lsame.c @@ -0,0 +1,117 @@ +/* lsame.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +logical lsame_(char *ca, char *cb) +{ + /* System generated locals */ + logical ret_val; + + /* Local variables */ + integer inta, intb, zcode; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */ +/* case. */ + +/* Arguments */ +/* ========= */ + +/* CA (input) CHARACTER*1 */ + +/* CB (input) CHARACTER*1 */ +/* CA and CB specify the single characters to be compared. */ + +/* ===================================================================== */ + +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ + +/* Test if the characters are equal */ + + ret_val = *(unsigned char *)ca == *(unsigned char *)cb; + if (ret_val) { + return ret_val; + } + +/* Now test for equivalence if both characters are alphabetic. */ + + zcode = 'Z'; + +/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */ +/* machines, on which ICHAR returns a value with bit 8 set. */ +/* ICHAR('A') on Prime machines returns 193 which is the same as */ +/* ICHAR('A') on an EBCDIC machine. */ + + inta = *(unsigned char *)ca; + intb = *(unsigned char *)cb; + + if (zcode == 90 || zcode == 122) { + +/* ASCII is assumed - ZCODE is the ASCII code of either lower or */ +/* upper case 'Z'. */ + + if (inta >= 97 && inta <= 122) { + inta += -32; + } + if (intb >= 97 && intb <= 122) { + intb += -32; + } + + } else if (zcode == 233 || zcode == 169) { + +/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */ +/* upper case 'Z'. */ + + if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta + >= 162 && inta <= 169) { + inta += 64; + } + if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb + >= 162 && intb <= 169) { + intb += 64; + } + + } else if (zcode == 218 || zcode == 250) { + +/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */ +/* plus 128 of either lower or upper case 'Z'. */ + + if (inta >= 225 && inta <= 250) { + inta += -32; + } + if (intb >= 225 && intb <= 250) { + intb += -32; + } + } + ret_val = inta == intb; + +/* RETURN */ + +/* End of LSAME */ + + return ret_val; +} /* lsame_ */ diff --git a/contrib/libs/cblas/sasum.c b/contrib/libs/cblas/sasum.c new file mode 100644 index 00000000000..24d9799caef --- /dev/null +++ b/contrib/libs/cblas/sasum.c @@ -0,0 +1,101 @@ +/* sasum.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal sasum_(integer *n, real *sx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val, r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + integer i__, m, mp1, nincx; + real stemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* takes the sum of the absolute values. */ +/* uses unrolled loops for increment equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sx; + + /* Function Body */ + ret_val = 0.f; + stemp = 0.f; + if (*n <= 0 || *incx <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + stemp += (r__1 = sx[i__], dabs(r__1)); +/* L10: */ + } + ret_val = stemp; + return ret_val; + +/* code for increment equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 6; + if (m == 0) { + goto L40; + } + i__2 = m; + for (i__ = 1; i__ <= i__2; ++i__) { + stemp += (r__1 = sx[i__], dabs(r__1)); +/* L30: */ + } + if (*n < 6) { + goto L60; + } +L40: + mp1 = m + 1; + i__2 = *n; + for (i__ = mp1; i__ <= i__2; i__ += 6) { + stemp = stemp + (r__1 = sx[i__], dabs(r__1)) + (r__2 = sx[i__ + 1], + dabs(r__2)) + (r__3 = sx[i__ + 2], dabs(r__3)) + (r__4 = sx[ + i__ + 3], dabs(r__4)) + (r__5 = sx[i__ + 4], dabs(r__5)) + ( + r__6 = sx[i__ + 5], dabs(r__6)); +/* L50: */ + } +L60: + ret_val = stemp; + return ret_val; +} /* sasum_ */ diff --git a/contrib/libs/cblas/saxpy.c b/contrib/libs/cblas/saxpy.c new file mode 100644 index 00000000000..f591cca330e --- /dev/null +++ b/contrib/libs/cblas/saxpy.c @@ -0,0 +1,107 @@ +/* saxpy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx, + real *sy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SAXPY constant times a vector plus a vector. */ +/* uses unrolled loop for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*sa == 0.f) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sy[iy] += *sa * sx[ix]; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 4; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + sy[i__] += *sa * sx[i__]; +/* L30: */ + } + if (*n < 4) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 4) { + sy[i__] += *sa * sx[i__]; + sy[i__ + 1] += *sa * sx[i__ + 1]; + sy[i__ + 2] += *sa * sx[i__ + 2]; + sy[i__ + 3] += *sa * sx[i__ + 3]; +/* L50: */ + } + return 0; +} /* saxpy_ */ diff --git a/contrib/libs/cblas/scabs1.c b/contrib/libs/cblas/scabs1.c new file mode 100644 index 00000000000..d6c63fc626a --- /dev/null +++ b/contrib/libs/cblas/scabs1.c @@ -0,0 +1,36 @@ +/* scabs1.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal scabs1_(complex *z__) +{ + /* System generated locals */ + real ret_val, r__1, r__2; + + /* Builtin functions */ + double r_imag(complex *); + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SCABS1 computes absolute value of a complex number */ + +/* .. Intrinsic Functions .. */ +/* .. */ + ret_val = (r__1 = z__->r, dabs(r__1)) + (r__2 = r_imag(z__), dabs(r__2)); + return ret_val; +} /* scabs1_ */ diff --git a/contrib/libs/cblas/scasum.c b/contrib/libs/cblas/scasum.c new file mode 100644 index 00000000000..d9345df0a7b --- /dev/null +++ b/contrib/libs/cblas/scasum.c @@ -0,0 +1,87 @@ +/* scasum.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal scasum_(integer *n, complex *cx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real ret_val, r__1, r__2; + + /* Builtin functions */ + double r_imag(complex *); + + /* Local variables */ + integer i__, nincx; + real stemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* takes the sum of the absolute values of a complex vector and */ +/* returns a single precision result. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --cx; + + /* Function Body */ + ret_val = 0.f; + stemp = 0.f; + if (*n <= 0 || *incx <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + stemp = stemp + (r__1 = cx[i__3].r, dabs(r__1)) + (r__2 = r_imag(&cx[ + i__]), dabs(r__2)); +/* L10: */ + } + ret_val = stemp; + return ret_val; + +/* code for increment equal to 1 */ + +L20: + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__1 = i__; + stemp = stemp + (r__1 = cx[i__1].r, dabs(r__1)) + (r__2 = r_imag(&cx[ + i__]), dabs(r__2)); +/* L30: */ + } + ret_val = stemp; + return ret_val; +} /* scasum_ */ diff --git a/contrib/libs/cblas/scnrm2.c b/contrib/libs/cblas/scnrm2.c new file mode 100644 index 00000000000..a965801f4b3 --- /dev/null +++ b/contrib/libs/cblas/scnrm2.c @@ -0,0 +1,109 @@ +/* scnrm2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal scnrm2_(integer *n, complex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real ret_val, r__1; + + /* Builtin functions */ + double r_imag(complex *), sqrt(doublereal); + + /* Local variables */ + integer ix; + real ssq, temp, norm, scale; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SCNRM2 returns the euclidean norm of a vector via the function */ +/* name, so that */ + +/* SCNRM2 := sqrt( conjg( x' )*x ) */ + + + +/* -- This version written on 25-October-1982. */ +/* Modified on 14-October-1993 to inline the call to CLASSQ. */ +/* Sven Hammarling, Nag Ltd. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n < 1 || *incx < 1) { + norm = 0.f; + } else { + scale = 0.f; + ssq = 1.f; +/* The following loop is equivalent to this call to the LAPACK */ +/* auxiliary routine: */ +/* CALL CLASSQ( N, X, INCX, SCALE, SSQ ) */ + + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + if (x[i__3].r != 0.f) { + i__3 = ix; + temp = (r__1 = x[i__3].r, dabs(r__1)); + if (scale < temp) { +/* Computing 2nd power */ + r__1 = scale / temp; + ssq = ssq * (r__1 * r__1) + 1.f; + scale = temp; + } else { +/* Computing 2nd power */ + r__1 = temp / scale; + ssq += r__1 * r__1; + } + } + if (r_imag(&x[ix]) != 0.f) { + temp = (r__1 = r_imag(&x[ix]), dabs(r__1)); + if (scale < temp) { +/* Computing 2nd power */ + r__1 = scale / temp; + ssq = ssq * (r__1 * r__1) + 1.f; + scale = temp; + } else { +/* Computing 2nd power */ + r__1 = temp / scale; + ssq += r__1 * r__1; + } + } +/* L10: */ + } + norm = scale * sqrt(ssq); + } + + ret_val = norm; + return ret_val; + +/* End of SCNRM2. */ + +} /* scnrm2_ */ diff --git a/contrib/libs/cblas/scopy.c b/contrib/libs/cblas/scopy.c new file mode 100644 index 00000000000..13651fa118d --- /dev/null +++ b/contrib/libs/cblas/scopy.c @@ -0,0 +1,107 @@ +/* scopy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy, + integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* copies a vector, x, to a vector, y. */ +/* uses unrolled loops for increments equal to 1. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sy[iy] = sx[ix]; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 7; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + sy[i__] = sx[i__]; +/* L30: */ + } + if (*n < 7) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 7) { + sy[i__] = sx[i__]; + sy[i__ + 1] = sx[i__ + 1]; + sy[i__ + 2] = sx[i__ + 2]; + sy[i__ + 3] = sx[i__ + 3]; + sy[i__ + 4] = sx[i__ + 4]; + sy[i__ + 5] = sx[i__ + 5]; + sy[i__ + 6] = sx[i__ + 6]; +/* L50: */ + } + return 0; +} /* scopy_ */ diff --git a/contrib/libs/cblas/sdot.c b/contrib/libs/cblas/sdot.c new file mode 100644 index 00000000000..26e9129bac5 --- /dev/null +++ b/contrib/libs/cblas/sdot.c @@ -0,0 +1,109 @@ +/* sdot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy) +{ + /* System generated locals */ + integer i__1; + real ret_val; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + real stemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* forms the dot product of two vectors. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + stemp = 0.f; + ret_val = 0.f; + if (*n <= 0) { + return ret_val; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp += sx[ix] * sy[iy]; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val = stemp; + return ret_val; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 5; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp += sx[i__] * sy[i__]; +/* L30: */ + } + if (*n < 5) { + goto L60; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[ + i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ + + 4] * sy[i__ + 4]; +/* L50: */ + } +L60: + ret_val = stemp; + return ret_val; +} /* sdot_ */ diff --git a/contrib/libs/cblas/sdsdot.c b/contrib/libs/cblas/sdsdot.c new file mode 100644 index 00000000000..ec5638ab506 --- /dev/null +++ b/contrib/libs/cblas/sdsdot.c @@ -0,0 +1,144 @@ +/* sdsdot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal sdsdot_(integer *n, real *sb, real *sx, integer *incx, real *sy, + integer *incy) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val; + + /* Local variables */ + integer i__, ns, kx, ky; + doublereal dsdot; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* PURPOSE */ +/* ======= */ + +/* Compute the inner product of two vectors with extended */ +/* precision accumulation. */ + +/* Returns S.P. result with dot product accumulated in D.P. */ +/* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), */ +/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */ +/* defined in a similar way using INCY. */ + +/* AUTHOR */ +/* ====== */ +/* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */ +/* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */ + +/* ARGUMENTS */ +/* ========= */ + +/* N (input) INTEGER */ +/* number of elements in input vector(s) */ + +/* SB (input) REAL */ +/* single precision scalar to be added to inner product */ + +/* SX (input) REAL array, dimension (N) */ +/* single precision vector with N elements */ + +/* INCX (input) INTEGER */ +/* storage spacing between elements of SX */ + +/* SY (input) REAL array, dimension (N) */ +/* single precision vector with N elements */ + +/* INCY (input) INTEGER */ +/* storage spacing between elements of SY */ + +/* SDSDOT (output) REAL */ +/* single precision dot product (SB if N .LE. 0) */ + +/* REFERENCES */ +/* ========== */ + +/* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */ +/* Krogh, Basic linear algebra subprograms for Fortran */ +/* usage, Algorithm No. 539, Transactions on Mathematical */ +/* Software 5, 3 (September 1979), pp. 308-323. */ + +/* REVISION HISTORY (YYMMDD) */ +/* ========================== */ + +/* 791001 DATE WRITTEN */ +/* 890531 Changed all specific intrinsics to generic. (WRB) */ +/* 890831 Modified array declarations. (WRB) */ +/* 890831 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* 070118 Reformat to LAPACK coding style */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + dsdot = *sb; + if (*n <= 0) { + goto L30; + } + if (*incx == *incy && *incx > 0) { + goto L40; + } + +/* Code for unequal or nonpositive increments. */ + + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dsdot += (doublereal) sx[kx] * (doublereal) sy[ky]; + kx += *incx; + ky += *incy; +/* L10: */ + } +L30: + ret_val = dsdot; + return ret_val; + +/* Code for equal and positive increments. */ + +L40: + ns = *n * *incx; + i__1 = ns; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dsdot += (doublereal) sx[i__] * (doublereal) sy[i__]; +/* L50: */ + } + ret_val = dsdot; + return ret_val; +} /* sdsdot_ */ diff --git a/contrib/libs/cblas/sgbmv.c b/contrib/libs/cblas/sgbmv.c new file mode 100644 index 00000000000..11db1d99ca4 --- /dev/null +++ b/contrib/libs/cblas/sgbmv.c @@ -0,0 +1,368 @@ +/* sgbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sgbmv_(char *trans, integer *m, integer *n, integer *kl, + integer *ku, real *alpha, real *a, integer *lda, real *x, integer * + incx, real *beta, real *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info; + real temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SGBMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* KL - INTEGER. */ +/* On entry, KL specifies the number of sub-diagonals of the */ +/* matrix A. KL must satisfy 0 .le. KL. */ +/* Unchanged on exit. */ + +/* KU - INTEGER. */ +/* On entry, KU specifies the number of super-diagonals of the */ +/* matrix A. KU must satisfy 0 .le. KU. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading ( kl + ku + 1 ) by n part of the */ +/* array A must contain the matrix of coefficients, supplied */ +/* column by column, with the leading diagonal of the matrix in */ +/* row ( ku + 1 ) of the array, the first super-diagonal */ +/* starting at position 2 in row ku, the first sub-diagonal */ +/* starting at position 1 in row ( ku + 2 ), and so on. */ +/* Elements in the array A that do not correspond to elements */ +/* in the band matrix (such as the top left ku by ku triangle) */ +/* are not referenced. */ +/* The following program segment will transfer a band matrix */ +/* from conventional full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* K = KU + 1 - J */ +/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */ +/* A( K + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( kl + ku + 1 ). */ +/* Unchanged on exit. */ + +/* X - REAL array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - REAL array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0) { + info = 4; + } else if (*ku < 0) { + info = 5; + } else if (*lda < *kl + *ku + 1) { + info = 8; + } else if (*incx == 0) { + info = 10; + } else if (*incy == 0) { + info = 13; + } + if (info != 0) { + xerbla_("SGBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the band part of A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.f) { + if (*incy == 1) { + if (*beta == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.f; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.f) { + return 0; + } + kup1 = *ku + 1; + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + y[i__] += temp * a[k + i__ + j * a_dim1]; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + iy = ky; + k = kup1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + y[iy] += temp * a[k + i__ + j * a_dim1]; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + if (j > *ku) { + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.f; + k = kup1 - j; +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + temp += a[k + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L100: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.f; + ix = kx; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + temp += a[k + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + y[jy] += *alpha * temp; + jy += *incy; + if (j > *ku) { + kx += *incx; + } +/* L120: */ + } + } + } + + return 0; + +/* End of SGBMV . */ + +} /* sgbmv_ */ diff --git a/contrib/libs/cblas/sgemm.c b/contrib/libs/cblas/sgemm.c new file mode 100644 index 00000000000..527735a6d0d --- /dev/null +++ b/contrib/libs/cblas/sgemm.c @@ -0,0 +1,388 @@ +/* sgemm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sgemm_(char *transa, char *transb, integer *m, integer * + n, integer *k, real *alpha, real *a, integer *lda, real *b, integer * + ldb, real *beta, real *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, l, info; + logical nota, notb; + real temp; + integer ncola; + extern logical lsame_(char *, char *); + integer nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SGEMM performs one of the matrix-matrix operations */ + +/* C := alpha*op( A )*op( B ) + beta*C, */ + +/* where op( X ) is one of */ + +/* op( X ) = X or op( X ) = X', */ + +/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */ +/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n', op( A ) = A. */ + +/* TRANSA = 'T' or 't', op( A ) = A'. */ + +/* TRANSA = 'C' or 'c', op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* TRANSB - CHARACTER*1. */ +/* On entry, TRANSB specifies the form of op( B ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSB = 'N' or 'n', op( B ) = B. */ + +/* TRANSB = 'T' or 't', op( B ) = B'. */ + +/* TRANSB = 'C' or 'c', op( B ) = B'. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix */ +/* op( A ) and of the matrix C. M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix */ +/* op( B ) and the number of columns of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of columns of the matrix */ +/* op( A ) and the number of rows of the matrix op( B ). K must */ +/* be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANSA = 'N' or 'n', and is m otherwise. */ +/* Before entry with TRANSA = 'N' or 'n', the leading m by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by m part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */ +/* n when TRANSB = 'N' or 'n', and is k otherwise. */ +/* Before entry with TRANSB = 'N' or 'n', the leading k by n */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading n by k part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */ +/* LDB must be at least max( 1, k ), otherwise LDB must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - REAL array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n matrix */ +/* ( alpha*op( A )*op( B ) + beta*C ). */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NOTA and NOTB as true if A and B respectively are not */ +/* transposed and set NROWA, NCOLA and NROWB as the number of rows */ +/* and columns of A and the number of rows of B respectively. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + nota = lsame_(transa, "N"); + notb = lsame_(transb, "N"); + if (nota) { + nrowa = *m; + ncola = *k; + } else { + nrowa = *k; + ncola = *m; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + +/* Test the input parameters. */ + + info = 0; + if (! nota && ! lsame_(transa, "C") && ! lsame_( + transa, "T")) { + info = 1; + } else if (! notb && ! lsame_(transb, "C") && ! + lsame_(transb, "T")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < max(1,nrowa)) { + info = 8; + } else if (*ldb < max(1,nrowb)) { + info = 10; + } else if (*ldc < max(1,*m)) { + info = 13; + } + if (info != 0) { + xerbla_("SGEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { + return 0; + } + +/* And if alpha.eq.zero. */ + + if (*alpha == 0.f) { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (notb) { + if (nota) { + +/* Form C := alpha*A*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L50: */ + } + } else if (*beta != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L60: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (b[l + j * b_dim1] != 0.f) { + temp = *alpha * b[l + j * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L70: */ + } + } +/* L80: */ + } +/* L90: */ + } + } else { + +/* Form C := alpha*A'*B + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; +/* L100: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L110: */ + } +/* L120: */ + } + } + } else { + if (nota) { + +/* Form C := alpha*A*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L130: */ + } + } else if (*beta != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L140: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (b[j + l * b_dim1] != 0.f) { + temp = *alpha * b[j + l * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L150: */ + } + } +/* L160: */ + } +/* L170: */ + } + } else { + +/* Form C := alpha*A'*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; +/* L180: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L190: */ + } +/* L200: */ + } + } + } + + return 0; + +/* End of SGEMM . */ + +} /* sgemm_ */ diff --git a/contrib/libs/cblas/sgemv.c b/contrib/libs/cblas/sgemv.c new file mode 100644 index 00000000000..10eacd3a15f --- /dev/null +++ b/contrib/libs/cblas/sgemv.c @@ -0,0 +1,312 @@ +/* sgemv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sgemv_(char *trans, integer *m, integer *n, real *alpha, + real *a, integer *lda, real *x, integer *incx, real *beta, real *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + real temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SGEMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* X - REAL array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - REAL array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry with BETA non-zero, the incremented array Y */ +/* must contain the vector y. On exit, Y is overwritten by the */ +/* updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < max(1,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("SGEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.f) { + if (*incy == 1) { + if (*beta == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.f; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.f) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.f) { + return 0; + } + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp * a[i__ + j * a_dim1]; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp * a[i__ + j * a_dim1]; + iy += *incy; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.f; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L100: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.f; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of SGEMV . */ + +} /* sgemv_ */ diff --git a/contrib/libs/cblas/sger.c b/contrib/libs/cblas/sger.c new file mode 100644 index 00000000000..a6e02758d88 --- /dev/null +++ b/contrib/libs/cblas/sger.c @@ -0,0 +1,193 @@ +/* sger.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sger_(integer *m, integer *n, real *alpha, real *x, + integer *incx, real *y, integer *incy, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + real temp; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SGER performs the rank 1 operation */ + +/* A := alpha*x*y' + A, */ + +/* where alpha is a scalar, x is an m element vector, y is an n element */ +/* vector and A is an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the m */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. On exit, A is */ +/* overwritten by the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("SGER ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0.f) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.f) { + temp = *alpha * y[jy]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.f) { + temp = *alpha * y[jy]; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of SGER . */ + +} /* sger_ */ diff --git a/contrib/libs/cblas/snrm2.c b/contrib/libs/cblas/snrm2.c new file mode 100644 index 00000000000..ca5233f35ac --- /dev/null +++ b/contrib/libs/cblas/snrm2.c @@ -0,0 +1,97 @@ +/* snrm2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +doublereal snrm2_(integer *n, real *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val, r__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + integer ix; + real ssq, norm, scale, absxi; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SNRM2 returns the euclidean norm of a vector via the function */ +/* name, so that */ + +/* SNRM2 := sqrt( x'*x ). */ + +/* Further Details */ +/* =============== */ + +/* -- This version written on 25-October-1982. */ +/* Modified on 14-October-1993 to inline the call to SLASSQ. */ +/* Sven Hammarling, Nag Ltd. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n < 1 || *incx < 1) { + norm = 0.f; + } else if (*n == 1) { + norm = dabs(x[1]); + } else { + scale = 0.f; + ssq = 1.f; +/* The following loop is equivalent to this call to the LAPACK */ +/* auxiliary routine: */ +/* CALL SLASSQ( N, X, INCX, SCALE, SSQ ) */ + + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.f) { + absxi = (r__1 = x[ix], dabs(r__1)); + if (scale < absxi) { +/* Computing 2nd power */ + r__1 = scale / absxi; + ssq = ssq * (r__1 * r__1) + 1.f; + scale = absxi; + } else { +/* Computing 2nd power */ + r__1 = absxi / scale; + ssq += r__1 * r__1; + } + } +/* L10: */ + } + norm = scale * sqrt(ssq); + } + + ret_val = norm; + return ret_val; + +/* End of SNRM2. */ + +} /* snrm2_ */ diff --git a/contrib/libs/cblas/srot.c b/contrib/libs/cblas/srot.c new file mode 100644 index 00000000000..085677c73c6 --- /dev/null +++ b/contrib/libs/cblas/srot.c @@ -0,0 +1,90 @@ +/* srot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int srot_(integer *n, real *sx, integer *incx, real *sy, + integer *incy, real *c__, real *s) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ix, iy; + real stemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* applies a plane rotation. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = *c__ * sx[ix] + *s * sy[iy]; + sy[iy] = *c__ * sy[iy] - *s * sx[ix]; + sx[ix] = stemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = *c__ * sx[i__] + *s * sy[i__]; + sy[i__] = *c__ * sy[i__] - *s * sx[i__]; + sx[i__] = stemp; +/* L30: */ + } + return 0; +} /* srot_ */ diff --git a/contrib/libs/cblas/srotg.c b/contrib/libs/cblas/srotg.c new file mode 100644 index 00000000000..99be0f8ec41 --- /dev/null +++ b/contrib/libs/cblas/srotg.c @@ -0,0 +1,78 @@ +/* srotg.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Table of constant values */ + +static real c_b4 = 1.f; + +/* Subroutine */ int srotg_(real *sa, real *sb, real *c__, real *s) +{ + /* System generated locals */ + real r__1, r__2; + + /* Builtin functions */ + double sqrt(doublereal), r_sign(real *, real *); + + /* Local variables */ + real r__, z__, roe, scale; + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* construct givens plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + roe = *sb; + if (dabs(*sa) > dabs(*sb)) { + roe = *sa; + } + scale = dabs(*sa) + dabs(*sb); + if (scale != 0.f) { + goto L10; + } + *c__ = 1.f; + *s = 0.f; + r__ = 0.f; + z__ = 0.f; + goto L20; +L10: +/* Computing 2nd power */ + r__1 = *sa / scale; +/* Computing 2nd power */ + r__2 = *sb / scale; + r__ = scale * sqrt(r__1 * r__1 + r__2 * r__2); + r__ = r_sign(&c_b4, &roe) * r__; + *c__ = *sa / r__; + *s = *sb / r__; + z__ = 1.f; + if (dabs(*sa) > dabs(*sb)) { + z__ = *s; + } + if (dabs(*sb) >= dabs(*sa) && *c__ != 0.f) { + z__ = 1.f / *c__; + } +L20: + *sa = r__; + *sb = z__; + return 0; +} /* srotg_ */ diff --git a/contrib/libs/cblas/srotm.c b/contrib/libs/cblas/srotm.c new file mode 100644 index 00000000000..b83bf8628d9 --- /dev/null +++ b/contrib/libs/cblas/srotm.c @@ -0,0 +1,216 @@ +/* srotm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, + integer *incy, real *sparam) +{ + /* Initialized data */ + + static real zero = 0.f; + static real two = 2.f; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__; + real w, z__; + integer kx, ky; + real sh11, sh12, sh21, sh22, sflag; + integer nsteps; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ + +/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */ +/* (DX**T) */ + +/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ +/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */ +/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ + +/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ +/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */ + + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* number of elements in input vector(s) */ + +/* SX (input/output) REAL array, dimension N */ +/* double precision vector with N elements */ + +/* INCX (input) INTEGER */ +/* storage spacing between elements of SX */ + +/* SY (input/output) REAL array, dimension N */ +/* double precision vector with N elements */ + +/* INCY (input) INTEGER */ +/* storage spacing between elements of SY */ + +/* SPARAM (input/output) REAL array, dimension 5 */ +/* SPARAM(1)=SFLAG */ +/* SPARAM(2)=SH11 */ +/* SPARAM(3)=SH21 */ +/* SPARAM(4)=SH12 */ +/* SPARAM(5)=SH22 */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --sparam; + --sy; + --sx; + + /* Function Body */ +/* .. */ + + sflag = sparam[1]; + if (*n <= 0 || sflag + two == zero) { + goto L140; + } + if (! (*incx == *incy && *incx > 0)) { + goto L70; + } + + nsteps = *n * *incx; + if (sflag < 0.f) { + goto L50; + } else if (sflag == 0) { + goto L10; + } else { + goto L30; + } +L10: + sh12 = sparam[4]; + sh21 = sparam[3]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w + z__ * sh12; + sy[i__] = w * sh21 + z__; +/* L20: */ + } + goto L140; +L30: + sh11 = sparam[2]; + sh22 = sparam[5]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w * sh11 + z__; + sy[i__] = -w + sh22 * z__; +/* L40: */ + } + goto L140; +L50: + sh11 = sparam[2]; + sh12 = sparam[4]; + sh21 = sparam[3]; + sh22 = sparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w * sh11 + z__ * sh12; + sy[i__] = w * sh21 + z__ * sh22; +/* L60: */ + } + goto L140; +L70: + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (sflag < 0.f) { + goto L120; + } else if (sflag == 0) { + goto L80; + } else { + goto L100; + } +L80: + sh12 = sparam[4]; + sh21 = sparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w + z__ * sh12; + sy[ky] = w * sh21 + z__; + kx += *incx; + ky += *incy; +/* L90: */ + } + goto L140; +L100: + sh11 = sparam[2]; + sh22 = sparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w * sh11 + z__; + sy[ky] = -w + sh22 * z__; + kx += *incx; + ky += *incy; +/* L110: */ + } + goto L140; +L120: + sh11 = sparam[2]; + sh12 = sparam[4]; + sh21 = sparam[3]; + sh22 = sparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w * sh11 + z__ * sh12; + sy[ky] = w * sh21 + z__ * sh22; + kx += *incx; + ky += *incy; +/* L130: */ + } +L140: + return 0; +} /* srotm_ */ diff --git a/contrib/libs/cblas/srotmg.c b/contrib/libs/cblas/srotmg.c new file mode 100644 index 00000000000..912778bedb3 --- /dev/null +++ b/contrib/libs/cblas/srotmg.c @@ -0,0 +1,295 @@ +/* srotmg.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real + *sparam) +{ + /* Initialized data */ + + static real zero = 0.f; + static real one = 1.f; + static real two = 2.f; + static real gam = 4096.f; + static real gamsq = 16777200.f; + static real rgamsq = 5.96046e-8f; + + /* Format strings */ + static char fmt_120[] = ""; + static char fmt_150[] = ""; + static char fmt_180[] = ""; + static char fmt_210[] = ""; + + /* System generated locals */ + real r__1; + + /* Local variables */ + real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22; + integer igo; + real sflag, stemp; + + /* Assigned format variables */ + static char *igo_fmt; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ +/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */ +/* SY2)**T. */ +/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ + +/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ +/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */ +/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */ +/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */ + +/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ +/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ +/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ + + +/* Arguments */ +/* ========= */ + + +/* SD1 (input/output) REAL */ + +/* SD2 (input/output) REAL */ + +/* SX1 (input/output) REAL */ + +/* SY1 (input) REAL */ + + +/* SPARAM (input/output) REAL array, dimension 5 */ +/* SPARAM(1)=SFLAG */ +/* SPARAM(2)=SH11 */ +/* SPARAM(3)=SH21 */ +/* SPARAM(4)=SH12 */ +/* SPARAM(5)=SH22 */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Data statements .. */ + + /* Parameter adjustments */ + --sparam; + + /* Function Body */ +/* .. */ + if (! (*sd1 < zero)) { + goto L10; + } +/* GO ZERO-H-D-AND-SX1.. */ + goto L60; +L10: +/* CASE-SD1-NONNEGATIVE */ + sp2 = *sd2 * *sy1; + if (! (sp2 == zero)) { + goto L20; + } + sflag = -two; + goto L260; +/* REGULAR-CASE.. */ +L20: + sp1 = *sd1 * *sx1; + sq2 = sp2 * *sy1; + sq1 = sp1 * *sx1; + + if (! (dabs(sq1) > dabs(sq2))) { + goto L40; + } + sh21 = -(*sy1) / *sx1; + sh12 = sp2 / sp1; + + su = one - sh12 * sh21; + + if (! (su <= zero)) { + goto L30; + } +/* GO ZERO-H-D-AND-SX1.. */ + goto L60; +L30: + sflag = zero; + *sd1 /= su; + *sd2 /= su; + *sx1 *= su; +/* GO SCALE-CHECK.. */ + goto L100; +L40: + if (! (sq2 < zero)) { + goto L50; + } +/* GO ZERO-H-D-AND-SX1.. */ + goto L60; +L50: + sflag = one; + sh11 = sp1 / sp2; + sh22 = *sx1 / *sy1; + su = one + sh11 * sh22; + stemp = *sd2 / su; + *sd2 = *sd1 / su; + *sd1 = stemp; + *sx1 = *sy1 * su; +/* GO SCALE-CHECK */ + goto L100; +/* PROCEDURE..ZERO-H-D-AND-SX1.. */ +L60: + sflag = -one; + sh11 = zero; + sh12 = zero; + sh21 = zero; + sh22 = zero; + + *sd1 = zero; + *sd2 = zero; + *sx1 = zero; +/* RETURN.. */ + goto L220; +/* PROCEDURE..FIX-H.. */ +L70: + if (! (sflag >= zero)) { + goto L90; + } + + if (! (sflag == zero)) { + goto L80; + } + sh11 = one; + sh22 = one; + sflag = -one; + goto L90; +L80: + sh21 = -one; + sh12 = one; + sflag = -one; +L90: + switch (igo) { + case 0: goto L120; + case 1: goto L150; + case 2: goto L180; + case 3: goto L210; + } +/* PROCEDURE..SCALE-CHECK */ +L100: +L110: + if (! (*sd1 <= rgamsq)) { + goto L130; + } + if (*sd1 == zero) { + goto L160; + } + igo = 0; + igo_fmt = fmt_120; +/* FIX-H.. */ + goto L70; +L120: +/* Computing 2nd power */ + r__1 = gam; + *sd1 *= r__1 * r__1; + *sx1 /= gam; + sh11 /= gam; + sh12 /= gam; + goto L110; +L130: +L140: + if (! (*sd1 >= gamsq)) { + goto L160; + } + igo = 1; + igo_fmt = fmt_150; +/* FIX-H.. */ + goto L70; +L150: +/* Computing 2nd power */ + r__1 = gam; + *sd1 /= r__1 * r__1; + *sx1 *= gam; + sh11 *= gam; + sh12 *= gam; + goto L140; +L160: +L170: + if (! (dabs(*sd2) <= rgamsq)) { + goto L190; + } + if (*sd2 == zero) { + goto L220; + } + igo = 2; + igo_fmt = fmt_180; +/* FIX-H.. */ + goto L70; +L180: +/* Computing 2nd power */ + r__1 = gam; + *sd2 *= r__1 * r__1; + sh21 /= gam; + sh22 /= gam; + goto L170; +L190: +L200: + if (! (dabs(*sd2) >= gamsq)) { + goto L220; + } + igo = 3; + igo_fmt = fmt_210; +/* FIX-H.. */ + goto L70; +L210: +/* Computing 2nd power */ + r__1 = gam; + *sd2 /= r__1 * r__1; + sh21 *= gam; + sh22 *= gam; + goto L200; +L220: + if (sflag < 0.f) { + goto L250; + } else if (sflag == 0) { + goto L230; + } else { + goto L240; + } +L230: + sparam[3] = sh21; + sparam[4] = sh12; + goto L260; +L240: + sparam[2] = sh11; + sparam[5] = sh22; + goto L260; +L250: + sparam[2] = sh11; + sparam[3] = sh21; + sparam[4] = sh12; + sparam[5] = sh22; +L260: + sparam[1] = sflag; + return 0; +} /* srotmg_ */ diff --git a/contrib/libs/cblas/ssbmv.c b/contrib/libs/cblas/ssbmv.c new file mode 100644 index 00000000000..9b22b21c1c6 --- /dev/null +++ b/contrib/libs/cblas/ssbmv.c @@ -0,0 +1,364 @@ +/* ssbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha, + real *a, integer *lda, real *x, integer *incx, real *beta, real *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, iy, jx, jy, kx, ky, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSBMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric band matrix, with k super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the band matrix A is being supplied as */ +/* follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* being supplied. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* being supplied. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of super-diagonals of the */ +/* matrix A. K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the symmetric matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer the upper */ +/* triangular part of a symmetric band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the symmetric matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer the lower */ +/* triangular part of a symmetric band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - REAL array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* Y - REAL array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*k < 0) { + info = 3; + } else if (*lda < *k + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("SSBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array A */ +/* are accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.f) { + if (*incy == 1) { + if (*beta == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.f) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when upper triangle of A is stored. */ + + kplus1 = *k + 1; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.f; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + y[i__] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[i__]; +/* L50: */ + } + y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.f; + ix = kx; + iy = ky; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + y[iy] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * + temp2; + jx += *incx; + jy += *incy; + if (j > *k) { + kx += *incx; + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y when lower triangle of A is stored. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.f; + y[j] += temp1 * a[j * a_dim1 + 1]; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + y[i__] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[j] += *alpha * temp2; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.f; + y[jy] += temp1 * a[j * a_dim1 + 1]; + l = 1 - j; + ix = jx; + iy = jy; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of SSBMV . */ + +} /* ssbmv_ */ diff --git a/contrib/libs/cblas/sscal.c b/contrib/libs/cblas/sscal.c new file mode 100644 index 00000000000..1bd2963e3b4 --- /dev/null +++ b/contrib/libs/cblas/sscal.c @@ -0,0 +1,95 @@ +/* sscal.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, m, mp1, nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* scales a vector by a constant. */ +/* uses unrolled loops for increment equal to 1. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + sx[i__] = *sa * sx[i__]; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 5; + if (m == 0) { + goto L40; + } + i__2 = m; + for (i__ = 1; i__ <= i__2; ++i__) { + sx[i__] = *sa * sx[i__]; +/* L30: */ + } + if (*n < 5) { + return 0; + } +L40: + mp1 = m + 1; + i__2 = *n; + for (i__ = mp1; i__ <= i__2; i__ += 5) { + sx[i__] = *sa * sx[i__]; + sx[i__ + 1] = *sa * sx[i__ + 1]; + sx[i__ + 2] = *sa * sx[i__ + 2]; + sx[i__ + 3] = *sa * sx[i__ + 3]; + sx[i__ + 4] = *sa * sx[i__ + 4]; +/* L50: */ + } + return 0; +} /* sscal_ */ diff --git a/contrib/libs/cblas/sspmv.c b/contrib/libs/cblas/sspmv.c new file mode 100644 index 00000000000..7a5db80c544 --- /dev/null +++ b/contrib/libs/cblas/sspmv.c @@ -0,0 +1,311 @@ +/* sspmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap, + real *x, integer *incx, real *beta, real *y, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSPMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* AP - REAL array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --y; + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 6; + } else if (*incy == 0) { + info = 9; + } + if (info != 0) { + xerbla_("SSPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + +/* First form y := beta*y. */ + + if (*beta != 1.f) { + if (*incy == 1) { + if (*beta == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.f) { + return 0; + } + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form y when AP contains the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.f; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * ap[k]; + temp2 += ap[k] * x[i__]; + ++k; +/* L50: */ + } + y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; + kk += j; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.f; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + y[iy] += temp1 * ap[k]; + temp2 += ap[k] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; + jx += *incx; + jy += *incy; + kk += j; +/* L80: */ + } + } + } else { + +/* Form y when AP contains the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.f; + y[j] += temp1 * ap[kk]; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * ap[k]; + temp2 += ap[k] * x[i__]; + ++k; +/* L90: */ + } + y[j] += *alpha * temp2; + kk += *n - j + 1; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.f; + y[jy] += temp1 * ap[kk]; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * ap[k]; + temp2 += ap[k] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; + kk += *n - j + 1; +/* L120: */ + } + } + } + + return 0; + +/* End of SSPMV . */ + +} /* sspmv_ */ diff --git a/contrib/libs/cblas/sspr.c b/contrib/libs/cblas/sspr.c new file mode 100644 index 00000000000..97791a8ab3f --- /dev/null +++ b/contrib/libs/cblas/sspr.c @@ -0,0 +1,237 @@ +/* sspr.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sspr_(char *uplo, integer *n, real *alpha, real *x, + integer *incx, real *ap) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSPR performs the symmetric rank 1 operation */ + +/* A := alpha*x*x' + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* AP - REAL array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } + if (info != 0) { + xerbla_("SSPR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = *alpha * x[j]; + k = kk; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[k] += x[i__] * temp; + ++k; +/* L10: */ + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + ix = kx; + i__2 = kk + j - 1; + for (k = kk; k <= i__2; ++k) { + ap[k] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = *alpha * x[j]; + k = kk; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[k] += x[i__] * temp; + ++k; +/* L50: */ + } + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + ix = jx; + i__2 = kk + *n - j; + for (k = kk; k <= i__2; ++k) { + ap[k] += x[ix] * temp; + ix += *incx; +/* L70: */ + } + } + jx += *incx; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of SSPR . */ + +} /* sspr_ */ diff --git a/contrib/libs/cblas/sspr2.c b/contrib/libs/cblas/sspr2.c new file mode 100644 index 00000000000..3fb675a6f18 --- /dev/null +++ b/contrib/libs/cblas/sspr2.c @@ -0,0 +1,269 @@ +/* sspr2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sspr2_(char *uplo, integer *n, real *alpha, real *x, + integer *incx, real *y, integer *incy, real *ap) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSPR2 performs the symmetric rank 2 operation */ + +/* A := alpha*x*y' + alpha*y*x' + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an */ +/* n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* AP - REAL array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --y; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } + if (info != 0) { + xerbla_("SSPR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f || y[j] != 0.f) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + k = kk; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; + ++k; +/* L10: */ + } + } + kk += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f || y[jy] != 0.f) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = kk + j - 1; + for (k = kk; k <= i__2; ++k) { + ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L30: */ + } + } + jx += *incx; + jy += *incy; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f || y[j] != 0.f) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + k = kk; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; + ++k; +/* L50: */ + } + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f || y[jy] != 0.f) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk; k <= i__2; ++k) { + ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + jy += *incy; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of SSPR2 . */ + +} /* sspr2_ */ diff --git a/contrib/libs/cblas/sswap.c b/contrib/libs/cblas/sswap.c new file mode 100644 index 00000000000..6d6e9e43713 --- /dev/null +++ b/contrib/libs/cblas/sswap.c @@ -0,0 +1,114 @@ +/* sswap.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy, + integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + real stemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* interchanges two vectors. */ +/* uses unrolled loops for increments equal to 1. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = sx[ix]; + sx[ix] = sy[iy]; + sy[iy] = stemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 3; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = sx[i__]; + sx[i__] = sy[i__]; + sy[i__] = stemp; +/* L30: */ + } + if (*n < 3) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 3) { + stemp = sx[i__]; + sx[i__] = sy[i__]; + sy[i__] = stemp; + stemp = sx[i__ + 1]; + sx[i__ + 1] = sy[i__ + 1]; + sy[i__ + 1] = stemp; + stemp = sx[i__ + 2]; + sx[i__ + 2] = sy[i__ + 2]; + sy[i__ + 2] = stemp; +/* L50: */ + } + return 0; +} /* sswap_ */ diff --git a/contrib/libs/cblas/ssymm.c b/contrib/libs/cblas/ssymm.c new file mode 100644 index 00000000000..df3424298e9 --- /dev/null +++ b/contrib/libs/cblas/ssymm.c @@ -0,0 +1,362 @@ +/* ssymm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssymm_(char *side, char *uplo, integer *m, integer *n, + real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta, + real *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, k, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSYMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is a symmetric matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the symmetric matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the symmetric matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix C. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix C. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - REAL array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - REAL array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n updated */ +/* matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,*m)) { + info = 9; + } else if (*ldc < max(1,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("SSYMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.f) { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.f; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; +/* L50: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.f; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; +/* L80: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * a[j + j * a_dim1]; + if (*beta == 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * b[i__ + j * b_dim1]; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[k + j * a_dim1]; + } else { + temp1 = *alpha * a[j + k * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[j + k * a_dim1]; + } else { + temp1 = *alpha * a[k + j * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of SSYMM . */ + +} /* ssymm_ */ diff --git a/contrib/libs/cblas/ssymv.c b/contrib/libs/cblas/ssymv.c new file mode 100644 index 00000000000..3a1502c6f0a --- /dev/null +++ b/contrib/libs/cblas/ssymv.c @@ -0,0 +1,313 @@ +/* ssymv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssymv_(char *uplo, integer *n, real *alpha, real *a, + integer *lda, real *x, integer *incx, real *beta, real *y, integer * + incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSYMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < max(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("SSYMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f && *beta == 1.f) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.f) { + if (*incy == 1) { + if (*beta == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.f; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.f; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.f) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when A is stored in upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; +/* L50: */ + } + y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.f; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } else { + +/* Form y when A is stored in lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.f; + y[j] += temp1 * a[j + j * a_dim1]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[j] += *alpha * temp2; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.f; + y[jy] += temp1 * a[j + j * a_dim1]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of SSYMV . */ + +} /* ssymv_ */ diff --git a/contrib/libs/cblas/ssyr.c b/contrib/libs/cblas/ssyr.c new file mode 100644 index 00000000000..dd433a3450e --- /dev/null +++ b/contrib/libs/cblas/ssyr.c @@ -0,0 +1,238 @@ +/* ssyr.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssyr_(char *uplo, integer *n, real *alpha, real *x, + integer *incx, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSYR performs the symmetric rank 1 operation */ + +/* A := alpha*x*x' + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*lda < max(1,*n)) { + info = 7; + } + if (info != 0) { + xerbla_("SSYR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in upper triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + ix = kx; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jx += *incx; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in lower triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = *alpha * x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + + return 0; + +/* End of SSYR . */ + +} /* ssyr_ */ diff --git a/contrib/libs/cblas/ssyr2.c b/contrib/libs/cblas/ssyr2.c new file mode 100644 index 00000000000..738250ebcd3 --- /dev/null +++ b/contrib/libs/cblas/ssyr2.c @@ -0,0 +1,274 @@ +/* ssyr2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssyr2_(char *uplo, integer *n, real *alpha, real *x, + integer *incx, real *y, integer *incy, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSYR2 performs the symmetric rank 2 operation */ + +/* A := alpha*x*y' + alpha*y*x' + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an n */ +/* by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*n)) { + info = 9; + } + if (info != 0) { + xerbla_("SSYR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.f) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f || y[j] != 0.f) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; +/* L10: */ + } + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f || y[jy] != 0.f) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L30: */ + } + } + jx += *incx; + jy += *incy; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f || y[j] != 0.f) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; +/* L50: */ + } + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f || y[jy] != 0.f) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } + + return 0; + +/* End of SSYR2 . */ + +} /* ssyr2_ */ diff --git a/contrib/libs/cblas/ssyr2k.c b/contrib/libs/cblas/ssyr2k.c new file mode 100644 index 00000000000..2d082fcf888 --- /dev/null +++ b/contrib/libs/cblas/ssyr2k.c @@ -0,0 +1,409 @@ +/* ssyr2k.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssyr2k_(char *uplo, char *trans, integer *n, integer *k, + real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta, + real *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, l, info; + real temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSYR2K performs one of the symmetric rank 2k operations */ + +/* C := alpha*A*B' + alpha*B*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*B + alpha*B'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A and B are n by k matrices in the first case and k by n */ +/* matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ +/* beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ +/* of rows of the matrices A and B. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - REAL array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,nrowa)) { + info = 9; + } else if (*ldc < max(1,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("SSYR2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.f) { + if (upper) { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*B' + alpha*B*A' + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L90: */ + } + } else if (*beta != 1.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f) + { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L140: */ + } + } else if (*beta != 1.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f) + { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*B + alpha*B'*A + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = 0.f; + temp2 = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; +/* L190: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1 = 0.f; + temp2 = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; +/* L220: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of SSYR2K. */ + +} /* ssyr2k_ */ diff --git a/contrib/libs/cblas/ssyrk.c b/contrib/libs/cblas/ssyrk.c new file mode 100644 index 00000000000..1c2bc37c2d3 --- /dev/null +++ b/contrib/libs/cblas/ssyrk.c @@ -0,0 +1,372 @@ +/* ssyrk.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ssyrk_(char *uplo, char *trans, integer *n, integer *k, + real *alpha, real *a, integer *lda, real *beta, real *c__, integer * + ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, info; + real temp; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SSYRK performs one of the symmetric rank k operations */ + +/* C := alpha*A*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A is an n by k matrix in the first case and a k by n matrix */ +/* in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ +/* of rows of the matrix A. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - REAL . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - REAL array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldc < max(1,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("SSYRK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.f) { + if (upper) { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (*beta == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*A' + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L90: */ + } + } else if (*beta != 1.f) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.f) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.f; +/* L140: */ + } + } else if (*beta != 1.f) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.f) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; +/* L190: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp = 0.f; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; +/* L220: */ + } + if (*beta == 0.f) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of SSYRK . */ + +} /* ssyrk_ */ diff --git a/contrib/libs/cblas/stbmv.c b/contrib/libs/cblas/stbmv.c new file mode 100644 index 00000000000..bea0335e2d8 --- /dev/null +++ b/contrib/libs/cblas/stbmv.c @@ -0,0 +1,422 @@ +/* stbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, real *a, integer *lda, real *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STBMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := A'*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("STBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = x[j]; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + x[i__] += temp * a[l + i__ + j * a_dim1]; +/* L10: */ + } + if (nounit) { + x[j] *= a[kplus1 + j * a_dim1]; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = x[jx]; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + x[ix] += temp * a[l + i__ + j * a_dim1]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= a[kplus1 + j * a_dim1]; + } + } + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.f) { + temp = x[j]; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { + x[i__] += temp * a[l + i__ + j * a_dim1]; +/* L50: */ + } + if (nounit) { + x[j] *= a[j * a_dim1 + 1]; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.f) { + temp = x[jx]; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { + x[ix] += temp * a[l + i__ + j * a_dim1]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= a[j * a_dim1 + 1]; + } + } + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + l = kplus1 - j; + if (nounit) { + temp *= a[kplus1 + j * a_dim1]; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + temp += a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + x[j] = temp; +/* L100: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + kx -= *incx; + ix = kx; + l = kplus1 - j; + if (nounit) { + temp *= a[kplus1 + j * a_dim1]; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + temp += a[l + i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + temp = x[j]; + l = 1 - j; + if (nounit) { + temp *= a[j * a_dim1 + 1]; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + temp += a[l + i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + x[j] = temp; +/* L140: */ + } + } else { + jx = kx; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + temp = x[jx]; + kx += *incx; + ix = kx; + l = 1 - j; + if (nounit) { + temp *= a[j * a_dim1 + 1]; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + temp += a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L150: */ + } + x[jx] = temp; + jx += *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of STBMV . */ + +} /* stbmv_ */ diff --git a/contrib/libs/cblas/stbsv.c b/contrib/libs/cblas/stbsv.c new file mode 100644 index 00000000000..ef933a1602b --- /dev/null +++ b/contrib/libs/cblas/stbsv.c @@ -0,0 +1,426 @@ +/* stbsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int stbsv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, real *a, integer *lda, real *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STBSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */ +/* diagonals. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' A'*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("STBSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed by sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.f) { + l = kplus1 - j; + if (nounit) { + x[j] /= a[kplus1 + j * a_dim1]; + } + temp = x[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + x[i__] -= temp * a[l + i__ + j * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + kx -= *incx; + if (x[jx] != 0.f) { + ix = kx; + l = kplus1 - j; + if (nounit) { + x[jx] /= a[kplus1 + j * a_dim1]; + } + temp = x[jx]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + x[ix] -= temp * a[l + i__ + j * a_dim1]; + ix -= *incx; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + l = 1 - j; + if (nounit) { + x[j] /= a[j * a_dim1 + 1]; + } + temp = x[j]; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[l + i__ + j * a_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + kx += *incx; + if (x[jx] != 0.f) { + ix = kx; + l = 1 - j; + if (nounit) { + x[jx] /= a[j * a_dim1 + 1]; + } + temp = x[jx]; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[ix] -= temp * a[l + i__ + j * a_dim1]; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A')*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + temp -= a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + if (nounit) { + temp /= a[kplus1 + j * a_dim1]; + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + temp -= a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= a[kplus1 + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L120: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { + temp -= a[l + i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + if (nounit) { + temp /= a[j * a_dim1 + 1]; + } + x[j] = temp; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { + temp -= a[l + i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= a[j * a_dim1 + 1]; + } + x[jx] = temp; + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L160: */ + } + } + } + } + + return 0; + +/* End of STBSV . */ + +} /* stbsv_ */ diff --git a/contrib/libs/cblas/stpmv.c b/contrib/libs/cblas/stpmv.c new file mode 100644 index 00000000000..9d57e2ea9ef --- /dev/null +++ b/contrib/libs/cblas/stpmv.c @@ -0,0 +1,357 @@ +/* stpmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int stpmv_(char *uplo, char *trans, char *diag, integer *n, + real *ap, real *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STPMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := A'*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - REAL array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("STPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x:= A*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = x[j]; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * ap[k]; + ++k; +/* L10: */ + } + if (nounit) { + x[j] *= ap[kk + j - 1]; + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = x[jx]; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + x[ix] += temp * ap[k]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= ap[kk + j - 1]; + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.f) { + temp = x[j]; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * ap[k]; + --k; +/* L50: */ + } + if (nounit) { + x[j] *= ap[kk - *n + j]; + } + } + kk -= *n - j + 1; +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.f) { + temp = x[jx]; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + x[ix] += temp * ap[k]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= ap[kk - *n + j]; + } + } + jx -= *incx; + kk -= *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= ap[kk]; + } + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + temp += ap[k] * x[i__]; + --k; +/* L90: */ + } + x[j] = temp; + kk -= j; +/* L100: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= ap[kk]; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + temp += ap[k] * x[ix]; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; + kk -= j; +/* L120: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= ap[kk]; + } + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += ap[k] * x[i__]; + ++k; +/* L130: */ + } + x[j] = temp; + kk += *n - j + 1; +/* L140: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= ap[kk]; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + temp += ap[k] * x[ix]; +/* L150: */ + } + x[jx] = temp; + jx += *incx; + kk += *n - j + 1; +/* L160: */ + } + } + } + } + + return 0; + +/* End of STPMV . */ + +} /* stpmv_ */ diff --git a/contrib/libs/cblas/stpsv.c b/contrib/libs/cblas/stpsv.c new file mode 100644 index 00000000000..f16be31a772 --- /dev/null +++ b/contrib/libs/cblas/stpsv.c @@ -0,0 +1,360 @@ +/* stpsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int stpsv_(char *uplo, char *trans, char *diag, integer *n, + real *ap, real *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STPSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix, supplied in packed form. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' A'*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - REAL array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("STPSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.f) { + if (nounit) { + x[j] /= ap[kk]; + } + temp = x[j]; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * ap[k]; + --k; +/* L10: */ + } + } + kk -= j; +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.f) { + if (nounit) { + x[jx] /= ap[kk]; + } + temp = x[jx]; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + x[ix] -= temp * ap[k]; +/* L30: */ + } + } + jx -= *incx; + kk -= j; +/* L40: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + if (nounit) { + x[j] /= ap[kk]; + } + temp = x[j]; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * ap[k]; + ++k; +/* L50: */ + } + } + kk += *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + if (nounit) { + x[jx] /= ap[kk]; + } + temp = x[jx]; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + x[ix] -= temp * ap[k]; +/* L70: */ + } + } + jx += *incx; + kk += *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= ap[k] * x[i__]; + ++k; +/* L90: */ + } + if (nounit) { + temp /= ap[kk + j - 1]; + } + x[j] = temp; + kk += j; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + temp -= ap[k] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= ap[kk + j - 1]; + } + x[jx] = temp; + jx += *incx; + kk += j; +/* L120: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= ap[k] * x[i__]; + --k; +/* L130: */ + } + if (nounit) { + temp /= ap[kk - *n + j]; + } + x[j] = temp; + kk -= *n - j + 1; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + temp -= ap[k] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= ap[kk - *n + j]; + } + x[jx] = temp; + jx -= *incx; + kk -= *n - j + 1; +/* L160: */ + } + } + } + } + + return 0; + +/* End of STPSV . */ + +} /* stpsv_ */ diff --git a/contrib/libs/cblas/strmm.c b/contrib/libs/cblas/strmm.c new file mode 100644 index 00000000000..0dfb68f9a8c --- /dev/null +++ b/contrib/libs/cblas/strmm.c @@ -0,0 +1,453 @@ +/* strmm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int strmm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, real *alpha, real *a, integer *lda, real *b, + integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, info; + real temp; + logical lside; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STRMM performs one of the matrix-matrix operations */ + +/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */ + +/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A'. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) multiplies B from */ +/* the left or right as follows: */ + +/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */ + +/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - REAL array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B, and on exit is overwritten by the */ +/* transformed matrix. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("STRMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*A*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.f) { + temp = *alpha * b[k + j * b_dim1]; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; +/* L30: */ + } + if (nounit) { + temp *= a[k + k * a_dim1]; + } + b[k + j * b_dim1] = temp; + } +/* L40: */ + } +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.f) { + temp = *alpha * b[k + j * b_dim1]; + b[k + j * b_dim1] = temp; + if (nounit) { + b[k + j * b_dim1] *= a[k + k * a_dim1]; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; +/* L60: */ + } + } +/* L70: */ + } +/* L80: */ + } + } + } else { + +/* Form B := alpha*A'*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L90: */ + } + b[i__ + j * b_dim1] = *alpha * temp; +/* L100: */ + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L120: */ + } + b[i__ + j * b_dim1] = *alpha * temp; +/* L130: */ + } +/* L140: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*A. */ + + if (upper) { + for (j = *n; j >= 1; --j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L150: */ + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.f) { + temp = *alpha * a[k + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L190: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.f) { + temp = *alpha * a[k + j * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L200: */ + } + } +/* L210: */ + } +/* L220: */ + } + } + } else { + +/* Form B := alpha*B*A'. */ + + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.f) { + temp = *alpha * a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L230: */ + } + } +/* L240: */ + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L250: */ + } + } +/* L260: */ + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.f) { + temp = *alpha * a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L270: */ + } + } +/* L280: */ + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L290: */ + } + } +/* L300: */ + } + } + } + } + + return 0; + +/* End of STRMM . */ + +} /* strmm_ */ diff --git a/contrib/libs/cblas/strmv.c b/contrib/libs/cblas/strmv.c new file mode 100644 index 00000000000..d4ff0b9f5a4 --- /dev/null +++ b/contrib/libs/cblas/strmv.c @@ -0,0 +1,345 @@ +/* strmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int strmv_(char *uplo, char *trans, char *diag, integer *n, + real *a, integer *lda, real *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STRMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := A'*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("STRMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * a[i__ + j * a_dim1]; +/* L10: */ + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx += *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.f) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * a[i__ + j * a_dim1]; +/* L50: */ + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.f) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx -= *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + x[j] = temp; +/* L140: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +/* L150: */ + } + x[jx] = temp; + jx += *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of STRMV . */ + +} /* strmv_ */ diff --git a/contrib/libs/cblas/strsm.c b/contrib/libs/cblas/strsm.c new file mode 100644 index 00000000000..8c50307edce --- /dev/null +++ b/contrib/libs/cblas/strsm.c @@ -0,0 +1,490 @@ +/* strsm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int strsm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, real *alpha, real *a, integer *lda, real *b, + integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, info; + real temp; + logical lside; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STRSM solves one of the matrix equations */ + +/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ + +/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A'. */ + +/* The matrix X is overwritten on B. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) appears on the left */ +/* or right of X as follows: */ + +/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ + +/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - REAL . */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - REAL array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the right-hand side matrix B, and on exit is */ +/* overwritten by the solution matrix X. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("STRSM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*inv( A )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L30: */ + } + } + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.f) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; +/* L40: */ + } + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L70: */ + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.f) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; +/* L80: */ + } + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form B := alpha*inv( A' )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L110: */ + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L140: */ + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; +/* L150: */ + } +/* L160: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*inv( A ). */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L170: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.f) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; +/* L180: */ + } + } +/* L190: */ + } + if (nounit) { + temp = 1.f / a[j + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L200: */ + } + } +/* L210: */ + } + } else { + for (j = *n; j >= 1; --j) { + if (*alpha != 1.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L220: */ + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; +/* L230: */ + } + } +/* L240: */ + } + if (nounit) { + temp = 1.f / a[j + j * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L250: */ + } + } +/* L260: */ + } + } + } else { + +/* Form B := alpha*B*inv( A' ). */ + + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + temp = 1.f / a[k + k * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L270: */ + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.f) { + temp = a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; +/* L280: */ + } + } +/* L290: */ + } + if (*alpha != 1.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; +/* L300: */ + } + } +/* L310: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + temp = 1.f / a[k + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L320: */ + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.f) { + temp = a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; +/* L330: */ + } + } +/* L340: */ + } + if (*alpha != 1.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; +/* L350: */ + } + } +/* L360: */ + } + } + } + } + + return 0; + +/* End of STRSM . */ + +} /* strsm_ */ diff --git a/contrib/libs/cblas/strsv.c b/contrib/libs/cblas/strsv.c new file mode 100644 index 00000000000..fe61b84b527 --- /dev/null +++ b/contrib/libs/cblas/strsv.c @@ -0,0 +1,348 @@ +/* strsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int strsv_(char *uplo, char *trans, char *diag, integer *n, + real *a, integer *lda, real *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + real temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* STRSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' A'*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - REAL array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - REAL array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("STRSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.f) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.f) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.f) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.f) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx -= *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of STRSV . */ + +} /* strsv_ */ diff --git a/contrib/libs/cblas/xerbla.c b/contrib/libs/cblas/xerbla.c new file mode 100644 index 00000000000..1088d0fa8f9 --- /dev/null +++ b/contrib/libs/cblas/xerbla.c @@ -0,0 +1,77 @@ +/* xerbla.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" +#include <stdio.h> + +/* Table of constant values */ + +static integer c__1 = 1; + +/* Subroutine */ int xerbla_(char *srname, integer *info) +{ + /* Format strings */ + static char fmt_9999[] = "(\002 ** On entry to \002,a,\002 parameter num" + "ber \002,i2,\002 had \002,\002an illegal value\002)"; + + /* Builtin functions */ + integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *, + char *, ftnlen), e_wsfe(void); + /* Subroutine */ int s_stop(char *, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___1 = { 0, 6, 0, fmt_9999, 0 }; + + + +/* -- LAPACK auxiliary routine (preliminary version) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* XERBLA is an error handler for the LAPACK routines. */ +/* It is called by an LAPACK routine if an input parameter has an */ +/* invalid value. A message is printed and execution stops. */ + +/* Installers may consider modifying the STOP statement in order to */ +/* call system-specific exception-handling facilities. */ + +/* Arguments */ +/* ========= */ + +/* SRNAME (input) CHARACTER*(*) */ +/* The name of the routine which called XERBLA. */ + +/* INFO (input) INTEGER */ +/* The position of the invalid parameter in the parameter list */ +/* of the calling routine. */ + +/* ===================================================================== */ + +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + printf("** On entry to %6s, parameter number %2i had an illegal value\n", + srname, *info); + + +/* End of XERBLA */ + + return 0; +} /* xerbla_ */ diff --git a/contrib/libs/cblas/xerbla_array.c b/contrib/libs/cblas/xerbla_array.c new file mode 100644 index 00000000000..d4e4c249026 --- /dev/null +++ b/contrib/libs/cblas/xerbla_array.c @@ -0,0 +1,102 @@ +/* xerbla_array.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int xerbla_array__(char *srname_array__, integer * + srname_len__, integer *info, ftnlen srname_array_len) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer i_len(char *, ftnlen); + + /* Local variables */ + integer i__; + extern /* Subroutine */ int xerbla_(char *, integer *); + char srname[32]; + + +/* -- LAPACK auxiliary routine (version 3.0) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ +/* September 19, 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK */ +/* and BLAS error handler. Rather than taking a Fortran string argument */ +/* as the function's name, XERBLA_ARRAY takes an array of single */ +/* characters along with the array's length. XERBLA_ARRAY then copies */ +/* up to 32 characters of that array into a Fortran string and passes */ +/* that to XERBLA. If called with a non-positive SRNAME_LEN, */ +/* XERBLA_ARRAY will call XERBLA with a string of all blank characters. */ + +/* Say some macro or other device makes XERBLA_ARRAY available to C99 */ +/* by a name lapack_xerbla and with a common Fortran calling convention. */ +/* Then a C99 program could invoke XERBLA via: */ +/* { */ +/* int flen = strlen(__func__); */ +/* lapack_xerbla(__func__, &flen, &info); */ +/* } */ + +/* Providing XERBLA_ARRAY is not necessary for intercepting LAPACK */ +/* errors. XERBLA_ARRAY calls XERBLA. */ + +/* Arguments */ +/* ========= */ + +/* SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN) */ +/* The name of the routine which called XERBLA_ARRAY. */ + +/* SRNAME_LEN (input) INTEGER */ +/* The length of the name in SRNAME_ARRAY. */ + +/* INFO (input) INTEGER */ +/* The position of the invalid parameter in the parameter list */ +/* of the calling routine. */ + +/* ===================================================================== */ + +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --srname_array__; + + /* Function Body */ + s_copy(srname, "", (ftnlen)32, (ftnlen)0); +/* Computing MIN */ + i__2 = *srname_len__, i__3 = i_len(srname, (ftnlen)32); + i__1 = min(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + *(unsigned char *)&srname[i__ - 1] = *(unsigned char *)& + srname_array__[i__]; + } + xerbla_(srname, info); + return 0; +} /* xerbla_array__ */ diff --git a/contrib/libs/cblas/zaxpy.c b/contrib/libs/cblas/zaxpy.c new file mode 100644 index 00000000000..1bbebbaaddd --- /dev/null +++ b/contrib/libs/cblas/zaxpy.c @@ -0,0 +1,99 @@ +/* zaxpy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx, + integer *incx, doublecomplex *zy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, ix, iy; + extern doublereal dcabs1_(doublecomplex *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* constant times a vector plus a vector. */ +/* jack dongarra, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ + /* Parameter adjustments */ + --zy; + --zx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (dcabs1_(za) == 0.) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + i__4 = ix; + z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * zx[ + i__4].i + za->i * zx[i__4].r; + z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * zx[ + i__4].i + za->i * zx[i__4].r; + z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; +/* L30: */ + } + return 0; +} /* zaxpy_ */ diff --git a/contrib/libs/cblas/zcopy.c b/contrib/libs/cblas/zcopy.c new file mode 100644 index 00000000000..5999a693b3a --- /dev/null +++ b/contrib/libs/cblas/zcopy.c @@ -0,0 +1,85 @@ +/* zcopy.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zcopy_(integer *n, doublecomplex *zx, integer *incx, + doublecomplex *zy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, ix, iy; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* copies a vector, x, to a vector, y. */ +/* jack dongarra, linpack, 4/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --zy; + --zx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = ix; + zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i; +/* L30: */ + } + return 0; +} /* zcopy_ */ diff --git a/contrib/libs/cblas/zdotc.c b/contrib/libs/cblas/zdotc.c new file mode 100644 index 00000000000..383b2c23ae9 --- /dev/null +++ b/contrib/libs/cblas/zdotc.c @@ -0,0 +1,105 @@ +/* zdotc.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Double Complex */ VOID zdotc_(doublecomplex * ret_val, integer *n, + doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, ix, iy; + doublecomplex ztemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZDOTC forms the dot product of a vector. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --zy; + --zx; + + /* Function Body */ + ztemp.r = 0., ztemp.i = 0.; + ret_val->r = 0., ret_val->i = 0.; + if (*n <= 0) { + return ; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d_cnjg(&z__3, &zx[ix]); + i__2 = iy; + z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = z__3.r * + zy[i__2].i + z__3.i * zy[i__2].r; + z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; + ztemp.r = z__1.r, ztemp.i = z__1.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val->r = ztemp.r, ret_val->i = ztemp.i; + return ; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d_cnjg(&z__3, &zx[i__]); + i__2 = i__; + z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = z__3.r * + zy[i__2].i + z__3.i * zy[i__2].r; + z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; + ztemp.r = z__1.r, ztemp.i = z__1.i; +/* L30: */ + } + ret_val->r = ztemp.r, ret_val->i = ztemp.i; + return ; +} /* zdotc_ */ diff --git a/contrib/libs/cblas/zdotu.c b/contrib/libs/cblas/zdotu.c new file mode 100644 index 00000000000..e32993aade3 --- /dev/null +++ b/contrib/libs/cblas/zdotu.c @@ -0,0 +1,100 @@ +/* zdotu.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Double Complex */ VOID zdotu_(doublecomplex * ret_val, integer *n, + doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, ix, iy; + doublecomplex ztemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZDOTU forms the dot product of two vectors. */ + +/* Further Details */ +/* =============== */ + +/* jack dongarra, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --zy; + --zx; + + /* Function Body */ + ztemp.r = 0., ztemp.i = 0.; + ret_val->r = 0., ret_val->i = 0.; + if (*n <= 0) { + return ; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + i__3 = iy; + z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i, z__2.i = + zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r; + z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; + ztemp.r = z__1.r, ztemp.i = z__1.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val->r = ztemp.r, ret_val->i = ztemp.i; + return ; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i, z__2.i = + zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r; + z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i; + ztemp.r = z__1.r, ztemp.i = z__1.i; +/* L30: */ + } + ret_val->r = ztemp.r, ret_val->i = ztemp.i; + return ; +} /* zdotu_ */ diff --git a/contrib/libs/cblas/zdrot.c b/contrib/libs/cblas/zdrot.c new file mode 100644 index 00000000000..81016873383 --- /dev/null +++ b/contrib/libs/cblas/zdrot.c @@ -0,0 +1,153 @@ +/* zdrot.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zdrot_(integer *n, doublecomplex *cx, integer *incx, + doublecomplex *cy, integer *incy, doublereal *c__, doublereal *s) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__, ix, iy; + doublecomplex ctemp; + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Applies a plane rotation, where the cos and sin (c and s) are real */ +/* and the vectors cx and cy are complex. */ +/* jack dongarra, linpack, 3/11/78. */ + +/* Arguments */ +/* ========== */ + +/* N (input) INTEGER */ +/* On entry, N specifies the order of the vectors cx and cy. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* CX (input) COMPLEX*16 array, dimension at least */ +/* ( 1 + ( N - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array CX must contain the n */ +/* element vector cx. On exit, CX is overwritten by the updated */ +/* vector cx. */ + +/* INCX (input) INTEGER */ +/* On entry, INCX specifies the increment for the elements of */ +/* CX. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* CY (input) COMPLEX*16 array, dimension at least */ +/* ( 1 + ( N - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array CY must contain the n */ +/* element vector cy. On exit, CY is overwritten by the updated */ +/* vector cy. */ + +/* INCY (input) INTEGER */ +/* On entry, INCY specifies the increment for the elements of */ +/* CY. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* C (input) DOUBLE PRECISION */ +/* On entry, C specifies the cosine, cos. */ +/* Unchanged on exit. */ + +/* S (input) DOUBLE PRECISION */ +/* On entry, S specifies the sine, sin. */ +/* Unchanged on exit. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i; + i__3 = iy; + z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = iy; + i__3 = iy; + z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i; + i__4 = ix; + z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + cy[i__2].r = z__1.r, cy[i__2].i = z__1.i; + i__2 = ix; + cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i; + i__3 = i__; + z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = i__; + i__3 = i__; + z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i; + i__4 = i__; + z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + cy[i__2].r = z__1.r, cy[i__2].i = z__1.i; + i__2 = i__; + cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; +/* L30: */ + } + return 0; +} /* zdrot_ */ diff --git a/contrib/libs/cblas/zdscal.c b/contrib/libs/cblas/zdscal.c new file mode 100644 index 00000000000..9cb703011f9 --- /dev/null +++ b/contrib/libs/cblas/zdscal.c @@ -0,0 +1,85 @@ +/* zdscal.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zdscal_(integer *n, doublereal *da, doublecomplex *zx, + integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, ix; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* scales a vector by a constant. */ +/* jack dongarra, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --zx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + z__2.r = *da, z__2.i = 0.; + i__3 = ix; + z__1.r = z__2.r * zx[i__3].r - z__2.i * zx[i__3].i, z__1.i = z__2.r * + zx[i__3].i + z__2.i * zx[i__3].r; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; + ix += *incx; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__2.r = *da, z__2.i = 0.; + i__3 = i__; + z__1.r = z__2.r * zx[i__3].r - z__2.i * zx[i__3].i, z__1.i = z__2.r * + zx[i__3].i + z__2.i * zx[i__3].r; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; +/* L30: */ + } + return 0; +} /* zdscal_ */ diff --git a/contrib/libs/cblas/zgbmv.c b/contrib/libs/cblas/zgbmv.c new file mode 100644 index 00000000000..22ae8dd4973 --- /dev/null +++ b/contrib/libs/cblas/zgbmv.c @@ -0,0 +1,478 @@ +/* zgbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zgbmv_(char *trans, integer *m, integer *n, integer *kl, + integer *ku, doublecomplex *alpha, doublecomplex *a, integer *lda, + doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex * + y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info; + doublecomplex temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZGBMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */ + +/* y := alpha*conjg( A' )*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* KL - INTEGER. */ +/* On entry, KL specifies the number of sub-diagonals of the */ +/* matrix A. KL must satisfy 0 .le. KL. */ +/* Unchanged on exit. */ + +/* KU - INTEGER. */ +/* On entry, KU specifies the number of super-diagonals of the */ +/* matrix A. KU must satisfy 0 .le. KU. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading ( kl + ku + 1 ) by n part of the */ +/* array A must contain the matrix of coefficients, supplied */ +/* column by column, with the leading diagonal of the matrix in */ +/* row ( ku + 1 ) of the array, the first super-diagonal */ +/* starting at position 2 in row ku, the first sub-diagonal */ +/* starting at position 1 in row ( ku + 2 ), and so on. */ +/* Elements in the array A that do not correspond to elements */ +/* in the band matrix (such as the top left ku by ku triangle) */ +/* are not referenced. */ +/* The following program segment will transfer a band matrix */ +/* from conventional full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* K = KU + 1 - J */ +/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */ +/* A( K + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( kl + ku + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0) { + info = 4; + } else if (*ku < 0) { + info = 5; + } else if (*lda < *kl + *ku + 1) { + info = 8; + } else if (*incx == 0) { + info = 10; + } else if (*incy == 0) { + info = 13; + } + if (info != 0) { + xerbla_("ZGBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == + 1. && beta->i == 0.)) { + return 0; + } + + noconj = lsame_(trans, "T"); + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the band part of A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1. || beta->i != 0.) { + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0. && alpha->i == 0.) { + return 0; + } + kup1 = *ku + 1; + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = z__1.r, temp.i = z__1.i; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = i__; + i__3 = i__; + i__5 = k + i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = jx; + if (x[i__4].r != 0. || x[i__4].i != 0.) { + i__4 = jx; + z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, + z__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4] + .r; + temp.r = z__1.r, temp.i = z__1.i; + iy = ky; + k = kup1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = iy; + i__2 = iy; + i__5 = k + i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + + z__2.i; + y[i__4].r = z__1.r, y[i__4].i = z__1.i; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + if (j > *ku) { + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + k = kup1 - j; + if (noconj) { +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + i__3 = k + i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + } else { +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = min(i__5,i__6); + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + d_cnjg(&z__3, &a[k + i__ + j * a_dim1]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[i__2] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + } + i__4 = jy; + i__2 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = + alpha->r * temp.i + alpha->i * temp.r; + z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; + y[i__4].r = z__1.r, y[i__4].i = z__1.i; + jy += *incy; +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + ix = kx; + k = kup1 - j; + if (noconj) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = min(i__5,i__6); + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = k + i__ + j * a_dim1; + i__2 = ix; + z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2] + .i, z__2.i = a[i__4].r * x[i__2].i + a[i__4] + .i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L120: */ + } + } else { +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = min(i__5,i__6); + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[k + i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L130: */ + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = + alpha->r * temp.i + alpha->i * temp.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jy += *incy; + if (j > *ku) { + kx += *incx; + } +/* L140: */ + } + } + } + + return 0; + +/* End of ZGBMV . */ + +} /* zgbmv_ */ diff --git a/contrib/libs/cblas/zgemm.c b/contrib/libs/cblas/zgemm.c new file mode 100644 index 00000000000..f43a6062d28 --- /dev/null +++ b/contrib/libs/cblas/zgemm.c @@ -0,0 +1,698 @@ +/* zgemm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zgemm_(char *transa, char *transb, integer *m, integer * + n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda, + doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex * + c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, l, info; + logical nota, notb; + doublecomplex temp; + logical conja, conjb; + integer ncola; + extern logical lsame_(char *, char *); + integer nrowa, nrowb; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZGEMM performs one of the matrix-matrix operations */ + +/* C := alpha*op( A )*op( B ) + beta*C, */ + +/* where op( X ) is one of */ + +/* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), */ + +/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */ +/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n', op( A ) = A. */ + +/* TRANSA = 'T' or 't', op( A ) = A'. */ + +/* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). */ + +/* Unchanged on exit. */ + +/* TRANSB - CHARACTER*1. */ +/* On entry, TRANSB specifies the form of op( B ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSB = 'N' or 'n', op( B ) = B. */ + +/* TRANSB = 'T' or 't', op( B ) = B'. */ + +/* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix */ +/* op( A ) and of the matrix C. M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix */ +/* op( B ) and the number of columns of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of columns of the matrix */ +/* op( A ) and the number of rows of the matrix op( B ). K must */ +/* be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANSA = 'N' or 'n', and is m otherwise. */ +/* Before entry with TRANSA = 'N' or 'n', the leading m by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by m part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */ +/* n when TRANSB = 'N' or 'n', and is k otherwise. */ +/* Before entry with TRANSB = 'N' or 'n', the leading k by n */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading n by k part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */ +/* LDB must be at least max( 1, k ), otherwise LDB must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n matrix */ +/* ( alpha*op( A )*op( B ) + beta*C ). */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NOTA and NOTB as true if A and B respectively are not */ +/* conjugated or transposed, set CONJA and CONJB as true if A and */ +/* B respectively are to be transposed but not conjugated and set */ +/* NROWA, NCOLA and NROWB as the number of rows and columns of A */ +/* and the number of rows of B respectively. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + nota = lsame_(transa, "N"); + notb = lsame_(transb, "N"); + conja = lsame_(transa, "C"); + conjb = lsame_(transb, "C"); + if (nota) { + nrowa = *m; + ncola = *k; + } else { + nrowa = *k; + ncola = *m; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + +/* Test the input parameters. */ + + info = 0; + if (! nota && ! conja && ! lsame_(transa, "T")) { + info = 1; + } else if (! notb && ! conjb && ! lsame_(transb, "T")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < max(1,nrowa)) { + info = 8; + } else if (*ldb < max(1,nrowb)) { + info = 10; + } else if (*ldc < max(1,*m)) { + info = 13; + } + if (info != 0) { + xerbla_("ZGEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && + (beta->r == 1. && beta->i == 0.)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (notb) { + if (nota) { + +/* Form C := alpha*A*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L50: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L60: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + i__3 = l + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L70: */ + } + } +/* L80: */ + } +/* L90: */ + } + } else if (conja) { + +/* Form C := alpha*conjg( A' )*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L110: */ + } +/* L120: */ + } + } else { + +/* Form C := alpha*A'*B + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L130: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L140: */ + } +/* L150: */ + } + } + } else if (nota) { + if (conjb) { + +/* Form C := alpha*A*conjg( B' ) + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L160: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L170: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, + z__1.i = alpha->r * z__2.i + alpha->i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L180: */ + } + } +/* L190: */ + } +/* L200: */ + } + } else { + +/* Form C := alpha*A*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L210: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L220: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + i__3 = j + l * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L230: */ + } + } +/* L240: */ + } +/* L250: */ + } + } + } else if (conja) { + if (conjb) { + +/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + d_cnjg(&z__4, &b[j + l * b_dim1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = + z__3.r * z__4.i + z__3.i * z__4.r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L260: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L270: */ + } +/* L280: */ + } + } else { + +/* Form C := alpha*conjg( A' )*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = j + l * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L290: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L300: */ + } +/* L310: */ + } + } + } else { + if (conjb) { + +/* Form C := alpha*A'*conjg( B' ) + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + d_cnjg(&z__3, &b[j + l * b_dim1]); + z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i, + z__2.i = a[i__4].r * z__3.i + a[i__4].i * + z__3.r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L320: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L330: */ + } +/* L340: */ + } + } else { + +/* Form C := alpha*A'*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = j + l * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L350: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L360: */ + } +/* L370: */ + } + } + } + + return 0; + +/* End of ZGEMM . */ + +} /* zgemm_ */ diff --git a/contrib/libs/cblas/zgemv.c b/contrib/libs/cblas/zgemv.c new file mode 100644 index 00000000000..54e83560c2b --- /dev/null +++ b/contrib/libs/cblas/zgemv.c @@ -0,0 +1,412 @@ +/* zgemv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + x, integer *incx, doublecomplex *beta, doublecomplex *y, integer * + incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp; + integer lenx, leny; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZGEMV performs one of the matrix-vector operations */ + +/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */ + +/* y := alpha*conjg( A' )*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are vectors and A is an */ +/* m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */ + +/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */ + +/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of DIMENSION at least */ +/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* and at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* Before entry with BETA non-zero, the incremented array Y */ +/* must contain the vector y. On exit, Y is overwritten by the */ +/* updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < max(1,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("ZGEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == + 1. && beta->i == 0.)) { + return 0; + } + + noconj = lsame_(trans, "T"); + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (lsame_(trans, "N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1. || beta->i != 0.) { + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0. && alpha->i == 0.) { + return 0; + } + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + temp.r = z__1.r, temp.i = z__1.i; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + iy += *incy; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = + alpha->r * temp.i + alpha->i * temp.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jy += *incy; +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + ix = kx; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ix; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4] + .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3] + .i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L120: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L130: */ + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = + alpha->r * temp.i + alpha->i * temp.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jy += *incy; +/* L140: */ + } + } + } + + return 0; + +/* End of ZGEMV . */ + +} /* zgemv_ */ diff --git a/contrib/libs/cblas/zgerc.c b/contrib/libs/cblas/zgerc.c new file mode 100644 index 00000000000..97929453e87 --- /dev/null +++ b/contrib/libs/cblas/zgerc.c @@ -0,0 +1,218 @@ +/* zgerc.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha, + doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, + doublecomplex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + doublecomplex temp; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZGERC performs the rank 1 operation */ + +/* A := alpha*x*conjg( y' ) + A, */ + +/* where alpha is a scalar, x is an m element vector, y is an n element */ +/* vector and A is an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the m */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. On exit, A is */ +/* overwritten by the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("ZGERC ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of ZGERC . */ + +} /* zgerc_ */ diff --git a/contrib/libs/cblas/zgeru.c b/contrib/libs/cblas/zgeru.c new file mode 100644 index 00000000000..f0b98c806ac --- /dev/null +++ b/contrib/libs/cblas/zgeru.c @@ -0,0 +1,215 @@ +/* zgeru.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zgeru_(integer *m, integer *n, doublecomplex *alpha, + doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, + doublecomplex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + doublecomplex temp; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZGERU performs the rank 1 operation */ + +/* A := alpha*x*y' + A, */ + +/* where alpha is a scalar, x is an m element vector, y is an n element */ +/* vector and A is an m by n matrix. */ + +/* Arguments */ +/* ========== */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix A. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( m - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the m */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry, the leading m by n part of the array A must */ +/* contain the matrix of coefficients. On exit, A is */ +/* overwritten by the updated matrix. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("ZGERU ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + i__2 = jy; + z__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, z__1.i = + alpha->r * y[i__2].i + alpha->i * y[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + i__2 = jy; + z__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, z__1.i = + alpha->r * y[i__2].i + alpha->i * y[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i = + x[i__5].r * temp.i + x[i__5].i * temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of ZGERU . */ + +} /* zgeru_ */ diff --git a/contrib/libs/cblas/zhbmv.c b/contrib/libs/cblas/zhbmv.c new file mode 100644 index 00000000000..01da70107f7 --- /dev/null +++ b/contrib/libs/cblas/zhbmv.c @@ -0,0 +1,483 @@ +/* zhbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex + *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer * + incx, doublecomplex *beta, doublecomplex *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, l, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHBMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n hermitian band matrix, with k super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the band matrix A is being supplied as */ +/* follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* being supplied. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* being supplied. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of super-diagonals of the */ +/* matrix A. K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the hermitian matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer the upper */ +/* triangular part of a hermitian band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the hermitian matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer the lower */ +/* triangular part of a hermitian band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set and are assumed to be zero. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the */ +/* vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of DIMENSION at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the */ +/* vector y. On exit, Y is overwritten by the updated vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*k < 0) { + info = 3; + } else if (*lda < *k + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("ZHBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && + beta->i == 0.)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array A */ +/* are accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1. || beta->i != 0.) { + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0. && alpha->i == 0.) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when upper triangle of A is stored. */ + + kplus1 = *k + 1; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = i__; + i__3 = i__; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__2.i = + z__3.r * x[i__2].i + z__3.i * x[i__2].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L50: */ + } + i__4 = j; + i__2 = j; + i__3 = kplus1 + j * a_dim1; + d__1 = a[i__3].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__4].r = z__1.r, y[i__4].i = z__1.i; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = jx; + z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i = + alpha->r * x[i__4].i + alpha->i * x[i__4].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + ix = kx; + iy = ky; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = iy; + i__2 = iy; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; + y[i__4].r = z__1.r, y[i__4].i = z__1.i; + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__4 = ix; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = + z__3.r * x[i__4].i + z__3.i * x[i__4].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__3 = jy; + i__4 = jy; + i__2 = kplus1 + j * a_dim1; + d__1 = a[i__2].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + jx += *incx; + jy += *incy; + if (j > *k) { + kx += *incx; + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y when lower triangle of A is stored. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = j; + z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = + alpha->r * x[i__3].i + alpha->i * x[i__3].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__3 = j; + i__4 = j; + i__2 = j * a_dim1 + 1; + d__1 = a[i__2].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__; + i__2 = i__; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; + y[i__4].r = z__1.r, y[i__4].i = z__1.i; + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__4 = i__; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = + z__3.r * x[i__4].i + z__3.i * x[i__4].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L90: */ + } + i__3 = j; + i__4 = j; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = jx; + z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i = + alpha->r * x[i__3].i + alpha->i * x[i__3].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__3 = jy; + i__4 = jy; + i__2 = j * a_dim1 + 1; + d__1 = a[i__2].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + l = 1 - j; + ix = jx; + iy = jy; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + ix += *incx; + iy += *incy; + i__4 = iy; + i__2 = iy; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i; + y[i__4].r = z__1.r, y[i__4].i = z__1.i; + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__4 = ix; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = + z__3.r * x[i__4].i + z__3.i * x[i__4].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L110: */ + } + i__3 = jy; + i__4 = jy; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of ZHBMV . */ + +} /* zhbmv_ */ diff --git a/contrib/libs/cblas/zhemm.c b/contrib/libs/cblas/zhemm.c new file mode 100644 index 00000000000..dc43c4f0c60 --- /dev/null +++ b/contrib/libs/cblas/zhemm.c @@ -0,0 +1,496 @@ +/* zhemm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zhemm_(char *side, char *uplo, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer * + ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHEMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is an hermitian matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the hermitian matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the hermitian matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* hermitian matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* hermitian matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix C. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix C. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the hermitian matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the hermitian matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the hermitian */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the hermitian matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the hermitian matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the hermitian */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n updated */ +/* matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,*m)) { + info = 9; + } else if (*ldc < max(1,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("ZHEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == + 1. && beta->i == 0.)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + j * c_dim1; + i__5 = k + j * c_dim1; + i__6 = k + i__ * a_dim1; + z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i, + z__2.i = temp1.r * a[i__6].i + temp1.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + i__4 = k + j * b_dim1; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + z__2.r = b[i__4].r * z__3.r - b[i__4].i * z__3.i, + z__2.i = b[i__4].r * z__3.i + b[i__4].i * + z__3.r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L50: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + i__ * a_dim1; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + i__5 = i__ + i__ * a_dim1; + d__1 = a[i__5].r; + z__4.r = d__1 * temp1.r, z__4.i = d__1 * temp1.i; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, + z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + j * c_dim1; + i__4 = k + j * c_dim1; + i__5 = k + i__ * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[ + i__5].r; + z__1.r = c__[i__4].r + z__2.r, z__1.i = c__[i__4].i + + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__3 = k + j * b_dim1; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + z__2.r = b[i__3].r * z__3.r - b[i__3].i * z__3.i, + z__2.i = b[i__3].r * z__3.i + b[i__3].i * + z__3.r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L80: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__2 = i__ + j * c_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + } else { + i__2 = i__ + j * c_dim1; + i__3 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3] + .i, z__3.i = beta->r * c__[i__3].i + beta->i * + c__[i__3].r; + i__4 = i__ + i__ * a_dim1; + d__1 = a[i__4].r; + z__4.r = d__1 * temp1.r, z__4.i = d__1 * temp1.i; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + d__1 = a[i__2].r; + z__1.r = d__1 * alpha->r, z__1.i = d__1 * alpha->i; + temp1.r = z__1.r, temp1.i = z__1.i; + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i, + z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4] + .r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__2.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + i__5 = i__ + j * b_dim1; + z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i, + z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5] + .r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + i__3 = k + j * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + } else { + d_cnjg(&z__2, &a[j + k * a_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + d_cnjg(&z__2, &a[j + k * a_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + } else { + i__3 = k + j * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of ZHEMM . */ + +} /* zhemm_ */ diff --git a/contrib/libs/cblas/zhemv.c b/contrib/libs/cblas/zhemv.c new file mode 100644 index 00000000000..646dc12c101 --- /dev/null +++ b/contrib/libs/cblas/zhemv.c @@ -0,0 +1,433 @@ +/* zhemv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zhemv_(char *uplo, integer *n, doublecomplex *alpha, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, + doublecomplex *beta, doublecomplex *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHEMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n hermitian matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of A is not referenced. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set and are assumed to be zero. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < max(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("ZHEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && + beta->i == 0.)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + +/* First form y := beta*y. */ + + if (beta->r != 1. || beta->i != 0.) { + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0. && alpha->i == 0.) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when A is stored in upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L50: */ + } + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } else { + +/* Form y when A is stored in lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L90: */ + } + i__2 = j; + i__3 = j; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L110: */ + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of ZHEMV . */ + +} /* zhemv_ */ diff --git a/contrib/libs/cblas/zher.c b/contrib/libs/cblas/zher.c new file mode 100644 index 00000000000..1aedcc6ded1 --- /dev/null +++ b/contrib/libs/cblas/zher.c @@ -0,0 +1,338 @@ +/* zher.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zher_(char *uplo, integer *n, doublereal *alpha, + doublecomplex *x, integer *incx, doublecomplex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHER performs the hermitian rank 1 operation */ + +/* A := alpha*x*conjg( x' ) + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n hermitian matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*lda < max(1,*n)) { + info = 7; + } + if (info != 0) { + xerbla_("ZHER ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in upper triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[j]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[jx]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; +/* L30: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + jx += *incx; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in lower triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[j]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L50: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[jx]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + + z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L70: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + jx += *incx; +/* L80: */ + } + } + } + + return 0; + +/* End of ZHER . */ + +} /* zher_ */ diff --git a/contrib/libs/cblas/zher2.c b/contrib/libs/cblas/zher2.c new file mode 100644 index 00000000000..27b31bce095 --- /dev/null +++ b/contrib/libs/cblas/zher2.c @@ -0,0 +1,447 @@ +/* zher2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zher2_(char *uplo, integer *n, doublecomplex *alpha, + doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, + doublecomplex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHER2 performs the hermitian rank 2 operation */ + +/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an n */ +/* by n hermitian matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1,*n)) { + info = 9; + } + if (info != 0) { + xerbla_("ZHER2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0. && alpha->i == 0.) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[j]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; + iy += *incy; +/* L30: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + jx += *incx; + jy += *incy; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[j]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L50: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L70: */ + } + } else { + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } + + return 0; + +/* End of ZHER2 . */ + +} /* zher2_ */ diff --git a/contrib/libs/cblas/zher2k.c b/contrib/libs/cblas/zher2k.c new file mode 100644 index 00000000000..efe4ed6d4f6 --- /dev/null +++ b/contrib/libs/cblas/zher2k.c @@ -0,0 +1,671 @@ +/* zher2k.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zher2k_(char *uplo, char *trans, integer *n, integer *k, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + b, integer *ldb, doublereal *beta, doublecomplex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, l, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHER2K performs one of the hermitian rank 2k operations */ + +/* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, */ + +/* or */ + +/* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, */ + +/* where alpha and beta are scalars with beta real, C is an n by n */ +/* hermitian matrix and A and B are n by k matrices in the first case */ +/* and k by n matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + */ +/* conjg( alpha )*B*conjg( A' ) + */ +/* beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + */ +/* conjg( alpha )*conjg( B' )*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'C' or 'c', K specifies the number of rows of the */ +/* matrices A and B. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. */ +/* Ed Anderson, Cray Research Inc. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,nrowa)) { + info = 9; + } else if (*ldc < max(1,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("ZHER2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && *beta == + 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; +/* L40: */ + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + */ +/* C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L90: */ + } + } else if (*beta != 1.) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L100: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != + 0. || b[i__4].i != 0.)) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, + z__1.i = alpha->r * z__2.i + alpha->i * + z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__3 = j + l * a_dim1; + z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__2.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, z__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] + .i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, z__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + + z__4.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L110: */ + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + z__2.i = a[i__5].r * temp1.i + a[i__5].i * + temp1.r; + i__6 = j + l * b_dim1; + z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + z__3.i = b[i__6].r * temp2.i + b[i__6].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L140: */ + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L150: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != + 0. || b[i__4].i != 0.)) { + d_cnjg(&z__2, &b[j + l * b_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, + z__1.i = alpha->r * z__2.i + alpha->i * + z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__3 = j + l * a_dim1; + z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__2.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, z__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] + .i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, z__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + + z__4.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L160: */ + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + z__2.i = a[i__5].r * temp1.i + a[i__5].i * + temp1.r; + i__6 = j + l * b_dim1; + z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + z__3.i = b[i__6].r * temp2.i + b[i__6].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + */ +/* C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + d_cnjg(&z__3, &b[l + i__ * b_dim1]); + i__4 = l + j * a_dim1; + z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, + z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] + .r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L190: */ + } + if (i__ == j) { + if (*beta == 0.) { + i__3 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = *beta * c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } else { + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = *beta * c__[i__4].r, z__3.i = *beta * + c__[i__4].i; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + + z__4.i; + d_cnjg(&z__6, alpha); + z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, + z__5.i = z__6.r * temp2.i + z__6.i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4] + .r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + d_cnjg(&z__3, &b[l + i__ * b_dim1]); + i__4 = l + j * a_dim1; + z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, + z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] + .r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L220: */ + } + if (i__ == j) { + if (*beta == 0.) { + i__3 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + d__1 = *beta * c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } else { + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + d_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = *beta * c__[i__4].r, z__3.i = *beta * + c__[i__4].i; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + + z__4.i; + d_cnjg(&z__6, alpha); + z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, + z__5.i = z__6.r * temp2.i + z__6.i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of ZHER2K. */ + +} /* zher2k_ */ diff --git a/contrib/libs/cblas/zherk.c b/contrib/libs/cblas/zherk.c new file mode 100644 index 00000000000..611ebb0921a --- /dev/null +++ b/contrib/libs/cblas/zherk.c @@ -0,0 +1,533 @@ +/* zherk.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zherk_(char *uplo, char *trans, integer *n, integer *k, + doublereal *alpha, doublecomplex *a, integer *lda, doublereal *beta, + doublecomplex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublereal d__1; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, l, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + integer nrowa; + doublereal rtemp; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHERK performs one of the hermitian rank k operations */ + +/* C := alpha*A*conjg( A' ) + beta*C, */ + +/* or */ + +/* C := alpha*conjg( A' )*A + beta*C, */ + +/* where alpha and beta are real scalars, C is an n by n hermitian */ +/* matrix and A is an n by k matrix in the first case and a k by n */ +/* matrix in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'C' or 'c', K specifies the number of rows of the */ +/* matrix A. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the hermitian matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the hermitian matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + +/* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. */ +/* Ed Anderson, Cray Research Inc. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldc < max(1,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("ZHERK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; +/* L40: */ + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*conjg( A' ) + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L90: */ + } + } else if (*beta != 1.) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L100: */ + } + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + d_cnjg(&z__2, &a[j + l * a_dim1]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L110: */ + } + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = i__ + l * a_dim1; + z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__1.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L140: */ + } + } else if (*beta != 1.) { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[ + i__4].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L150: */ + } + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + d_cnjg(&z__2, &a[j + l * a_dim1]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + i__5 = j + l * a_dim1; + z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__1.i = temp.r * a[i__5].i + temp.i * a[i__5] + .r; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*conjg( A' )*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * a_dim1; + z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, + z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L190: */ + } + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i; + i__4 = i__ + j * c_dim1; + z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L200: */ + } + rtemp = 0.; + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + d_cnjg(&z__3, &a[l + j * a_dim1]); + i__3 = l + j * a_dim1; + z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i = + z__3.r * a[i__3].i + z__3.i * a[i__3].r; + z__1.r = rtemp + z__2.r, z__1.i = z__2.i; + rtemp = z__1.r; +/* L210: */ + } + if (*beta == 0.) { + i__2 = j + j * c_dim1; + d__1 = *alpha * rtemp; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *alpha * rtemp + *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } +/* L220: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + rtemp = 0.; + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + d_cnjg(&z__3, &a[l + j * a_dim1]); + i__3 = l + j * a_dim1; + z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i = + z__3.r * a[i__3].i + z__3.i * a[i__3].r; + z__1.r = rtemp + z__2.r, z__1.i = z__2.i; + rtemp = z__1.r; +/* L230: */ + } + if (*beta == 0.) { + i__2 = j + j * c_dim1; + d__1 = *alpha * rtemp; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } else { + i__2 = j + j * c_dim1; + i__3 = j + j * c_dim1; + d__1 = *alpha * rtemp + *beta * c__[i__3].r; + c__[i__2].r = d__1, c__[i__2].i = 0.; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + d_cnjg(&z__3, &a[l + i__ * a_dim1]); + i__4 = l + j * a_dim1; + z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i, + z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4] + .r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L240: */ + } + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i; + i__4 = i__ + j * c_dim1; + z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L250: */ + } +/* L260: */ + } + } + } + + return 0; + +/* End of ZHERK . */ + +} /* zherk_ */ diff --git a/contrib/libs/cblas/zhpmv.c b/contrib/libs/cblas/zhpmv.c new file mode 100644 index 00000000000..c631c86d687 --- /dev/null +++ b/contrib/libs/cblas/zhpmv.c @@ -0,0 +1,434 @@ +/* zhpmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha, + doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex * + beta, doublecomplex *y, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHPMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n hermitian matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX*16 array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set and are assumed to be zero. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then Y need not be set on input. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. On exit, Y is overwritten by the updated */ +/* vector y. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --y; + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 6; + } else if (*incy == 0) { + info = 9; + } + if (info != 0) { + xerbla_("ZHPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && + beta->i == 0.)) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + +/* First form y := beta*y. */ + + if (beta->r != 1. || beta->i != 0.) { + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; +/* L20: */ + } + } + } else { + iy = ky; + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + y[i__2].r = 0., y[i__2].i = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = iy; + i__3 = iy; + z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i, + z__1.i = beta->r * y[i__3].i + beta->i * y[i__3] + .r; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + iy += *incy; +/* L40: */ + } + } + } + } + if (alpha->r == 0. && alpha->i == 0.) { + return 0; + } + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form y when AP contains the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + ++k; +/* L50: */ + } + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + d__1 = ap[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + kk += j; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = iy; + i__4 = iy; + i__5 = k; + z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + ix += *incx; + iy += *incy; +/* L70: */ + } + i__2 = jy; + i__3 = jy; + i__4 = kk + j - 1; + d__1 = ap[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i; + z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jx += *incx; + jy += *incy; + kk += j; +/* L80: */ + } + } + } else { + +/* Form y when AP contains the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = j; + i__3 = j; + i__4 = kk; + d__1 = ap[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + ++k; +/* L90: */ + } + i__2 = j; + i__3 = j; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + kk += *n - j + 1; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i = + alpha->r * x[i__2].i + alpha->i * x[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = jy; + i__3 = jy; + i__4 = kk; + d__1 = ap[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + i__3 = iy; + i__4 = iy; + i__5 = k; + z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i, + z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5] + .r; + z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i; + y[i__3].r = z__1.r, y[i__3].i = z__1.i; + d_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i = + z__3.r * x[i__3].i + z__3.i * x[i__3].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L110: */ + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i = + alpha->r * temp2.i + alpha->i * temp2.r; + z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + jx += *incx; + jy += *incy; + kk += *n - j + 1; +/* L120: */ + } + } + } + + return 0; + +/* End of ZHPMV . */ + +} /* zhpmv_ */ diff --git a/contrib/libs/cblas/zhpr.c b/contrib/libs/cblas/zhpr.c new file mode 100644 index 00000000000..a2c189bbff3 --- /dev/null +++ b/contrib/libs/cblas/zhpr.c @@ -0,0 +1,339 @@ +/* zhpr.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zhpr_(char *uplo, integer *n, doublereal *alpha, + doublecomplex *x, integer *incx, doublecomplex *ap) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHPR performs the hermitian rank 1 operation */ + +/* A := alpha*x*conjg( x' ) + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n hermitian matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX*16 array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } + if (info != 0) { + xerbla_("ZHPR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[j]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; +/* L10: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = j; + z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[jx]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ix += *incx; +/* L30: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = jx; + z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i = + x[i__4].r * temp.i + x[i__4].i * temp.r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[j]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = kk; + i__3 = kk; + i__4 = j; + z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; +/* L50: */ + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + d_cnjg(&z__2, &x[jx]); + z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = kk; + i__3 = kk; + i__4 = jx; + z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i = + temp.r * x[i__4].i + temp.i * x[i__4].r; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = k; + i__5 = ix; + z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, + z__2.i = x[i__5].r * temp.i + x[i__5].i * + temp.r; + z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L70: */ + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of ZHPR . */ + +} /* zhpr_ */ diff --git a/contrib/libs/cblas/zhpr2.c b/contrib/libs/cblas/zhpr2.c new file mode 100644 index 00000000000..e116ba7dc3a --- /dev/null +++ b/contrib/libs/cblas/zhpr2.c @@ -0,0 +1,448 @@ +/* zhpr2.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zhpr2_(char *uplo, integer *n, doublecomplex *alpha, + doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, + doublecomplex *ap) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZHPR2 performs the hermitian rank 2 operation */ + +/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an */ +/* n by n hermitian matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. */ +/* Unchanged on exit. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + +/* Y - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element vector y. */ +/* Unchanged on exit. */ + +/* INCY - INTEGER. */ +/* On entry, INCY specifies the increment for the elements of */ +/* Y. INCY must not be zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX*16 array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the hermitian matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ +/* Note that the imaginary parts of the diagonal elements need */ +/* not be set, they are assumed to be zero, and on exit they */ +/* are set to zero. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --y; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } + if (info != 0) { + xerbla_("ZHPR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || alpha->r == 0. && alpha->i == 0.) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[j]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i + + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; +/* L10: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i + + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ix += *incx; + iy += *incy; +/* L30: */ + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + jy += *incy; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[j]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = kk; + i__3 = kk; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + i__5 = i__; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i + + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; +/* L50: */ + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || + y[i__3].i != 0.)) { + d_cnjg(&z__2, &y[jy]); + z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i = + alpha->r * z__2.i + alpha->i * z__2.r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2] + .r; + d_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = kk; + i__3 = kk; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * + temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + i__3 = k; + i__4 = k; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * + temp1.r; + z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i + + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * + temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L70: */ + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + jy += *incy; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of ZHPR2 . */ + +} /* zhpr2_ */ diff --git a/contrib/libs/cblas/zrotg.c b/contrib/libs/cblas/zrotg.c new file mode 100644 index 00000000000..4f41c1afcd5 --- /dev/null +++ b/contrib/libs/cblas/zrotg.c @@ -0,0 +1,77 @@ +/* zrotg.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zrotg_(doublecomplex *ca, doublecomplex *cb, doublereal * + c__, doublecomplex *s) +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + double z_abs(doublecomplex *); + void z_div(doublecomplex *, doublecomplex *, doublecomplex *); + double sqrt(doublereal); + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + doublereal norm; + doublecomplex alpha; + doublereal scale; + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* determines a double complex Givens rotation. */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + if (z_abs(ca) != 0.) { + goto L10; + } + *c__ = 0.; + s->r = 1., s->i = 0.; + ca->r = cb->r, ca->i = cb->i; + goto L20; +L10: + scale = z_abs(ca) + z_abs(cb); + z__2.r = scale, z__2.i = 0.; + z_div(&z__1, ca, &z__2); +/* Computing 2nd power */ + d__1 = z_abs(&z__1); + z__4.r = scale, z__4.i = 0.; + z_div(&z__3, cb, &z__4); +/* Computing 2nd power */ + d__2 = z_abs(&z__3); + norm = scale * sqrt(d__1 * d__1 + d__2 * d__2); + d__1 = z_abs(ca); + z__1.r = ca->r / d__1, z__1.i = ca->i / d__1; + alpha.r = z__1.r, alpha.i = z__1.i; + *c__ = z_abs(ca) / norm; + d_cnjg(&z__3, cb); + z__2.r = alpha.r * z__3.r - alpha.i * z__3.i, z__2.i = alpha.r * z__3.i + + alpha.i * z__3.r; + z__1.r = z__2.r / norm, z__1.i = z__2.i / norm; + s->r = z__1.r, s->i = z__1.i; + z__1.r = norm * alpha.r, z__1.i = norm * alpha.i; + ca->r = z__1.r, ca->i = z__1.i; +L20: + return 0; +} /* zrotg_ */ diff --git a/contrib/libs/cblas/zscal.c b/contrib/libs/cblas/zscal.c new file mode 100644 index 00000000000..0975b43ddb0 --- /dev/null +++ b/contrib/libs/cblas/zscal.c @@ -0,0 +1,81 @@ +/* zscal.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zscal_(integer *n, doublecomplex *za, doublecomplex *zx, + integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__, ix; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* scales a vector by a constant. */ +/* jack dongarra, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --zx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + i__3 = ix; + z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * zx[ + i__3].i + za->i * zx[i__3].r; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; + ix += *incx; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * zx[ + i__3].i + za->i * zx[i__3].r; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; +/* L30: */ + } + return 0; +} /* zscal_ */ diff --git a/contrib/libs/cblas/zswap.c b/contrib/libs/cblas/zswap.c new file mode 100644 index 00000000000..0eaed352761 --- /dev/null +++ b/contrib/libs/cblas/zswap.c @@ -0,0 +1,93 @@ +/* zswap.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zswap_(integer *n, doublecomplex *zx, integer *incx, + doublecomplex *zy, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, ix, iy; + doublecomplex ztemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* interchanges two vectors. */ +/* jack dongarra, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --zy; + --zx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; + i__2 = ix; + i__3 = iy; + zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; + i__2 = iy; + zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; + i__2 = i__; + i__3 = i__; + zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; + i__2 = i__; + zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; +/* L30: */ + } + return 0; +} /* zswap_ */ diff --git a/contrib/libs/cblas/zsymm.c b/contrib/libs/cblas/zsymm.c new file mode 100644 index 00000000000..f6c7671c863 --- /dev/null +++ b/contrib/libs/cblas/zsymm.c @@ -0,0 +1,496 @@ +/* zsymm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zsymm_(char *side, char *uplo, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer * + ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + integer i__, j, k, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZSYMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is a symmetric matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the symmetric matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the symmetric matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of the matrix C. */ +/* M must be at least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of the matrix C. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), otherwise LDA must be at */ +/* least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. When BETA is */ +/* supplied as zero then C need not be set on input. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry, the leading m by n part of the array C must */ +/* contain the matrix C, except when beta is zero, in which */ +/* case C need not be set on entry. */ +/* On exit, the array C is overwritten by the m by n updated */ +/* matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,*m)) { + info = 9; + } else if (*ldc < max(1,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("ZSYMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == + 1. && beta->i == 0.)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__1.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + j * c_dim1; + i__5 = k + j * c_dim1; + i__6 = k + i__ * a_dim1; + z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i, + z__2.i = temp1.r * a[i__6].i + temp1.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; + i__4 = k + j * b_dim1; + i__5 = k + i__ * a_dim1; + z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] + .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4] + .i * a[i__5].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L50: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + i__ * a_dim1; + z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, + z__2.i = temp1.r * a[i__4].i + temp1.i * a[ + i__4].r; + z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + i__5 = i__ + i__ * a_dim1; + z__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__4.i = temp1.r * a[i__5].i + temp1.i * a[ + i__5].r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, + z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + temp2.r = 0., temp2.i = 0.; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + j * c_dim1; + i__4 = k + j * c_dim1; + i__5 = k + i__ * a_dim1; + z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, + z__2.i = temp1.r * a[i__5].i + temp1.i * a[ + i__5].r; + z__1.r = c__[i__4].r + z__2.r, z__1.i = c__[i__4].i + + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + i__3 = k + j * b_dim1; + i__4 = k + i__ * a_dim1; + z__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4] + .i, z__2.i = b[i__3].r * a[i__4].i + b[i__3] + .i * a[i__4].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L80: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__2 = i__ + j * c_dim1; + i__3 = i__ + i__ * a_dim1; + z__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, + z__2.i = temp1.r * a[i__3].i + temp1.i * a[ + i__3].r; + z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + } else { + i__2 = i__ + j * c_dim1; + i__3 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3] + .i, z__3.i = beta->r * c__[i__3].i + beta->i * + c__[i__3].r; + i__4 = i__ + i__ * a_dim1; + z__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, + z__4.i = temp1.r * a[i__4].i + temp1.i * a[ + i__4].r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, z__1.i = + alpha->r * a[i__2].i + alpha->i * a[i__2].r; + temp1.r = z__1.r, temp1.i = z__1.i; + if (beta->r == 0. && beta->i == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i, + z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4] + .r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, + z__2.i = beta->r * c__[i__4].i + beta->i * c__[ + i__4].r; + i__5 = i__ + j * b_dim1; + z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i, + z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5] + .r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + i__3 = k + j * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + } else { + i__3 = j + k * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + i__3 = j + k * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + } else { + i__3 = k + j * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] + .r; + temp1.r = z__1.r, temp1.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, + z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] + .r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of ZSYMM . */ + +} /* zsymm_ */ diff --git a/contrib/libs/cblas/zsyr2k.c b/contrib/libs/cblas/zsyr2k.c new file mode 100644 index 00000000000..79c76090b91 --- /dev/null +++ b/contrib/libs/cblas/zsyr2k.c @@ -0,0 +1,538 @@ +/* zsyr2k.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zsyr2k_(char *uplo, char *trans, integer *n, integer *k, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer * + ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + integer i__, j, l, info; + doublecomplex temp1, temp2; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZSYR2K performs one of the symmetric rank 2k operations */ + +/* C := alpha*A*B' + alpha*B*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*B + alpha*B'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A and B are n by k matrices in the first case and k by n */ +/* matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ +/* beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'T' or 't', K specifies the number of rows of the */ +/* matrices A and B. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n part of the array B must contain the */ +/* matrix B. */ +/* Unchanged on exit. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldb < max(1,nrowa)) { + info = 9; + } else if (*ldc < max(1,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("ZSYR2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && (beta->r + == 1. && beta->i == 0.)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + if (upper) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*B' + alpha*B*A' + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L90: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != + 0. || b[i__4].i != 0.)) { + i__3 = j + l * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__3 = j + l * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp2.r = z__1.r, temp2.i = z__1.i; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, z__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] + .i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, z__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + + z__4.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L140: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != + 0. || b[i__4].i != 0.)) { + i__3 = j + l * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp1.r = z__1.r, temp1.i = z__1.i; + i__3 = j + l * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp2.r = z__1.r, temp2.i = z__1.i; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__3.r = a[i__6].r * temp1.r - a[i__6].i * + temp1.i, z__3.i = a[i__6].r * temp1.i + a[ + i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5] + .i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * + temp2.i, z__4.i = b[i__7].r * temp2.i + b[ + i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + + z__4.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*B + alpha*B'*A + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + i__4 = l + i__ * b_dim1; + i__5 = l + j * a_dim1; + z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] + .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4] + .i * a[i__5].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L190: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5] + .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4] + .i * b[i__5].r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + i__4 = l + i__ * b_dim1; + i__5 = l + j * a_dim1; + z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5] + .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4] + .i * a[i__5].r; + z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; +/* L220: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__3.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__3.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * + temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + z__5.r = alpha->r * temp2.r - alpha->i * temp2.i, + z__5.i = alpha->r * temp2.i + alpha->i * + temp2.r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of ZSYR2K. */ + +} /* zsyr2k_ */ diff --git a/contrib/libs/cblas/zsyrk.c b/contrib/libs/cblas/zsyrk.c new file mode 100644 index 00000000000..c1a1c03d98f --- /dev/null +++ b/contrib/libs/cblas/zsyrk.c @@ -0,0 +1,457 @@ +/* zsyrk.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zsyrk_(char *uplo, char *trans, integer *n, integer *k, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * + beta, doublecomplex *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__, j, l, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZSYRK performs one of the symmetric rank k operations */ + +/* C := alpha*A*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A is an n by k matrix in the first case and a k by n matrix */ +/* in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'T' or 't', K specifies the number of rows of the */ +/* matrix A. K must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n part of the array A must contain the */ +/* matrix A. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - COMPLEX*16 . */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* LDC - INTEGER. */ +/* On entry, LDC specifies the first dimension of C as declared */ +/* in the calling (sub) program. LDC must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < max(1,nrowa)) { + info = 7; + } else if (*ldc < max(1,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("ZSYRK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && (beta->r + == 1. && beta->i == 0.)) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + if (upper) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (beta->r == 0. && beta->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*A' + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L90: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + i__3 = j + l * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + c__[i__3].r = 0., c__[i__3].i = 0.; +/* L140: */ + } + } else if (beta->r != 1. || beta->i != 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__1.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + i__3 = j + l * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__1.i = alpha->r * a[i__3].i + alpha->i * a[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * c_dim1; + i__6 = i__ + l * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, + z__2.i = temp.r * a[i__6].i + temp.i * a[ + i__6].r; + z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] + .i + z__2.i; + c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * a_dim1; + z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5] + .i, z__2.i = a[i__4].r * a[i__5].i + a[i__4] + .i * a[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L190: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * a_dim1; + z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5] + .i, z__2.i = a[i__4].r * a[i__5].i + a[i__4] + .i * a[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L220: */ + } + if (beta->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * + temp.r; + i__4 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] + .i, z__3.i = beta->r * c__[i__4].i + beta->i * + c__[i__4].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of ZSYRK . */ + +} /* zsyrk_ */ diff --git a/contrib/libs/cblas/ztbmv.c b/contrib/libs/cblas/ztbmv.c new file mode 100644 index 00000000000..2585383a7d5 --- /dev/null +++ b/contrib/libs/cblas/ztbmv.c @@ -0,0 +1,642 @@ +/* ztbmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer + *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTBMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("ZTBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = i__; + i__3 = i__; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L10: */ + } + if (nounit) { + i__4 = j; + i__2 = j; + i__3 = kplus1 + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, z__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__4].r = z__1.r, x[i__4].i = z__1.i; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = jx; + if (x[i__4].r != 0. || x[i__4].i != 0.) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = ix; + i__2 = ix; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__2].r + z__2.r, z__1.i = x[i__2].i + + z__2.i; + x[i__4].r = z__1.r, x[i__4].i = z__1.i; + ix += *incx; +/* L30: */ + } + if (nounit) { + i__3 = jx; + i__4 = jx; + i__2 = kplus1 + j * a_dim1; + z__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[ + i__2].i, z__1.i = x[i__4].r * a[i__2].i + + x[i__4].i * a[i__2].r; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { + i__1 = i__; + i__3 = i__; + i__2 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__2.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; +/* L50: */ + } + if (nounit) { + i__4 = j; + i__1 = j; + i__3 = j * a_dim1 + 1; + z__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[ + i__3].i, z__1.i = x[i__1].r * a[i__3].i + + x[i__1].i * a[i__3].r; + x[i__4].r = z__1.r, x[i__4].i = z__1.i; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__4 = jx; + if (x[i__4].r != 0. || x[i__4].i != 0.) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { + i__4 = ix; + i__1 = ix; + i__2 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__2.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + z__1.r = x[i__1].r + z__2.r, z__1.i = x[i__1].i + + z__2.i; + x[i__4].r = z__1.r, x[i__4].i = z__1.i; + ix -= *incx; +/* L70: */ + } + if (nounit) { + i__3 = jx; + i__4 = jx; + i__1 = j * a_dim1 + 1; + z__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[ + i__1].i, z__1.i = x[i__4].r * a[i__1].i + + x[i__4].i * a[i__1].r; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x or x := conjg( A' )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__3 = j; + temp.r = x[i__3].r, temp.i = x[i__3].i; + l = kplus1 - j; + if (noconj) { + if (nounit) { + i__3 = kplus1 + j * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + z__1.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + i__4 = l + i__ + j * a_dim1; + i__1 = i__; + z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ + i__1].i, z__2.i = a[i__4].r * x[i__1].i + + a[i__4].i * x[i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__4 = i__; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, + z__2.i = z__3.r * x[i__4].i + z__3.i * x[ + i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + } + i__3 = j; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L110: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__3 = jx; + temp.r = x[i__3].r, temp.i = x[i__3].i; + kx -= *incx; + ix = kx; + l = kplus1 - j; + if (noconj) { + if (nounit) { + i__3 = kplus1 + j * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + z__1.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + i__4 = l + i__ + j * a_dim1; + i__1 = ix; + z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[ + i__1].i, z__2.i = a[i__4].r * x[i__1].i + + a[i__4].i * x[i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L120: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__4 = ix; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, + z__2.i = z__3.r * x[i__4].i + z__3.i * x[ + i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L130: */ + } + } + i__3 = jx; + x[i__3].r = temp.r, x[i__3].i = temp.i; + jx -= *incx; +/* L140: */ + } + } + } else { + if (*incx == 1) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + i__4 = j; + temp.r = x[i__4].r, temp.i = x[i__4].i; + l = 1 - j; + if (noconj) { + if (nounit) { + i__4 = j * a_dim1 + 1; + z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__1.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + i__1 = l + i__ + j * a_dim1; + i__2 = i__; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, z__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L150: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j * a_dim1 + 1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L160: */ + } + } + i__4 = j; + x[i__4].r = temp.r, x[i__4].i = temp.i; +/* L170: */ + } + } else { + jx = kx; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + kx += *incx; + ix = kx; + l = 1 - j; + if (noconj) { + if (nounit) { + i__4 = j * a_dim1 + 1; + z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__1.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + i__1 = l + i__ + j * a_dim1; + i__2 = ix; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, z__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L180: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j * a_dim1 + 1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__1 = ix; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L190: */ + } + } + i__4 = jx; + x[i__4].r = temp.r, x[i__4].i = temp.i; + jx += *incx; +/* L200: */ + } + } + } + } + + return 0; + +/* End of ZTBMV . */ + +} /* ztbmv_ */ diff --git a/contrib/libs/cblas/ztbsv.c b/contrib/libs/cblas/ztbsv.c new file mode 100644 index 00000000000..c09ac40d414 --- /dev/null +++ b/contrib/libs/cblas/ztbsv.c @@ -0,0 +1,611 @@ +/* ztbsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztbsv_(char *uplo, char *trans, char *diag, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer + *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( + doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + integer kplus1; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTBSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */ +/* diagonals. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' conjg( A' )*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* ( k + 1 ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("ZTBSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed by sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + l = kplus1 - j; + if (nounit) { + i__1 = j; + z_div(&z__1, &x[j], &a[kplus1 + j * a_dim1]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i - + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L10: */ + } + } +/* L20: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + kx -= *incx; + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + ix = kx; + l = kplus1 - j; + if (nounit) { + i__1 = jx; + z_div(&z__1, &x[jx], &a[kplus1 + j * a_dim1]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + i__2 = ix; + i__3 = ix; + i__4 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i - + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + l = 1 - j; + if (nounit) { + i__2 = j; + z_div(&z__1, &x[j], &a[j * a_dim1 + 1]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + kx += *incx; + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + ix = kx; + l = 1 - j; + if (nounit) { + i__2 = jx; + z_div(&z__1, &x[jx], &a[j * a_dim1 + 1]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = ix; + i__4 = ix; + i__5 = l + i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x or x := inv( conjg( A') )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + l = kplus1 - j; + if (noconj) { +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = l + i__ + j * a_dim1; + i__3 = i__; + z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[ + i__3].i, z__2.i = a[i__2].r * x[i__3].i + + a[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[kplus1 + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__4 = i__; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, + z__2.i = z__3.r * x[i__4].i + z__3.i * x[ + i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + if (nounit) { + d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__3 = j; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L110: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = jx; + temp.r = x[i__3].r, temp.i = x[i__3].i; + ix = kx; + l = kplus1 - j; + if (noconj) { +/* Computing MAX */ + i__3 = 1, i__4 = j - *k; + i__2 = j - 1; + for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { + i__3 = l + i__ + j * a_dim1; + i__4 = ix; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L120: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[kplus1 + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L130: */ + } + if (nounit) { + d_cnjg(&z__2, &a[kplus1 + j * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__4 = jx; + x[i__4].r = temp.r, x[i__4].i = temp.i; + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L140: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + l = 1 - j; + if (noconj) { +/* Computing MIN */ + i__1 = *n, i__4 = j + *k; + i__2 = j + 1; + for (i__ = min(i__1,i__4); i__ >= i__2; --i__) { + i__1 = l + i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__1].r * x[i__4].r - a[i__1].i * x[ + i__4].i, z__2.i = a[i__1].r * x[i__4].i + + a[i__1].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L150: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[j * a_dim1 + 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { +/* Computing MIN */ + i__2 = *n, i__1 = j + *k; + i__4 = j + 1; + for (i__ = min(i__2,i__1); i__ >= i__4; --i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L160: */ + } + if (nounit) { + d_cnjg(&z__2, &a[j * a_dim1 + 1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__4 = j; + x[i__4].r = temp.r, x[i__4].i = temp.i; +/* L170: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__4 = jx; + temp.r = x[i__4].r, temp.i = x[i__4].i; + ix = kx; + l = 1 - j; + if (noconj) { +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__1 = j + 1; + for (i__ = min(i__4,i__2); i__ >= i__1; --i__) { + i__4 = l + i__ + j * a_dim1; + i__2 = ix; + z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[ + i__2].i, z__2.i = a[i__4].r * x[i__2].i + + a[i__4].i * x[i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L180: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[j * a_dim1 + 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { +/* Computing MIN */ + i__1 = *n, i__4 = j + *k; + i__2 = j + 1; + for (i__ = min(i__1,i__4); i__ >= i__2; --i__) { + d_cnjg(&z__3, &a[l + i__ + j * a_dim1]); + i__1 = ix; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L190: */ + } + if (nounit) { + d_cnjg(&z__2, &a[j * a_dim1 + 1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L200: */ + } + } + } + } + + return 0; + +/* End of ZTBSV . */ + +} /* ztbsv_ */ diff --git a/contrib/libs/cblas/ztpmv.c b/contrib/libs/cblas/ztpmv.c new file mode 100644 index 00000000000..3983febd600 --- /dev/null +++ b/contrib/libs/cblas/ztpmv.c @@ -0,0 +1,571 @@ +/* ztpmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztpmv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *ap, doublecomplex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTPMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX*16 array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("ZTPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x:= A*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ++k; +/* L10: */ + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ + i__4].i, z__1.i = x[i__3].r * ap[i__4].i + + x[i__3].i * ap[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = ix; + i__4 = ix; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; +/* L30: */ + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = kk + j - 1; + z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[ + i__4].i, z__1.i = x[i__3].r * ap[i__4].i + + x[i__3].i * ap[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, z__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + --k; +/* L50: */ + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = kk - *n + j; + z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ + i__3].i, z__1.i = x[i__2].r * ap[i__3].i + + x[i__2].i * ap[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + kk -= *n - j + 1; +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = ix; + i__3 = ix; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, z__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; +/* L70: */ + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = kk - *n + j; + z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[ + i__3].i, z__1.i = x[i__2].r * ap[i__3].i + + x[i__2].i * ap[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + jx -= *incx; + kk -= *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x or x := conjg( A' )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + if (noconj) { + if (nounit) { + i__1 = kk; + z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] + .i, z__1.i = temp.r * ap[i__1].i + temp.i + * ap[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = k; + i__2 = i__; + z__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[ + i__2].i, z__2.i = ap[i__1].r * x[i__2].i + + ap[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; +/* L90: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + d_cnjg(&z__3, &ap[k]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; +/* L100: */ + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= j; +/* L110: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = kk; + z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1] + .i, z__1.i = temp.r * ap[i__1].i + temp.i + * ap[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = k; + i__3 = ix; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, z__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L120: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + d_cnjg(&z__3, &ap[k]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L130: */ + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= j; +/* L140: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + if (noconj) { + if (nounit) { + i__2 = kk; + z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] + .i, z__1.i = temp.r * ap[i__2].i + temp.i + * ap[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; +/* L150: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; +/* L160: */ + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += *n - j + 1; +/* L170: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = kk; + z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2] + .i, z__1.i = temp.r * ap[i__2].i + temp.i + * ap[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = ix; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L180: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + d_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L190: */ + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += *n - j + 1; +/* L200: */ + } + } + } + } + + return 0; + +/* End of ZTPMV . */ + +} /* ztpmv_ */ diff --git a/contrib/libs/cblas/ztpsv.c b/contrib/libs/cblas/ztpsv.c new file mode 100644 index 00000000000..9e5b5850e03 --- /dev/null +++ b/contrib/libs/cblas/ztpsv.c @@ -0,0 +1,540 @@ +/* ztpsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztpsv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *ap, doublecomplex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( + doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTPSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix, supplied in packed form. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' conjg( A' )*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* AP - COMPLEX*16 array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("ZTPSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = j; + z_div(&z__1, &x[j], &ap[kk]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__; + i__2 = i__; + i__3 = k; + z__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3] + .i, z__2.i = temp.r * ap[i__3].i + temp.i + * ap[i__3].r; + z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i - + z__2.i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + --k; +/* L10: */ + } + } + kk -= j; +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = jx; + z_div(&z__1, &x[jx], &ap[kk]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = ix; + i__3 = ix; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4] + .i, z__2.i = temp.r * ap[i__4].i + temp.i + * ap[i__4].r; + z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i - + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L30: */ + } + } + jx -= *incx; + kk -= j; +/* L40: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + if (nounit) { + i__2 = j; + z_div(&z__1, &x[j], &ap[kk]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ++k; +/* L50: */ + } + } + kk += *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + if (nounit) { + i__2 = jx; + z_div(&z__1, &x[jx], &ap[kk]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = ix; + i__4 = ix; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5] + .i, z__2.i = temp.r * ap[i__5].i + temp.i + * ap[i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L70: */ + } + } + jx += *incx; + kk += *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; +/* L90: */ + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ++k; +/* L100: */ + } + if (nounit) { + d_cnjg(&z__2, &ap[kk + j - 1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += j; +/* L110: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + if (noconj) { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = ix; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[ + i__4].i, z__2.i = ap[i__3].r * x[i__4].i + + ap[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L120: */ + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + d_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L130: */ + } + if (nounit) { + d_cnjg(&z__2, &ap[kk + j - 1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += j; +/* L140: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = k; + i__3 = i__; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, z__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; +/* L150: */ + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk - *n + j]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + d_cnjg(&z__3, &ap[k]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + --k; +/* L160: */ + } + if (nounit) { + d_cnjg(&z__2, &ap[kk - *n + j]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= *n - j + 1; +/* L170: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + if (noconj) { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = k; + i__3 = ix; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[ + i__3].i, z__2.i = ap[i__2].r * x[i__3].i + + ap[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L180: */ + } + if (nounit) { + z_div(&z__1, &temp, &ap[kk - *n + j]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + d_cnjg(&z__3, &ap[k]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L190: */ + } + if (nounit) { + d_cnjg(&z__2, &ap[kk - *n + j]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= *n - j + 1; +/* L200: */ + } + } + } + } + + return 0; + +/* End of ZTPSV . */ + +} /* ztpsv_ */ diff --git a/contrib/libs/cblas/ztrmm.c b/contrib/libs/cblas/ztrmm.c new file mode 100644 index 00000000000..c2af1d560f5 --- /dev/null +++ b/contrib/libs/cblas/ztrmm.c @@ -0,0 +1,688 @@ +/* ztrmm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztrmm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, + integer *lda, doublecomplex *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, + i__6; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, info; + doublecomplex temp; + logical lside; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTRMM performs one of the matrix-matrix operations */ + +/* B := alpha*op( A )*B, or B := alpha*B*op( A ) */ + +/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) multiplies B from */ +/* the left or right as follows: */ + +/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */ + +/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the matrix B, and on exit is overwritten by the */ +/* transformed matrix. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + noconj = lsame_(transa, "T"); + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("ZTRMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*A*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + i__3 = k + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, z__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * a_dim1; + z__2.r = temp.r * a[i__6].r - temp.i * a[i__6] + .i, z__2.i = temp.r * a[i__6].i + + temp.i * a[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] + .i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L30: */ + } + if (nounit) { + i__3 = k + k * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3] + .i, z__1.i = temp.r * a[i__3].i + + temp.i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = k + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; + } +/* L40: */ + } +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + i__2 = k + j * b_dim1; + if (b[i__2].r != 0. || b[i__2].i != 0.) { + i__2 = k + j * b_dim1; + z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2] + .i, z__1.i = alpha->r * b[i__2].i + + alpha->i * b[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = k + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; + if (nounit) { + i__2 = k + j * b_dim1; + i__3 = k + j * b_dim1; + i__4 = k + k * a_dim1; + z__1.r = b[i__3].r * a[i__4].r - b[i__3].i * + a[i__4].i, z__1.i = b[i__3].r * a[ + i__4].i + b[i__3].i * a[i__4].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5] + .i, z__2.i = temp.r * a[i__5].i + + temp.i * a[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] + .i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L60: */ + } + } +/* L70: */ + } +/* L80: */ + } + } + } else { + +/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + temp.r = b[i__2].r, temp.i = b[i__2].i; + if (noconj) { + if (nounit) { + i__2 = i__ + i__ * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2] + .i, z__1.i = temp.r * a[i__2].i + + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * a_dim1; + i__4 = k + j * b_dim1; + z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * + b[i__4].i, z__2.i = a[i__3].r * b[ + i__4].i + a[i__3].i * b[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__3 = k + j * b_dim1; + z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3] + .i, z__2.i = z__3.r * b[i__3].i + + z__3.i * b[i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + } + i__2 = i__ + j * b_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L110: */ + } +/* L120: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + temp.r = b[i__3].r, temp.i = b[i__3].i; + if (noconj) { + if (nounit) { + i__3 = i__ + i__ * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3] + .i, z__1.i = temp.r * a[i__3].i + + temp.i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * + b[i__5].i, z__2.i = a[i__4].r * b[ + i__5].i + a[i__4].i * b[i__5].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L130: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__4 = k + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4] + .i, z__2.i = z__3.r * b[i__4].i + + z__3.i * b[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L140: */ + } + } + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * + temp.r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L150: */ + } +/* L160: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*A. */ + + if (upper) { + for (j = *n; j >= 1; --j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[i__1] + .r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[i__3] + .r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L170: */ + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k + j * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + i__2 = k + j * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2] + .i, z__1.i = alpha->r * a[i__2].i + + alpha->i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, z__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] + .i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L180: */ + } + } +/* L190: */ + } +/* L200: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2] + .r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[i__4] + .r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L210: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + i__3 = k + j * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + i__3 = k + j * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3] + .i, z__1.i = alpha->r * a[i__3].i + + alpha->i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, z__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] + .i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L220: */ + } + } +/* L230: */ + } +/* L240: */ + } + } + } else { + +/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */ + + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + k * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + if (noconj) { + i__3 = j + k * a_dim1; + z__1.r = alpha->r * a[i__3].r - alpha->i * a[ + i__3].i, z__1.i = alpha->r * a[i__3] + .i + alpha->i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[j + k * a_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * + z__2.i, z__1.i = alpha->r * z__2.i + + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, z__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5] + .i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L250: */ + } + } +/* L260: */ + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__2 = k + k * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[k + k * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + } + if (temp.r != 1. || temp.i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L270: */ + } + } +/* L280: */ + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + if (noconj) { + i__2 = j + k * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[ + i__2].i, z__1.i = alpha->r * a[i__2] + .i + alpha->i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[j + k * a_dim1]); + z__1.r = alpha->r * z__2.r - alpha->i * + z__2.i, z__1.i = alpha->r * z__2.i + + alpha->i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, z__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4] + .i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L290: */ + } + } +/* L300: */ + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__1 = k + k * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[k + k * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + } + if (temp.r != 1. || temp.i != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L310: */ + } + } +/* L320: */ + } + } + } + } + + return 0; + +/* End of ZTRMM . */ + +} /* ztrmm_ */ diff --git a/contrib/libs/cblas/ztrmv.c b/contrib/libs/cblas/ztrmv.c new file mode 100644 index 00000000000..a4d8d3ccfb9 --- /dev/null +++ b/contrib/libs/cblas/ztrmv.c @@ -0,0 +1,554 @@ +/* ztrmv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTRMV performs one of the matrix-vector operations */ + +/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */ + +/* where x is an n element vector and A is an n by n unit, or non-unit, */ +/* upper or lower triangular matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' x := A*x. */ + +/* TRANS = 'T' or 't' x := A'*x. */ + +/* TRANS = 'C' or 'c' x := conjg( A' )*x. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element vector x. On exit, X is overwritten with the */ +/* tranformed vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("ZTRMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L10: */ + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ + i__4].i, z__1.i = x[i__3].r * a[i__4].i + + x[i__3].i * a[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = ix; + i__4 = ix; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; +/* L30: */ + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = j + j * a_dim1; + z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[ + i__4].i, z__1.i = x[i__3].r * a[i__4].i + + x[i__3].i * a[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx += *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L50: */ + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = j + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, z__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = ix; + i__3 = ix; + i__4 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[ + i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; +/* L70: */ + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = j + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[ + i__3].i, z__1.i = x[i__2].r * a[i__3].i + + x[i__2].i * a[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + jx -= *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x or x := conjg( A' )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__ + j * a_dim1; + i__2 = i__; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, z__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; +/* L110: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[ + i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + i__1 = i__ + j * a_dim1; + i__2 = ix; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[ + i__2].i, z__2.i = a[i__1].r * x[i__2].i + + a[i__1].i * x[i__2].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L120: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__1 = ix; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[ + i__1].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L130: */ + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; +/* L140: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L150: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L160: */ + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; +/* L170: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = i__ + j * a_dim1; + i__4 = ix; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L180: */ + } + } else { + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * + z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r + z__2.r, z__1.i = temp.i + + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L190: */ + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; +/* L200: */ + } + } + } + } + + return 0; + +/* End of ZTRMV . */ + +} /* ztrmv_ */ diff --git a/contrib/libs/cblas/ztrsm.c b/contrib/libs/cblas/ztrsm.c new file mode 100644 index 00000000000..068744c20ab --- /dev/null +++ b/contrib/libs/cblas/ztrsm.c @@ -0,0 +1,699 @@ +/* ztrsm.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Table of constant values */ + +static doublecomplex c_b1 = {1.,0.}; + +/* Subroutine */ int ztrsm_(char *side, char *uplo, char *transa, char *diag, + integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, + integer *lda, doublecomplex *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, + i__6, i__7; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( + doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, k, info; + doublecomplex temp; + logical lside; + extern logical lsame_(char *, char *); + integer nrowa; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTRSM solves one of the matrix equations */ + +/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ + +/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* non-unit, upper or lower triangular matrix and op( A ) is one of */ + +/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */ + +/* The matrix X is overwritten on B. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) appears on the left */ +/* or right of X as follows: */ + +/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ + +/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix A is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANSA - CHARACTER*1. */ +/* On entry, TRANSA specifies the form of op( A ) to be used in */ +/* the matrix multiplication as follows: */ + +/* TRANSA = 'N' or 'n' op( A ) = A. */ + +/* TRANSA = 'T' or 't' op( A ) = A'. */ + +/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit triangular */ +/* as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - COMPLEX*16 . */ +/* On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* zero then A is not referenced and B need not be set before */ +/* entry. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m */ +/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */ +/* Before entry with UPLO = 'U' or 'u', the leading k by k */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading k by k */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When SIDE = 'L' or 'l' then */ +/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */ +/* then LDA must be at least max( 1, n ). */ +/* Unchanged on exit. */ + +/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the right-hand side matrix B, and on exit is */ +/* overwritten by the solution matrix X. */ + +/* LDB - INTEGER. */ +/* On entry, LDB specifies the first dimension of B as declared */ +/* in the calling (sub) program. LDB must be at least */ +/* max( 1, m ). */ +/* Unchanged on exit. */ + + +/* Level 3 Blas routine. */ + +/* -- Written on 8-February-1989. */ +/* Jack Dongarra, Argonne National Laboratory. */ +/* Iain Duff, AERE Harwell. */ +/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ +/* Sven Hammarling, Numerical Algorithms Group Ltd. */ + + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + noconj = lsame_(transa, "T"); + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1,nrowa)) { + info = 9; + } else if (*ldb < max(1,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("ZTRSM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (alpha->r == 0. && alpha->i == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*inv( A )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (alpha->r != 1. || alpha->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, z__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L30: */ + } + } + for (k = *m; k >= 1; --k) { + i__2 = k + j * b_dim1; + if (b[i__2].r != 0. || b[i__2].i != 0.) { + if (nounit) { + i__2 = k + j * b_dim1; + z_div(&z__1, &b[k + j * b_dim1], &a[k + k * + a_dim1]); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = k + j * b_dim1; + i__6 = i__ + k * a_dim1; + z__2.r = b[i__5].r * a[i__6].r - b[i__5].i * + a[i__6].i, z__2.i = b[i__5].r * a[ + i__6].i + b[i__5].i * a[i__6].r; + z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4] + .i - z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L40: */ + } + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (alpha->r != 1. || alpha->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, z__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L70: */ + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + if (nounit) { + i__3 = k + j * b_dim1; + z_div(&z__1, &b[k + j * b_dim1], &a[k + k * + a_dim1]); + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = k + j * b_dim1; + i__7 = i__ + k * a_dim1; + z__2.r = b[i__6].r * a[i__7].r - b[i__6].i * + a[i__7].i, z__2.i = b[i__6].r * a[ + i__7].i + b[i__6].i * a[i__7].r; + z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5] + .i - z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L80: */ + } + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form B := alpha*inv( A' )*B */ +/* or B := alpha*inv( conjg( A' ) )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, + z__1.i = alpha->r * b[i__3].i + alpha->i * b[ + i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + if (noconj) { + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * + b[i__5].i, z__2.i = a[i__4].r * b[ + i__5].i + a[i__4].i * b[i__5].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L110: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[i__ + i__ * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__4 = k + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4] + .i, z__2.i = z__3.r * b[i__4].i + + z__3.i * b[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L120: */ + } + if (nounit) { + d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__3 = i__ + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; +/* L130: */ + } +/* L140: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, + z__1.i = alpha->r * b[i__2].i + alpha->i * b[ + i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + if (noconj) { + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + i__3 = k + i__ * a_dim1; + i__4 = k + j * b_dim1; + z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * + b[i__4].i, z__2.i = a[i__3].r * b[ + i__4].i + a[i__3].i * b[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L150: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[i__ + i__ * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__3 = k + j * b_dim1; + z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3] + .i, z__2.i = z__3.r * b[i__3].i + + z__3.i * b[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L160: */ + } + if (nounit) { + d_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = i__ + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; +/* L170: */ + } +/* L180: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*inv( A ). */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (alpha->r != 1. || alpha->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, z__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L190: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = k + j * a_dim1; + i__7 = i__ + k * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * + b[i__7].i, z__2.i = a[i__6].r * b[ + i__7].i + a[i__6].i * b[i__7].r; + z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5] + .i - z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L200: */ + } + } +/* L210: */ + } + if (nounit) { + z_div(&z__1, &c_b1, &a[j + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L220: */ + } + } +/* L230: */ + } + } else { + for (j = *n; j >= 1; --j) { + if (alpha->r != 1. || alpha->i != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, z__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L240: */ + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + i__2 = k + j * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = k + j * a_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = a[i__5].r * b[i__6].r - a[i__5].i * + b[i__6].i, z__2.i = a[i__5].r * b[ + i__6].i + a[i__5].i * b[i__6].r; + z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4] + .i - z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L250: */ + } + } +/* L260: */ + } + if (nounit) { + z_div(&z__1, &c_b1, &a[j + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L270: */ + } + } +/* L280: */ + } + } + } else { + +/* Form B := alpha*B*inv( A' ) */ +/* or B := alpha*B*inv( conjg( A' ) ). */ + + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + if (noconj) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[k + k * a_dim1]); + z_div(&z__1, &c_b1, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[ + i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L290: */ + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + if (noconj) { + i__2 = j + k * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + } else { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5] + .i, z__2.i = temp.r * b[i__5].i + + temp.i * b[i__5].r; + z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4] + .i - z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L300: */ + } + } +/* L310: */ + } + if (alpha->r != 1. || alpha->i != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3] + .i, z__1.i = alpha->r * b[i__3].i + + alpha->i * b[i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L320: */ + } + } +/* L330: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + if (noconj) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_cnjg(&z__2, &a[k + k * a_dim1]); + z_div(&z__1, &c_b1, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[ + i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L340: */ + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + i__3 = j + k * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + if (noconj) { + i__3 = j + k * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + } else { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6] + .i, z__2.i = temp.r * b[i__6].i + + temp.i * b[i__6].r; + z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5] + .i - z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L350: */ + } + } +/* L360: */ + } + if (alpha->r != 1. || alpha->i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4] + .i, z__1.i = alpha->r * b[i__4].i + + alpha->i * b[i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L370: */ + } + } +/* L380: */ + } + } + } + } + + return 0; + +/* End of ZTRSM . */ + +} /* ztrsm_ */ diff --git a/contrib/libs/cblas/ztrsv.c b/contrib/libs/cblas/ztrsv.c new file mode 100644 index 00000000000..df3205f8a91 --- /dev/null +++ b/contrib/libs/cblas/ztrsv.c @@ -0,0 +1,524 @@ +/* ztrsv.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int ztrsv_(char *uplo, char *trans, char *diag, integer *n, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Builtin functions */ + void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( + doublecomplex *, doublecomplex *); + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical noconj, nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZTRSV solves one of the systems of equations */ + +/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */ + +/* where b and x are n element vectors and A is an n by n unit, or */ +/* non-unit, upper or lower triangular matrix. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the matrix is an upper or */ +/* lower triangular matrix as follows: */ + +/* UPLO = 'U' or 'u' A is an upper triangular matrix. */ + +/* UPLO = 'L' or 'l' A is a lower triangular matrix. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the equations to be solved as */ +/* follows: */ + +/* TRANS = 'N' or 'n' A*x = b. */ + +/* TRANS = 'T' or 't' A'*x = b. */ + +/* TRANS = 'C' or 'c' conjg( A' )*x = b. */ + +/* Unchanged on exit. */ + +/* DIAG - CHARACTER*1. */ +/* On entry, DIAG specifies whether or not A is unit */ +/* triangular as follows: */ + +/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */ + +/* DIAG = 'N' or 'n' A is not assumed to be unit */ +/* triangular. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular matrix and the strictly lower triangular part of */ +/* A is not referenced. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular matrix and the strictly upper triangular part of */ +/* A is not referenced. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced either, but are assumed to be unity. */ +/* Unchanged on exit. */ + +/* LDA - INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. LDA must be at least */ +/* max( 1, n ). */ +/* Unchanged on exit. */ + +/* X - COMPLEX*16 array of dimension at least */ +/* ( 1 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* element right-hand side vector b. On exit, X is overwritten */ +/* with the solution vector x. */ + +/* INCX - INTEGER. */ +/* On entry, INCX specifies the increment for the elements of */ +/* X. INCX must not be zero. */ +/* Unchanged on exit. */ + + +/* Level 2 Blas routine. */ + +/* -- Written on 22-October-1986. */ +/* Jack Dongarra, Argonne National Lab. */ +/* Jeremy Du Croz, Nag Central Office. */ +/* Sven Hammarling, Nag Central Office. */ +/* Richard Hanson, Sandia National Labs. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("ZTRSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + noconj = lsame_(trans, "T"); + nounit = lsame_(diag, "N"); + +/* Set up the start point in X if the increment is not unity. This */ +/* will be ( N - 1 )*INCX too small for descending loops. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = j; + z_div(&z__1, &x[j], &a[j + j * a_dim1]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__; + i__2 = i__; + i__3 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + z__2.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i - + z__2.i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = jx; + z_div(&z__1, &x[jx], &a[j + j * a_dim1]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + i__1 = ix; + i__2 = ix; + i__3 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + z__2.i = temp.r * a[i__3].i + temp.i * a[ + i__3].r; + z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i - + z__2.i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + if (nounit) { + i__2 = j; + z_div(&z__1, &x[j], &a[j + j * a_dim1]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + if (x[i__2].r != 0. || x[i__2].i != 0.) { + if (nounit) { + i__2 = jx; + z_div(&z__1, &x[jx], &a[j + j * a_dim1]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + i__3 = ix; + i__4 = ix; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[ + i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L90: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[j + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L100: */ + } + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; +/* L110: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ix = kx; + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = ix; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[ + i__4].i, z__2.i = a[i__3].r * x[i__4].i + + a[i__3].i * x[i__4].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L120: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[j + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[ + i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; +/* L130: */ + } + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; +/* L140: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__ + j * a_dim1; + i__3 = i__; + z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[ + i__3].i, z__2.i = a[i__2].r * x[i__3].i + + a[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L150: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[j + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; +/* L160: */ + } + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; +/* L170: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + ix = kx; + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__ + j * a_dim1; + i__3 = ix; + z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[ + i__3].i, z__2.i = a[i__2].r * x[i__3].i + + a[i__2].i * x[i__3].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L180: */ + } + if (nounit) { + z_div(&z__1, &temp, &a[j + j * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + d_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[ + i__2].r; + z__1.r = temp.r - z__2.r, z__1.i = temp.i - + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix -= *incx; +/* L190: */ + } + if (nounit) { + d_cnjg(&z__2, &a[j + j * a_dim1]); + z_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; +/* L200: */ + } + } + } + } + + return 0; + +/* End of ZTRSV . */ + +} /* ztrsv_ */ |