mirror of
https://github.com/opencv/opencv.git
synced 2024-11-24 11:10:21 +08:00
Merge pull request #18571 from vpisarev:add_lapack
Added clapack * bring a small subset of Lapack, automatically converted to C, into OpenCV * added missing lsame_ prototype * * small fix in make_clapack script * trying to fix remaining CI problems * fixed character arrays' initializers * get rid of F2C_STR_MAX * * added back single-precision versions for QR, LU and Cholesky decompositions. It adds very little extra overhead. * added stub version of sdesdd. * uncommented calls to all the single-precision Lapack functions from opencv/core/src/hal_internal.cpp. * fixed warning from Visual Studio + cleaned f2c runtime a bit * * regenerated Lapack w/o forward declarations of intrinsic functions (such as sqrt(), r_cnjg() etc.) * at once, trailing whitespaces are removed from the generated sources, just in case * since there is no declarations of intrinsic functions anymore, we could turn some of them into inline functions * trying to eliminate the crash on ARM * fixed API and semantics of s_copy * * CLapack has been tested successfully. It's now time to restore the standard LAPACK detection procedure * removed some more trailing whitespaces * * retained only the essential stuff in CLapack * added checks to lapack calls to gracefully return "not implemented" instead of returning invalid results with "ok" status * disabled warning when building lapack * cmake: update LAPACK detection Co-authored-by: Alexander Alekhin <alexander.a.alekhin@gmail.com>
This commit is contained in:
Vadim Pisarevsky
GitHub
parent
d0310c2a6a
commit
2ee9d21dae
48
3rdparty/clapack/CMakeLists.txt
vendored
Normal file
48
3rdparty/clapack/CMakeLists.txt
vendored
Normal file
@ -0,0 +1,48 @@
|
||||
# ----------------------------------------------------------------------------
|
||||
# CMake file for opencv_lapack. See root CMakeLists.txt
|
||||
#
|
||||
# ----------------------------------------------------------------------------
|
||||
project(clapack)
|
||||
|
||||
# TODO: extract it from sources somehow
|
||||
set(CLAPACK_VERSION "3.9.0" PARENT_SCOPE)
|
||||
|
||||
include_directories("${CMAKE_CURRENT_SOURCE_DIR}/include")
|
||||
|
||||
# The .cpp files:
|
||||
file(GLOB lapack_srcs src/*.c)
|
||||
file(GLOB runtime_srcs runtime/*.c)
|
||||
file(GLOB lib_hdrs include/*.h)
|
||||
|
||||
# ----------------------------------------------------------------------------------
|
||||
# Define the library target:
|
||||
# ----------------------------------------------------------------------------------
|
||||
|
||||
set(the_target "libclapack")
|
||||
|
||||
add_library(${the_target} STATIC ${lapack_srcs} ${runtime_srcs} ${lib_hdrs})
|
||||
|
||||
ocv_warnings_disable(CMAKE_C_FLAGS -Wno-parentheses -Wno-uninitialized -Wno-array-bounds
|
||||
-Wno-implicit-function-declaration -Wno-unused -Wunused-parameter) # gcc/clang warnings
|
||||
ocv_warnings_disable(CMAKE_C_FLAGS /wd4244 /wd4554 /wd4723) # visual studio warnings
|
||||
|
||||
set_target_properties(${the_target}
|
||||
PROPERTIES OUTPUT_NAME ${the_target}
|
||||
DEBUG_POSTFIX "${OPENCV_DEBUG_POSTFIX}"
|
||||
COMPILE_PDB_NAME ${the_target}
|
||||
COMPILE_PDB_NAME_DEBUG "${the_target}${OPENCV_DEBUG_POSTFIX}"
|
||||
ARCHIVE_OUTPUT_DIRECTORY ${3P_LIBRARY_OUTPUT_PATH}
|
||||
)
|
||||
|
||||
set(CLAPACK_INCLUDE_DIR "${CMAKE_CURRENT_SOURCE_DIR}/include" PARENT_SCOPE)
|
||||
set(CLAPACK_LIBRARIES ${the_target} PARENT_SCOPE)
|
||||
|
||||
if(ENABLE_SOLUTION_FOLDERS)
|
||||
set_target_properties(${the_target} PROPERTIES FOLDER "3rdparty")
|
||||
endif()
|
||||
|
||||
if(NOT BUILD_SHARED_LIBS)
|
||||
ocv_install_target(${the_target} EXPORT OpenCVModules ARCHIVE DESTINATION ${OPENCV_3P_LIB_INSTALL_PATH} COMPONENT dev)
|
||||
endif()
|
||||
|
||||
ocv_install_3rdparty_licenses(clapack lapack_LICENSE)
|
||||
102
3rdparty/clapack/include/cblas.h
vendored
Normal file
102
3rdparty/clapack/include/cblas.h
vendored
Normal file
@ -0,0 +1,102 @@
|
||||
#ifndef __CBLAS_H__
|
||||
#define __CBLAS_H__
|
||||
|
||||
/* most of the stuff is in lapacke.h */
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
typedef struct lapack_complex
|
||||
{
|
||||
float r, i;
|
||||
} lapack_complex;
|
||||
|
||||
typedef struct lapack_doublecomplex
|
||||
{
|
||||
double r, i;
|
||||
} lapack_doublecomplex;
|
||||
|
||||
typedef enum {CblasRowMajor=101, CblasColMajor=102} CBLAS_LAYOUT;
|
||||
typedef enum {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113} CBLAS_TRANSPOSE;
|
||||
|
||||
void cblas_xerbla(const CBLAS_LAYOUT layout, int info,
|
||||
const char *rout, const char *form, ...);
|
||||
|
||||
void cblas_sgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA,
|
||||
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_dgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA,
|
||||
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_cgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA,
|
||||
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_zgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA,
|
||||
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);
|
||||
|
||||
int xerbla_(char *, int *);
|
||||
int lsame_(char *, char *);
|
||||
double slamch_(char* cmach);
|
||||
double slamc3_(float *a, float *b);
|
||||
double dlamch_(char* cmach);
|
||||
double dlamc3_(double *a, double *b);
|
||||
|
||||
int dgels_(char *trans, int *m, int *n, int *nrhs, double *a,
|
||||
int *lda, double *b, int *ldb, double *work, int *lwork, int *info);
|
||||
|
||||
int dgesv_(int *n, int *nrhs, double *a, int *lda, int *ipiv,
|
||||
double *b, int *ldb, int *info);
|
||||
|
||||
int dgetrf_(int *m, int *n, double *a, int *lda, int *ipiv,
|
||||
int *info);
|
||||
|
||||
int dposv_(char *uplo, int *n, int *nrhs, double *a, int *
|
||||
lda, double *b, int *ldb, int *info);
|
||||
|
||||
int dpotrf_(char *uplo, int *n, double *a, int *lda, int *
|
||||
info);
|
||||
|
||||
int sgels_(char *trans, int *m, int *n, int *nrhs, float *a,
|
||||
int *lda, float *b, int *ldb, float *work, int *lwork, int *info);
|
||||
|
||||
int sgeev_(char *jobvl, char *jobvr, int *n, float *a, int *
|
||||
lda, float *wr, float *wi, float *vl, int *ldvl, float *vr, int *
|
||||
ldvr, float *work, int *lwork, int *info);
|
||||
|
||||
int sgeqrf_(int *m, int *n, float *a, int *lda, float *tau,
|
||||
float *work, int *lwork, int *info);
|
||||
|
||||
int sgesv_(int *n, int *nrhs, float *a, int *lda, int *ipiv,
|
||||
float *b, int *ldb, int *info);
|
||||
|
||||
int sgetrf_(int *m, int *n, float *a, int *lda, int *ipiv,
|
||||
int *info);
|
||||
|
||||
int sposv_(char *uplo, int *n, int *nrhs, float *a, int *
|
||||
lda, float *b, int *ldb, int *info);
|
||||
|
||||
int spotrf_(char *uplo, int *n, float *a, int *lda, int *
|
||||
info);
|
||||
|
||||
int sgesdd_(char *jobz, int *m, int *n, float *a, int *lda,
|
||||
float *s, float *u, int *ldu, float *vt, int *ldvt, float *work,
|
||||
int *lwork, int *iwork, int *info);
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif /* __CBLAS_H__ */
|
||||
129
3rdparty/clapack/include/f2c.h
vendored
Normal file
129
3rdparty/clapack/include/f2c.h
vendored
Normal file
@ -0,0 +1,129 @@
|
||||
/* f2c.h -- Standard Fortran to C header file */
|
||||
|
||||
/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
|
||||
|
||||
- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
|
||||
|
||||
#ifndef __F2C_H__
|
||||
#define __F2C_H__
|
||||
|
||||
#include <assert.h>
|
||||
#include <math.h>
|
||||
#include <ctype.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#include "cblas.h"
|
||||
#include "lapack.h"
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#undef complex
|
||||
|
||||
typedef int integer;
|
||||
typedef unsigned int uinteger;
|
||||
typedef char *address;
|
||||
typedef short int shortint;
|
||||
typedef float real;
|
||||
typedef double doublereal;
|
||||
typedef lapack_complex complex;
|
||||
typedef lapack_doublecomplex doublecomplex;
|
||||
typedef int logical;
|
||||
typedef short int shortlogical;
|
||||
typedef char logical1;
|
||||
typedef char integer1;
|
||||
|
||||
#define TRUE_ (1)
|
||||
#define FALSE_ (0)
|
||||
|
||||
#ifndef abs
|
||||
#define abs(x) ((x) >= 0 ? (x) : -(x))
|
||||
#endif
|
||||
#define dabs(x) (double)abs(x)
|
||||
#ifndef min
|
||||
#define min(a,b) ((a) <= (b) ? (a) : (b))
|
||||
#endif
|
||||
#ifndef max
|
||||
#define max(a,b) ((a) >= (b) ? (a) : (b))
|
||||
#endif
|
||||
#define dmin(a,b) (double)min(a,b)
|
||||
#define dmax(a,b) (double)max(a,b)
|
||||
#define bit_test(a,b) ((a) >> (b) & 1)
|
||||
#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
|
||||
#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
|
||||
|
||||
static __inline double r_lg10(float *x)
|
||||
{
|
||||
return 0.43429448190325182765*log(*x);
|
||||
}
|
||||
|
||||
static __inline double d_lg10(double *x)
|
||||
{
|
||||
return 0.43429448190325182765*log(*x);
|
||||
}
|
||||
|
||||
static __inline double d_sign(double *a, double *b)
|
||||
{
|
||||
double x = fabs(*a);
|
||||
return *b >= 0 ? x : -x;
|
||||
}
|
||||
|
||||
static __inline double r_sign(float *a, float *b)
|
||||
{
|
||||
double x = fabs((double)*a);
|
||||
return *b >= 0 ? x : -x;
|
||||
}
|
||||
|
||||
static __inline int i_nint(float *x)
|
||||
{
|
||||
return (int)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
|
||||
}
|
||||
|
||||
int pow_ii(int *ap, int *bp);
|
||||
double pow_di(double *ap, int *bp);
|
||||
static __inline double pow_ri(float *ap, int *bp)
|
||||
{
|
||||
double apd = *ap;
|
||||
return pow_di(&apd, bp);
|
||||
}
|
||||
static __inline double pow_dd(double *ap, double *bp)
|
||||
{
|
||||
return pow(*ap, *bp);
|
||||
}
|
||||
|
||||
static __inline void d_cnjg(doublecomplex *r, doublecomplex *z)
|
||||
{
|
||||
double zi = z->i;
|
||||
r->r = z->r;
|
||||
r->i = -zi;
|
||||
}
|
||||
|
||||
static __inline void r_cnjg(complex *r, complex *z)
|
||||
{
|
||||
float zi = z->i;
|
||||
r->r = z->r;
|
||||
r->i = -zi;
|
||||
}
|
||||
|
||||
static __inline int s_copy(char *a, char *b, int maxlen)
|
||||
{
|
||||
strncpy(a, b, maxlen);
|
||||
a[maxlen] = '\0';
|
||||
return 0;
|
||||
}
|
||||
|
||||
int s_cat(char *lp, char **rpp, int* rnp, int *np);
|
||||
int s_cmp(char *a0, char *b0);
|
||||
static __inline int i_len(char* s)
|
||||
{
|
||||
return (int)strlen(s);
|
||||
}
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif
|
||||
381
3rdparty/clapack/include/lapack.h
vendored
Normal file
381
3rdparty/clapack/include/lapack.h
vendored
Normal file
@ -0,0 +1,381 @@
|
||||
// this is auto-generated header for Lapack subset
|
||||
#ifndef __CLAPACK_H__
|
||||
#define __CLAPACK_H__
|
||||
|
||||
#include "cblas.h"
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
int cgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, lapack_complex *alpha, lapack_complex *a, int *lda, lapack_complex *b, int *ldb,
|
||||
lapack_complex *beta, lapack_complex *c__, int *ldc);
|
||||
|
||||
int daxpy_(int *n, double *da, double *dx, int *incx, double
|
||||
*dy, int *incy);
|
||||
|
||||
int dbdsdc_(char *uplo, char *compq, int *n, double *d__,
|
||||
double *e, double *u, int *ldu, double *vt, int *ldvt, double *q, int
|
||||
*iq, double *work, int *iwork, int *info);
|
||||
|
||||
int dbdsqr_(char *uplo, int *n, int *ncvt, int *nru, int *
|
||||
ncc, double *d__, double *e, double *vt, int *ldvt, double *u, int *
|
||||
ldu, double *c__, int *ldc, double *work, int *info);
|
||||
|
||||
int dcombssq_(double *v1, double *v2);
|
||||
|
||||
int dcopy_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy);
|
||||
|
||||
double ddot_(int *n, double *dx, int *incx, double *dy, int *incy);
|
||||
|
||||
int dgebak_(char *job, char *side, int *n, int *ilo, int *
|
||||
ihi, double *scale, int *m, double *v, int *ldv, int *info);
|
||||
|
||||
int dgebal_(char *job, int *n, double *a, int *lda, int *ilo,
|
||||
int *ihi, double *scale, int *info);
|
||||
|
||||
int dgebd2_(int *m, int *n, double *a, int *lda, double *d__,
|
||||
double *e, double *tauq, double *taup, double *work, int *info);
|
||||
|
||||
int dgebrd_(int *m, int *n, double *a, int *lda, double *d__,
|
||||
double *e, double *tauq, double *taup, double *work, int *lwork, int
|
||||
*info);
|
||||
|
||||
int dgeev_(char *jobvl, char *jobvr, int *n, double *a, int *
|
||||
lda, double *wr, double *wi, double *vl, int *ldvl, double *vr, int *
|
||||
ldvr, double *work, int *lwork, int *info);
|
||||
|
||||
int dgehd2_(int *n, int *ilo, int *ihi, double *a, int *lda,
|
||||
double *tau, double *work, int *info);
|
||||
|
||||
int dgehrd_(int *n, int *ilo, int *ihi, double *a, int *lda,
|
||||
double *tau, double *work, int *lwork, int *info);
|
||||
|
||||
int dgelq2_(int *m, int *n, double *a, int *lda, double *tau,
|
||||
double *work, int *info);
|
||||
|
||||
int dgelqf_(int *m, int *n, double *a, int *lda, double *tau,
|
||||
double *work, int *lwork, int *info);
|
||||
|
||||
int dgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, double *alpha, double *a, int *lda, double *b, int *ldb, double *
|
||||
beta, double *c__, int *ldc);
|
||||
|
||||
int dgemv_(char *trans, int *m, int *n, double *alpha,
|
||||
double *a, int *lda, double *x, int *incx, double *beta, double *y,
|
||||
int *incy);
|
||||
|
||||
int dgeqr2_(int *m, int *n, double *a, int *lda, double *tau,
|
||||
double *work, int *info);
|
||||
|
||||
int dgeqrf_(int *m, int *n, double *a, int *lda, double *tau,
|
||||
double *work, int *lwork, int *info);
|
||||
|
||||
int dger_(int *m, int *n, double *alpha, double *x, int *
|
||||
incx, double *y, int *incy, double *a, int *lda);
|
||||
|
||||
int dgesdd_(char *jobz, int *m, int *n, double *a, int *lda,
|
||||
double *s, double *u, int *ldu, double *vt, int *ldvt, double *work,
|
||||
int *lwork, int *iwork, int *info);
|
||||
|
||||
int dhseqr_(char *job, char *compz, int *n, int *ilo, int *
|
||||
ihi, double *h__, int *ldh, double *wr, double *wi, double *z__, int *
|
||||
ldz, double *work, int *lwork, int *info);
|
||||
|
||||
int disnan_(double *din);
|
||||
|
||||
int dlabad_(double *small, double *large);
|
||||
|
||||
int dlabrd_(int *m, int *n, int *nb, double *a, int *lda,
|
||||
double *d__, double *e, double *tauq, double *taup, double *x, int *
|
||||
ldx, double *y, int *ldy);
|
||||
|
||||
int dlacpy_(char *uplo, int *m, int *n, double *a, int *lda,
|
||||
double *b, int *ldb);
|
||||
|
||||
int dladiv1_(double *a, double *b, double *c__, double *d__,
|
||||
double *p, double *q);
|
||||
|
||||
double dladiv2_(double *a, double *b, double *c__, double *d__, double *r__,
|
||||
double *t);
|
||||
|
||||
int dladiv_(double *a, double *b, double *c__, double *d__,
|
||||
double *p, double *q);
|
||||
|
||||
int dlaed6_(int *kniter, int *orgati, double *rho, double *
|
||||
d__, double *z__, double *finit, double *tau, int *info);
|
||||
|
||||
int dlaexc_(int *wantq, int *n, double *t, int *ldt, double *
|
||||
q, int *ldq, int *j1, int *n1, int *n2, double *work, int *info);
|
||||
|
||||
int dlahqr_(int *wantt, int *wantz, int *n, int *ilo, int *
|
||||
ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int *
|
||||
ihiz, double *z__, int *ldz, int *info);
|
||||
|
||||
int dlahr2_(int *n, int *k, int *nb, double *a, int *lda,
|
||||
double *tau, double *t, int *ldt, double *y, int *ldy);
|
||||
|
||||
int dlaisnan_(double *din1, double *din2);
|
||||
|
||||
int dlaln2_(int *ltrans, int *na, int *nw, double *smin,
|
||||
double *ca, double *a, int *lda, double *d1, double *d2, double *b,
|
||||
int *ldb, double *wr, double *wi, double *x, int *ldx, double *scale,
|
||||
double *xnorm, int *info);
|
||||
|
||||
int dlamrg_(int *n1, int *n2, double *a, int *dtrd1, int *
|
||||
dtrd2, int *index);
|
||||
|
||||
double dlange_(char *norm, int *m, int *n, double *a, int *lda, double *work);
|
||||
|
||||
double dlanst_(char *norm, int *n, double *d__, double *e);
|
||||
|
||||
int dlanv2_(double *a, double *b, double *c__, double *d__,
|
||||
double *rt1r, double *rt1i, double *rt2r, double *rt2i, double *cs,
|
||||
double *sn);
|
||||
|
||||
double dlapy2_(double *x, double *y);
|
||||
|
||||
int dlaqr0_(int *wantt, int *wantz, int *n, int *ilo, int *
|
||||
ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int *
|
||||
ihiz, double *z__, int *ldz, double *work, int *lwork, int *info);
|
||||
|
||||
int dlaqr1_(int *n, double *h__, int *ldh, double *sr1,
|
||||
double *si1, double *sr2, double *si2, double *v);
|
||||
|
||||
int dlaqr2_(int *wantt, int *wantz, int *n, int *ktop, int *
|
||||
kbot, int *nw, double *h__, int *ldh, int *iloz, int *ihiz, double *
|
||||
z__, int *ldz, int *ns, int *nd, double *sr, double *si, double *v,
|
||||
int *ldv, int *nh, double *t, int *ldt, int *nv, double *wv, int *
|
||||
ldwv, double *work, int *lwork);
|
||||
|
||||
int dlaqr3_(int *wantt, int *wantz, int *n, int *ktop, int *
|
||||
kbot, int *nw, double *h__, int *ldh, int *iloz, int *ihiz, double *
|
||||
z__, int *ldz, int *ns, int *nd, double *sr, double *si, double *v,
|
||||
int *ldv, int *nh, double *t, int *ldt, int *nv, double *wv, int *
|
||||
ldwv, double *work, int *lwork);
|
||||
|
||||
int dlaqr4_(int *wantt, int *wantz, int *n, int *ilo, int *
|
||||
ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int *
|
||||
ihiz, double *z__, int *ldz, double *work, int *lwork, int *info);
|
||||
|
||||
int dlaqr5_(int *wantt, int *wantz, int *kacc22, int *n, int
|
||||
*ktop, int *kbot, int *nshfts, double *sr, double *si, double *h__,
|
||||
int *ldh, int *iloz, int *ihiz, double *z__, int *ldz, double *v, int
|
||||
*ldv, double *u, int *ldu, int *nv, double *wv, int *ldwv, int *nh,
|
||||
double *wh, int *ldwh);
|
||||
|
||||
int dlarf_(char *side, int *m, int *n, double *v, int *incv,
|
||||
double *tau, double *c__, int *ldc, double *work);
|
||||
|
||||
int dlarfb_(char *side, char *trans, char *direct, char *
|
||||
storev, int *m, int *n, int *k, double *v, int *ldv, double *t, int *
|
||||
ldt, double *c__, int *ldc, double *work, int *ldwork);
|
||||
|
||||
int dlarfg_(int *n, double *alpha, double *x, int *incx,
|
||||
double *tau);
|
||||
|
||||
int dlarft_(char *direct, char *storev, int *n, int *k,
|
||||
double *v, int *ldv, double *tau, double *t, int *ldt);
|
||||
|
||||
int dlarfx_(char *side, int *m, int *n, double *v, double *
|
||||
tau, double *c__, int *ldc, double *work);
|
||||
|
||||
int dlartg_(double *f, double *g, double *cs, double *sn,
|
||||
double *r__);
|
||||
|
||||
int dlas2_(double *f, double *g, double *h__, double *ssmin,
|
||||
double *ssmax);
|
||||
|
||||
int dlascl_(char *type__, int *kl, int *ku, double *cfrom,
|
||||
double *cto, int *m, int *n, double *a, int *lda, int *info);
|
||||
|
||||
int dlasd0_(int *n, int *sqre, double *d__, double *e,
|
||||
double *u, int *ldu, double *vt, int *ldvt, int *smlsiz, int *iwork,
|
||||
double *work, int *info);
|
||||
|
||||
int dlasd1_(int *nl, int *nr, int *sqre, double *d__, double
|
||||
*alpha, double *beta, double *u, int *ldu, double *vt, int *ldvt, int
|
||||
*idxq, int *iwork, double *work, int *info);
|
||||
|
||||
int dlasd2_(int *nl, int *nr, int *sqre, int *k, double *d__,
|
||||
double *z__, double *alpha, double *beta, double *u, int *ldu,
|
||||
double *vt, int *ldvt, double *dsigma, double *u2, int *ldu2, double *
|
||||
vt2, int *ldvt2, int *idxp, int *idx, int *idxc, int *idxq, int *
|
||||
coltyp, int *info);
|
||||
|
||||
int dlasd3_(int *nl, int *nr, int *sqre, int *k, double *d__,
|
||||
double *q, int *ldq, double *dsigma, double *u, int *ldu, double *u2,
|
||||
int *ldu2, double *vt, int *ldvt, double *vt2, int *ldvt2, int *idxc,
|
||||
int *ctot, double *z__, int *info);
|
||||
|
||||
int dlasd4_(int *n, int *i__, double *d__, double *z__,
|
||||
double *delta, double *rho, double *sigma, double *work, int *info);
|
||||
|
||||
int dlasd5_(int *i__, double *d__, double *z__, double *
|
||||
delta, double *rho, double *dsigma, double *work);
|
||||
|
||||
int dlasd6_(int *icompq, int *nl, int *nr, int *sqre, double
|
||||
*d__, double *vf, double *vl, double *alpha, double *beta, int *idxq,
|
||||
int *perm, int *givptr, int *givcol, int *ldgcol, double *givnum, int
|
||||
*ldgnum, double *poles, double *difl, double *difr, double *z__, int *
|
||||
k, double *c__, double *s, double *work, int *iwork, int *info);
|
||||
|
||||
int dlasd7_(int *icompq, int *nl, int *nr, int *sqre, int *k,
|
||||
double *d__, double *z__, double *zw, double *vf, double *vfw,
|
||||
double *vl, double *vlw, double *alpha, double *beta, double *dsigma,
|
||||
int *idx, int *idxp, int *idxq, int *perm, int *givptr, int *givcol,
|
||||
int *ldgcol, double *givnum, int *ldgnum, double *c__, double *s, int
|
||||
*info);
|
||||
|
||||
int dlasd8_(int *icompq, int *k, double *d__, double *z__,
|
||||
double *vf, double *vl, double *difl, double *difr, int *lddifr,
|
||||
double *dsigma, double *work, int *info);
|
||||
|
||||
int dlasda_(int *icompq, int *smlsiz, int *n, int *sqre,
|
||||
double *d__, double *e, double *u, int *ldu, double *vt, int *k,
|
||||
double *difl, double *difr, double *z__, double *poles, int *givptr,
|
||||
int *givcol, int *ldgcol, int *perm, double *givnum, double *c__,
|
||||
double *s, double *work, int *iwork, int *info);
|
||||
|
||||
int dlasdq_(char *uplo, int *sqre, int *n, int *ncvt, int *
|
||||
nru, int *ncc, double *d__, double *e, double *vt, int *ldvt, double *
|
||||
u, int *ldu, double *c__, int *ldc, double *work, int *info);
|
||||
|
||||
int dlasdt_(int *n, int *lvl, int *nd, int *inode, int *
|
||||
ndiml, int *ndimr, int *msub);
|
||||
|
||||
int dlaset_(char *uplo, int *m, int *n, double *alpha,
|
||||
double *beta, double *a, int *lda);
|
||||
|
||||
int dlasq1_(int *n, double *d__, double *e, double *work,
|
||||
int *info);
|
||||
|
||||
int dlasq2_(int *n, double *z__, int *info);
|
||||
|
||||
int dlasq3_(int *i0, int *n0, double *z__, int *pp, double *
|
||||
dmin__, double *sigma, double *desig, double *qmax, int *nfail, int *
|
||||
iter, int *ndiv, int *ieee, int *ttype, double *dmin1, double *dmin2,
|
||||
double *dn, double *dn1, double *dn2, double *g, double *tau);
|
||||
|
||||
int dlasq4_(int *i0, int *n0, double *z__, int *pp, int *
|
||||
n0in, double *dmin__, double *dmin1, double *dmin2, double *dn,
|
||||
double *dn1, double *dn2, double *tau, int *ttype, double *g);
|
||||
|
||||
int dlasq5_(int *i0, int *n0, double *z__, int *pp, double *
|
||||
tau, double *sigma, double *dmin__, double *dmin1, double *dmin2,
|
||||
double *dn, double *dnm1, double *dnm2, int *ieee, double *eps);
|
||||
|
||||
int dlasq6_(int *i0, int *n0, double *z__, int *pp, double *
|
||||
dmin__, double *dmin1, double *dmin2, double *dn, double *dnm1,
|
||||
double *dnm2);
|
||||
|
||||
int dlasr_(char *side, char *pivot, char *direct, int *m,
|
||||
int *n, double *c__, double *s, double *a, int *lda);
|
||||
|
||||
int dlasrt_(char *id, int *n, double *d__, int *info);
|
||||
|
||||
int dlassq_(int *n, double *x, int *incx, double *scale,
|
||||
double *sumsq);
|
||||
|
||||
int dlasv2_(double *f, double *g, double *h__, double *ssmin,
|
||||
double *ssmax, double *snr, double *csr, double *snl, double *csl);
|
||||
|
||||
int dlasy2_(int *ltranl, int *ltranr, int *isgn, int *n1,
|
||||
int *n2, double *tl, int *ldtl, double *tr, int *ldtr, double *b, int
|
||||
*ldb, double *scale, double *x, int *ldx, double *xnorm, int *info);
|
||||
|
||||
double dnrm2_(int *n, double *x, int *incx);
|
||||
|
||||
int dorg2r_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *info);
|
||||
|
||||
int dorgbr_(char *vect, int *m, int *n, int *k, double *a,
|
||||
int *lda, double *tau, double *work, int *lwork, int *info);
|
||||
|
||||
int dorghr_(int *n, int *ilo, int *ihi, double *a, int *lda,
|
||||
double *tau, double *work, int *lwork, int *info);
|
||||
|
||||
int dorgl2_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *info);
|
||||
|
||||
int dorglq_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *lwork, int *info);
|
||||
|
||||
int dorgqr_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *lwork, int *info);
|
||||
|
||||
int dorm2r_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *info);
|
||||
|
||||
int dormbr_(char *vect, char *side, char *trans, int *m, int
|
||||
*n, int *k, double *a, int *lda, double *tau, double *c__, int *ldc,
|
||||
double *work, int *lwork, int *info);
|
||||
|
||||
int dormhr_(char *side, char *trans, int *m, int *n, int *
|
||||
ilo, int *ihi, double *a, int *lda, double *tau, double *c__, int *
|
||||
ldc, double *work, int *lwork, int *info);
|
||||
|
||||
int dorml2_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *info);
|
||||
|
||||
int dormlq_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *lwork, int *info);
|
||||
|
||||
int dormqr_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *lwork, int *info);
|
||||
|
||||
int drot_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy, double *c__, double *s);
|
||||
|
||||
int dscal_(int *n, double *da, double *dx, int *incx);
|
||||
|
||||
int dswap_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy);
|
||||
|
||||
int dtrevc3_(char *side, char *howmny, int *select, int *n,
|
||||
double *t, int *ldt, double *vl, int *ldvl, double *vr, int *ldvr,
|
||||
int *mm, int *m, double *work, int *lwork, int *info);
|
||||
|
||||
int dtrexc_(char *compq, int *n, double *t, int *ldt, double
|
||||
*q, int *ldq, int *ifst, int *ilst, double *work, int *info);
|
||||
|
||||
int dtrmm_(char *side, char *uplo, char *transa, char *diag,
|
||||
int *m, int *n, double *alpha, double *a, int *lda, double *b, int *
|
||||
ldb);
|
||||
|
||||
int dtrmv_(char *uplo, char *trans, char *diag, int *n,
|
||||
double *a, int *lda, double *x, int *incx);
|
||||
|
||||
int idamax_(int *n, double *dx, int *incx);
|
||||
|
||||
int ieeeck_(int *ispec, float *zero, float *one);
|
||||
|
||||
int iladlc_(int *m, int *n, double *a, int *lda);
|
||||
|
||||
int iladlr_(int *m, int *n, double *a, int *lda);
|
||||
|
||||
int ilaenv_(int *ispec, char *name__, char *opts, int *n1, int *n2, int *n3,
|
||||
int *n4);
|
||||
|
||||
int iparmq_(int *ispec, char *name__, char *opts, int *n, int *ilo, int *ihi,
|
||||
int *lwork);
|
||||
|
||||
int sgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, float *alpha, float *a, int *lda, float *b, int *ldb, float *beta,
|
||||
float *c__, int *ldc);
|
||||
|
||||
int zgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, lapack_doublecomplex *alpha, lapack_doublecomplex *a, int *lda, lapack_doublecomplex *b,
|
||||
int *ldb, lapack_doublecomplex *beta, lapack_doublecomplex *c__, int *ldc);
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif
|
||||
48
3rdparty/clapack/lapack_LICENSE
vendored
Normal file
48
3rdparty/clapack/lapack_LICENSE
vendored
Normal file
@ -0,0 +1,48 @@
|
||||
Copyright (c) 1992-2017 The University of Tennessee and The University
|
||||
of Tennessee Research Foundation. All rights
|
||||
reserved.
|
||||
Copyright (c) 2000-2017 The University of California Berkeley. All
|
||||
rights reserved.
|
||||
Copyright (c) 2006-2017 The University of Colorado Denver. 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.
|
||||
|
||||
The copyright holders provide no reassurances that the source code
|
||||
provided does not infringe any patent, copyright, or any other
|
||||
intellectual property rights of third parties. The copyright holders
|
||||
disclaim any liability to any recipient for claims brought against
|
||||
recipient by any third party for infringement of that parties
|
||||
intellectual property rights.
|
||||
|
||||
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.
|
||||
272
3rdparty/clapack/make_clapack.py
vendored
Normal file
272
3rdparty/clapack/make_clapack.py
vendored
Normal file
@ -0,0 +1,272 @@
|
||||
appdoc = """
|
||||
This is generator of CLapack subset.
|
||||
The usage:
|
||||
|
||||
1. Make sure you have the special version of f2c installed.
|
||||
Grab it from https://github.com/vpisarev/f2c/tree/for_lapack.
|
||||
2. Download fresh version of Lapack from
|
||||
https://github.com/Reference-LAPACK/lapack.
|
||||
You may choose some specific version or the latest snapshot.
|
||||
3. If necessary, edit "roots" and "banlist" variables in this script, specify the needed and unneeded functions
|
||||
4. From within a working directory run
|
||||
|
||||
$ python3 <opencv_root>/3rdparty/clapack/make_clapack.py <lapack_root>
|
||||
or
|
||||
$ F2C=<path_to_custom_f2c> python3 <opencv_root>/3rdparty/clapack/make_clapack.py <lapack_root>
|
||||
|
||||
it will generate "new_clapack" directory with "include" and "src" subdirectories.
|
||||
5. erase opencv/3rdparty/clapack/src and replace it with new_clapack/src.
|
||||
6. copy new_clapack/include/lapack.h to opencv/3rdparty/clapack/include.
|
||||
7. optionally, edit opencv/3rdparty/clapack/CMakeLists.txt and update CLAPACK_VERSION as needed.
|
||||
|
||||
This is it. Now build it and enjoy.
|
||||
"""
|
||||
|
||||
import glob, re, os, shutil, subprocess, sys
|
||||
|
||||
roots = ["cgemm_", "dgemm_", "sgemm_", "zgemm_",
|
||||
"dgeev_", "dgesdd_",
|
||||
#"dsyevr_",
|
||||
#"dgesv_", "dgetrf_", "dposv_", "dpotrf_", "dgels_", "dgeqrf_",
|
||||
#"sgesv_", "sgetrf_", "sposv_", "spotrf_", "sgels_", "sgeqrf_"
|
||||
]
|
||||
banlist = ["slamch_", "slamc3_", "dlamch_", "dlamc3_", "lsame_", "xerbla_"]
|
||||
|
||||
if len(sys.argv) < 2:
|
||||
print(appdoc)
|
||||
sys.exit(0)
|
||||
|
||||
lapack_root = sys.argv[1]
|
||||
dst_path = "."
|
||||
|
||||
def error(msg):
|
||||
print ("error: " + msg)
|
||||
sys.exit(0)
|
||||
|
||||
def file2fun(fname):
|
||||
return (os.path.basename(fname)[:-2]).upper()
|
||||
|
||||
def print_graph(m):
|
||||
for (k, neighbors) in sorted(m.items()):
|
||||
print (k + " : " + ", ".join(sorted(list(neighbors))))
|
||||
|
||||
blas_path = os.path.join(lapack_root, "BLAS/SRC")
|
||||
lapack_path = os.path.join(lapack_root, "SRC")
|
||||
|
||||
roots = [f[:-1].upper() for f in roots]
|
||||
banlist = [f[:-1].upper() for f in banlist]
|
||||
|
||||
def fun2file(func):
|
||||
filename = func.lower() + ".f"
|
||||
blas_loc = blas_path + "/" + filename
|
||||
lapack_loc = lapack_path + "/" + filename
|
||||
if os.path.exists(blas_loc):
|
||||
return blas_loc
|
||||
elif os.path.exists(lapack_loc):
|
||||
return lapack_loc
|
||||
else:
|
||||
error("neither %s nor %s exist" % (blas_loc, lapack_loc))
|
||||
|
||||
all_files = glob.glob(blas_path + "/*.f") + glob.glob(lapack_path + "/*.f")
|
||||
all_funcs = [file2fun(fname) for fname in all_files]
|
||||
all_funcs_set = set(all_funcs).difference(set(banlist))
|
||||
all_funcs = sorted(list(all_funcs_set))
|
||||
|
||||
func_deps = {}
|
||||
|
||||
#print all_funcs
|
||||
|
||||
words_regexp = re.compile(r'\w+')
|
||||
|
||||
def scan_deps(func):
|
||||
global func_deps
|
||||
if func in func_deps:
|
||||
return
|
||||
func_deps[func] = set([]) # to avoid possibly infinite recursion
|
||||
f = open(fun2file(func), 'rt')
|
||||
deps = []
|
||||
external_mode = False
|
||||
for l in f.readlines():
|
||||
if l.startswith('*'):
|
||||
continue
|
||||
l = l.strip().upper()
|
||||
if l.startswith('EXTERNAL '):
|
||||
external_mode = True
|
||||
elif l.startswith('$') and external_mode:
|
||||
pass
|
||||
else:
|
||||
external_mode = False
|
||||
if not external_mode:
|
||||
continue
|
||||
for w in words_regexp.findall(l):
|
||||
if w in all_funcs_set:
|
||||
deps.append(w)
|
||||
f.close()
|
||||
# remove func from its dependencies
|
||||
deps = set(deps).difference(set([func]))
|
||||
func_deps[func] = deps
|
||||
for d in deps:
|
||||
scan_deps(d)
|
||||
|
||||
for r in roots:
|
||||
scan_deps(r)
|
||||
|
||||
selected_funcs = sorted(func_deps.keys())
|
||||
print ("total files before amalgamation: %d" % len(selected_funcs))
|
||||
|
||||
inv_deps = {}
|
||||
for func in selected_funcs:
|
||||
inv_deps[func] = set([])
|
||||
|
||||
for (func, deps) in func_deps.items():
|
||||
for d in deps:
|
||||
inv_deps[d] = inv_deps[d].union(set([func]))
|
||||
|
||||
#print_graph(inv_deps)
|
||||
|
||||
func_home = {}
|
||||
for func in selected_funcs:
|
||||
func_home[func] = func
|
||||
|
||||
def get_home0(func, func0):
|
||||
used_by = inv_deps[func]
|
||||
if len(used_by) == 1:
|
||||
p = list(used_by)[0]
|
||||
if p != func and p != func0:
|
||||
return get_home0(p, func0)
|
||||
return func
|
||||
return func
|
||||
|
||||
# try to merge some files
|
||||
for func in selected_funcs:
|
||||
func_home[func] = get_home0(func, func)
|
||||
|
||||
# try to merge some files even more
|
||||
for iters in range(100):
|
||||
homes_changed = False
|
||||
for (func, used_by) in inv_deps.items():
|
||||
p0 = func_home[func]
|
||||
n = len(used_by)
|
||||
if n == 1:
|
||||
p = list(used_by)[0]
|
||||
p1 = func_home[p]
|
||||
if p1 != p0:
|
||||
func_home[func] = p1
|
||||
homes_changed = True
|
||||
continue
|
||||
elif n > 1:
|
||||
phomes = set([])
|
||||
for p in used_by:
|
||||
phomes.add(func_home[p])
|
||||
if len(phomes) == 1:
|
||||
p1 = list(phomes)[0]
|
||||
if p1 != p0:
|
||||
func_home[func] = p1
|
||||
homes_changed = True
|
||||
if not homes_changed:
|
||||
break
|
||||
|
||||
res_files = {}
|
||||
for (func, h) in func_home.items():
|
||||
elems = res_files.get(h, set([]))
|
||||
elems.add(func)
|
||||
res_files[h] = elems
|
||||
|
||||
print ("total files after amalgamation: %d" % len(res_files))
|
||||
#print_graph(res_files)
|
||||
|
||||
outdir = os.path.join(dst_path, "new_clapack")
|
||||
outdir_src = os.path.join(outdir, "src")
|
||||
outdir_inc = os.path.join(outdir, "include")
|
||||
|
||||
shutil.rmtree(outdir, ignore_errors=True)
|
||||
try:
|
||||
os.makedirs(outdir_src)
|
||||
except os.error:
|
||||
pass
|
||||
try:
|
||||
os.makedirs(outdir_inc)
|
||||
except os.error:
|
||||
pass
|
||||
|
||||
f2c_appname = os.getenv("F2C", default="f2c")
|
||||
print ("f2c used: %s" % f2c_appname)
|
||||
|
||||
f2c_getver_cmd = f2c_appname + " -v"
|
||||
|
||||
verstr = subprocess.check_output(f2c_getver_cmd.split(' ')).decode("utf-8")
|
||||
if "for_lapack" not in verstr:
|
||||
error("invalid version of f2c\n" + appdoc)
|
||||
|
||||
f2c_flags = "-ctypes -localconst -no-proto"
|
||||
f2c_cmd0 = f2c_appname + " " + f2c_flags
|
||||
f2c_cmd1 = f2c_appname + " -hdr none " + f2c_flags
|
||||
|
||||
lapack_protos = {}
|
||||
extract_fn_regexp = re.compile(r'.+?(\w+)\s*\(')
|
||||
|
||||
def extract_proto(func, csrc):
|
||||
global lapack_protos
|
||||
cname = func.lower() + "_"
|
||||
cfname = func.lower() + ".c"
|
||||
regexp_str = r'\n(?:/\* Subroutine \*/\s*)?\w+\s+\w+\s*\((?:.|\n)+?\)[\s\n]*\{'
|
||||
proto_regexp = re.compile(regexp_str)
|
||||
ps = proto_regexp.findall(csrc)
|
||||
for p in ps:
|
||||
n = p.find("*/")
|
||||
if n < 0:
|
||||
n = 0
|
||||
else:
|
||||
n += 2
|
||||
p = p[n:-1].strip() + ";"
|
||||
fns = extract_fn_regexp.findall(p)
|
||||
if len(fns) != 1:
|
||||
error("prototype of function (%s) when analyzing %s cannot be parsed" % (p, cfname))
|
||||
fn = fns[0]
|
||||
if fn not in lapack_protos:
|
||||
p = re.sub(r'\bcomplex\b', 'lapack_complex', p)
|
||||
p = re.sub(r'\bdoublecomplex\b', 'lapack_doublecomplex', p)
|
||||
lapack_protos[fn] = p
|
||||
|
||||
for (filename, funcs) in sorted(res_files.items()):
|
||||
out = ""
|
||||
f2c_cmd = f2c_cmd0
|
||||
for func in sorted(list(funcs)):
|
||||
ffilename = fun2file(func)
|
||||
print ("running " + f2c_cmd + " on " + ffilename + " ...")
|
||||
ffile = open(ffilename, 'rt')
|
||||
delta_out = subprocess.check_output(f2c_cmd.split(' '), stdin=ffile).decode("utf-8")
|
||||
# remove trailing whitespaces
|
||||
delta_out = '\n'.join([l.rstrip() for l in delta_out.split('\n')])
|
||||
extract_proto(func, delta_out)
|
||||
out += delta_out
|
||||
ffile.close()
|
||||
f2c_cmd = f2c_cmd1
|
||||
outname = os.path.join(outdir_src, filename.lower() + ".c")
|
||||
outfile = open(outname, 'wt')
|
||||
outfile.write(out)
|
||||
outfile.close()
|
||||
|
||||
proto_hdr = """// this is auto-generated header for Lapack subset
|
||||
#ifndef __CLAPACK_H__
|
||||
#define __CLAPACK_H__
|
||||
|
||||
#include "cblas.h"
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
%s
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif
|
||||
""" % "\n\n".join([p for (n, p) in sorted(lapack_protos.items())])
|
||||
|
||||
proto_hdr_fname = os.path.join(outdir_inc, "lapack.h")
|
||||
f = open(proto_hdr_fname, 'wt')
|
||||
f.write(proto_hdr)
|
||||
f.close()
|
||||
289
3rdparty/clapack/runtime/cblas_wrap.c
vendored
Normal file
289
3rdparty/clapack/runtime/cblas_wrap.c
vendored
Normal file
@ -0,0 +1,289 @@
|
||||
#include "f2c.h"
|
||||
#include <stdarg.h>
|
||||
|
||||
void cblas_cgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA,
|
||||
const 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;
|
||||
|
||||
if( layout == CblasColMajor )
|
||||
{
|
||||
if(TransA == CblasTrans) TA='T';
|
||||
else if ( TransA == CblasConjTrans ) TA='C';
|
||||
else if ( TransA == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
|
||||
if(TransB == CblasTrans) TB='T';
|
||||
else if ( TransB == CblasConjTrans ) TB='C';
|
||||
else if ( TransB == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
cgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (complex*)alpha, (complex*)A, (int*)&lda,
|
||||
(complex*)B, (int*)&ldb, (complex*)beta, (complex*)C, (int*)&ldc);
|
||||
}
|
||||
else if (layout == CblasRowMajor)
|
||||
{
|
||||
if(TransA == CblasTrans) TB='T';
|
||||
else if ( TransA == CblasConjTrans ) TB='C';
|
||||
else if ( TransA == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
if(TransB == CblasTrans) TA='T';
|
||||
else if ( TransB == CblasConjTrans ) TA='C';
|
||||
else if ( TransB == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
cgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (complex*)alpha, (complex*)B, (int*)&ldb,
|
||||
(complex*)A, (int*)&lda, (complex*)beta, (complex*)C, (int*)&ldc);
|
||||
}
|
||||
else cblas_xerbla(layout, 1, "cblas_cgemm", "Illegal layout setting, %d\n", layout);
|
||||
}
|
||||
|
||||
void cblas_dgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA,
|
||||
const 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;
|
||||
|
||||
if( layout == CblasColMajor )
|
||||
{
|
||||
if(TransA == CblasTrans) TA='T';
|
||||
else if ( TransA == CblasConjTrans ) TA='C';
|
||||
else if ( TransA == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_dgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
|
||||
if(TransB == CblasTrans) TB='T';
|
||||
else if ( TransB == CblasConjTrans ) TB='C';
|
||||
else if ( TransB == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 3, "cblas_dgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
dgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (double*)&alpha, (double*)A, (int*)&lda,
|
||||
(double*)B, (int*)&ldb, (double*)&beta, (double*)C, (int*)&ldc);
|
||||
}
|
||||
else if (layout == CblasRowMajor)
|
||||
{
|
||||
if(TransA == CblasTrans) TB='T';
|
||||
else if ( TransA == CblasConjTrans ) TB='C';
|
||||
else if ( TransA == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_dgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
if(TransB == CblasTrans) TA='T';
|
||||
else if ( TransB == CblasConjTrans ) TA='C';
|
||||
else if ( TransB == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_dgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
dgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (double*)&alpha, (double*)B, (int*)&ldb,
|
||||
(double*)A, (int*)&lda, (double*)&beta, (double*)C, (int*)&ldc);
|
||||
}
|
||||
else cblas_xerbla(layout, 1, "cblas_dgemm", "Illegal layout setting, %d\n", layout);
|
||||
}
|
||||
|
||||
|
||||
void cblas_sgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA,
|
||||
const 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;
|
||||
|
||||
if( layout == CblasColMajor )
|
||||
{
|
||||
if(TransA == CblasTrans) TA='T';
|
||||
else if ( TransA == CblasConjTrans ) TA='C';
|
||||
else if ( TransA == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
|
||||
if(TransB == CblasTrans) TB='T';
|
||||
else if ( TransB == CblasConjTrans ) TB='C';
|
||||
else if ( TransB == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 3, "cblas_sgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
sgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (float*)&alpha, (float*)A, (int*)&lda,
|
||||
(float*)B, (int*)&ldb, (float*)&beta, (float*)C, (int*)&ldc);
|
||||
}
|
||||
else if (layout == CblasRowMajor)
|
||||
{
|
||||
if(TransA == CblasTrans) TB='T';
|
||||
else if ( TransA == CblasConjTrans ) TB='C';
|
||||
else if ( TransA == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_sgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
if(TransB == CblasTrans) TA='T';
|
||||
else if ( TransB == CblasConjTrans ) TA='C';
|
||||
else if ( TransB == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_sgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
sgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (float*)&alpha, (float*)B, (int*)&ldb,
|
||||
(float*)A, (int*)&lda, (float*)&beta, (float*)C, (int*)&ldc);
|
||||
}
|
||||
else cblas_xerbla(layout, 1, "cblas_sgemm", "Illegal layout setting, %d\n", layout);
|
||||
}
|
||||
|
||||
void cblas_zgemm(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE TransA,
|
||||
const 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;
|
||||
|
||||
if( layout == CblasColMajor )
|
||||
{
|
||||
if(TransA == CblasTrans) TA='T';
|
||||
else if ( TransA == CblasConjTrans ) TA='C';
|
||||
else if ( TransA == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_zgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
|
||||
if(TransB == CblasTrans) TB='T';
|
||||
else if ( TransB == CblasConjTrans ) TB='C';
|
||||
else if ( TransB == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 3, "cblas_zgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
zgemm_(&TA, &TB, (int*)&M, (int*)&N, (int*)&K, (doublecomplex*)alpha, (doublecomplex*)A, (int*)&lda,
|
||||
(doublecomplex*)B, (int*)&ldb, (doublecomplex*)beta, (doublecomplex*)C, (int*)&ldc);
|
||||
}
|
||||
else if (layout == CblasRowMajor)
|
||||
{
|
||||
if(TransA == CblasTrans) TB='T';
|
||||
else if ( TransA == CblasConjTrans ) TB='C';
|
||||
else if ( TransA == CblasNoTrans ) TB='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_zgemm", "Illegal TransA setting, %d\n", TransA);
|
||||
return;
|
||||
}
|
||||
if(TransB == CblasTrans) TA='T';
|
||||
else if ( TransB == CblasConjTrans ) TA='C';
|
||||
else if ( TransB == CblasNoTrans ) TA='N';
|
||||
else
|
||||
{
|
||||
cblas_xerbla(layout, 2, "cblas_zgemm", "Illegal TransB setting, %d\n", TransB);
|
||||
return;
|
||||
}
|
||||
|
||||
zgemm_(&TA, &TB, (int*)&N, (int*)&M, (int*)&K, (doublecomplex*)alpha, (doublecomplex*)B, (int*)&ldb,
|
||||
(doublecomplex*)A, (int*)&lda, (doublecomplex*)beta, (doublecomplex*)C, (int*)&ldc);
|
||||
}
|
||||
else cblas_xerbla(layout, 1, "cblas_zgemm", "Illegal layout setting, %d\n", layout);
|
||||
}
|
||||
|
||||
void cblas_xerbla(const CBLAS_LAYOUT layout, int info, const char *rout, const char *form, ...)
|
||||
{
|
||||
extern int RowMajorStrg;
|
||||
char empty[1] = "";
|
||||
va_list argptr;
|
||||
|
||||
va_start(argptr, form);
|
||||
|
||||
if (layout == CblasRowMajor)
|
||||
{
|
||||
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)
|
||||
xerbla_(empty, &info); /* Force link of our F77 error handler */
|
||||
exit(-1);
|
||||
}
|
||||
72
3rdparty/clapack/runtime/dlamch_custom.c
vendored
Normal file
72
3rdparty/clapack/runtime/dlamch_custom.c
vendored
Normal file
@ -0,0 +1,72 @@
|
||||
#include "f2c.h"
|
||||
#include <float.h>
|
||||
#include <stdio.h>
|
||||
|
||||
/* *********************************************************************** */
|
||||
|
||||
double dlamc3_(double *a, double *b)
|
||||
{
|
||||
/* -- LAPACK auxiliary routine (version 3.1) -- */
|
||||
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
|
||||
/* November 2006 */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* DLAMC3 is intended to force A and B to be stored prior to doing */
|
||||
/* the addition of A and B , for use in situations where optimizers */
|
||||
/* might hold one of these in a register. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
/* A (input) DOUBLE PRECISION */
|
||||
/* B (input) DOUBLE PRECISION */
|
||||
/* The values A and B. */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Executable Statements .. */
|
||||
|
||||
double ret_val = *a + *b;
|
||||
|
||||
return ret_val;
|
||||
|
||||
/* End of DLAMC3 */
|
||||
|
||||
} /* dlamc3_ */
|
||||
|
||||
|
||||
/* simpler version of dlamch for the case of IEEE754-compliant FPU module by Piotr Luszczek S.
|
||||
taken from http://www.mail-archive.com/numpy-discussion@lists.sourceforge.net/msg02448.html */
|
||||
|
||||
#ifndef DBL_DIGITS
|
||||
#define DBL_DIGITS 53
|
||||
#endif
|
||||
|
||||
static const unsigned char lapack_dlamch_tab0[] =
|
||||
{
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, 7, 0, 8, 9, 0, 10, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, 7, 0, 8, 9,
|
||||
0, 10, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
|
||||
};
|
||||
|
||||
const double lapack_dlamch_tab1[] =
|
||||
{
|
||||
0, FLT_RADIX, DBL_EPSILON, DBL_MAX_EXP, DBL_MIN_EXP, DBL_DIGITS, DBL_MAX,
|
||||
DBL_EPSILON*FLT_RADIX, 1, DBL_MIN*(1 + DBL_EPSILON), DBL_MIN
|
||||
};
|
||||
|
||||
double dlamch_(char* cmach)
|
||||
{
|
||||
return lapack_dlamch_tab1[lapack_dlamch_tab0[(unsigned char)cmach[0]]];
|
||||
}
|
||||
96
3rdparty/clapack/runtime/lapack_stubs.c
vendored
Normal file
96
3rdparty/clapack/runtime/lapack_stubs.c
vendored
Normal file
@ -0,0 +1,96 @@
|
||||
#include "f2c.h"
|
||||
|
||||
static const int CLAPACK_NOT_IMPLEMENTED = -1024;
|
||||
|
||||
int sgesdd_(char *jobz, int *m, int *n, float *a, int *lda,
|
||||
float *s, float *u, int *ldu, float *vt, int *ldvt, float *work,
|
||||
int *lwork, int *iwork, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int dgels_(char *trans, int *m, int *n, int *nrhs, double *a,
|
||||
int *lda, double *b, int *ldb, double *work, int *lwork, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int dgesv_(int *n, int *nrhs, double *a, int *lda, int *ipiv,
|
||||
double *b, int *ldb, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int dgetrf_(int *m, int *n, double *a, int *lda, int *ipiv,
|
||||
int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int dposv_(char *uplo, int *n, int *nrhs, double *a, int *
|
||||
lda, double *b, int *ldb, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int dpotrf_(char *uplo, int *n, double *a, int *lda, int *
|
||||
info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int sgels_(char *trans, int *m, int *n, int *nrhs, float *a,
|
||||
int *lda, float *b, int *ldb, float *work, int *lwork, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int sgeev_(char *jobvl, char *jobvr, int *n, float *a, int *
|
||||
lda, float *wr, float *wi, float *vl, int *ldvl, float *vr, int *
|
||||
ldvr, float *work, int *lwork, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int sgeqrf_(int *m, int *n, float *a, int *lda, float *tau,
|
||||
float *work, int *lwork, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int sgesv_(int *n, int *nrhs, float *a, int *lda, int *ipiv,
|
||||
float *b, int *ldb, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int sgetrf_(int *m, int *n, float *a, int *lda, int *ipiv,
|
||||
int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int sposv_(char *uplo, int *n, int *nrhs, float *a, int *
|
||||
lda, float *b, int *ldb, int *info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int spotrf_(char *uplo, int *n, float *a, int *lda, int *
|
||||
info)
|
||||
{
|
||||
*info = CLAPACK_NOT_IMPLEMENTED;
|
||||
return 0;
|
||||
}
|
||||
25
3rdparty/clapack/runtime/lsame_custom.c
vendored
Normal file
25
3rdparty/clapack/runtime/lsame_custom.c
vendored
Normal file
@ -0,0 +1,25 @@
|
||||
#include "f2c.h"
|
||||
|
||||
static const unsigned char lapack_toupper_tab[] =
|
||||
{
|
||||
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23,
|
||||
24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
|
||||
46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67,
|
||||
68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
|
||||
90, 91, 92, 93, 94, 95, 96, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
|
||||
80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 123, 124, 125, 126, 127, 128, 129, 130, 131,
|
||||
132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149,
|
||||
150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167,
|
||||
168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185,
|
||||
186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203,
|
||||
204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221,
|
||||
222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239,
|
||||
240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255
|
||||
};
|
||||
|
||||
#define lapack_toupper(c) ((char)lapack_toupper_tab[(unsigned char)(c)])
|
||||
|
||||
int lsame_(char *ca, char *cb)
|
||||
{
|
||||
return lapack_toupper(ca[0]) == lapack_toupper(cb[0]);
|
||||
}
|
||||
27
3rdparty/clapack/runtime/pow_di.c
vendored
Normal file
27
3rdparty/clapack/runtime/pow_di.c
vendored
Normal file
@ -0,0 +1,27 @@
|
||||
#include "f2c.h"
|
||||
|
||||
double pow_di(double *ap, int *bp)
|
||||
{
|
||||
double p = 1;
|
||||
double x = *ap;
|
||||
int n = *bp;
|
||||
|
||||
if(n != 0)
|
||||
{
|
||||
if(n < 0)
|
||||
{
|
||||
n = -n;
|
||||
x = 1/x;
|
||||
}
|
||||
unsigned u = (unsigned)n;
|
||||
for(;;)
|
||||
{
|
||||
if((u & 1) != 0)
|
||||
p *= x;
|
||||
if((u >>= 1) == 0)
|
||||
break;
|
||||
x *= x;
|
||||
}
|
||||
}
|
||||
return p;
|
||||
}
|
||||
25
3rdparty/clapack/runtime/pow_ii.c
vendored
Normal file
25
3rdparty/clapack/runtime/pow_ii.c
vendored
Normal file
@ -0,0 +1,25 @@
|
||||
#include "f2c.h"
|
||||
|
||||
int pow_ii(int *ap, int *bp)
|
||||
{
|
||||
int p;
|
||||
int x = *ap;
|
||||
int n = *bp;
|
||||
|
||||
if (n <= 0) {
|
||||
if (n == 0 || x == 1)
|
||||
return 1;
|
||||
return x != -1 ? 0 : (n & 1) ? -1 : 1;
|
||||
}
|
||||
unsigned u = (unsigned)n;
|
||||
for(p = 1; ; )
|
||||
{
|
||||
if(u & 01)
|
||||
p *= x;
|
||||
if(u >>= 1)
|
||||
x *= x;
|
||||
else
|
||||
break;
|
||||
}
|
||||
return p;
|
||||
}
|
||||
22
3rdparty/clapack/runtime/s_cat.c
vendored
Normal file
22
3rdparty/clapack/runtime/s_cat.c
vendored
Normal file
@ -0,0 +1,22 @@
|
||||
/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the
|
||||
* target of a concatenation to appear on its right-hand side (contrary
|
||||
* to the Fortran 77 Standard, but in accordance with Fortran 90).
|
||||
*/
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
int s_cat(char *lp, char **rpp, int* rnp, int *np)
|
||||
{
|
||||
int i, L = 0;
|
||||
int n = *np;
|
||||
|
||||
for(i = 0; i < n; i++) {
|
||||
int ni = rnp[i];
|
||||
if(ni > 0) {
|
||||
memcpy(lp + L, rpp[i], ni);
|
||||
L += ni;
|
||||
}
|
||||
}
|
||||
lp[L] = '\0';
|
||||
return 0;
|
||||
}
|
||||
40
3rdparty/clapack/runtime/s_cmp.c
vendored
Normal file
40
3rdparty/clapack/runtime/s_cmp.c
vendored
Normal file
@ -0,0 +1,40 @@
|
||||
#include "f2c.h"
|
||||
|
||||
/* compare two strings */
|
||||
int s_cmp(char *a0, char *b0)
|
||||
{
|
||||
int la = (int)strlen(a0);
|
||||
int lb = (int)strlen(b0);
|
||||
unsigned char *a, *aend, *b, *bend;
|
||||
a = (unsigned char *)a0;
|
||||
b = (unsigned char *)b0;
|
||||
aend = a + la;
|
||||
bend = b + lb;
|
||||
|
||||
if(la <= lb)
|
||||
{
|
||||
while(a < aend)
|
||||
if(*a != *b)
|
||||
return( *a - *b );
|
||||
else
|
||||
{ ++a; ++b; }
|
||||
|
||||
while(b < bend)
|
||||
if(*b != ' ')
|
||||
return( ' ' - *b );
|
||||
else ++b;
|
||||
}
|
||||
else
|
||||
{
|
||||
while(b < bend)
|
||||
if(*a == *b)
|
||||
{ ++a; ++b; }
|
||||
else
|
||||
return( *a - *b );
|
||||
while(a < aend)
|
||||
if(*a != ' ')
|
||||
return(*a - ' ');
|
||||
else ++a;
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
71
3rdparty/clapack/runtime/slamch_custom.c
vendored
Normal file
71
3rdparty/clapack/runtime/slamch_custom.c
vendored
Normal file
@ -0,0 +1,71 @@
|
||||
#include "f2c.h"
|
||||
#include <float.h>
|
||||
#include <stdio.h>
|
||||
|
||||
/* *********************************************************************** */
|
||||
|
||||
double slamc3_(float *a, float *b)
|
||||
{
|
||||
/* -- LAPACK auxiliary routine (version 3.1) -- */
|
||||
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
|
||||
/* November 2006 */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* Purpose */
|
||||
/* ======= */
|
||||
|
||||
/* SLAMC3 is intended to force A and B to be stored prior to doing */
|
||||
/* the addition of A and B , for use in situations where optimizers */
|
||||
/* might hold one of these in a register. */
|
||||
|
||||
/* Arguments */
|
||||
/* ========= */
|
||||
|
||||
/* A (input) REAL */
|
||||
/* B (input) REAL */
|
||||
/* The values A and B. */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Executable Statements .. */
|
||||
|
||||
float ret_val = *a + *b;
|
||||
|
||||
return ret_val;
|
||||
|
||||
/* End of SLAMC3 */
|
||||
|
||||
} /* slamc3_ */
|
||||
|
||||
/* simpler version of slamch for the case of IEEE754-compliant FPU module by Piotr Luszczek S.
|
||||
taken from http://www.mail-archive.com/numpy-discussion@lists.sourceforge.net/msg02448.html */
|
||||
|
||||
#ifndef FLT_DIGITS
|
||||
#define FLT_DIGITS 24
|
||||
#endif
|
||||
|
||||
static const unsigned char lapack_slamch_tab0[] =
|
||||
{
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, 7, 0, 8, 9, 0, 10, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 3, 4, 5, 6, 7, 0, 8, 9,
|
||||
0, 10, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
|
||||
};
|
||||
|
||||
const double lapack_slamch_tab1[] =
|
||||
{
|
||||
0, FLT_RADIX, FLT_EPSILON, FLT_MAX_EXP, FLT_MIN_EXP, FLT_DIGITS, FLT_MAX,
|
||||
FLT_EPSILON*FLT_RADIX, 1, FLT_MIN*(1 + FLT_EPSILON), FLT_MIN
|
||||
};
|
||||
|
||||
double slamch_(char* cmach)
|
||||
{
|
||||
return lapack_slamch_tab1[lapack_slamch_tab0[(unsigned char)cmach[0]]];
|
||||
}
|
||||
19
3rdparty/clapack/runtime/xerbla_custom.c
vendored
Normal file
19
3rdparty/clapack/runtime/xerbla_custom.c
vendored
Normal file
@ -0,0 +1,19 @@
|
||||
/* 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"
|
||||
|
||||
/* Subroutine */ int xerbla_(char *srname, int *info)
|
||||
{
|
||||
printf("** On entry to %s, parameter number %2i had an illegal value\n", srname, *info);
|
||||
return 0;
|
||||
} /* xerbla_ */
|
||||
752
3rdparty/clapack/src/cgemm.c
vendored
Normal file
752
3rdparty/clapack/src/cgemm.c
vendored
Normal file
@ -0,0 +1,752 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b CGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// COMPLEX ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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**T or op( X ) = X**H,
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] TRANSA
|
||||
//> \verbatim
|
||||
//> TRANSA is 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**T.
|
||||
//>
|
||||
//> TRANSA = 'C' or 'c', op( A ) = A**H.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANSB
|
||||
//> \verbatim
|
||||
//> TRANSB is 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**T.
|
||||
//>
|
||||
//> TRANSB = 'C' or 'c', op( B ) = B**H.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is COMPLEX
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is COMPLEX array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] B
|
||||
//> \verbatim
|
||||
//> B is COMPLEX array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] BETA
|
||||
//> \verbatim
|
||||
//> BETA is COMPLEX
|
||||
//> On entry, BETA specifies the scalar beta. When BETA is
|
||||
//> supplied as zero then C need not be set on input.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is COMPLEX array, 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is 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 ).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup complex_blas_level3
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int cgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, complex *alpha, complex *a, int *lda, complex *b, int *ldb,
|
||||
complex *beta, complex *c__, int *ldc)
|
||||
{
|
||||
// Table of constant values
|
||||
complex c_b1 = {1.f,0.f};
|
||||
complex c_b2 = {0.f,0.f};
|
||||
|
||||
// System generated locals
|
||||
int 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;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
complex temp;
|
||||
int conja, conjb;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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;
|
||||
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*A**H*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**T*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*B**H + 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) {
|
||||
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**T + 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;
|
||||
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*A**H*B**H + 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*A**H*B**T + 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**T*B**H + 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**T*B**T + 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_
|
||||
|
||||
171
3rdparty/clapack/src/dcopy.c
vendored
Normal file
171
3rdparty/clapack/src/dcopy.c
vendored
Normal file
@ -0,0 +1,171 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DCOPY
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,INCY,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*),DY(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DCOPY copies a vector, x, to a vector, y.
|
||||
//> uses unrolled loops for increments equal to 1.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DX
|
||||
//> \verbatim
|
||||
//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> storage spacing between elements of DX
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] DY
|
||||
//> \verbatim
|
||||
//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCY
|
||||
//> \verbatim
|
||||
//> INCY is INTEGER
|
||||
//> storage spacing between elements of DY
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup double_blas_level1
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> jack dongarra, linpack, 3/11/78.
|
||||
//> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dcopy_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, m, ix, iy, mp1;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// Parameter adjustments
|
||||
--dy;
|
||||
--dx;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
//
|
||||
// code for both increments equal to 1
|
||||
//
|
||||
//
|
||||
// clean-up loop
|
||||
//
|
||||
m = *n % 7;
|
||||
if (m != 0) {
|
||||
i__1 = m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dy[i__] = dx[i__];
|
||||
}
|
||||
if (*n < 7) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
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];
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// 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;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // dcopy_
|
||||
|
||||
172
3rdparty/clapack/src/ddot.c
vendored
Normal file
172
3rdparty/clapack/src/ddot.c
vendored
Normal file
@ -0,0 +1,172 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DDOT
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,INCY,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*),DY(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DDOT forms the dot product of two vectors.
|
||||
//> uses unrolled loops for increments equal to one.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DX
|
||||
//> \verbatim
|
||||
//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> storage spacing between elements of DX
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DY
|
||||
//> \verbatim
|
||||
//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCY
|
||||
//> \verbatim
|
||||
//> INCY is INTEGER
|
||||
//> storage spacing between elements of DY
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup double_blas_level1
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> jack dongarra, linpack, 3/11/78.
|
||||
//> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
double ddot_(int *n, double *dx, int *incx, double *dy, int *incy)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
double ret_val;
|
||||
|
||||
// Local variables
|
||||
int i__, m, ix, iy, mp1;
|
||||
double dtemp;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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) {
|
||||
//
|
||||
// code for both increments equal to 1
|
||||
//
|
||||
//
|
||||
// clean-up loop
|
||||
//
|
||||
m = *n % 5;
|
||||
if (m != 0) {
|
||||
i__1 = m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp += dx[i__] * dy[i__];
|
||||
}
|
||||
if (*n < 5) {
|
||||
ret_val = dtemp;
|
||||
return ret_val;
|
||||
}
|
||||
}
|
||||
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];
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// 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;
|
||||
}
|
||||
}
|
||||
ret_val = dtemp;
|
||||
return ret_val;
|
||||
} // ddot_
|
||||
|
||||
14369
3rdparty/clapack/src/dgeev.c
vendored
Normal file
14369
3rdparty/clapack/src/dgeev.c
vendored
Normal file
File diff suppressed because it is too large
Load Diff
444
3rdparty/clapack/src/dgemm.c
vendored
Normal file
444
3rdparty/clapack/src/dgemm.c
vendored
Normal file
@ -0,0 +1,444 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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**T,
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] TRANSA
|
||||
//> \verbatim
|
||||
//> TRANSA is 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**T.
|
||||
//>
|
||||
//> TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANSB
|
||||
//> \verbatim
|
||||
//> TRANSB is 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**T.
|
||||
//>
|
||||
//> TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is DOUBLE PRECISION.
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] B
|
||||
//> \verbatim
|
||||
//> B is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] BETA
|
||||
//> \verbatim
|
||||
//> BETA is DOUBLE PRECISION.
|
||||
//> On entry, BETA specifies the scalar beta. When BETA is
|
||||
//> supplied as zero then C need not be set on input.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION array, 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is 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 ).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup double_blas_level3
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, double *alpha, double *a, int *lda, double *b, int *ldb, double *
|
||||
beta, double *c__, int *ldc)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
|
||||
i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
double temp;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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) {
|
||||
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**T*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**T + 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) {
|
||||
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**T*B**T + 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_
|
||||
|
||||
370
3rdparty/clapack/src/dgemv.c
vendored
Normal file
370
3rdparty/clapack/src/dgemv.c
vendored
Normal file
@ -0,0 +1,370 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DGEMV
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION ALPHA,BETA
|
||||
// INTEGER INCX,INCY,LDA,M,N
|
||||
// CHARACTER TRANS
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DGEMV performs one of the matrix-vector operations
|
||||
//>
|
||||
//> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
//>
|
||||
//> where alpha and beta are scalars, x and y are vectors and A is an
|
||||
//> m by n matrix.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is 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**T*x + beta*y.
|
||||
//>
|
||||
//> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> On entry, M specifies the number of rows of the matrix A.
|
||||
//> M must be at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> On entry, N specifies the number of columns of the matrix A.
|
||||
//> N must be at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is DOUBLE PRECISION.
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension ( LDA, N )
|
||||
//> Before entry, the leading m by n part of the array A must
|
||||
//> contain the matrix of coefficients.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> On entry, INCX specifies the increment for the elements of
|
||||
//> X. INCX must not be zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] BETA
|
||||
//> \verbatim
|
||||
//> BETA is DOUBLE PRECISION.
|
||||
//> On entry, BETA specifies the scalar beta. When BETA is
|
||||
//> supplied as zero then Y need not be set on input.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] Y
|
||||
//> \verbatim
|
||||
//> Y is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCY
|
||||
//> \verbatim
|
||||
//> INCY is INTEGER
|
||||
//> On entry, INCY specifies the increment for the elements of
|
||||
//> Y. INCY must not be zero.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup double_blas_level2
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> Level 2 Blas routine.
|
||||
//> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
//>
|
||||
//> -- 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dgemv_(char *trans, int *m, int *n, double *alpha,
|
||||
double *a, int *lda, double *x, int *incx, double *beta, double *y,
|
||||
int *incy)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j, ix, iy, jx, jy, kx, ky, info;
|
||||
double temp;
|
||||
int lenx, leny;
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level2 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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) {
|
||||
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) {
|
||||
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**T*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_
|
||||
|
||||
18599
3rdparty/clapack/src/dgesdd.c
vendored
Normal file
18599
3rdparty/clapack/src/dgesdd.c
vendored
Normal file
File diff suppressed because it is too large
Load Diff
186
3rdparty/clapack/src/disnan.c
vendored
Normal file
186
3rdparty/clapack/src/disnan.c
vendored
Normal file
@ -0,0 +1,186 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DISNAN tests input for NaN.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DISNAN + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/disnan.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/disnan.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/disnan.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// LOGICAL FUNCTION DISNAN( DIN )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION, INTENT(IN) :: DIN
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
|
||||
//> otherwise. To be replaced by the Fortran 2003 intrinsic in the
|
||||
//> future.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] DIN
|
||||
//> \verbatim
|
||||
//> DIN is DOUBLE PRECISION
|
||||
//> Input to test for NaN.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2017
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int disnan_(double *din)
|
||||
{
|
||||
// System generated locals
|
||||
int ret_val;
|
||||
|
||||
// Local variables
|
||||
extern int dlaisnan_(double *, double *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.1) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
ret_val = dlaisnan_(din, din);
|
||||
return ret_val;
|
||||
} // disnan_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLAISNAN + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaisnan.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaisnan.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaisnan.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> This routine is not for general use. It exists solely to avoid
|
||||
//> over-optimization in DISNAN.
|
||||
//>
|
||||
//> DLAISNAN checks for NaNs by comparing its two arguments for
|
||||
//> inequality. NaN is the only floating-point value where NaN != NaN
|
||||
//> returns .TRUE. To check for NaNs, pass the same variable as both
|
||||
//> arguments.
|
||||
//>
|
||||
//> A compiler must assume that the two arguments are
|
||||
//> not the same variable, and the test will not be optimized away.
|
||||
//> Interprocedural or whole-program optimization may delete this
|
||||
//> test. The ISNAN functions will be replaced by the correct
|
||||
//> Fortran 03 intrinsic once the intrinsic is widely available.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] DIN1
|
||||
//> \verbatim
|
||||
//> DIN1 is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIN2
|
||||
//> \verbatim
|
||||
//> DIN2 is DOUBLE PRECISION
|
||||
//> Two numbers to compare for inequality.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2017
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int dlaisnan_(double *din1, double *din2)
|
||||
{
|
||||
// System generated locals
|
||||
int ret_val;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.1) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Executable Statements ..
|
||||
ret_val = *din1 != *din2;
|
||||
return ret_val;
|
||||
} // dlaisnan_
|
||||
|
||||
184
3rdparty/clapack/src/dlacpy.c
vendored
Normal file
184
3rdparty/clapack/src/dlacpy.c
vendored
Normal file
@ -0,0 +1,184 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLACPY copies all or part of one two-dimensional array to another.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLACPY + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlacpy.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlacpy.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlacpy.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER UPLO
|
||||
// INTEGER LDA, LDB, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * ), B( LDB, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLACPY copies all or part of a two-dimensional matrix A to another
|
||||
//> matrix B.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] UPLO
|
||||
//> \verbatim
|
||||
//> UPLO is CHARACTER*1
|
||||
//> Specifies the part of the matrix A to be copied to B.
|
||||
//> = 'U': Upper triangular part
|
||||
//> = 'L': Lower triangular part
|
||||
//> Otherwise: All of the matrix A
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A. N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> The m by n matrix A. If UPLO = 'U', only the upper triangle
|
||||
//> or trapezoid is accessed; if UPLO = 'L', only the lower
|
||||
//> triangle or trapezoid is accessed.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A. LDA >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] B
|
||||
//> \verbatim
|
||||
//> B is DOUBLE PRECISION array, dimension (LDB,N)
|
||||
//> On exit, B = A in the locations specified by UPLO.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is INTEGER
|
||||
//> The leading dimension of the array B. LDB >= max(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlacpy_(char *uplo, int *m, int *n, double *a, int *lda,
|
||||
double *b, int *ldb)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
extern int lsame_(char *, char *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// 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
|
||||
if (lsame_(uplo, "U")) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = min(j,*m);
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else if (lsame_(uplo, "L")) {
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = j; i__ <= i__2; ++i__) {
|
||||
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
|
||||
// L30:
|
||||
}
|
||||
// L40:
|
||||
}
|
||||
} else {
|
||||
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] = a[i__ + j * a_dim1];
|
||||
// L50:
|
||||
}
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLACPY
|
||||
//
|
||||
} // dlacpy_
|
||||
|
||||
367
3rdparty/clapack/src/dlange.c
vendored
Normal file
367
3rdparty/clapack/src/dlange.c
vendored
Normal file
@ -0,0 +1,367 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DCOMBSSQ adds two scaled sum of squares quantities.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DCOMBSSQ( V1, V2 )
|
||||
//
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION V1( 2 ), V2( 2 )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2.
|
||||
//> That is,
|
||||
//>
|
||||
//> V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq
|
||||
//> + V2_scale**2 * V2_sumsq
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in,out] V1
|
||||
//> \verbatim
|
||||
//> V1 is DOUBLE PRECISION array, dimension (2).
|
||||
//> The first scaled sum.
|
||||
//> V1(1) = V1_scale, V1(2) = V1_sumsq.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] V2
|
||||
//> \verbatim
|
||||
//> V2 is DOUBLE PRECISION array, dimension (2).
|
||||
//> The second scaled sum.
|
||||
//> V2(1) = V2_scale, V2(2) = V2_sumsq.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2018
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dcombssq_(double *v1, double *v2)
|
||||
{
|
||||
// System generated locals
|
||||
double d__1;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2018
|
||||
//
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
//=====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
--v2;
|
||||
--v1;
|
||||
|
||||
// Function Body
|
||||
if (v1[1] >= v2[1]) {
|
||||
if (v1[1] != 0.) {
|
||||
// Computing 2nd power
|
||||
d__1 = v2[1] / v1[1];
|
||||
v1[2] += d__1 * d__1 * v2[2];
|
||||
}
|
||||
} else {
|
||||
// Computing 2nd power
|
||||
d__1 = v1[1] / v2[1];
|
||||
v1[2] = v2[2] + d__1 * d__1 * v1[2];
|
||||
v1[1] = v2[1];
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DCOMBSSQ
|
||||
//
|
||||
} // dcombssq_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLANGE + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlange.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlange.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlange.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER NORM
|
||||
// INTEGER LDA, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * ), WORK( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLANGE returns the value of the one norm, or the Frobenius norm, or
|
||||
//> the infinity norm, or the element of largest absolute value of a
|
||||
//> real matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \return DLANGE
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
|
||||
//> (
|
||||
//> ( norm1(A), NORM = '1', 'O' or 'o'
|
||||
//> (
|
||||
//> ( normI(A), NORM = 'I' or 'i'
|
||||
//> (
|
||||
//> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
|
||||
//>
|
||||
//> where norm1 denotes the one norm of a matrix (maximum column sum),
|
||||
//> normI denotes the infinity norm of a matrix (maximum row sum) and
|
||||
//> normF denotes the Frobenius norm of a matrix (square root of sum of
|
||||
//> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] NORM
|
||||
//> \verbatim
|
||||
//> NORM is CHARACTER*1
|
||||
//> Specifies the value to be returned in DLANGE as described
|
||||
//> above.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A. M >= 0. When M = 0,
|
||||
//> DLANGE is set to zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A. N >= 0. When N = 0,
|
||||
//> DLANGE is set to zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> The m by n matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A. LDA >= max(M,1).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
|
||||
//> where LWORK >= M when NORM = 'I'; otherwise, WORK is not
|
||||
//> referenced.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleGEauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
double dlange_(char *norm, int *m, int *n, double *a, int *lda, double *work)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
double ret_val, d__1;
|
||||
|
||||
// Local variables
|
||||
extern /* Subroutine */ int dcombssq_(double *, double *);
|
||||
int i__, j;
|
||||
double sum, ssq[2], temp;
|
||||
extern int lsame_(char *, char *);
|
||||
double value;
|
||||
extern int disnan_(double *);
|
||||
extern /* Subroutine */ int dlassq_(int *, double *, int *, double *,
|
||||
double *);
|
||||
double colssq[2];
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
//=====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Local Arrays ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
if (min(*m,*n) == 0) {
|
||||
value = 0.;
|
||||
} else if (lsame_(norm, "M")) {
|
||||
//
|
||||
// Find max(abs(A(i,j))).
|
||||
//
|
||||
value = 0.;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
|
||||
if (value < temp || disnan_(&temp)) {
|
||||
value = temp;
|
||||
}
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
|
||||
//
|
||||
// Find norm1(A).
|
||||
//
|
||||
value = 0.;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
sum = 0.;
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
|
||||
// L30:
|
||||
}
|
||||
if (value < sum || disnan_(&sum)) {
|
||||
value = sum;
|
||||
}
|
||||
// L40:
|
||||
}
|
||||
} else if (lsame_(norm, "I")) {
|
||||
//
|
||||
// Find normI(A).
|
||||
//
|
||||
i__1 = *m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
work[i__] = 0.;
|
||||
// L50:
|
||||
}
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
|
||||
// L60:
|
||||
}
|
||||
// L70:
|
||||
}
|
||||
value = 0.;
|
||||
i__1 = *m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
temp = work[i__];
|
||||
if (value < temp || disnan_(&temp)) {
|
||||
value = temp;
|
||||
}
|
||||
// L80:
|
||||
}
|
||||
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
|
||||
//
|
||||
// Find normF(A).
|
||||
// SSQ(1) is scale
|
||||
// SSQ(2) is sum-of-squares
|
||||
// For better accuracy, sum each column separately.
|
||||
//
|
||||
ssq[0] = 0.;
|
||||
ssq[1] = 1.;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
colssq[0] = 0.;
|
||||
colssq[1] = 1.;
|
||||
dlassq_(m, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]);
|
||||
dcombssq_(ssq, colssq);
|
||||
// L90:
|
||||
}
|
||||
value = ssq[0] * sqrt(ssq[1]);
|
||||
}
|
||||
ret_val = value;
|
||||
return ret_val;
|
||||
//
|
||||
// End of DLANGE
|
||||
//
|
||||
} // dlange_
|
||||
|
||||
125
3rdparty/clapack/src/dlapy2.c
vendored
Normal file
125
3rdparty/clapack/src/dlapy2.c
vendored
Normal file
@ -0,0 +1,125 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLAPY2 returns sqrt(x2+y2).
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLAPY2 + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlapy2.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlapy2.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlapy2.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION X, Y
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
|
||||
//> overflow.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] Y
|
||||
//> \verbatim
|
||||
//> Y is DOUBLE PRECISION
|
||||
//> X and Y specify the values x and y.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2017
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
double dlapy2_(double *x, double *y)
|
||||
{
|
||||
// System generated locals
|
||||
double ret_val, d__1;
|
||||
|
||||
// Local variables
|
||||
int x_is_nan__, y_is_nan__;
|
||||
double w, z__, xabs, yabs;
|
||||
extern int disnan_(double *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.1) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
x_is_nan__ = disnan_(x);
|
||||
y_is_nan__ = disnan_(y);
|
||||
if (x_is_nan__) {
|
||||
ret_val = *x;
|
||||
}
|
||||
if (y_is_nan__) {
|
||||
ret_val = *y;
|
||||
}
|
||||
if (! (x_is_nan__ || y_is_nan__)) {
|
||||
xabs = abs(*x);
|
||||
yabs = abs(*y);
|
||||
w = max(xabs,yabs);
|
||||
z__ = min(xabs,yabs);
|
||||
if (z__ == 0.) {
|
||||
ret_val = w;
|
||||
} else {
|
||||
// Computing 2nd power
|
||||
d__1 = z__ / w;
|
||||
ret_val = w * sqrt(d__1 * d__1 + 1.);
|
||||
}
|
||||
}
|
||||
return ret_val;
|
||||
//
|
||||
// End of DLAPY2
|
||||
//
|
||||
} // dlapy2_
|
||||
|
||||
768
3rdparty/clapack/src/dlarf.c
vendored
Normal file
768
3rdparty/clapack/src/dlarf.c
vendored
Normal file
@ -0,0 +1,768 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DGER
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION ALPHA
|
||||
// INTEGER INCX,INCY,LDA,M,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DGER performs the rank 1 operation
|
||||
//>
|
||||
//> A := alpha*x*y**T + 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.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> On entry, M specifies the number of rows of the matrix A.
|
||||
//> M must be at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> On entry, N specifies the number of columns of the matrix A.
|
||||
//> N must be at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is DOUBLE PRECISION.
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, dimension at least
|
||||
//> ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
//> Before entry, the incremented array X must contain the m
|
||||
//> element vector x.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> On entry, INCX specifies the increment for the elements of
|
||||
//> X. INCX must not be zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] Y
|
||||
//> \verbatim
|
||||
//> Y is DOUBLE PRECISION array, dimension at least
|
||||
//> ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
//> Before entry, the incremented array Y must contain the n
|
||||
//> element vector y.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCY
|
||||
//> \verbatim
|
||||
//> INCY is INTEGER
|
||||
//> On entry, INCY specifies the increment for the elements of
|
||||
//> Y. INCY must not be zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup double_blas_level2
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dger_(int *m, int *n, double *alpha, double *x, int *
|
||||
incx, double *y, int *incy, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j, ix, jy, kx, info;
|
||||
double temp;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level2 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DLARF applies an elementary reflector to a general rectangular matrix.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLARF + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarf.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarf.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarf.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER SIDE
|
||||
// INTEGER INCV, LDC, M, N
|
||||
// DOUBLE PRECISION TAU
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLARF applies a real elementary reflector H to a real m by n matrix
|
||||
//> C, from either the left or the right. H is represented in the form
|
||||
//>
|
||||
//> H = I - tau * v * v**T
|
||||
//>
|
||||
//> where tau is a real scalar and v is a real vector.
|
||||
//>
|
||||
//> If tau = 0, then H is taken to be the unit matrix.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is CHARACTER*1
|
||||
//> = 'L': form H * C
|
||||
//> = 'R': form C * H
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix C.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix C.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] V
|
||||
//> \verbatim
|
||||
//> V is DOUBLE PRECISION array, dimension
|
||||
//> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
|
||||
//> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
|
||||
//> The vector v in the representation of H. V is not used if
|
||||
//> TAU = 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCV
|
||||
//> \verbatim
|
||||
//> INCV is INTEGER
|
||||
//> The increment between elements of v. INCV <> 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION
|
||||
//> The value tau in the representation of H.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION array, dimension (LDC,N)
|
||||
//> On entry, the m by n matrix C.
|
||||
//> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
|
||||
//> or C * H if SIDE = 'R'.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is INTEGER
|
||||
//> The leading dimension of the array C. LDC >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension
|
||||
//> (N) if SIDE = 'L'
|
||||
//> or (M) if SIDE = 'R'
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlarf_(char *side, int *m, int *n, double *v, int *incv,
|
||||
double *tau, double *c__, int *ldc, double *work)
|
||||
{
|
||||
// Table of constant values
|
||||
double c_b4 = 1.;
|
||||
double c_b5 = 0.;
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int c_dim1, c_offset;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int i__;
|
||||
int applyleft;
|
||||
extern /* Subroutine */ int dger_(int *, int *, double *, double *, int *,
|
||||
double *, int *, double *, int *);
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double
|
||||
*, int *, double *, int *, double *, double *, int *);
|
||||
int lastc, lastv;
|
||||
extern int iladlc_(int *, int *, double *, int *), iladlr_(int *, int *,
|
||||
double *, int *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
--v;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
applyleft = lsame_(side, "L");
|
||||
lastv = 0;
|
||||
lastc = 0;
|
||||
if (*tau != 0.) {
|
||||
// Set up variables for scanning V. LASTV begins pointing to the end
|
||||
// of V.
|
||||
if (applyleft) {
|
||||
lastv = *m;
|
||||
} else {
|
||||
lastv = *n;
|
||||
}
|
||||
if (*incv > 0) {
|
||||
i__ = (lastv - 1) * *incv + 1;
|
||||
} else {
|
||||
i__ = 1;
|
||||
}
|
||||
// Look for the last non-zero row in V.
|
||||
while(lastv > 0 && v[i__] == 0.) {
|
||||
--lastv;
|
||||
i__ -= *incv;
|
||||
}
|
||||
if (applyleft) {
|
||||
// Scan for the last non-zero column in C(1:lastv,:).
|
||||
lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
|
||||
} else {
|
||||
// Scan for the last non-zero row in C(:,1:lastv).
|
||||
lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
|
||||
}
|
||||
}
|
||||
// Note that lastc.eq.0 renders the BLAS operations null; no special
|
||||
// case is needed at this level.
|
||||
if (applyleft) {
|
||||
//
|
||||
// Form H * C
|
||||
//
|
||||
if (lastv > 0) {
|
||||
//
|
||||
// w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
|
||||
//
|
||||
dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
|
||||
v[1], incv, &c_b5, &work[1], &c__1);
|
||||
//
|
||||
// C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
|
||||
//
|
||||
d__1 = -(*tau);
|
||||
dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
|
||||
c_offset], ldc);
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Form C * H
|
||||
//
|
||||
if (lastv > 0) {
|
||||
//
|
||||
// w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
|
||||
//
|
||||
dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc,
|
||||
&v[1], incv, &c_b5, &work[1], &c__1);
|
||||
//
|
||||
// C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
|
||||
//
|
||||
d__1 = -(*tau);
|
||||
dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
|
||||
c_offset], ldc);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARF
|
||||
//
|
||||
} // dlarf_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b ILADLC scans a matrix for its last non-zero column.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download ILADLC + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iladlc.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iladlc.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iladlc.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// INTEGER FUNCTION ILADLC( M, N, A, LDA )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER M, N, LDA
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> ILADLC scans A for its last non-zero column.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> The m by n matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A. LDA >= max(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int iladlc_(int *m, int *n, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, ret_val, i__1;
|
||||
|
||||
// Local variables
|
||||
int i__;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick test for the common case where one corner is non-zero.
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
if (*n == 0) {
|
||||
ret_val = *n;
|
||||
} else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) {
|
||||
ret_val = *n;
|
||||
} else {
|
||||
// Now scan each column from the end, returning with the first non-zero.
|
||||
for (ret_val = *n; ret_val >= 1; --ret_val) {
|
||||
i__1 = *m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
if (a[i__ + ret_val * a_dim1] != 0.) {
|
||||
return ret_val;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return ret_val;
|
||||
} // iladlc_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b ILADLR scans a matrix for its last non-zero row.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download ILADLR + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iladlr.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iladlr.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iladlr.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// INTEGER FUNCTION ILADLR( M, N, A, LDA )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER M, N, LDA
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> ILADLR scans A for its last non-zero row.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> The m by n matrix A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A. LDA >= max(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
int iladlr_(int *m, int *n, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, ret_val, i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick test for the common case where one corner is non-zero.
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
if (*m == 0) {
|
||||
ret_val = *m;
|
||||
} else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) {
|
||||
ret_val = *m;
|
||||
} else {
|
||||
// Scan up each column tracking the last zero row seen.
|
||||
ret_val = 0;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__ = *m;
|
||||
while(a[max(i__,1) + j * a_dim1] == 0. && i__ >= 1) {
|
||||
--i__;
|
||||
}
|
||||
ret_val = max(ret_val,i__);
|
||||
}
|
||||
}
|
||||
return ret_val;
|
||||
} // iladlr_
|
||||
|
||||
824
3rdparty/clapack/src/dlarfb.c
vendored
Normal file
824
3rdparty/clapack/src/dlarfb.c
vendored
Normal file
@ -0,0 +1,824 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLARFB + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
|
||||
// T, LDT, C, LDC, WORK, LDWORK )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER DIRECT, SIDE, STOREV, TRANS
|
||||
// INTEGER K, LDC, LDT, LDV, LDWORK, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
|
||||
// $ WORK( LDWORK, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLARFB applies a real block reflector H or its transpose H**T to a
|
||||
//> real m by n matrix C, from either the left or the right.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is CHARACTER*1
|
||||
//> = 'L': apply H or H**T from the Left
|
||||
//> = 'R': apply H or H**T from the Right
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is CHARACTER*1
|
||||
//> = 'N': apply H (No transpose)
|
||||
//> = 'T': apply H**T (Transpose)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIRECT
|
||||
//> \verbatim
|
||||
//> DIRECT is CHARACTER*1
|
||||
//> Indicates how H is formed from a product of elementary
|
||||
//> reflectors
|
||||
//> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
//> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] STOREV
|
||||
//> \verbatim
|
||||
//> STOREV is CHARACTER*1
|
||||
//> Indicates how the vectors which define the elementary
|
||||
//> reflectors are stored:
|
||||
//> = 'C': Columnwise
|
||||
//> = 'R': Rowwise
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix C.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix C.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The order of the matrix T (= the number of elementary
|
||||
//> reflectors whose product defines the block reflector).
|
||||
//> If SIDE = 'L', M >= K >= 0;
|
||||
//> if SIDE = 'R', N >= K >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] V
|
||||
//> \verbatim
|
||||
//> V is DOUBLE PRECISION array, dimension
|
||||
//> (LDV,K) if STOREV = 'C'
|
||||
//> (LDV,M) if STOREV = 'R' and SIDE = 'L'
|
||||
//> (LDV,N) if STOREV = 'R' and SIDE = 'R'
|
||||
//> The matrix V. See Further Details.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDV
|
||||
//> \verbatim
|
||||
//> LDV is INTEGER
|
||||
//> The leading dimension of the array V.
|
||||
//> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
|
||||
//> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
|
||||
//> if STOREV = 'R', LDV >= K.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] T
|
||||
//> \verbatim
|
||||
//> T is DOUBLE PRECISION array, dimension (LDT,K)
|
||||
//> The triangular k by k matrix T in the representation of the
|
||||
//> block reflector.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDT
|
||||
//> \verbatim
|
||||
//> LDT is INTEGER
|
||||
//> The leading dimension of the array T. LDT >= K.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION array, dimension (LDC,N)
|
||||
//> On entry, the m by n matrix C.
|
||||
//> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is INTEGER
|
||||
//> The leading dimension of the array C. LDC >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension (LDWORK,K)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDWORK
|
||||
//> \verbatim
|
||||
//> LDWORK is INTEGER
|
||||
//> The leading dimension of the array WORK.
|
||||
//> If SIDE = 'L', LDWORK >= max(1,N);
|
||||
//> if SIDE = 'R', LDWORK >= max(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2013
|
||||
//
|
||||
//> \ingroup doubleOTHERauxiliary
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> The shape of the matrix V and the storage of the vectors which define
|
||||
//> the H(i) is best illustrated by the following example with n = 5 and
|
||||
//> k = 3. The elements equal to 1 are not stored; the corresponding
|
||||
//> array elements are modified but restored on exit. The rest of the
|
||||
//> array is not used.
|
||||
//>
|
||||
//> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
//>
|
||||
//> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
//> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
//> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
//> ( v1 v2 v3 )
|
||||
//> ( v1 v2 v3 )
|
||||
//>
|
||||
//> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
//>
|
||||
//> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
//> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
//> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
//> ( 1 v3 )
|
||||
//> ( 1 )
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
|
||||
storev, int *m, int *n, int *k, double *v, int *ldv, double *t, int *
|
||||
ldt, double *c__, int *ldc, double *work, int *ldwork)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
double c_b14 = 1.;
|
||||
double c_b25 = -1.;
|
||||
|
||||
// System generated locals
|
||||
int c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
|
||||
work_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
extern /* Subroutine */ int dgemm_(char *, char *, int *, int *, int *,
|
||||
double *, double *, int *, double *, int *, double *, double *,
|
||||
int *);
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int dcopy_(int *, double *, int *, double *, int *
|
||||
), dtrmm_(char *, char *, char *, char *, int *, int *, double *,
|
||||
double *, int *, double *, int *);
|
||||
char transt[1+1]={'\0'};
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2013
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
// Parameter adjustments
|
||||
v_dim1 = *ldv;
|
||||
v_offset = 1 + v_dim1;
|
||||
v -= v_offset;
|
||||
t_dim1 = *ldt;
|
||||
t_offset = 1 + t_dim1;
|
||||
t -= t_offset;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
work_dim1 = *ldwork;
|
||||
work_offset = 1 + work_dim1;
|
||||
work -= work_offset;
|
||||
|
||||
// Function Body
|
||||
if (*m <= 0 || *n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(trans, "N")) {
|
||||
*(unsigned char *)transt = 'T';
|
||||
} else {
|
||||
*(unsigned char *)transt = 'N';
|
||||
}
|
||||
if (lsame_(storev, "C")) {
|
||||
if (lsame_(direct, "F")) {
|
||||
//
|
||||
// Let V = ( V1 ) (first K rows)
|
||||
// ( V2 )
|
||||
// where V1 is unit lower triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
//
|
||||
// W := C1**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
|
||||
&c__1);
|
||||
// L10:
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C2**T * V2
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
|
||||
c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1],
|
||||
ldv, &c_b14, &work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C2 := C2 - V2 * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
|
||||
v[*k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L20:
|
||||
}
|
||||
// L30:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H**T where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
//
|
||||
// W := C1
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L40:
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C2 * V2
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, k, &i__1, &
|
||||
c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
|
||||
1 + v_dim1], ldv, &c_b14, &work[work_offset],
|
||||
ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V**T
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C2 := C2 - W * V2**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
|
||||
work[work_offset], ldwork, &v[*k + 1 + v_dim1],
|
||||
ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L50:
|
||||
}
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Let V = ( V1 )
|
||||
// ( V2 ) (last K rows)
|
||||
// where V2 is unit upper triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
|
||||
//
|
||||
// W := C2**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L70:
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C1**T * V1
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
|
||||
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
|
||||
work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C1 := C1 - V1 * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork, &
|
||||
c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
//
|
||||
// C2 := C2 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L80:
|
||||
}
|
||||
// L90:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H**T where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V = (C1*V1 + C2*V2) (stored in WORK)
|
||||
//
|
||||
// W := C2
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
|
||||
j * work_dim1 + 1], &c__1);
|
||||
// L100:
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C1 * V1
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, k, &i__1, &
|
||||
c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
|
||||
c_b14, &work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V**T
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C1 := C1 - W * V1**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
|
||||
work[work_offset], ldwork, &v[v_offset], ldv, &
|
||||
c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
|
||||
ldwork);
|
||||
//
|
||||
// C2 := C2 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L110:
|
||||
}
|
||||
// L120:
|
||||
}
|
||||
}
|
||||
}
|
||||
} else if (lsame_(storev, "R")) {
|
||||
if (lsame_(direct, "F")) {
|
||||
//
|
||||
// Let V = ( V1 V2 ) (V1: first K columns)
|
||||
// where V1 is unit upper triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C1**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
|
||||
&c__1);
|
||||
// L130:
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C2**T * V2**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
|
||||
c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 +
|
||||
1], ldv, &c_b14, &work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V**T * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C2 := C2 - V2**T * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[(
|
||||
*k + 1) * v_dim1 + 1], ldv, &work[work_offset],
|
||||
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L140:
|
||||
}
|
||||
// L150:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H**T where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C1
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L160:
|
||||
}
|
||||
//
|
||||
// W := W * V1**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C2 * V2**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
|
||||
c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) *
|
||||
v_dim1 + 1], ldv, &c_b14, &work[work_offset],
|
||||
ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C2 := C2 - W * V2
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, &i__1, k, &
|
||||
c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
|
||||
v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
|
||||
+ 1], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V1
|
||||
//
|
||||
dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[v_offset], ldv, &work[work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
|
||||
// L170:
|
||||
}
|
||||
// L180:
|
||||
}
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Let V = ( V1 V2 ) (V2: last K columns)
|
||||
// where V2 is unit lower triangular.
|
||||
//
|
||||
if (lsame_(side, "L")) {
|
||||
//
|
||||
// Form H * C or H**T * C where C = ( C1 )
|
||||
// ( C2 )
|
||||
//
|
||||
// W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C2**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
|
||||
work_dim1 + 1], &c__1);
|
||||
// L190:
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
|
||||
v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
|
||||
, ldwork);
|
||||
if (*m > *k) {
|
||||
//
|
||||
// W := W + C1**T * V1**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
|
||||
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
|
||||
work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T**T or W * T
|
||||
//
|
||||
dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - V**T * W**T
|
||||
//
|
||||
if (*m > *k) {
|
||||
//
|
||||
// C1 := C1 - V1**T * W**T
|
||||
//
|
||||
i__1 = *m - *k;
|
||||
dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[
|
||||
v_offset], ldv, &work[work_offset], ldwork, &
|
||||
c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
|
||||
&v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
|
||||
work_offset], ldwork);
|
||||
//
|
||||
// C2 := C2 - W**T
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *n;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L200:
|
||||
}
|
||||
// L210:
|
||||
}
|
||||
} else if (lsame_(side, "R")) {
|
||||
//
|
||||
// Form C * H or C * H' where C = ( C1 C2 )
|
||||
//
|
||||
// W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
|
||||
//
|
||||
// W := C2
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
|
||||
j * work_dim1 + 1], &c__1);
|
||||
// L220:
|
||||
}
|
||||
//
|
||||
// W := W * V2**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
|
||||
v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
|
||||
, ldwork);
|
||||
if (*n > *k) {
|
||||
//
|
||||
// W := W + C1 * V1**T
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
|
||||
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
|
||||
work[work_offset], ldwork);
|
||||
}
|
||||
//
|
||||
// W := W * T or W * T**T
|
||||
//
|
||||
dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
|
||||
t_offset], ldt, &work[work_offset], ldwork);
|
||||
//
|
||||
// C := C - W * V
|
||||
//
|
||||
if (*n > *k) {
|
||||
//
|
||||
// C1 := C1 - W * V1
|
||||
//
|
||||
i__1 = *n - *k;
|
||||
dgemm_("No transpose", "No transpose", m, &i__1, k, &
|
||||
c_b25, &work[work_offset], ldwork, &v[v_offset],
|
||||
ldv, &c_b14, &c__[c_offset], ldc);
|
||||
}
|
||||
//
|
||||
// W := W * V2
|
||||
//
|
||||
dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
|
||||
&v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
|
||||
work_offset], ldwork);
|
||||
//
|
||||
// C1 := C1 - W
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
|
||||
work_dim1];
|
||||
// L230:
|
||||
}
|
||||
// L240:
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARFB
|
||||
//
|
||||
} // dlarfb_
|
||||
|
||||
216
3rdparty/clapack/src/dlarfg.c
vendored
Normal file
216
3rdparty/clapack/src/dlarfg.c
vendored
Normal file
@ -0,0 +1,216 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLARFG generates an elementary reflector (Householder matrix).
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLARFG + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfg.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfg.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfg.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX, N
|
||||
// DOUBLE PRECISION ALPHA, TAU
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION X( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLARFG generates a real elementary reflector H of order n, such
|
||||
//> that
|
||||
//>
|
||||
//> H * ( alpha ) = ( beta ), H**T * H = I.
|
||||
//> ( x ) ( 0 )
|
||||
//>
|
||||
//> where alpha and beta are scalars, and x is an (n-1)-element real
|
||||
//> vector. H is represented in the form
|
||||
//>
|
||||
//> H = I - tau * ( 1 ) * ( 1 v**T ) ,
|
||||
//> ( v )
|
||||
//>
|
||||
//> where tau is a real scalar and v is a real (n-1)-element
|
||||
//> vector.
|
||||
//>
|
||||
//> If the elements of x are all zero, then tau = 0 and H is taken to be
|
||||
//> the unit matrix.
|
||||
//>
|
||||
//> Otherwise 1 <= tau <= 2.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The order of the elementary reflector.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is DOUBLE PRECISION
|
||||
//> On entry, the value alpha.
|
||||
//> On exit, it is overwritten with the value beta.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, dimension
|
||||
//> (1+(N-2)*abs(INCX))
|
||||
//> On entry, the vector x.
|
||||
//> On exit, it is overwritten with the vector v.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> The increment between elements of X. INCX > 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION
|
||||
//> The value tau.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup doubleOTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlarfg_(int *n, double *alpha, double *x, int *incx,
|
||||
double *tau)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int j, knt;
|
||||
double beta;
|
||||
extern double dnrm2_(int *, double *, int *);
|
||||
extern /* Subroutine */ int dscal_(int *, double *, double *, int *);
|
||||
double xnorm;
|
||||
extern double dlapy2_(double *, double *), dlamch_(char *);
|
||||
double safmin, rsafmn;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.8.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
--x;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 1) {
|
||||
*tau = 0.;
|
||||
return 0;
|
||||
}
|
||||
i__1 = *n - 1;
|
||||
xnorm = dnrm2_(&i__1, &x[1], incx);
|
||||
if (xnorm == 0.) {
|
||||
//
|
||||
// H = I
|
||||
//
|
||||
*tau = 0.;
|
||||
} else {
|
||||
//
|
||||
// general case
|
||||
//
|
||||
d__1 = dlapy2_(alpha, &xnorm);
|
||||
beta = -d_sign(&d__1, alpha);
|
||||
safmin = dlamch_("S") / dlamch_("E");
|
||||
knt = 0;
|
||||
if (abs(beta) < safmin) {
|
||||
//
|
||||
// XNORM, BETA may be inaccurate; scale X and recompute them
|
||||
//
|
||||
rsafmn = 1. / safmin;
|
||||
L10:
|
||||
++knt;
|
||||
i__1 = *n - 1;
|
||||
dscal_(&i__1, &rsafmn, &x[1], incx);
|
||||
beta *= rsafmn;
|
||||
*alpha *= rsafmn;
|
||||
if (abs(beta) < safmin && knt < 20) {
|
||||
goto L10;
|
||||
}
|
||||
//
|
||||
// New BETA is at most 1, at least SAFMIN
|
||||
//
|
||||
i__1 = *n - 1;
|
||||
xnorm = dnrm2_(&i__1, &x[1], incx);
|
||||
d__1 = dlapy2_(alpha, &xnorm);
|
||||
beta = -d_sign(&d__1, alpha);
|
||||
}
|
||||
*tau = (beta - *alpha) / beta;
|
||||
i__1 = *n - 1;
|
||||
d__1 = 1. / (*alpha - beta);
|
||||
dscal_(&i__1, &d__1, &x[1], incx);
|
||||
//
|
||||
// If ALPHA is subnormal, it may lose relative accuracy
|
||||
//
|
||||
i__1 = knt;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
beta *= safmin;
|
||||
// L20:
|
||||
}
|
||||
*alpha = beta;
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARFG
|
||||
//
|
||||
} // dlarfg_
|
||||
|
||||
389
3rdparty/clapack/src/dlarft.c
vendored
Normal file
389
3rdparty/clapack/src/dlarft.c
vendored
Normal file
@ -0,0 +1,389 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLARFT + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarft.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarft.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarft.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER DIRECT, STOREV
|
||||
// INTEGER K, LDT, LDV, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLARFT forms the triangular factor T of a real block reflector H
|
||||
//> of order n, which is defined as a product of k elementary reflectors.
|
||||
//>
|
||||
//> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
|
||||
//>
|
||||
//> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
|
||||
//>
|
||||
//> If STOREV = 'C', the vector which defines the elementary reflector
|
||||
//> H(i) is stored in the i-th column of the array V, and
|
||||
//>
|
||||
//> H = I - V * T * V**T
|
||||
//>
|
||||
//> If STOREV = 'R', the vector which defines the elementary reflector
|
||||
//> H(i) is stored in the i-th row of the array V, and
|
||||
//>
|
||||
//> H = I - V**T * T * V
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] DIRECT
|
||||
//> \verbatim
|
||||
//> DIRECT is CHARACTER*1
|
||||
//> Specifies the order in which the elementary reflectors are
|
||||
//> multiplied to form the block reflector:
|
||||
//> = 'F': H = H(1) H(2) . . . H(k) (Forward)
|
||||
//> = 'B': H = H(k) . . . H(2) H(1) (Backward)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] STOREV
|
||||
//> \verbatim
|
||||
//> STOREV is CHARACTER*1
|
||||
//> Specifies how the vectors which define the elementary
|
||||
//> reflectors are stored (see also Further Details):
|
||||
//> = 'C': columnwise
|
||||
//> = 'R': rowwise
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The order of the block reflector H. N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The order of the triangular factor T (= the number of
|
||||
//> elementary reflectors). K >= 1.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] V
|
||||
//> \verbatim
|
||||
//> V is DOUBLE PRECISION array, dimension
|
||||
//> (LDV,K) if STOREV = 'C'
|
||||
//> (LDV,N) if STOREV = 'R'
|
||||
//> The matrix V. See further details.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDV
|
||||
//> \verbatim
|
||||
//> LDV is INTEGER
|
||||
//> The leading dimension of the array V.
|
||||
//> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
//> TAU(i) must contain the scalar factor of the elementary
|
||||
//> reflector H(i).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] T
|
||||
//> \verbatim
|
||||
//> T is DOUBLE PRECISION array, dimension (LDT,K)
|
||||
//> The k by k triangular factor T of the block reflector.
|
||||
//> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
|
||||
//> lower triangular. The rest of the array is not used.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDT
|
||||
//> \verbatim
|
||||
//> LDT is INTEGER
|
||||
//> The leading dimension of the array T. LDT >= K.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERauxiliary
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> The shape of the matrix V and the storage of the vectors which define
|
||||
//> the H(i) is best illustrated by the following example with n = 5 and
|
||||
//> k = 3. The elements equal to 1 are not stored.
|
||||
//>
|
||||
//> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
|
||||
//>
|
||||
//> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
|
||||
//> ( v1 1 ) ( 1 v2 v2 v2 )
|
||||
//> ( v1 v2 1 ) ( 1 v3 v3 )
|
||||
//> ( v1 v2 v3 )
|
||||
//> ( v1 v2 v3 )
|
||||
//>
|
||||
//> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
|
||||
//>
|
||||
//> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
|
||||
//> ( v1 v2 v3 ) ( v2 v2 v2 1 )
|
||||
//> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
|
||||
//> ( 1 v3 )
|
||||
//> ( 1 )
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlarft_(char *direct, char *storev, int *n, int *k,
|
||||
double *v, int *ldv, double *tau, double *t, int *ldt)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
double c_b7 = 1.;
|
||||
|
||||
// System generated locals
|
||||
int t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int i__, j, prevlastv;
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int dgemv_(char *, int *, int *, double *, double
|
||||
*, int *, double *, int *, double *, double *, int *);
|
||||
int lastv;
|
||||
extern /* Subroutine */ int dtrmv_(char *, char *, char *, int *, double *
|
||||
, int *, double *, int *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
// Parameter adjustments
|
||||
v_dim1 = *ldv;
|
||||
v_offset = 1 + v_dim1;
|
||||
v -= v_offset;
|
||||
--tau;
|
||||
t_dim1 = *ldt;
|
||||
t_offset = 1 + t_dim1;
|
||||
t -= t_offset;
|
||||
|
||||
// Function Body
|
||||
if (*n == 0) {
|
||||
return 0;
|
||||
}
|
||||
if (lsame_(direct, "F")) {
|
||||
prevlastv = *n;
|
||||
i__1 = *k;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
prevlastv = max(i__,prevlastv);
|
||||
if (tau[i__] == 0.) {
|
||||
//
|
||||
// H(i) = I
|
||||
//
|
||||
i__2 = i__;
|
||||
for (j = 1; j <= i__2; ++j) {
|
||||
t[j + i__ * t_dim1] = 0.;
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// general case
|
||||
//
|
||||
if (lsame_(storev, "C")) {
|
||||
// Skip any trailing zeros.
|
||||
i__2 = i__ + 1;
|
||||
for (lastv = *n; lastv >= i__2; --lastv) {
|
||||
if (v[lastv + i__ * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
i__2 = i__ - 1;
|
||||
for (j = 1; j <= i__2; ++j) {
|
||||
t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1];
|
||||
}
|
||||
j = min(lastv,prevlastv);
|
||||
//
|
||||
// T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
|
||||
//
|
||||
i__2 = j - i__;
|
||||
i__3 = i__ - 1;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 +
|
||||
v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, &
|
||||
c_b7, &t[i__ * t_dim1 + 1], &c__1);
|
||||
} else {
|
||||
// Skip any trailing zeros.
|
||||
i__2 = i__ + 1;
|
||||
for (lastv = *n; lastv >= i__2; --lastv) {
|
||||
if (v[i__ + lastv * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
i__2 = i__ - 1;
|
||||
for (j = 1; j <= i__2; ++j) {
|
||||
t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1];
|
||||
}
|
||||
j = min(lastv,prevlastv);
|
||||
//
|
||||
// T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
|
||||
//
|
||||
i__2 = i__ - 1;
|
||||
i__3 = j - i__;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) *
|
||||
v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1],
|
||||
ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1);
|
||||
}
|
||||
//
|
||||
// T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
|
||||
//
|
||||
i__2 = i__ - 1;
|
||||
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
|
||||
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
|
||||
t[i__ + i__ * t_dim1] = tau[i__];
|
||||
if (i__ > 1) {
|
||||
prevlastv = max(prevlastv,lastv);
|
||||
} else {
|
||||
prevlastv = lastv;
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
prevlastv = 1;
|
||||
for (i__ = *k; i__ >= 1; --i__) {
|
||||
if (tau[i__] == 0.) {
|
||||
//
|
||||
// H(i) = I
|
||||
//
|
||||
i__1 = *k;
|
||||
for (j = i__; j <= i__1; ++j) {
|
||||
t[j + i__ * t_dim1] = 0.;
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// general case
|
||||
//
|
||||
if (i__ < *k) {
|
||||
if (lsame_(storev, "C")) {
|
||||
// Skip any leading zeros.
|
||||
i__1 = i__ - 1;
|
||||
for (lastv = 1; lastv <= i__1; ++lastv) {
|
||||
if (v[lastv + i__ * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
i__1 = *k;
|
||||
for (j = i__ + 1; j <= i__1; ++j) {
|
||||
t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__
|
||||
+ j * v_dim1];
|
||||
}
|
||||
j = max(lastv,prevlastv);
|
||||
//
|
||||
// T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
|
||||
//
|
||||
i__1 = *n - *k + i__ - j;
|
||||
i__2 = *k - i__;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__
|
||||
+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
|
||||
c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], &
|
||||
c__1);
|
||||
} else {
|
||||
// Skip any leading zeros.
|
||||
i__1 = i__ - 1;
|
||||
for (lastv = 1; lastv <= i__1; ++lastv) {
|
||||
if (v[i__ + lastv * v_dim1] != 0.) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
i__1 = *k;
|
||||
for (j = i__ + 1; j <= i__1; ++j) {
|
||||
t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k
|
||||
+ i__) * v_dim1];
|
||||
}
|
||||
j = max(lastv,prevlastv);
|
||||
//
|
||||
// T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
|
||||
//
|
||||
i__1 = *k - i__;
|
||||
i__2 = *n - *k + i__ - j;
|
||||
d__1 = -tau[i__];
|
||||
dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ +
|
||||
1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
|
||||
ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1)
|
||||
;
|
||||
}
|
||||
//
|
||||
// T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
|
||||
//
|
||||
i__1 = *k - i__;
|
||||
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
|
||||
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
|
||||
t_dim1], &c__1);
|
||||
if (i__ > 1) {
|
||||
prevlastv = min(prevlastv,lastv);
|
||||
} else {
|
||||
prevlastv = lastv;
|
||||
}
|
||||
}
|
||||
t[i__ + i__ * t_dim1] = tau[i__];
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARFT
|
||||
//
|
||||
} // dlarft_
|
||||
|
||||
236
3rdparty/clapack/src/dlartg.c
vendored
Normal file
236
3rdparty/clapack/src/dlartg.c
vendored
Normal file
@ -0,0 +1,236 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLARTG + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlartg.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlartg.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlartg.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLARTG( F, G, CS, SN, R )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION CS, F, G, R, SN
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLARTG generate a plane rotation so that
|
||||
//>
|
||||
//> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
|
||||
//> [ -SN CS ] [ G ] [ 0 ]
|
||||
//>
|
||||
//> This is a slower, more accurate version of the BLAS1 routine DROTG,
|
||||
//> with the following other differences:
|
||||
//> F and G are unchanged on return.
|
||||
//> If G=0, then CS=1 and SN=0.
|
||||
//> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
|
||||
//> floating point operations (saves work in DBDSQR when
|
||||
//> there are zeros on the diagonal).
|
||||
//>
|
||||
//> If F exceeds G in magnitude, CS will be positive.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] F
|
||||
//> \verbatim
|
||||
//> F is DOUBLE PRECISION
|
||||
//> The first component of vector to be rotated.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] G
|
||||
//> \verbatim
|
||||
//> G is DOUBLE PRECISION
|
||||
//> The second component of vector to be rotated.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] CS
|
||||
//> \verbatim
|
||||
//> CS is DOUBLE PRECISION
|
||||
//> The cosine of the rotation.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] SN
|
||||
//> \verbatim
|
||||
//> SN is DOUBLE PRECISION
|
||||
//> The sine of the rotation.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] R
|
||||
//> \verbatim
|
||||
//> R is DOUBLE PRECISION
|
||||
//> The nonzero component of the rotated vector.
|
||||
//>
|
||||
//> This version has a few statements commented out for thread safety
|
||||
//> (machine parameters are computed on each entry). 10 feb 03, SJH.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlartg_(double *f, double *g, double *cs, double *sn,
|
||||
double *r__)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
double d__1, d__2;
|
||||
|
||||
// Local variables
|
||||
int i__;
|
||||
double f1, g1, eps, scale;
|
||||
int count;
|
||||
double safmn2, safmx2;
|
||||
extern double dlamch_(char *);
|
||||
double safmin;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// LOGICAL FIRST
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Save statement ..
|
||||
// SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
|
||||
// ..
|
||||
// .. Data statements ..
|
||||
// DATA FIRST / .TRUE. /
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// IF( FIRST ) THEN
|
||||
safmin = dlamch_("S");
|
||||
eps = dlamch_("E");
|
||||
d__1 = dlamch_("B");
|
||||
i__1 = (int) (log(safmin / eps) / log(dlamch_("B")) / 2.);
|
||||
safmn2 = pow_di(&d__1, &i__1);
|
||||
safmx2 = 1. / safmn2;
|
||||
// FIRST = .FALSE.
|
||||
// END IF
|
||||
if (*g == 0.) {
|
||||
*cs = 1.;
|
||||
*sn = 0.;
|
||||
*r__ = *f;
|
||||
} else if (*f == 0.) {
|
||||
*cs = 0.;
|
||||
*sn = 1.;
|
||||
*r__ = *g;
|
||||
} else {
|
||||
f1 = *f;
|
||||
g1 = *g;
|
||||
// Computing MAX
|
||||
d__1 = abs(f1), d__2 = abs(g1);
|
||||
scale = max(d__1,d__2);
|
||||
if (scale >= safmx2) {
|
||||
count = 0;
|
||||
L10:
|
||||
++count;
|
||||
f1 *= safmn2;
|
||||
g1 *= safmn2;
|
||||
// Computing MAX
|
||||
d__1 = abs(f1), d__2 = abs(g1);
|
||||
scale = max(d__1,d__2);
|
||||
if (scale >= safmx2) {
|
||||
goto L10;
|
||||
}
|
||||
// Computing 2nd power
|
||||
d__1 = f1;
|
||||
// Computing 2nd power
|
||||
d__2 = g1;
|
||||
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
|
||||
*cs = f1 / *r__;
|
||||
*sn = g1 / *r__;
|
||||
i__1 = count;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
*r__ *= safmx2;
|
||||
// L20:
|
||||
}
|
||||
} else if (scale <= safmn2) {
|
||||
count = 0;
|
||||
L30:
|
||||
++count;
|
||||
f1 *= safmx2;
|
||||
g1 *= safmx2;
|
||||
// Computing MAX
|
||||
d__1 = abs(f1), d__2 = abs(g1);
|
||||
scale = max(d__1,d__2);
|
||||
if (scale <= safmn2) {
|
||||
goto L30;
|
||||
}
|
||||
// Computing 2nd power
|
||||
d__1 = f1;
|
||||
// Computing 2nd power
|
||||
d__2 = g1;
|
||||
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
|
||||
*cs = f1 / *r__;
|
||||
*sn = g1 / *r__;
|
||||
i__1 = count;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
*r__ *= safmn2;
|
||||
// L40:
|
||||
}
|
||||
} else {
|
||||
// Computing 2nd power
|
||||
d__1 = f1;
|
||||
// Computing 2nd power
|
||||
d__2 = g1;
|
||||
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
|
||||
*cs = f1 / *r__;
|
||||
*sn = g1 / *r__;
|
||||
}
|
||||
if (abs(*f) > abs(*g) && *cs < 0.) {
|
||||
*cs = -(*cs);
|
||||
*sn = -(*sn);
|
||||
*r__ = -(*r__);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLARTG
|
||||
//
|
||||
} // dlartg_
|
||||
|
||||
413
3rdparty/clapack/src/dlascl.c
vendored
Normal file
413
3rdparty/clapack/src/dlascl.c
vendored
Normal file
@ -0,0 +1,413 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLASCL + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlascl.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlascl.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlascl.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER TYPE
|
||||
// INTEGER INFO, KL, KU, LDA, M, N
|
||||
// DOUBLE PRECISION CFROM, CTO
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLASCL multiplies the M by N real matrix A by the real scalar
|
||||
//> CTO/CFROM. This is done without over/underflow as long as the final
|
||||
//> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
|
||||
//> A may be full, upper triangular, lower triangular, upper Hessenberg,
|
||||
//> or banded.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] TYPE
|
||||
//> \verbatim
|
||||
//> TYPE is CHARACTER*1
|
||||
//> TYPE indices the storage type of the input matrix.
|
||||
//> = 'G': A is a full matrix.
|
||||
//> = 'L': A is a lower triangular matrix.
|
||||
//> = 'U': A is an upper triangular matrix.
|
||||
//> = 'H': A is an upper Hessenberg matrix.
|
||||
//> = 'B': A is a symmetric band matrix with lower bandwidth KL
|
||||
//> and upper bandwidth KU and with the only the lower
|
||||
//> half stored.
|
||||
//> = 'Q': A is a symmetric band matrix with lower bandwidth KL
|
||||
//> and upper bandwidth KU and with the only the upper
|
||||
//> half stored.
|
||||
//> = 'Z': A is a band matrix with lower bandwidth KL and upper
|
||||
//> bandwidth KU. See DGBTRF for storage details.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] KL
|
||||
//> \verbatim
|
||||
//> KL is INTEGER
|
||||
//> The lower bandwidth of A. Referenced only if TYPE = 'B',
|
||||
//> 'Q' or 'Z'.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] KU
|
||||
//> \verbatim
|
||||
//> KU is INTEGER
|
||||
//> The upper bandwidth of A. Referenced only if TYPE = 'B',
|
||||
//> 'Q' or 'Z'.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] CFROM
|
||||
//> \verbatim
|
||||
//> CFROM is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] CTO
|
||||
//> \verbatim
|
||||
//> CTO is DOUBLE PRECISION
|
||||
//>
|
||||
//> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
|
||||
//> without over/underflow if the final result CTO*A(I,J)/CFROM
|
||||
//> can be represented without over/underflow. CFROM must be
|
||||
//> nonzero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A. N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> The matrix to be multiplied by CTO/CFROM. See TYPE for the
|
||||
//> storage type.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A.
|
||||
//> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
|
||||
//> TYPE = 'B', LDA >= KL+1;
|
||||
//> TYPE = 'Q', LDA >= KU+1;
|
||||
//> TYPE = 'Z', LDA >= 2*KL+KU+1.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] INFO
|
||||
//> \verbatim
|
||||
//> INFO is INTEGER
|
||||
//> 0 - successful exit
|
||||
//> <0 - if INFO = -i, the i-th argument had an illegal value.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date June 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlascl_(char *type__, int *kl, int *ku, double *cfrom,
|
||||
double *cto, int *m, int *n, double *a, int *lda, int *info)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
|
||||
|
||||
// Local variables
|
||||
int i__, j, k1, k2, k3, k4;
|
||||
double mul, cto1;
|
||||
int done;
|
||||
double ctoc;
|
||||
extern int lsame_(char *, char *);
|
||||
int itype;
|
||||
double cfrom1;
|
||||
extern double dlamch_(char *);
|
||||
double cfromc;
|
||||
extern int disnan_(double *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
double bignum, smlnum;
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// June 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
if (lsame_(type__, "G")) {
|
||||
itype = 0;
|
||||
} else if (lsame_(type__, "L")) {
|
||||
itype = 1;
|
||||
} else if (lsame_(type__, "U")) {
|
||||
itype = 2;
|
||||
} else if (lsame_(type__, "H")) {
|
||||
itype = 3;
|
||||
} else if (lsame_(type__, "B")) {
|
||||
itype = 4;
|
||||
} else if (lsame_(type__, "Q")) {
|
||||
itype = 5;
|
||||
} else if (lsame_(type__, "Z")) {
|
||||
itype = 6;
|
||||
} else {
|
||||
itype = -1;
|
||||
}
|
||||
if (itype == -1) {
|
||||
*info = -1;
|
||||
} else if (*cfrom == 0. || disnan_(cfrom)) {
|
||||
*info = -4;
|
||||
} else if (disnan_(cto)) {
|
||||
*info = -5;
|
||||
} else if (*m < 0) {
|
||||
*info = -6;
|
||||
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
|
||||
*info = -7;
|
||||
} else if (itype <= 3 && *lda < max(1,*m)) {
|
||||
*info = -9;
|
||||
} else if (itype >= 4) {
|
||||
// Computing MAX
|
||||
i__1 = *m - 1;
|
||||
if (*kl < 0 || *kl > max(i__1,0)) {
|
||||
*info = -2;
|
||||
} else /* if(complicated condition) */ {
|
||||
// Computing MAX
|
||||
i__1 = *n - 1;
|
||||
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
|
||||
*kl != *ku) {
|
||||
*info = -3;
|
||||
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
|
||||
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
|
||||
*info = -9;
|
||||
}
|
||||
}
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DLASCL", &i__1);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*n == 0 || *m == 0) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Get machine parameters
|
||||
//
|
||||
smlnum = dlamch_("S");
|
||||
bignum = 1. / smlnum;
|
||||
cfromc = *cfrom;
|
||||
ctoc = *cto;
|
||||
L10:
|
||||
cfrom1 = cfromc * smlnum;
|
||||
if (cfrom1 == cfromc) {
|
||||
// CFROMC is an inf. Multiply by a correctly signed zero for
|
||||
// finite CTOC, or a NaN if CTOC is infinite.
|
||||
mul = ctoc / cfromc;
|
||||
done = TRUE_;
|
||||
cto1 = ctoc;
|
||||
} else {
|
||||
cto1 = ctoc / bignum;
|
||||
if (cto1 == ctoc) {
|
||||
// CTOC is either 0 or an inf. In both cases, CTOC itself
|
||||
// serves as the correct multiplication factor.
|
||||
mul = ctoc;
|
||||
done = TRUE_;
|
||||
cfromc = 1.;
|
||||
} else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
|
||||
mul = smlnum;
|
||||
done = FALSE_;
|
||||
cfromc = cfrom1;
|
||||
} else if (abs(cto1) > abs(cfromc)) {
|
||||
mul = bignum;
|
||||
done = FALSE_;
|
||||
ctoc = cto1;
|
||||
} else {
|
||||
mul = ctoc / cfromc;
|
||||
done = TRUE_;
|
||||
}
|
||||
}
|
||||
if (itype == 0) {
|
||||
//
|
||||
// Full matrix
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L20:
|
||||
}
|
||||
// L30:
|
||||
}
|
||||
} else if (itype == 1) {
|
||||
//
|
||||
// Lower triangular matrix
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = j; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L40:
|
||||
}
|
||||
// L50:
|
||||
}
|
||||
} else if (itype == 2) {
|
||||
//
|
||||
// Upper triangular matrix
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = min(j,*m);
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L60:
|
||||
}
|
||||
// L70:
|
||||
}
|
||||
} else if (itype == 3) {
|
||||
//
|
||||
// Upper Hessenberg matrix
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
// Computing MIN
|
||||
i__3 = j + 1;
|
||||
i__2 = min(i__3,*m);
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L80:
|
||||
}
|
||||
// L90:
|
||||
}
|
||||
} else if (itype == 4) {
|
||||
//
|
||||
// Lower half of a symmetric band matrix
|
||||
//
|
||||
k3 = *kl + 1;
|
||||
k4 = *n + 1;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
// Computing MIN
|
||||
i__3 = k3, i__4 = k4 - j;
|
||||
i__2 = min(i__3,i__4);
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L100:
|
||||
}
|
||||
// L110:
|
||||
}
|
||||
} else if (itype == 5) {
|
||||
//
|
||||
// Upper half of a symmetric band matrix
|
||||
//
|
||||
k1 = *ku + 2;
|
||||
k3 = *ku + 1;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
// Computing MAX
|
||||
i__2 = k1 - j;
|
||||
i__3 = k3;
|
||||
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L120:
|
||||
}
|
||||
// L130:
|
||||
}
|
||||
} else if (itype == 6) {
|
||||
//
|
||||
// Band matrix
|
||||
//
|
||||
k1 = *kl + *ku + 2;
|
||||
k2 = *kl + 1;
|
||||
k3 = (*kl << 1) + *ku + 1;
|
||||
k4 = *kl + *ku + 1 + *m;
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
// Computing MAX
|
||||
i__3 = k1 - j;
|
||||
// Computing MIN
|
||||
i__4 = k3, i__5 = k4 - j;
|
||||
i__2 = min(i__4,i__5);
|
||||
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] *= mul;
|
||||
// L140:
|
||||
}
|
||||
// L150:
|
||||
}
|
||||
}
|
||||
if (! done) {
|
||||
goto L10;
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLASCL
|
||||
//
|
||||
} // dlascl_
|
||||
|
||||
209
3rdparty/clapack/src/dlaset.c
vendored
Normal file
209
3rdparty/clapack/src/dlaset.c
vendored
Normal file
@ -0,0 +1,209 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLASET + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaset.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaset.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaset.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER UPLO
|
||||
// INTEGER LDA, M, N
|
||||
// DOUBLE PRECISION ALPHA, BETA
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLASET initializes an m-by-n matrix A to BETA on the diagonal and
|
||||
//> ALPHA on the offdiagonals.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] UPLO
|
||||
//> \verbatim
|
||||
//> UPLO is CHARACTER*1
|
||||
//> Specifies the part of the matrix A to be set.
|
||||
//> = 'U': Upper triangular part is set; the strictly lower
|
||||
//> triangular part of A is not changed.
|
||||
//> = 'L': Lower triangular part is set; the strictly upper
|
||||
//> triangular part of A is not changed.
|
||||
//> Otherwise: All of the matrix A is set.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix A. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix A. N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is DOUBLE PRECISION
|
||||
//> The constant to which the offdiagonal elements are to be set.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] BETA
|
||||
//> \verbatim
|
||||
//> BETA is DOUBLE PRECISION
|
||||
//> The constant to which the diagonal elements are to be set.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> On exit, the leading m-by-n submatrix of A is set as follows:
|
||||
//>
|
||||
//> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
|
||||
//> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
|
||||
//> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
|
||||
//>
|
||||
//> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A. LDA >= max(1,M).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlaset_(char *uplo, int *m, int *n, double *alpha,
|
||||
double *beta, double *a, int *lda)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2, i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j;
|
||||
extern int lsame_(char *, char *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
//=====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
|
||||
// Function Body
|
||||
if (lsame_(uplo, "U")) {
|
||||
//
|
||||
// Set the strictly upper triangular or trapezoidal part of the
|
||||
// array to ALPHA.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 2; j <= i__1; ++j) {
|
||||
// Computing MIN
|
||||
i__3 = j - 1;
|
||||
i__2 = min(i__3,*m);
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] = *alpha;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else if (lsame_(uplo, "L")) {
|
||||
//
|
||||
// Set the strictly lower triangular or trapezoidal part of the
|
||||
// array to ALPHA.
|
||||
//
|
||||
i__1 = min(*m,*n);
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = j + 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] = *alpha;
|
||||
// L30:
|
||||
}
|
||||
// L40:
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// Set the leading m-by-n submatrix to ALPHA.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] = *alpha;
|
||||
// L50:
|
||||
}
|
||||
// L60:
|
||||
}
|
||||
}
|
||||
//
|
||||
// Set the first min(M,N) diagonal elements to BETA.
|
||||
//
|
||||
i__1 = min(*m,*n);
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
a[i__ + i__ * a_dim1] = *beta;
|
||||
// L70:
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLASET
|
||||
//
|
||||
} // dlaset_
|
||||
|
||||
172
3rdparty/clapack/src/dlassq.c
vendored
Normal file
172
3rdparty/clapack/src/dlassq.c
vendored
Normal file
@ -0,0 +1,172 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DLASSQ updates a sum of squares represented in scaled form.
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DLASSQ + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlassq.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlassq.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlassq.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX, N
|
||||
// DOUBLE PRECISION SCALE, SUMSQ
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION X( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DLASSQ returns the values scl and smsq such that
|
||||
//>
|
||||
//> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
|
||||
//>
|
||||
//> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
|
||||
//> assumed to be non-negative and scl returns the value
|
||||
//>
|
||||
//> scl = max( scale, abs( x( i ) ) ).
|
||||
//>
|
||||
//> scale and sumsq must be supplied in SCALE and SUMSQ and
|
||||
//> scl and smsq are overwritten on SCALE and SUMSQ respectively.
|
||||
//>
|
||||
//> The routine makes only one pass through the vector x.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of elements to be used from the vector X.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, dimension (1+(N-1)*INCX)
|
||||
//> The vector for which a scaled sum of squares is computed.
|
||||
//> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> The increment between successive values of the vector X.
|
||||
//> INCX > 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] SCALE
|
||||
//> \verbatim
|
||||
//> SCALE is DOUBLE PRECISION
|
||||
//> On entry, the value scale in the equation above.
|
||||
//> On exit, SCALE is overwritten with scl , the scaling factor
|
||||
//> for the sum of squares.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] SUMSQ
|
||||
//> \verbatim
|
||||
//> SUMSQ is DOUBLE PRECISION
|
||||
//> On entry, the value sumsq in the equation above.
|
||||
//> On exit, SUMSQ is overwritten with smsq , the basic sum of
|
||||
//> squares from which scl has been factored out.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup OTHERauxiliary
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dlassq_(int *n, double *x, int *incx, double *scale,
|
||||
double *sumsq)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1, i__2;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int ix;
|
||||
double absxi;
|
||||
extern int disnan_(double *);
|
||||
|
||||
//
|
||||
// -- LAPACK auxiliary routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
//=====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Parameter adjustments
|
||||
--x;
|
||||
|
||||
// Function Body
|
||||
if (*n > 0) {
|
||||
i__1 = (*n - 1) * *incx + 1;
|
||||
i__2 = *incx;
|
||||
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
|
||||
absxi = (d__1 = x[ix], abs(d__1));
|
||||
if (absxi > 0. || disnan_(&absxi)) {
|
||||
if (*scale < absxi) {
|
||||
// Computing 2nd power
|
||||
d__1 = *scale / absxi;
|
||||
*sumsq = *sumsq * (d__1 * d__1) + 1;
|
||||
*scale = absxi;
|
||||
} else {
|
||||
// Computing 2nd power
|
||||
d__1 = absxi / *scale;
|
||||
*sumsq += d__1 * d__1;
|
||||
}
|
||||
}
|
||||
// L10:
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DLASSQ
|
||||
//
|
||||
} // dlassq_
|
||||
|
||||
149
3rdparty/clapack/src/dnrm2.c
vendored
Normal file
149
3rdparty/clapack/src/dnrm2.c
vendored
Normal file
@ -0,0 +1,149 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DNRM2
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION X(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DNRM2 returns the euclidean norm of a vector via the function
|
||||
//> name, so that
|
||||
//>
|
||||
//> DNRM2 := sqrt( x'*x )
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> storage spacing between elements of DX
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup double_blas_level1
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> -- This version written on 25-October-1982.
|
||||
//> Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||
//> Sven Hammarling, Nag Ltd.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
double dnrm2_(int *n, double *x, int *incx)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1, i__2;
|
||||
double ret_val, d__1;
|
||||
|
||||
// Local variables
|
||||
int ix;
|
||||
double ssq, norm, scale, absxi;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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_
|
||||
|
||||
571
3rdparty/clapack/src/dorgqr.c
vendored
Normal file
571
3rdparty/clapack/src/dorgqr.c
vendored
Normal file
@ -0,0 +1,571 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DORG2R + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorg2r.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorg2r.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorg2r.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INFO, K, LDA, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DORG2R generates an m by n real matrix Q with orthonormal columns,
|
||||
//> which is defined as the first n columns of a product of k elementary
|
||||
//> reflectors of order m
|
||||
//>
|
||||
//> Q = H(1) H(2) . . . H(k)
|
||||
//>
|
||||
//> as returned by DGEQRF.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix Q. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix Q. M >= N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The number of elementary reflectors whose product defines the
|
||||
//> matrix Q. N >= K >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> On entry, the i-th column must contain the vector which
|
||||
//> defines the elementary reflector H(i), for i = 1,2,...,k, as
|
||||
//> returned by DGEQRF in the first k columns of its array
|
||||
//> argument A.
|
||||
//> On exit, the m-by-n matrix Q.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The first dimension of the array A. LDA >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
//> TAU(i) must contain the scalar factor of the elementary
|
||||
//> reflector H(i), as returned by DGEQRF.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension (N)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] INFO
|
||||
//> \verbatim
|
||||
//> INFO is INTEGER
|
||||
//> = 0: successful exit
|
||||
//> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dorg2r_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
double d__1;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l;
|
||||
extern /* Subroutine */ int dscal_(int *, double *, double *, int *),
|
||||
dlarf_(char *, int *, int *, double *, int *, double *, double *,
|
||||
int *, double *), xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- LAPACK computational routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--tau;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
if (*m < 0) {
|
||||
*info = -1;
|
||||
} else if (*n < 0 || *n > *m) {
|
||||
*info = -2;
|
||||
} else if (*k < 0 || *k > *n) {
|
||||
*info = -3;
|
||||
} else if (*lda < max(1,*m)) {
|
||||
*info = -5;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORG2R", &i__1);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Initialise columns k+1:n to columns of the unit matrix
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = *k + 1; j <= i__1; ++j) {
|
||||
i__2 = *m;
|
||||
for (l = 1; l <= i__2; ++l) {
|
||||
a[l + j * a_dim1] = 0.;
|
||||
// L10:
|
||||
}
|
||||
a[j + j * a_dim1] = 1.;
|
||||
// L20:
|
||||
}
|
||||
for (i__ = *k; i__ >= 1; --i__) {
|
||||
//
|
||||
// Apply H(i) to A(i:m,i:n) from the left
|
||||
//
|
||||
if (i__ < *n) {
|
||||
a[i__ + i__ * a_dim1] = 1.;
|
||||
i__1 = *m - i__ + 1;
|
||||
i__2 = *n - i__;
|
||||
dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
|
||||
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
|
||||
}
|
||||
if (i__ < *m) {
|
||||
i__1 = *m - i__;
|
||||
d__1 = -tau[i__];
|
||||
dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
|
||||
}
|
||||
a[i__ + i__ * a_dim1] = 1. - tau[i__];
|
||||
//
|
||||
// Set A(1:i-1,i) to zero
|
||||
//
|
||||
i__1 = i__ - 1;
|
||||
for (l = 1; l <= i__1; ++l) {
|
||||
a[l + i__ * a_dim1] = 0.;
|
||||
// L30:
|
||||
}
|
||||
// L40:
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DORG2R
|
||||
//
|
||||
} // dorg2r_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DORGQR
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DORGQR + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorgqr.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorgqr.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorgqr.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INFO, K, LDA, LWORK, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DORGQR generates an M-by-N real matrix Q with orthonormal columns,
|
||||
//> which is defined as the first N columns of a product of K elementary
|
||||
//> reflectors of order M
|
||||
//>
|
||||
//> Q = H(1) H(2) . . . H(k)
|
||||
//>
|
||||
//> as returned by DGEQRF.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix Q. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix Q. M >= N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The number of elementary reflectors whose product defines the
|
||||
//> matrix Q. N >= K >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,N)
|
||||
//> On entry, the i-th column must contain the vector which
|
||||
//> defines the elementary reflector H(i), for i = 1,2,...,k, as
|
||||
//> returned by DGEQRF in the first k columns of its array
|
||||
//> argument A.
|
||||
//> On exit, the M-by-N matrix Q.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The first dimension of the array A. LDA >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
//> TAU(i) must contain the scalar factor of the elementary
|
||||
//> reflector H(i), as returned by DGEQRF.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
|
||||
//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LWORK
|
||||
//> \verbatim
|
||||
//> LWORK is INTEGER
|
||||
//> The dimension of the array WORK. LWORK >= max(1,N).
|
||||
//> For optimum performance LWORK >= N*NB, where NB is the
|
||||
//> optimal blocksize.
|
||||
//>
|
||||
//> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
//> only calculates the optimal size of the WORK array, returns
|
||||
//> this value as the first entry of the WORK array, and no error
|
||||
//> message related to LWORK is issued by XERBLA.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] INFO
|
||||
//> \verbatim
|
||||
//> INFO is INTEGER
|
||||
//> = 0: successful exit
|
||||
//> < 0: if INFO = -i, the i-th argument has an illegal value
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dorgqr_(int *m, int *n, int *k, double *a, int *lda,
|
||||
double *tau, double *work, int *lwork, int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
int c_n1 = -1;
|
||||
int c__3 = 3;
|
||||
int c__2 = 2;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2, i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
|
||||
extern /* Subroutine */ int dorg2r_(int *, int *, int *, double *, int *,
|
||||
double *, double *, int *), dlarfb_(char *, char *, char *, char *
|
||||
, int *, int *, int *, double *, int *, double *, int *, double *,
|
||||
int *, double *, int *), dlarft_(char *, char *, int *, int *,
|
||||
double *, int *, double *, double *, int *), xerbla_(char *, int *
|
||||
);
|
||||
extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *);
|
||||
int ldwork, lwkopt;
|
||||
int lquery;
|
||||
|
||||
//
|
||||
// -- LAPACK computational routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--tau;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1);
|
||||
lwkopt = max(1,*n) * nb;
|
||||
work[1] = (double) lwkopt;
|
||||
lquery = *lwork == -1;
|
||||
if (*m < 0) {
|
||||
*info = -1;
|
||||
} else if (*n < 0 || *n > *m) {
|
||||
*info = -2;
|
||||
} else if (*k < 0 || *k > *n) {
|
||||
*info = -3;
|
||||
} else if (*lda < max(1,*m)) {
|
||||
*info = -5;
|
||||
} else if (*lwork < max(1,*n) && ! lquery) {
|
||||
*info = -8;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORGQR", &i__1);
|
||||
return 0;
|
||||
} else if (lquery) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*n <= 0) {
|
||||
work[1] = 1.;
|
||||
return 0;
|
||||
}
|
||||
nbmin = 2;
|
||||
nx = 0;
|
||||
iws = *n;
|
||||
if (nb > 1 && nb < *k) {
|
||||
//
|
||||
// Determine when to cross over from blocked to unblocked code.
|
||||
//
|
||||
// Computing MAX
|
||||
i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1);
|
||||
nx = max(i__1,i__2);
|
||||
if (nx < *k) {
|
||||
//
|
||||
// Determine if workspace is large enough for blocked code.
|
||||
//
|
||||
ldwork = *n;
|
||||
iws = ldwork * nb;
|
||||
if (*lwork < iws) {
|
||||
//
|
||||
// Not enough workspace to use optimal NB: reduce NB and
|
||||
// determine the minimum value of NB.
|
||||
//
|
||||
nb = *lwork / ldwork;
|
||||
// Computing MAX
|
||||
i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1)
|
||||
;
|
||||
nbmin = max(i__1,i__2);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (nb >= nbmin && nb < *k && nx < *k) {
|
||||
//
|
||||
// Use blocked code after the last block.
|
||||
// The first kk columns are handled by the block method.
|
||||
//
|
||||
ki = (*k - nx - 1) / nb * nb;
|
||||
// Computing MIN
|
||||
i__1 = *k, i__2 = ki + nb;
|
||||
kk = min(i__1,i__2);
|
||||
//
|
||||
// Set A(1:kk,kk+1:n) to zero.
|
||||
//
|
||||
i__1 = *n;
|
||||
for (j = kk + 1; j <= i__1; ++j) {
|
||||
i__2 = kk;
|
||||
for (i__ = 1; i__ <= i__2; ++i__) {
|
||||
a[i__ + j * a_dim1] = 0.;
|
||||
// L10:
|
||||
}
|
||||
// L20:
|
||||
}
|
||||
} else {
|
||||
kk = 0;
|
||||
}
|
||||
//
|
||||
// Use unblocked code for the last or only block.
|
||||
//
|
||||
if (kk < *n) {
|
||||
i__1 = *m - kk;
|
||||
i__2 = *n - kk;
|
||||
i__3 = *k - kk;
|
||||
dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
|
||||
tau[kk + 1], &work[1], &iinfo);
|
||||
}
|
||||
if (kk > 0) {
|
||||
//
|
||||
// Use blocked code
|
||||
//
|
||||
i__1 = -nb;
|
||||
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
|
||||
// Computing MIN
|
||||
i__2 = nb, i__3 = *k - i__ + 1;
|
||||
ib = min(i__2,i__3);
|
||||
if (i__ + ib <= *n) {
|
||||
//
|
||||
// Form the triangular factor of the block reflector
|
||||
// H = H(i) H(i+1) . . . H(i+ib-1)
|
||||
//
|
||||
i__2 = *m - i__ + 1;
|
||||
dlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
|
||||
a_dim1], lda, &tau[i__], &work[1], &ldwork);
|
||||
//
|
||||
// Apply H to A(i:m,i+ib:n) from the left
|
||||
//
|
||||
i__2 = *m - i__ + 1;
|
||||
i__3 = *n - i__ - ib + 1;
|
||||
dlarfb_("Left", "No transpose", "Forward", "Columnwise", &
|
||||
i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
|
||||
1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
|
||||
work[ib + 1], &ldwork);
|
||||
}
|
||||
//
|
||||
// Apply H to rows i:m of current block
|
||||
//
|
||||
i__2 = *m - i__ + 1;
|
||||
dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
|
||||
work[1], &iinfo);
|
||||
//
|
||||
// Set rows 1:i-1 of current block to zero
|
||||
//
|
||||
i__2 = i__ + ib - 1;
|
||||
for (j = i__; j <= i__2; ++j) {
|
||||
i__3 = i__ - 1;
|
||||
for (l = 1; l <= i__3; ++l) {
|
||||
a[l + j * a_dim1] = 0.;
|
||||
// L30:
|
||||
}
|
||||
// L40:
|
||||
}
|
||||
// L50:
|
||||
}
|
||||
}
|
||||
work[1] = (double) iws;
|
||||
return 0;
|
||||
//
|
||||
// End of DORGQR
|
||||
//
|
||||
} // dorgqr_
|
||||
|
||||
684
3rdparty/clapack/src/dormqr.c
vendored
Normal file
684
3rdparty/clapack/src/dormqr.c
vendored
Normal file
@ -0,0 +1,684 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DORM2R + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorm2r.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorm2r.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorm2r.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
|
||||
// WORK, INFO )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER SIDE, TRANS
|
||||
// INTEGER INFO, K, LDA, LDC, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DORM2R overwrites the general real m by n matrix C with
|
||||
//>
|
||||
//> Q * C if SIDE = 'L' and TRANS = 'N', or
|
||||
//>
|
||||
//> Q**T* C if SIDE = 'L' and TRANS = 'T', or
|
||||
//>
|
||||
//> C * Q if SIDE = 'R' and TRANS = 'N', or
|
||||
//>
|
||||
//> C * Q**T if SIDE = 'R' and TRANS = 'T',
|
||||
//>
|
||||
//> where Q is a real orthogonal matrix defined as the product of k
|
||||
//> elementary reflectors
|
||||
//>
|
||||
//> Q = H(1) H(2) . . . H(k)
|
||||
//>
|
||||
//> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
|
||||
//> if SIDE = 'R'.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is CHARACTER*1
|
||||
//> = 'L': apply Q or Q**T from the Left
|
||||
//> = 'R': apply Q or Q**T from the Right
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is CHARACTER*1
|
||||
//> = 'N': apply Q (No transpose)
|
||||
//> = 'T': apply Q**T (Transpose)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix C. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix C. N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The number of elementary reflectors whose product defines
|
||||
//> the matrix Q.
|
||||
//> If SIDE = 'L', M >= K >= 0;
|
||||
//> if SIDE = 'R', N >= K >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,K)
|
||||
//> The i-th column must contain the vector which defines the
|
||||
//> elementary reflector H(i), for i = 1,2,...,k, as returned by
|
||||
//> DGEQRF in the first k columns of its array argument A.
|
||||
//> A is modified by the routine but restored on exit.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A.
|
||||
//> If SIDE = 'L', LDA >= max(1,M);
|
||||
//> if SIDE = 'R', LDA >= max(1,N).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
//> TAU(i) must contain the scalar factor of the elementary
|
||||
//> reflector H(i), as returned by DGEQRF.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION array, dimension (LDC,N)
|
||||
//> On entry, the m by n matrix C.
|
||||
//> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is INTEGER
|
||||
//> The leading dimension of the array C. LDC >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension
|
||||
//> (N) if SIDE = 'L',
|
||||
//> (M) if SIDE = 'R'
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] INFO
|
||||
//> \verbatim
|
||||
//> INFO is INTEGER
|
||||
//> = 0: successful exit
|
||||
//> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dorm2r_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, i1, i2, i3, ic, jc, mi, ni, nq;
|
||||
double aii;
|
||||
int left;
|
||||
extern /* Subroutine */ int dlarf_(char *, int *, int *, double *, int *,
|
||||
double *, double *, int *, double *);
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
int notran;
|
||||
|
||||
//
|
||||
// -- LAPACK computational routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--tau;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
left = lsame_(side, "L");
|
||||
notran = lsame_(trans, "N");
|
||||
//
|
||||
// NQ is the order of Q
|
||||
//
|
||||
if (left) {
|
||||
nq = *m;
|
||||
} else {
|
||||
nq = *n;
|
||||
}
|
||||
if (! left && ! lsame_(side, "R")) {
|
||||
*info = -1;
|
||||
} else if (! notran && ! lsame_(trans, "T")) {
|
||||
*info = -2;
|
||||
} else if (*m < 0) {
|
||||
*info = -3;
|
||||
} else if (*n < 0) {
|
||||
*info = -4;
|
||||
} else if (*k < 0 || *k > nq) {
|
||||
*info = -5;
|
||||
} else if (*lda < max(1,nq)) {
|
||||
*info = -7;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
*info = -10;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORM2R", &i__1);
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*m == 0 || *n == 0 || *k == 0) {
|
||||
return 0;
|
||||
}
|
||||
if (left && ! notran || ! left && notran) {
|
||||
i1 = 1;
|
||||
i2 = *k;
|
||||
i3 = 1;
|
||||
} else {
|
||||
i1 = *k;
|
||||
i2 = 1;
|
||||
i3 = -1;
|
||||
}
|
||||
if (left) {
|
||||
ni = *n;
|
||||
jc = 1;
|
||||
} else {
|
||||
mi = *m;
|
||||
ic = 1;
|
||||
}
|
||||
i__1 = i2;
|
||||
i__2 = i3;
|
||||
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
if (left) {
|
||||
//
|
||||
// H(i) is applied to C(i:m,1:n)
|
||||
//
|
||||
mi = *m - i__ + 1;
|
||||
ic = i__;
|
||||
} else {
|
||||
//
|
||||
// H(i) is applied to C(1:m,i:n)
|
||||
//
|
||||
ni = *n - i__ + 1;
|
||||
jc = i__;
|
||||
}
|
||||
//
|
||||
// Apply H(i)
|
||||
//
|
||||
aii = a[i__ + i__ * a_dim1];
|
||||
a[i__ + i__ * a_dim1] = 1.;
|
||||
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
|
||||
ic + jc * c_dim1], ldc, &work[1]);
|
||||
a[i__ + i__ * a_dim1] = aii;
|
||||
// L10:
|
||||
}
|
||||
return 0;
|
||||
//
|
||||
// End of DORM2R
|
||||
//
|
||||
} // dorm2r_
|
||||
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
//> \brief \b DORMQR
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
//> \htmlonly
|
||||
//> Download DORMQR + dependencies
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormqr.f">
|
||||
//> [TGZ]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormqr.f">
|
||||
//> [ZIP]</a>
|
||||
//> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormqr.f">
|
||||
//> [TXT]</a>
|
||||
//> \endhtmlonly
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
|
||||
// WORK, LWORK, INFO )
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// CHARACTER SIDE, TRANS
|
||||
// INTEGER INFO, K, LDA, LDC, LWORK, M, N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DORMQR overwrites the general real M-by-N matrix C with
|
||||
//>
|
||||
//> SIDE = 'L' SIDE = 'R'
|
||||
//> TRANS = 'N': Q * C C * Q
|
||||
//> TRANS = 'T': Q**T * C C * Q**T
|
||||
//>
|
||||
//> where Q is a real orthogonal matrix defined as the product of k
|
||||
//> elementary reflectors
|
||||
//>
|
||||
//> Q = H(1) H(2) . . . H(k)
|
||||
//>
|
||||
//> as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
|
||||
//> if SIDE = 'R'.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is CHARACTER*1
|
||||
//> = 'L': apply Q or Q**T from the Left;
|
||||
//> = 'R': apply Q or Q**T from the Right.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is CHARACTER*1
|
||||
//> = 'N': No transpose, apply Q;
|
||||
//> = 'T': Transpose, apply Q**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> The number of rows of the matrix C. M >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> The number of columns of the matrix C. N >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is INTEGER
|
||||
//> The number of elementary reflectors whose product defines
|
||||
//> the matrix Q.
|
||||
//> If SIDE = 'L', M >= K >= 0;
|
||||
//> if SIDE = 'R', N >= K >= 0.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, dimension (LDA,K)
|
||||
//> The i-th column must contain the vector which defines the
|
||||
//> elementary reflector H(i), for i = 1,2,...,k, as returned by
|
||||
//> DGEQRF in the first k columns of its array argument A.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is INTEGER
|
||||
//> The leading dimension of the array A.
|
||||
//> If SIDE = 'L', LDA >= max(1,M);
|
||||
//> if SIDE = 'R', LDA >= max(1,N).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TAU
|
||||
//> \verbatim
|
||||
//> TAU is DOUBLE PRECISION array, dimension (K)
|
||||
//> TAU(i) must contain the scalar factor of the elementary
|
||||
//> reflector H(i), as returned by DGEQRF.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION array, dimension (LDC,N)
|
||||
//> On entry, the M-by-N matrix C.
|
||||
//> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is INTEGER
|
||||
//> The leading dimension of the array C. LDC >= max(1,M).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] WORK
|
||||
//> \verbatim
|
||||
//> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
|
||||
//> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LWORK
|
||||
//> \verbatim
|
||||
//> LWORK is INTEGER
|
||||
//> The dimension of the array WORK.
|
||||
//> If SIDE = 'L', LWORK >= max(1,N);
|
||||
//> if SIDE = 'R', LWORK >= max(1,M).
|
||||
//> For good performance, LWORK should generally be larger.
|
||||
//>
|
||||
//> If LWORK = -1, then a workspace query is assumed; the routine
|
||||
//> only calculates the optimal size of the WORK array, returns
|
||||
//> this value as the first entry of the WORK array, and no error
|
||||
//> message related to LWORK is issued by XERBLA.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[out] INFO
|
||||
//> \verbatim
|
||||
//> INFO is INTEGER
|
||||
//> = 0: successful exit
|
||||
//> < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup doubleOTHERcomputational
|
||||
//
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dormqr_(char *side, char *trans, int *m, int *n, int *k,
|
||||
double *a, int *lda, double *tau, double *c__, int *ldc, double *work,
|
||||
int *lwork, int *info)
|
||||
{
|
||||
// Table of constant values
|
||||
int c__1 = 1;
|
||||
int c_n1 = -1;
|
||||
int c__2 = 2;
|
||||
int c__65 = 65;
|
||||
|
||||
// System generated locals
|
||||
address a__1[2];
|
||||
int a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5;
|
||||
char ch__1[2+1]={'\0'};
|
||||
|
||||
// Local variables
|
||||
int i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt;
|
||||
int left;
|
||||
extern int lsame_(char *, char *);
|
||||
int nbmin, iinfo;
|
||||
extern /* Subroutine */ int dorm2r_(char *, char *, int *, int *, int *,
|
||||
double *, int *, double *, double *, int *, double *, int *),
|
||||
dlarfb_(char *, char *, char *, char *, int *, int *, int *,
|
||||
double *, int *, double *, int *, double *, int *, double *, int *
|
||||
), dlarft_(char *, char *, int *, int *, double *, int *, double *
|
||||
, double *, int *), xerbla_(char *, int *);
|
||||
extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *);
|
||||
int notran;
|
||||
int ldwork, lwkopt;
|
||||
int lquery;
|
||||
|
||||
//
|
||||
// -- LAPACK computational routine (version 3.7.0) --
|
||||
// -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Parameters ..
|
||||
// ..
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. External Functions ..
|
||||
// ..
|
||||
// .. External Subroutines ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// .. Executable Statements ..
|
||||
//
|
||||
// Test the input arguments
|
||||
//
|
||||
// Parameter adjustments
|
||||
a_dim1 = *lda;
|
||||
a_offset = 1 + a_dim1;
|
||||
a -= a_offset;
|
||||
--tau;
|
||||
c_dim1 = *ldc;
|
||||
c_offset = 1 + c_dim1;
|
||||
c__ -= c_offset;
|
||||
--work;
|
||||
|
||||
// Function Body
|
||||
*info = 0;
|
||||
left = lsame_(side, "L");
|
||||
notran = lsame_(trans, "N");
|
||||
lquery = *lwork == -1;
|
||||
//
|
||||
// NQ is the order of Q and NW is the minimum dimension of WORK
|
||||
//
|
||||
if (left) {
|
||||
nq = *m;
|
||||
nw = *n;
|
||||
} else {
|
||||
nq = *n;
|
||||
nw = *m;
|
||||
}
|
||||
if (! left && ! lsame_(side, "R")) {
|
||||
*info = -1;
|
||||
} else if (! notran && ! lsame_(trans, "T")) {
|
||||
*info = -2;
|
||||
} else if (*m < 0) {
|
||||
*info = -3;
|
||||
} else if (*n < 0) {
|
||||
*info = -4;
|
||||
} else if (*k < 0 || *k > nq) {
|
||||
*info = -5;
|
||||
} else if (*lda < max(1,nq)) {
|
||||
*info = -7;
|
||||
} else if (*ldc < max(1,*m)) {
|
||||
*info = -10;
|
||||
} else if (*lwork < max(1,nw) && ! lquery) {
|
||||
*info = -12;
|
||||
}
|
||||
if (*info == 0) {
|
||||
//
|
||||
// Compute the workspace requirements
|
||||
//
|
||||
// Computing MIN
|
||||
// Writing concatenation
|
||||
i__3[0] = 1, a__1[0] = side;
|
||||
i__3[1] = 1, a__1[1] = trans;
|
||||
s_cat(ch__1, a__1, i__3, &c__2);
|
||||
i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1);
|
||||
nb = min(i__1,i__2);
|
||||
lwkopt = max(1,nw) * nb + 4160;
|
||||
work[1] = (double) lwkopt;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_("DORMQR", &i__1);
|
||||
return 0;
|
||||
} else if (lquery) {
|
||||
return 0;
|
||||
}
|
||||
//
|
||||
// Quick return if possible
|
||||
//
|
||||
if (*m == 0 || *n == 0 || *k == 0) {
|
||||
work[1] = 1.;
|
||||
return 0;
|
||||
}
|
||||
nbmin = 2;
|
||||
ldwork = nw;
|
||||
if (nb > 1 && nb < *k) {
|
||||
if (*lwork < nw * nb + 4160) {
|
||||
nb = (*lwork - 4160) / ldwork;
|
||||
// Computing MAX
|
||||
// Writing concatenation
|
||||
i__3[0] = 1, a__1[0] = side;
|
||||
i__3[1] = 1, a__1[1] = trans;
|
||||
s_cat(ch__1, a__1, i__3, &c__2);
|
||||
i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1);
|
||||
nbmin = max(i__1,i__2);
|
||||
}
|
||||
}
|
||||
if (nb < nbmin || nb >= *k) {
|
||||
//
|
||||
// Use unblocked code
|
||||
//
|
||||
dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
|
||||
c_offset], ldc, &work[1], &iinfo);
|
||||
} else {
|
||||
//
|
||||
// Use blocked code
|
||||
//
|
||||
iwt = nw * nb + 1;
|
||||
if (left && ! notran || ! left && notran) {
|
||||
i1 = 1;
|
||||
i2 = *k;
|
||||
i3 = nb;
|
||||
} else {
|
||||
i1 = (*k - 1) / nb * nb + 1;
|
||||
i2 = 1;
|
||||
i3 = -nb;
|
||||
}
|
||||
if (left) {
|
||||
ni = *n;
|
||||
jc = 1;
|
||||
} else {
|
||||
mi = *m;
|
||||
ic = 1;
|
||||
}
|
||||
i__1 = i2;
|
||||
i__2 = i3;
|
||||
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
|
||||
// Computing MIN
|
||||
i__4 = nb, i__5 = *k - i__ + 1;
|
||||
ib = min(i__4,i__5);
|
||||
//
|
||||
// Form the triangular factor of the block reflector
|
||||
// H = H(i) H(i+1) . . . H(i+ib-1)
|
||||
//
|
||||
i__4 = nq - i__ + 1;
|
||||
dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
|
||||
a_dim1], lda, &tau[i__], &work[iwt], &c__65);
|
||||
if (left) {
|
||||
//
|
||||
// H or H**T is applied to C(i:m,1:n)
|
||||
//
|
||||
mi = *m - i__ + 1;
|
||||
ic = i__;
|
||||
} else {
|
||||
//
|
||||
// H or H**T is applied to C(1:m,i:n)
|
||||
//
|
||||
ni = *n - i__ + 1;
|
||||
jc = i__;
|
||||
}
|
||||
//
|
||||
// Apply H or H**T
|
||||
//
|
||||
dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
|
||||
i__ + i__ * a_dim1], lda, &work[iwt], &c__65, &c__[ic +
|
||||
jc * c_dim1], ldc, &work[1], &ldwork);
|
||||
// L10:
|
||||
}
|
||||
}
|
||||
work[1] = (double) lwkopt;
|
||||
return 0;
|
||||
//
|
||||
// End of DORMQR
|
||||
//
|
||||
} // dormqr_
|
||||
|
||||
164
3rdparty/clapack/src/drot.c
vendored
Normal file
164
3rdparty/clapack/src/drot.c
vendored
Normal file
@ -0,0 +1,164 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DROT
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION C,S
|
||||
// INTEGER INCX,INCY,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*),DY(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DROT applies a plane rotation.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] DX
|
||||
//> \verbatim
|
||||
//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> storage spacing between elements of DX
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] DY
|
||||
//> \verbatim
|
||||
//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCY
|
||||
//> \verbatim
|
||||
//> INCY is INTEGER
|
||||
//> storage spacing between elements of DY
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] C
|
||||
//> \verbatim
|
||||
//> C is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] S
|
||||
//> \verbatim
|
||||
//> S is DOUBLE PRECISION
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup double_blas_level1
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> jack dongarra, linpack, 3/11/78.
|
||||
//> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int drot_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy, double *c__, double *s)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, ix, iy;
|
||||
double dtemp;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// Parameter adjustments
|
||||
--dy;
|
||||
--dx;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
//
|
||||
// code for both increments equal to 1
|
||||
//
|
||||
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;
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// 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;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // drot_
|
||||
|
||||
155
3rdparty/clapack/src/dscal.c
vendored
Normal file
155
3rdparty/clapack/src/dscal.c
vendored
Normal file
@ -0,0 +1,155 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DSCAL
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DSCAL(N,DA,DX,INCX)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION DA
|
||||
// INTEGER INCX,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DSCAL scales a vector by a constant.
|
||||
//> uses unrolled loops for increment equal to 1.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DA
|
||||
//> \verbatim
|
||||
//> DA is DOUBLE PRECISION
|
||||
//> On entry, DA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] DX
|
||||
//> \verbatim
|
||||
//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> storage spacing between elements of DX
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup double_blas_level1
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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(*)
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dscal_(int *n, double *da, double *dx, int *incx)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, m, mp1, nincx;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// Parameter adjustments
|
||||
--dx;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 0 || *incx <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (*incx == 1) {
|
||||
//
|
||||
// code for increment equal to 1
|
||||
//
|
||||
//
|
||||
// clean-up loop
|
||||
//
|
||||
m = *n % 5;
|
||||
if (m != 0) {
|
||||
i__1 = m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dx[i__] = *da * dx[i__];
|
||||
}
|
||||
if (*n < 5) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
mp1 = m + 1;
|
||||
i__1 = *n;
|
||||
for (i__ = mp1; i__ <= i__1; 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];
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// 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__];
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // dscal_
|
||||
|
||||
178
3rdparty/clapack/src/dswap.c
vendored
Normal file
178
3rdparty/clapack/src/dswap.c
vendored
Normal file
@ -0,0 +1,178 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DSWAP
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,INCY,N
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION DX(*),DY(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DSWAP interchanges two vectors.
|
||||
//> uses unrolled loops for increments equal to 1.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> number of elements in input vector(s)
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] DX
|
||||
//> \verbatim
|
||||
//> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> storage spacing between elements of DX
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] DY
|
||||
//> \verbatim
|
||||
//> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCY
|
||||
//> \verbatim
|
||||
//> INCY is INTEGER
|
||||
//> storage spacing between elements of DY
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date November 2017
|
||||
//
|
||||
//> \ingroup double_blas_level1
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> jack dongarra, linpack, 3/11/78.
|
||||
//> modified 12/3/93, array(1) declarations changed to array(*)
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dswap_(int *n, double *dx, int *incx, double *dy, int *
|
||||
incy)
|
||||
{
|
||||
// System generated locals
|
||||
int i__1;
|
||||
|
||||
// Local variables
|
||||
int i__, m, ix, iy, mp1;
|
||||
double dtemp;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level1 routine (version 3.8.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// November 2017
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. Local Scalars ..
|
||||
// ..
|
||||
// .. Intrinsic Functions ..
|
||||
// ..
|
||||
// Parameter adjustments
|
||||
--dy;
|
||||
--dx;
|
||||
|
||||
// Function Body
|
||||
if (*n <= 0) {
|
||||
return 0;
|
||||
}
|
||||
if (*incx == 1 && *incy == 1) {
|
||||
//
|
||||
// code for both increments equal to 1
|
||||
//
|
||||
//
|
||||
// clean-up loop
|
||||
//
|
||||
m = *n % 3;
|
||||
if (m != 0) {
|
||||
i__1 = m;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
dtemp = dx[i__];
|
||||
dx[i__] = dy[i__];
|
||||
dy[i__] = dtemp;
|
||||
}
|
||||
if (*n < 3) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
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;
|
||||
}
|
||||
} else {
|
||||
//
|
||||
// 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;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
} // dswap_
|
||||
|
||||
509
3rdparty/clapack/src/dtrmm.c
vendored
Normal file
509
3rdparty/clapack/src/dtrmm.c
vendored
Normal file
@ -0,0 +1,509 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DTRMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// DOUBLE PRECISION ALPHA
|
||||
// INTEGER LDA,LDB,M,N
|
||||
// CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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**T.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] SIDE
|
||||
//> \verbatim
|
||||
//> SIDE is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] UPLO
|
||||
//> \verbatim
|
||||
//> UPLO is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANSA
|
||||
//> \verbatim
|
||||
//> TRANSA is 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**T.
|
||||
//>
|
||||
//> TRANSA = 'C' or 'c' op( A ) = A**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIAG
|
||||
//> \verbatim
|
||||
//> DIAG is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is INTEGER
|
||||
//> On entry, M specifies the number of rows of B. M must be at
|
||||
//> least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> On entry, N specifies the number of columns of B. N must be
|
||||
//> at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] B
|
||||
//> \verbatim
|
||||
//> B is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is 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 ).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup double_blas_level3
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag,
|
||||
int *m, int *n, double *alpha, double *a, int *lda, double *b, int *
|
||||
ldb)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, k, info;
|
||||
double temp;
|
||||
int lside;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa;
|
||||
int upper;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
int nounit;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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**T*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**T.
|
||||
//
|
||||
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_
|
||||
|
||||
396
3rdparty/clapack/src/dtrmv.c
vendored
Normal file
396
3rdparty/clapack/src/dtrmv.c
vendored
Normal file
@ -0,0 +1,396 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b DTRMV
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// INTEGER INCX,LDA,N
|
||||
// CHARACTER DIAG,TRANS,UPLO
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// DOUBLE PRECISION A(LDA,*),X(*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> DTRMV performs one of the matrix-vector operations
|
||||
//>
|
||||
//> x := A*x, or x := A**T*x,
|
||||
//>
|
||||
//> where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
//> upper or lower triangular matrix.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] UPLO
|
||||
//> \verbatim
|
||||
//> UPLO is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANS
|
||||
//> \verbatim
|
||||
//> TRANS is 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**T*x.
|
||||
//>
|
||||
//> TRANS = 'C' or 'c' x := A**T*x.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] DIAG
|
||||
//> \verbatim
|
||||
//> DIAG is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is INTEGER
|
||||
//> On entry, N specifies the order of the matrix A.
|
||||
//> N must be at least zero.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is DOUBLE PRECISION array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] X
|
||||
//> \verbatim
|
||||
//> X is DOUBLE PRECISION array, 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
|
||||
//> transformed vector x.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] INCX
|
||||
//> \verbatim
|
||||
//> INCX is INTEGER
|
||||
//> On entry, INCX specifies the increment for the elements of
|
||||
//> X. INCX must not be zero.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup double_blas_level2
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> Level 2 Blas routine.
|
||||
//> The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
//>
|
||||
//> -- 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, int *n,
|
||||
double *a, int *lda, double *x, int *incx)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, i__1, i__2;
|
||||
|
||||
// Local variables
|
||||
int i__, j, ix, jx, kx, info;
|
||||
double temp;
|
||||
extern int lsame_(char *, char *);
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
int nounit;
|
||||
|
||||
//
|
||||
// -- Reference BLAS level2 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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**T*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_
|
||||
|
||||
1334
3rdparty/clapack/src/ilaenv.c
vendored
Normal file
1334
3rdparty/clapack/src/ilaenv.c
vendored
Normal file
File diff suppressed because it is too large
Load Diff
444
3rdparty/clapack/src/sgemm.c
vendored
Normal file
444
3rdparty/clapack/src/sgemm.c
vendored
Normal file
@ -0,0 +1,444 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b SGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// REAL ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// REAL A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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**T,
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] TRANSA
|
||||
//> \verbatim
|
||||
//> TRANSA is 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**T.
|
||||
//>
|
||||
//> TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANSB
|
||||
//> \verbatim
|
||||
//> TRANSB is 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**T.
|
||||
//>
|
||||
//> TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is REAL
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is REAL array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] B
|
||||
//> \verbatim
|
||||
//> B is REAL array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] BETA
|
||||
//> \verbatim
|
||||
//> BETA is REAL
|
||||
//> On entry, BETA specifies the scalar beta. When BETA is
|
||||
//> supplied as zero then C need not be set on input.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is REAL array, 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is 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 ).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup single_blas_level3
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int sgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, float *alpha, float *a, int *lda, float *b, int *ldb, float *beta,
|
||||
float *c__, int *ldc)
|
||||
{
|
||||
// System generated locals
|
||||
int a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
|
||||
i__3;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
float temp;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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) {
|
||||
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**T*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**T + 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) {
|
||||
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**T*B**T + 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_
|
||||
|
||||
752
3rdparty/clapack/src/zgemm.c
vendored
Normal file
752
3rdparty/clapack/src/zgemm.c
vendored
Normal file
@ -0,0 +1,752 @@
|
||||
/* -- translated by f2c (version 20201020 (for_lapack)). -- */
|
||||
|
||||
#include "f2c.h"
|
||||
|
||||
//> \brief \b ZGEMM
|
||||
//
|
||||
// =========== DOCUMENTATION ===========
|
||||
//
|
||||
// Online html documentation available at
|
||||
// http://www.netlib.org/lapack/explore-html/
|
||||
//
|
||||
// Definition:
|
||||
// ===========
|
||||
//
|
||||
// SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// COMPLEX*16 ALPHA,BETA
|
||||
// INTEGER K,LDA,LDB,LDC,M,N
|
||||
// CHARACTER TRANSA,TRANSB
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
// ..
|
||||
//
|
||||
//
|
||||
//> \par Purpose:
|
||||
// =============
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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**T or op( X ) = X**H,
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//
|
||||
// Arguments:
|
||||
// ==========
|
||||
//
|
||||
//> \param[in] TRANSA
|
||||
//> \verbatim
|
||||
//> TRANSA is 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**T.
|
||||
//>
|
||||
//> TRANSA = 'C' or 'c', op( A ) = A**H.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] TRANSB
|
||||
//> \verbatim
|
||||
//> TRANSB is 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**T.
|
||||
//>
|
||||
//> TRANSB = 'C' or 'c', op( B ) = B**H.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] M
|
||||
//> \verbatim
|
||||
//> M is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] N
|
||||
//> \verbatim
|
||||
//> N is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] K
|
||||
//> \verbatim
|
||||
//> K is 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] ALPHA
|
||||
//> \verbatim
|
||||
//> ALPHA is COMPLEX*16
|
||||
//> On entry, ALPHA specifies the scalar alpha.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] A
|
||||
//> \verbatim
|
||||
//> A is COMPLEX*16 array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDA
|
||||
//> \verbatim
|
||||
//> LDA is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] B
|
||||
//> \verbatim
|
||||
//> B is COMPLEX*16 array, 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDB
|
||||
//> \verbatim
|
||||
//> LDB is 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] BETA
|
||||
//> \verbatim
|
||||
//> BETA is COMPLEX*16
|
||||
//> On entry, BETA specifies the scalar beta. When BETA is
|
||||
//> supplied as zero then C need not be set on input.
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in,out] C
|
||||
//> \verbatim
|
||||
//> C is COMPLEX*16 array, 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 ).
|
||||
//> \endverbatim
|
||||
//>
|
||||
//> \param[in] LDC
|
||||
//> \verbatim
|
||||
//> LDC is 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 ).
|
||||
//> \endverbatim
|
||||
//
|
||||
// Authors:
|
||||
// ========
|
||||
//
|
||||
//> \author Univ. of Tennessee
|
||||
//> \author Univ. of California Berkeley
|
||||
//> \author Univ. of Colorado Denver
|
||||
//> \author NAG Ltd.
|
||||
//
|
||||
//> \date December 2016
|
||||
//
|
||||
//> \ingroup complex16_blas_level3
|
||||
//
|
||||
//> \par Further Details:
|
||||
// =====================
|
||||
//>
|
||||
//> \verbatim
|
||||
//>
|
||||
//> 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.
|
||||
//> \endverbatim
|
||||
//>
|
||||
// =====================================================================
|
||||
/* Subroutine */ int zgemm_(char *transa, char *transb, int *m, int *n, int *
|
||||
k, doublecomplex *alpha, doublecomplex *a, int *lda, doublecomplex *b,
|
||||
int *ldb, doublecomplex *beta, doublecomplex *c__, int *ldc)
|
||||
{
|
||||
// Table of constant values
|
||||
doublecomplex c_b1 = {1.,0.};
|
||||
doublecomplex c_b2 = {0.,0.};
|
||||
|
||||
// System generated locals
|
||||
int 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;
|
||||
|
||||
// Local variables
|
||||
int i__, j, l, info;
|
||||
int nota, notb;
|
||||
doublecomplex temp;
|
||||
int conja, conjb;
|
||||
int ncola;
|
||||
extern int lsame_(char *, char *);
|
||||
int nrowa, nrowb;
|
||||
extern /* Subroutine */ int xerbla_(char *, int *);
|
||||
|
||||
//
|
||||
// -- Reference BLAS level3 routine (version 3.7.0) --
|
||||
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
// December 2016
|
||||
//
|
||||
// .. Scalar Arguments ..
|
||||
// ..
|
||||
// .. Array Arguments ..
|
||||
// ..
|
||||
//
|
||||
// =====================================================================
|
||||
//
|
||||
// .. 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;
|
||||
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*A**H*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**T*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*B**H + 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) {
|
||||
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**T + 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;
|
||||
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*A**H*B**H + 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*A**H*B**T + 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**T*B**H + 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**T*B**T + 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_
|
||||
|
||||
@ -227,6 +227,7 @@ OCV_OPTION(BUILD_ITT "Build Intel ITT from source"
|
||||
(NOT MINGW OR OPENCV_FORCE_3RDPARTY_BUILD)
|
||||
IF (X86_64 OR X86 OR ARM OR AARCH64 OR PPC64 OR PPC64LE) AND NOT WINRT AND NOT APPLE_FRAMEWORK
|
||||
)
|
||||
OCV_OPTION(BUILD_CLAPACK "Build CLapack from source" (((WIN32 OR ANDROID) AND NOT APPLE) OR OPENCV_FORCE_3RDPARTY_BUILD) )
|
||||
|
||||
# Optional 3rd party components
|
||||
# ===================================================
|
||||
@ -695,6 +696,9 @@ include(cmake/OpenCVFindLibsGUI.cmake)
|
||||
include(cmake/OpenCVFindLibsVideo.cmake)
|
||||
include(cmake/OpenCVFindLibsPerf.cmake)
|
||||
include(cmake/OpenCVFindLAPACK.cmake)
|
||||
if(WITH_LAPACK)
|
||||
ocv_assert(HAVE_LAPACK) # Lapack is required for OpenCV 5.0+
|
||||
endif()
|
||||
include(cmake/OpenCVFindProtobuf.cmake)
|
||||
if(WITH_TENGINE)
|
||||
include(cmake/OpenCVFindTengine.cmake)
|
||||
@ -1439,7 +1443,7 @@ if(WITH_TENGINE OR HAVE_TENGINE)
|
||||
endif()
|
||||
|
||||
if(WITH_LAPACK OR HAVE_LAPACK)
|
||||
status(" Lapack:" HAVE_LAPACK THEN "YES (${LAPACK_LIBRARIES})" ELSE NO)
|
||||
status(" Lapack:" HAVE_LAPACK THEN "YES (${LAPACK_LIBRARIES} ${LAPACK_VERSION})" ELSE NO)
|
||||
endif()
|
||||
|
||||
if(WITH_HALIDE OR HAVE_HALIDE)
|
||||
|
||||
@ -20,25 +20,17 @@ macro(_find_header_file_in_dirs VAR NAME)
|
||||
endif()
|
||||
endmacro()
|
||||
|
||||
macro(ocv_lapack_check)
|
||||
string(REGEX REPLACE "[^a-zA-Z0-9_]" "_" _lapack_impl "${LAPACK_IMPL}")
|
||||
message(STATUS "LAPACK(${LAPACK_IMPL}): LAPACK_LIBRARIES: ${LAPACK_LIBRARIES}")
|
||||
_find_header_file_in_dirs(OPENCV_CBLAS_H_PATH_${_lapack_impl} "${LAPACK_CBLAS_H}" "${LAPACK_INCLUDE_DIR}")
|
||||
_find_header_file_in_dirs(OPENCV_LAPACKE_H_PATH_${_lapack_impl} "${LAPACK_LAPACKE_H}" "${LAPACK_INCLUDE_DIR}")
|
||||
if(NOT OPENCV_CBLAS_H_PATH_${_lapack_impl} OR NOT OPENCV_LAPACKE_H_PATH_${_lapack_impl})
|
||||
message(WARNING "LAPACK(${LAPACK_IMPL}): CBLAS/LAPACK headers are not found in '${LAPACK_INCLUDE_DIR}'")
|
||||
unset(LAPACK_LIBRARIES)
|
||||
else()
|
||||
# adding proxy opencv_lapack.h header
|
||||
set(CBLAS_H_PROXY_PATH ${CMAKE_BINARY_DIR}/opencv_lapack.h)
|
||||
macro(ocv_lapack_make_hdr _cblas_hdr _lapacke_hdr)
|
||||
# adding proxy opencv_lapack.h header
|
||||
set(CBLAS_H_PROXY_PATH ${CMAKE_BINARY_DIR}/opencv_lapack.h)
|
||||
|
||||
set(_lapack_add_extern_c NOT (APPLE OR OPENCV_SKIP_LAPACK_EXTERN_C) OR OPENCV_FORCE_LAPACK_EXTERN_C)
|
||||
set(_lapack_add_extern_c NOT (APPLE OR OPENCV_SKIP_LAPACK_EXTERN_C) OR OPENCV_FORCE_LAPACK_EXTERN_C)
|
||||
|
||||
set(_lapack_content "// This file is auto-generated\n")
|
||||
if(${_lapack_add_extern_c})
|
||||
list(APPEND _lapack_content "extern \"C\" {")
|
||||
endif()
|
||||
if(NOT OPENCV_SKIP_LAPACK_MSVC_FIX)
|
||||
set(_lapack_content "// This file is auto-generated\n")
|
||||
if(${_lapack_add_extern_c})
|
||||
list(APPEND _lapack_content "extern \"C\" {")
|
||||
endif()
|
||||
if(NOT OPENCV_SKIP_LAPACK_MSVC_FIX)
|
||||
list(APPEND _lapack_content "
|
||||
#ifdef _MSC_VER
|
||||
#include <complex.h>
|
||||
@ -46,41 +38,58 @@ macro(ocv_lapack_check)
|
||||
#define lapack_complex_double _Dcomplex
|
||||
#endif
|
||||
")
|
||||
endif()
|
||||
list(APPEND _lapack_content "#include \"${OPENCV_CBLAS_H_PATH_${_lapack_impl}}\"")
|
||||
if(NOT "${OPENCV_CBLAS_H_PATH_${_lapack_impl}}" STREQUAL "${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}")
|
||||
list(APPEND _lapack_content "#include \"${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}\"")
|
||||
endif()
|
||||
if(${_lapack_add_extern_c})
|
||||
list(APPEND _lapack_content "}")
|
||||
endif()
|
||||
endif()
|
||||
list(APPEND _lapack_content "#include \"${_cblas_hdr}\"")
|
||||
if(NOT "${_cblas_hdr}" STREQUAL "${_lapacke_hdr}")
|
||||
list(APPEND _lapack_content "#include \"${_lapacke_hdr}\"")
|
||||
endif()
|
||||
if(${_lapack_add_extern_c})
|
||||
list(APPEND _lapack_content "}")
|
||||
endif()
|
||||
string(REPLACE ";" "\n" _lapack_content "${_lapack_content}")
|
||||
ocv_update_file("${CBLAS_H_PROXY_PATH}" "${_lapack_content}")
|
||||
endmacro()
|
||||
|
||||
string(REPLACE ";" "\n" _lapack_content "${_lapack_content}")
|
||||
ocv_update_file("${CBLAS_H_PROXY_PATH}" "${_lapack_content}")
|
||||
macro(ocv_lapack_run_check)
|
||||
try_compile(__VALID_LAPACK
|
||||
"${OpenCV_BINARY_DIR}"
|
||||
"${OpenCV_SOURCE_DIR}/cmake/checks/lapack_check.cpp"
|
||||
CMAKE_FLAGS "-DINCLUDE_DIRECTORIES:STRING=${LAPACK_INCLUDE_DIR}\;${CMAKE_BINARY_DIR}"
|
||||
"-DLINK_DIRECTORIES:STRING=${LAPACK_LINK_LIBRARIES}"
|
||||
"-DLINK_LIBRARIES:STRING=${LAPACK_LIBRARIES}"
|
||||
OUTPUT_VARIABLE TRY_OUT
|
||||
)
|
||||
if(NOT __VALID_LAPACK)
|
||||
#message(FATAL_ERROR "LAPACK: check build log:\n${TRY_OUT}")
|
||||
message(STATUS "${LAPACK_IMPL}: Can't build LAPACK check code. This LAPACK version is not supported.")
|
||||
unset(LAPACK_LIBRARIES)
|
||||
else()
|
||||
message(STATUS "${LAPACK_IMPL}: Support is enabled.")
|
||||
ocv_include_directories(${LAPACK_INCLUDE_DIR})
|
||||
set(HAVE_LAPACK 1)
|
||||
endif()
|
||||
endmacro()
|
||||
|
||||
try_compile(__VALID_LAPACK
|
||||
"${OpenCV_BINARY_DIR}"
|
||||
"${OpenCV_SOURCE_DIR}/cmake/checks/lapack_check.cpp"
|
||||
CMAKE_FLAGS "-DINCLUDE_DIRECTORIES:STRING=${LAPACK_INCLUDE_DIR}\;${CMAKE_BINARY_DIR}"
|
||||
"-DLINK_DIRECTORIES:STRING=${LAPACK_LINK_LIBRARIES}"
|
||||
"-DLINK_LIBRARIES:STRING=${LAPACK_LIBRARIES}"
|
||||
OUTPUT_VARIABLE TRY_OUT
|
||||
)
|
||||
if(NOT __VALID_LAPACK)
|
||||
#message(FATAL_ERROR "LAPACK: check build log:\n${TRY_OUT}")
|
||||
message(STATUS "LAPACK(${LAPACK_IMPL}): Can't build LAPACK check code. This LAPACK version is not supported.")
|
||||
unset(LAPACK_LIBRARIES)
|
||||
else()
|
||||
message(STATUS "LAPACK(${LAPACK_IMPL}): Support is enabled.")
|
||||
ocv_include_directories(${LAPACK_INCLUDE_DIR})
|
||||
set(HAVE_LAPACK 1)
|
||||
endif()
|
||||
macro(ocv_lapack_check)
|
||||
string(REGEX REPLACE "[^a-zA-Z0-9_]" "_" _lapack_impl "${LAPACK_IMPL}")
|
||||
message(STATUS "${LAPACK_IMPL}: LAPACK_LIBRARIES=${LAPACK_LIBRARIES}")
|
||||
_find_header_file_in_dirs(OPENCV_CBLAS_H_PATH_${_lapack_impl} "${LAPACK_CBLAS_H}" "${LAPACK_INCLUDE_DIR}")
|
||||
_find_header_file_in_dirs(OPENCV_LAPACKE_H_PATH_${_lapack_impl} "${LAPACK_LAPACKE_H}" "${LAPACK_INCLUDE_DIR}")
|
||||
message(STATUS "${LAPACK_IMPL}: Looking for CBLAS/LAPACK headers in '${LAPACK_INCLUDE_DIR}': '${OPENCV_CBLAS_H_PATH_${_lapack_impl}}', '${OPENCV_LAPACKE_H_PATH_${_lapack_impl}}'")
|
||||
if(OPENCV_CBLAS_H_PATH_${_lapack_impl} AND OPENCV_LAPACKE_H_PATH_${_lapack_impl})
|
||||
ocv_lapack_make_hdr(${OPENCV_CBLAS_H_PATH_${_lapack_impl}} ${OPENCV_LAPACKE_H_PATH_${_lapack_impl}})
|
||||
ocv_lapack_run_check()
|
||||
else()
|
||||
unset(LAPACK_LIBRARIES)
|
||||
endif()
|
||||
endmacro()
|
||||
|
||||
if(WITH_LAPACK)
|
||||
unset(LAPACK_LIBRARIES)
|
||||
unset(LAPACK_LIBRARIES CACHE)
|
||||
|
||||
ocv_update(LAPACK_IMPL "Unknown")
|
||||
if(NOT OPENCV_LAPACK_FIND_PACKAGE_ONLY)
|
||||
if(NOT BUILD_CLAPACK AND NOT OPENCV_LAPACK_FIND_PACKAGE_ONLY)
|
||||
if(NOT LAPACK_LIBRARIES AND NOT OPENCV_LAPACK_DISABLE_MKL)
|
||||
include(cmake/OpenCVFindMKL.cmake)
|
||||
if(HAVE_MKL)
|
||||
@ -89,6 +98,7 @@ if(WITH_LAPACK)
|
||||
set(LAPACK_CBLAS_H "mkl_cblas.h")
|
||||
set(LAPACK_LAPACKE_H "mkl_lapack.h")
|
||||
set(LAPACK_IMPL "MKL")
|
||||
set(LAPACK_VERSION "${MKL_VERSION_STR}")
|
||||
ocv_lapack_check()
|
||||
endif()
|
||||
endif()
|
||||
@ -116,7 +126,7 @@ if(WITH_LAPACK)
|
||||
endif()
|
||||
endif()
|
||||
|
||||
if(NOT LAPACK_LIBRARIES)
|
||||
if(NOT BUILD_CLAPACK AND NOT LAPACK_LIBRARIES)
|
||||
if(WIN32 AND NOT OPENCV_LAPACK_SHARED_LIBS)
|
||||
set(BLA_STATIC 1)
|
||||
endif()
|
||||
@ -142,31 +152,45 @@ if(WITH_LAPACK)
|
||||
set(LAPACK_LAPACKE_H "lapacke.h")
|
||||
set(LAPACK_IMPL "LAPACK/Generic")
|
||||
ocv_lapack_check()
|
||||
elseif(APPLE)
|
||||
set(LAPACK_CBLAS_H "Accelerate/Accelerate.h")
|
||||
set(LAPACK_LAPACKE_H "Accelerate/Accelerate.h")
|
||||
set(LAPACK_IMPL "LAPACK/Apple")
|
||||
ocv_lapack_check()
|
||||
endif()
|
||||
endif()
|
||||
endif()
|
||||
if(NOT HAVE_LAPACK)
|
||||
endif()
|
||||
|
||||
if(NOT HAVE_LAPACK)
|
||||
if(LAPACK_LIBRARIES AND LAPACK_CBLAS_H AND LAPACK_LAPACKE_H)
|
||||
ocv_lapack_check()
|
||||
else()
|
||||
unset(LAPACK_LIBRARIES)
|
||||
unset(LAPACK_LIBRARIES CACHE)
|
||||
endif()
|
||||
endif()
|
||||
|
||||
if(NOT LAPACK_LIBRARIES AND APPLE AND NOT OPENCV_LAPACK_FIND_PACKAGE_ONLY)
|
||||
if(NOT BUILD_CLAPACK AND APPLE AND NOT LAPACK_LIBRARIES)
|
||||
set(LAPACK_INCLUDE_DIR "")
|
||||
set(LAPACK_LIBRARIES "-framework Accelerate")
|
||||
set(LAPACK_CBLAS_H "Accelerate/Accelerate.h")
|
||||
set(LAPACK_LAPACKE_H "Accelerate/Accelerate.h")
|
||||
set(LAPACK_IMPL "Apple")
|
||||
set(LAPACK_IMPL "LAPACK/Apple")
|
||||
ocv_lapack_check()
|
||||
endif()
|
||||
|
||||
if(NOT HAVE_LAPACK AND LAPACK_LIBRARIES AND LAPACK_CBLAS_H AND LAPACK_LAPACKE_H)
|
||||
ocv_lapack_check()
|
||||
if(BUILD_CLAPACK)
|
||||
ocv_assert(NOT HAVE_LAPACK)
|
||||
endif()
|
||||
if(NOT HAVE_LAPACK) # OR BUILD_CLAPACK=ON
|
||||
add_subdirectory(3rdparty/clapack)
|
||||
|
||||
set(LAPACK_CBLAS_H "cblas.h")
|
||||
set(LAPACK_LAPACKE_H "lapack.h")
|
||||
set(LAPACK_IMPL "LAPACK/clapack")
|
||||
set(LAPACK_INCLUDE_DIR "${CLAPACK_INCLUDE_DIR}")
|
||||
set(LAPACK_LIBRARIES ${CLAPACK_LIBRARIES})
|
||||
set(LAPACK_VERSION "${CLAPACK_VERSION}")
|
||||
ocv_lapack_make_hdr("${LAPACK_INCLUDE_DIR}/${LAPACK_CBLAS_H}" "${LAPACK_INCLUDE_DIR}/${LAPACK_LAPACKE_H}")
|
||||
# unable to properly check against source code without binaries: ocv_lapack_check()
|
||||
ocv_include_directories(${LAPACK_INCLUDE_DIR})
|
||||
set(HAVE_LAPACK 1)
|
||||
endif()
|
||||
|
||||
set(LAPACK_INCLUDE_DIR ${LAPACK_INCLUDE_DIR} CACHE PATH "Path to BLAS include dir" FORCE)
|
||||
|
||||
@ -100,7 +100,7 @@ template <typename fptype> static inline int
|
||||
lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int* info)
|
||||
{
|
||||
int lda = (int)(a_step / sizeof(fptype)), sign = 0;
|
||||
int* piv = new int[m];
|
||||
std::vector<int> piv(m+1);
|
||||
|
||||
transpose_square_inplace(a, lda, m);
|
||||
|
||||
@ -109,34 +109,35 @@ lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int*
|
||||
if(n == 1 && b_step == sizeof(fptype))
|
||||
{
|
||||
if(typeid(fptype) == typeid(float))
|
||||
sgesv_(&m, &n, (float*)a, &lda, piv, (float*)b, &m, info);
|
||||
sgesv_(&m, &n, (float*)a, &lda, &piv[0], (float*)b, &m, info);
|
||||
else if(typeid(fptype) == typeid(double))
|
||||
dgesv_(&m, &n, (double*)a, &lda, piv, (double*)b, &m, info);
|
||||
dgesv_(&m, &n, (double*)a, &lda, &piv[0], (double*)b, &m, info);
|
||||
}
|
||||
else
|
||||
{
|
||||
int ldb = (int)(b_step / sizeof(fptype));
|
||||
fptype* tmpB = new fptype[m*n];
|
||||
std::vector<fptype> tmpB(m*n+1);
|
||||
|
||||
transpose(b, ldb, tmpB, m, m, n);
|
||||
transpose(b, ldb, &tmpB[0], m, m, n);
|
||||
|
||||
if(typeid(fptype) == typeid(float))
|
||||
sgesv_(&m, &n, (float*)a, &lda, piv, (float*)tmpB, &m, info);
|
||||
sgesv_(&m, &n, (float*)a, &lda, &piv[0], (float*)&tmpB[0], &m, info);
|
||||
else if(typeid(fptype) == typeid(double))
|
||||
dgesv_(&m, &n, (double*)a, &lda, piv, (double*)tmpB, &m, info);
|
||||
dgesv_(&m, &n, (double*)a, &lda, &piv[0], (double*)&tmpB[0], &m, info);
|
||||
|
||||
transpose(tmpB, m, b, ldb, n, m);
|
||||
delete[] tmpB;
|
||||
transpose(&tmpB[0], m, b, ldb, n, m);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if(typeid(fptype) == typeid(float))
|
||||
sgetrf_(&m, &m, (float*)a, &lda, piv, info);
|
||||
sgetrf_(&m, &m, (float*)a, &lda, &piv[0], info);
|
||||
else if(typeid(fptype) == typeid(double))
|
||||
dgetrf_(&m, &m, (double*)a, &lda, piv, info);
|
||||
dgetrf_(&m, &m, (double*)a, &lda, &piv[0], info);
|
||||
}
|
||||
|
||||
int retcode = *info >= 0 ? CV_HAL_ERROR_OK : CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
|
||||
if(*info == 0)
|
||||
{
|
||||
for(int i = 0; i < m; i++)
|
||||
@ -146,8 +147,7 @@ lapack_LU(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n, int*
|
||||
else
|
||||
*info = 0; //in opencv LU function zero means error
|
||||
|
||||
delete[] piv;
|
||||
return CV_HAL_ERROR_OK;
|
||||
return retcode;
|
||||
}
|
||||
|
||||
template <typename fptype> static inline int
|
||||
@ -192,7 +192,7 @@ lapack_Cholesky(fptype* a, size_t a_step, int m, fptype* b, size_t b_step, int n
|
||||
if(lapackStatus == 0) *info = true;
|
||||
else *info = false; //in opencv Cholesky function false means error
|
||||
|
||||
return CV_HAL_ERROR_OK;
|
||||
return lapackStatus >= 0 ? CV_HAL_ERROR_OK : CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
}
|
||||
|
||||
template <typename fptype> static inline int
|
||||
@ -202,7 +202,8 @@ lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype
|
||||
int ldv = (int)(v_step / sizeof(fptype));
|
||||
int ldu = (int)(u_step / sizeof(fptype));
|
||||
int lwork = -1;
|
||||
int* iworkBuf = new int[8*std::min(m, n)];
|
||||
std::vector<int> iworkBuf(8*std::min(m, n));
|
||||
std::vector<fptype> ubuf;
|
||||
fptype work1 = 0;
|
||||
|
||||
//A already transposed and m>=n
|
||||
@ -221,22 +222,30 @@ lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype
|
||||
|
||||
if((flags & CV_HAL_SVD_MODIFY_A) && (flags & CV_HAL_SVD_FULL_UV)) //U stored in a
|
||||
{
|
||||
u = new fptype[m*m];
|
||||
ubuf.resize(m*m);
|
||||
u = &ubuf[0];
|
||||
ldu = m;
|
||||
}
|
||||
|
||||
if(typeid(fptype) == typeid(float))
|
||||
sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, (float*)vt, &ldv, (float*)&work1, &lwork, iworkBuf, info);
|
||||
sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu,
|
||||
(float*)vt, &ldv, (float*)&work1, &lwork, &iworkBuf[0], info);
|
||||
else if(typeid(fptype) == typeid(double))
|
||||
dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, (double*)vt, &ldv, (double*)&work1, &lwork, iworkBuf, info);
|
||||
dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu,
|
||||
(double*)vt, &ldv, (double*)&work1, &lwork, &iworkBuf[0], info);
|
||||
|
||||
if(*info < 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
|
||||
lwork = (int)round(work1); //optimal buffer size
|
||||
fptype* buffer = new fptype[lwork + 1];
|
||||
std::vector<fptype> buffer(lwork + 1);
|
||||
|
||||
if(typeid(fptype) == typeid(float))
|
||||
sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu, (float*)vt, &ldv, (float*)buffer, &lwork, iworkBuf, info);
|
||||
sgesdd_(mode, &m, &n, (float*)a, &lda, (float*)w, (float*)u, &ldu,
|
||||
(float*)vt, &ldv, (float*)&buffer[0], &lwork, &iworkBuf[0], info);
|
||||
else if(typeid(fptype) == typeid(double))
|
||||
dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu, (double*)vt, &ldv, (double*)buffer, &lwork, iworkBuf, info);
|
||||
dgesdd_(mode, &m, &n, (double*)a, &lda, (double*)w, (double*)u, &ldu,
|
||||
(double*)vt, &ldv, (double*)&buffer[0], &lwork, &iworkBuf[0], info);
|
||||
|
||||
if(!(flags & CV_HAL_SVD_NO_UV))
|
||||
transpose_square_inplace(vt, ldv, n);
|
||||
@ -246,11 +255,10 @@ lapack_SVD(fptype* a, size_t a_step, fptype *w, fptype* u, size_t u_step, fptype
|
||||
for(int i = 0; i < m; i++)
|
||||
for(int j = 0; j < m; j++)
|
||||
a[i*lda + j] = u[i*m + j];
|
||||
delete[] u;
|
||||
}
|
||||
|
||||
delete[] iworkBuf;
|
||||
delete[] buffer;
|
||||
if(*info < 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
return CV_HAL_ERROR_OK;
|
||||
}
|
||||
|
||||
@ -291,6 +299,9 @@ lapack_QR(fptype* a, size_t a_step, int m, int n, int k, fptype* b, size_t b_ste
|
||||
else if (typeid(fptype) == typeid(double))
|
||||
dgels_(mode, &m, &n, &k, (double*)tmpA, &ldtmpA, (double*)b, &m, (double*)&work1, &lwork, info);
|
||||
|
||||
if (*info < 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
|
||||
lwork = cvRound(work1); //optimal buffer size
|
||||
std::vector<fptype> workBufMemHolder(lwork + 1);
|
||||
fptype* buffer = &workBufMemHolder.front();
|
||||
@ -312,6 +323,9 @@ lapack_QR(fptype* a, size_t a_step, int m, int n, int k, fptype* b, size_t b_ste
|
||||
else if (typeid(fptype) == typeid(double))
|
||||
dgels_(mode, &m, &n, &k, (double*)tmpA, &ldtmpA, (double*)tmpB, &m, (double*)&work1, &lwork, info);
|
||||
|
||||
if (*info < 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
|
||||
lwork = cvRound(work1); //optimal buffer size
|
||||
std::vector<fptype> workBufMemHolder(lwork + 1);
|
||||
fptype* buffer = &workBufMemHolder.front();
|
||||
@ -331,6 +345,9 @@ lapack_QR(fptype* a, size_t a_step, int m, int n, int k, fptype* b, size_t b_ste
|
||||
else if (typeid(fptype) == typeid(double))
|
||||
dgeqrf_(&m, &n, (double*)tmpA, &ldtmpA, (double*)dst, (double*)&work1, &lwork, info);
|
||||
|
||||
if (*info < 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
|
||||
lwork = cvRound(work1); //optimal buffer size
|
||||
std::vector<fptype> workBufMemHolder(lwork + 1);
|
||||
fptype* buffer = &workBufMemHolder.front();
|
||||
@ -538,19 +555,17 @@ int lapack_Cholesky64f(double* a, size_t a_step, int m, double* b, size_t b_step
|
||||
|
||||
int lapack_SVD32f(float* a, size_t a_step, float *w, float* u, size_t u_step, float* vt, size_t v_step, int m, int n, int flags)
|
||||
{
|
||||
|
||||
if(m < HAL_SVD_SMALL_MATRIX_THRESH)
|
||||
if(m < HAL_SVD_SMALL_MATRIX_THRESH || n <= 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
int info;
|
||||
int info = 0;
|
||||
return lapack_SVD(a, a_step, w, u, u_step, vt, v_step, m, n, flags, &info);
|
||||
}
|
||||
|
||||
int lapack_SVD64f(double* a, size_t a_step, double *w, double* u, size_t u_step, double* vt, size_t v_step, int m, int n, int flags)
|
||||
{
|
||||
|
||||
if(m < HAL_SVD_SMALL_MATRIX_THRESH)
|
||||
if(m < HAL_SVD_SMALL_MATRIX_THRESH || n <= 0)
|
||||
return CV_HAL_ERROR_NOT_IMPLEMENTED;
|
||||
int info;
|
||||
int info = 0;
|
||||
return lapack_SVD(a, a_step, w, u, u_step, vt, v_step, m, n, flags, &info);
|
||||
}
|
||||
|
||||
|
||||
@ -698,6 +698,11 @@ void Core_GEMMTest::get_minmax_bounds( int /*i*/, int /*j*/, int /*type*/, Scala
|
||||
|
||||
void Core_GEMMTest::run_func()
|
||||
{
|
||||
/*printf("tabc_flags=At:%d,Bt:%d,Ct:%d; A(%d x %d), B(%d x %d), C(%d x %d)\n",
|
||||
(tabc_flag & GEMM_1_T) != 0, (tabc_flag & GEMM_2_T) != 0, (tabc_flag & GEMM_3_T) != 0,
|
||||
test_mat[INPUT][0].rows, test_mat[INPUT][0].cols,
|
||||
test_mat[INPUT][1].rows, test_mat[INPUT][1].cols,
|
||||
test_mat[INPUT][4].rows, test_mat[INPUT][4].cols);*/
|
||||
cvGEMM( test_array[INPUT][0], test_array[INPUT][1], alpha,
|
||||
test_array[INPUT][4], beta, test_array[OUTPUT][0], tabc_flag );
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user