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>pull/18760/head
Vadim Pisarevsky
5 years ago
committed by
GitHub
parent
d0310c2a6a
commit
2ee9d21dae
50 changed files with 46103 additions and 87 deletions
@ -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) |
||||
@ -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__ */ |
||||
@ -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 |
||||
@ -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 |
||||
@ -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. |
||||
@ -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() |
||||
@ -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); |
||||
} |
||||
@ -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]]]; |
||||
} |
||||
@ -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; |
||||
} |
||||
@ -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]); |
||||
} |
||||
@ -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; |
||||
} |
||||
@ -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; |
||||
} |
||||
@ -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; |
||||
} |
||||
@ -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); |
||||
} |
||||
@ -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]]]; |
||||
} |
||||
@ -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_ */ |
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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_
|
||||
|
||||
@ -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_
|
||||
|
||||
Loading…
Reference in new issue