floraachy/OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #3821 from martin-frbg/lapack651

Browse Source 
Add a BLAS3-based triangular Sylvester equation solver (Reference-LAPACK PR 651)
This commit is contained in:
Martin Kroeker
2022-11-16 13:59:02 +01:00
committed by GitHub
parent c5c4888ed6 2a97ca615f
commit f16aa1ce7a
59 changed files with 24707 additions and 139 deletions
Download Patch File Download Diff File Expand all files Collapse all files

100
lapack-netlib/LAPACKE/include/lapack.h
View File

@@ -12,6 +12,7 @@
#include <stdlib.h>
#include <stdarg.h>
#include <inttypes.h>
/* It seems all current Fortran compilers put strlen at end.
* Some historical compilers put strlen after the str argument
@@ -80,11 +81,26 @@ extern "C" {
/*----------------------------------------------------------------------------*/
#ifndef lapack_int
#define lapack_int int
#if defined(LAPACK_ILP64)
#define lapack_int int64_t
#else
#define lapack_int int32_t
#endif
#endif
/*
* Integer format string
*/
#ifndef LAPACK_IFMT
#if defined(LAPACK_ILP64)
#define LAPACK_IFMT PRId64
#else
#define LAPACK_IFMT PRId32
#endif
#endif
#ifndef lapack_logical
#define lapack_logical lapack_int
#define lapack_logical lapack_int
#endif
/* f2c, hence clapack and MacOS Accelerate, returns double instead of float
@@ -115,7 +131,7 @@ typedef lapack_logical (*LAPACK_Z_SELECT2)
( const lapack_complex_double*, const lapack_complex_double* );
#define LAPACK_lsame_base LAPACK_GLOBAL(lsame,LSAME)
lapack_logical LAPACK_lsame_base( const char* ca, const char* cb,
lapack_logical LAPACK_lsame_base( const char* ca, const char* cb,
lapack_int lca, lapack_int lcb
#ifdef LAPACK_FORTRAN_STRLEN_END
, size_t, size_t
@@ -21986,6 +22002,84 @@ void LAPACK_ztrsyl_base(
#define LAPACK_ztrsyl(...) LAPACK_ztrsyl_base(__VA_ARGS__)
#endif
#define LAPACK_ctrsyl3_base LAPACK_GLOBAL(ctrsyl3,CTRSYL3)
void LAPACK_ctrsyl3_base(
char const* trana, char const* tranb,
lapack_int const* isgn, lapack_int const* m, lapack_int const* n,
lapack_complex_float const* A, lapack_int const* lda,
lapack_complex_float const* B, lapack_int const* ldb,
lapack_complex_float* C, lapack_int const* ldc, float* scale,
float* swork, lapack_int const *ldswork,
lapack_int* info
#ifdef LAPACK_FORTRAN_STRLEN_END
, size_t, size_t
#endif
);
#ifdef LAPACK_FORTRAN_STRLEN_END
#define LAPACK_ctrsyl3(...) LAPACK_ctrsyl3_base(__VA_ARGS__, 1, 1)
#else
#define LAPACK_ctrsyl3(...) LAPACK_ctrsyl3_base(__VA_ARGS__)
#endif
#define LAPACK_dtrsyl3_base LAPACK_GLOBAL(dtrsyl3,DTRSYL3)
void LAPACK_dtrsyl3_base(
char const* trana, char const* tranb,
lapack_int const* isgn, lapack_int const* m, lapack_int const* n,
double const* A, lapack_int const* lda,
double const* B, lapack_int const* ldb,
double* C, lapack_int const* ldc, double* scale,
lapack_int* iwork, lapack_int const* liwork,
double* swork, lapack_int const *ldswork,
lapack_int* info
#ifdef LAPACK_FORTRAN_STRLEN_END
, size_t, size_t
#endif
);
#ifdef LAPACK_FORTRAN_STRLEN_END
#define LAPACK_dtrsyl3(...) LAPACK_dtrsyl3_base(__VA_ARGS__, 1, 1)
#else
#define LAPACK_dtrsyl3(...) LAPACK_dtrsyl3_base(__VA_ARGS__)
#endif
#define LAPACK_strsyl3_base LAPACK_GLOBAL(strsyl3,STRSYL3)
void LAPACK_strsyl3_base(
char const* trana, char const* tranb,
lapack_int const* isgn, lapack_int const* m, lapack_int const* n,
float const* A, lapack_int const* lda,
float const* B, lapack_int const* ldb,
float* C, lapack_int const* ldc, float* scale,
lapack_int* iwork, lapack_int const* liwork,
float* swork, lapack_int const *ldswork,
lapack_int* info
#ifdef LAPACK_FORTRAN_STRLEN_END
, size_t, size_t
#endif
);
#ifdef LAPACK_FORTRAN_STRLEN_END
#define LAPACK_strsyl3(...) LAPACK_strsyl3_base(__VA_ARGS__, 1, 1)
#else
#define LAPACK_strsyl3(...) LAPACK_strsyl3_base(__VA_ARGS__)
#endif
#define LAPACK_ztrsyl3_base LAPACK_GLOBAL(ztrsyl3,ZTRSYL3)
void LAPACK_ztrsyl3_base(
char const* trana, char const* tranb,
lapack_int const* isgn, lapack_int const* m, lapack_int const* n,
lapack_complex_double const* A, lapack_int const* lda,
lapack_complex_double const* B, lapack_int const* ldb,
lapack_complex_double* C, lapack_int const* ldc, double* scale,
double* swork, lapack_int const *ldswork,
lapack_int* info
#ifdef LAPACK_FORTRAN_STRLEN_END
, size_t, size_t
#endif
);
#ifdef LAPACK_FORTRAN_STRLEN_END
#define LAPACK_ztrsyl3(...) LAPACK_ztrsyl3_base(__VA_ARGS__, 1, 1)
#else
#define LAPACK_ztrsyl3(...) LAPACK_ztrsyl3_base(__VA_ARGS__)
#endif
#define LAPACK_ctrtri_base LAPACK_GLOBAL(ctrtri,CTRTRI)
void LAPACK_ctrtri_base(
char const* uplo, char const* diag,

74
lapack-netlib/LAPACKE/include/lapacke.h
View File

@@ -2313,6 +2313,19 @@ lapack_int LAPACKE_zlagge( int matrix_layout, lapack_int m, lapack_int n,
float LAPACKE_slamch( char cmach );
double LAPACKE_dlamch( char cmach );
float LAPACKE_slangb( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku, const float* ab,
lapack_int ldab );
double LAPACKE_dlangb( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku, const double* ab,
lapack_int ldab );
float LAPACKE_clangb( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku,
const lapack_complex_float* ab, lapack_int ldab );
double LAPACKE_zlangb( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku,
const lapack_complex_double* ab, lapack_int ldab );
float LAPACKE_slange( int matrix_layout, char norm, lapack_int m,
lapack_int n, const float* a, lapack_int lda );
double LAPACKE_dlange( int matrix_layout, char norm, lapack_int m,
@@ -4477,6 +4490,23 @@ lapack_int LAPACKE_ztrsyl( int matrix_layout, char trana, char tranb,
lapack_complex_double* c, lapack_int ldc,
double* scale );
lapack_int LAPACKE_strsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const float* a, lapack_int lda, const float* b,
lapack_int ldb, float* c, lapack_int ldc,
float* scale );
lapack_int LAPACKE_dtrsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const double* a, lapack_int lda, const double* b,
lapack_int ldb, double* c, lapack_int ldc,
double* scale );
lapack_int LAPACKE_ztrsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_double* a, lapack_int lda,
const lapack_complex_double* b, lapack_int ldb,
lapack_complex_double* c, lapack_int ldc,
double* scale );
lapack_int LAPACKE_strtri( int matrix_layout, char uplo, char diag, lapack_int n,
float* a, lapack_int lda );
lapack_int LAPACKE_dtrtri( int matrix_layout, char uplo, char diag, lapack_int n,
@@ -7576,6 +7606,21 @@ double LAPACKE_dlapy3_work( double x, double y, double z );
float LAPACKE_slamch_work( char cmach );
double LAPACKE_dlamch_work( char cmach );
float LAPACKE_slangb_work( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku, const float* ab,
lapack_int ldab, float* work );
double LAPACKE_dlangb_work( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku, const double* ab,
lapack_int ldab, double* work );
float LAPACKE_clangb_work( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku,
const lapack_complex_float* ab, lapack_int ldab,
float* work );
double LAPACKE_zlangb_work( int matrix_layout, char norm, lapack_int n,
lapack_int kl, lapack_int ku,
const lapack_complex_double* ab, lapack_int ldab,
double* work );
float LAPACKE_slange_work( int matrix_layout, char norm, lapack_int m,
lapack_int n, const float* a, lapack_int lda,
float* work );
@@ -10174,6 +10219,35 @@ lapack_int LAPACKE_ztrsyl_work( int matrix_layout, char trana, char tranb,
lapack_complex_double* c, lapack_int ldc,
double* scale );
lapack_int LAPACKE_strsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const float* a, lapack_int lda,
const float* b, lapack_int ldb,
float* c, lapack_int ldc, float* scale,
lapack_int* iwork, lapack_int liwork,
float* swork, lapack_int ldswork );
lapack_int LAPACKE_dtrsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const double* a, lapack_int lda,
const double* b, lapack_int ldb,
double* c, lapack_int ldc, double* scale,
lapack_int* iwork, lapack_int liwork,
double* swork, lapack_int ldswork );
lapack_int LAPACKE_ctrsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_float* a, lapack_int lda,
const lapack_complex_float* b, lapack_int ldb,
lapack_complex_float* c, lapack_int ldc,
float* scale, float* swork,
lapack_int ldswork );
lapack_int LAPACKE_ztrsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_double* a, lapack_int lda,
const lapack_complex_double* b, lapack_int ldb,
lapack_complex_double* c, lapack_int ldc,
double* scale, double* swork,
lapack_int ldswork );
lapack_int LAPACKE_strtri_work( int matrix_layout, char uplo, char diag,
lapack_int n, float* a, lapack_int lda );
lapack_int LAPACKE_dtrtri_work( int matrix_layout, char uplo, char diag,

1
lapack-netlib/LAPACKE/src/lapacke_cgesvdq.c
View File

@@ -48,7 +48,6 @@ lapack_int LAPACKE_cgesvdq( int matrix_layout, char joba, char jobp,
lapack_int lrwork = -1;
float* rwork = NULL;
float rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_cgesvdq", -1 );
return -1;

56
lapack-netlib/LAPACKE/src/lapacke_ctrsyl3.c Normal file
View File

@@ -0,0 +1,56 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_ctrsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_float* a, lapack_int lda,
const lapack_complex_float* b, lapack_int ldb,
lapack_complex_float* c, lapack_int ldc,
float* scale )
{
lapack_int info = 0;
float swork_query[2];
float* swork = NULL;
lapack_int ldswork = -1;
lapack_int swork_size = -1;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_ctrsyl3", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
if( LAPACKE_cge_nancheck( matrix_layout, m, m, a, lda ) ) {
return -7;
}
if( LAPACKE_cge_nancheck( matrix_layout, n, n, b, ldb ) ) {
return -9;
}
if( LAPACKE_cge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -11;
}
}
#endif
/* Query optimal working array sizes */
info = LAPACKE_ctrsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a, lda,
b, ldb, c, ldc, scale, swork_query, ldswork );
if( info != 0 ) {
goto exit_level_0;
}
ldswork = swork_query[0];
swork_size = ldswork * swork_query[1];
swork = (float*)LAPACKE_malloc( sizeof(float) * swork_size);
if( swork == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_0;
}
/* Call middle-level interface */
info = LAPACKE_ctrsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a,
lda, b, ldb, c, ldc, scale, swork, ldswork );
/* Release memory and exit */
LAPACKE_free( swork );
exit_level_0:
if( info == LAPACK_WORK_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_ctrsyl3", info );
}
return info;
}

88
lapack-netlib/LAPACKE/src/lapacke_ctrsyl3_work.c Normal file
View File

@@ -0,0 +1,88 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_ctrsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_float* a, lapack_int lda,
const lapack_complex_float* b, lapack_int ldb,
lapack_complex_float* c, lapack_int ldc,
float* scale, float* swork,
lapack_int ldswork )
{
lapack_int info = 0;
if( matrix_layout == LAPACK_COL_MAJOR ) {
/* Call LAPACK function and adjust info */
LAPACK_ctrsyl3( &trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc,
scale, swork, &ldswork, &info );
if( info < 0 ) {
info = info - 1;
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int lda_t = MAX(1,m);
lapack_int ldb_t = MAX(1,n);
lapack_int ldc_t = MAX(1,m);
lapack_complex_float* a_t = NULL;
lapack_complex_float* b_t = NULL;
lapack_complex_float* c_t = NULL;
/* Check leading dimension(s) */
if( lda < m ) {
info = -8;
LAPACKE_xerbla( "LAPACKE_ctrsyl3_work", info );
return info;
}
if( ldb < n ) {
info = -10;
LAPACKE_xerbla( "LAPACKE_ctrsyl3_work", info );
return info;
}
if( ldc < n ) {
info = -12;
LAPACKE_xerbla( "LAPACKE_ctrsyl3_work", info );
return info;
}
/* Allocate memory for temporary array(s) */
a_t = (lapack_complex_float*)
LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,m) );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_0;
}
b_t = (lapack_complex_float*)
LAPACKE_malloc( sizeof(lapack_complex_float) * ldb_t * MAX(1,n) );
if( b_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
}
c_t = (lapack_complex_float*)
LAPACKE_malloc( sizeof(lapack_complex_float) * ldc_t * MAX(1,n) );
if( c_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_2;
}
/* Transpose input matrices */
LAPACKE_cge_trans( matrix_layout, m, m, a, lda, a_t, lda_t );
LAPACKE_cge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t );
LAPACKE_cge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t );
/* Call LAPACK function and adjust info */
LAPACK_ctrsyl3( &trana, &tranb, &isgn, &m, &n, a_t, &lda_t, b_t, &ldb_t,
c_t, &ldc_t, scale, swork, &ldswork, &info );
if( info < 0 ) {
info = info - 1;
}
/* Transpose output matrices */
LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc );
/* Release memory and exit */
LAPACKE_free( c_t );
exit_level_2:
LAPACKE_free( b_t );
exit_level_1:
LAPACKE_free( a_t );
exit_level_0:
if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_ctrsyl3_work", info );
}
} else {
info = -1;
LAPACKE_xerbla( "LAPACKE_ctrsyl3_work", info );
}
return info;
}

1
lapack-netlib/LAPACKE/src/lapacke_dgesvdq.c
View File

@@ -48,7 +48,6 @@ lapack_int LAPACKE_dgesvdq( int matrix_layout, char joba, char jobp,
lapack_int lrwork = -1;
double* rwork = NULL;
double rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_dgesvdq", -1 );
return -1;

68
lapack-netlib/LAPACKE/src/lapacke_dtrsyl3.c Normal file
View File

@@ -0,0 +1,68 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_dtrsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const double* a, lapack_int lda, const double* b,
lapack_int ldb, double* c, lapack_int ldc,
double* scale )
{
lapack_int info = 0;
double swork_query[2];
double* swork = NULL;
lapack_int ldswork = -1;
lapack_int swork_size = -1;
lapack_int iwork_query;
lapack_int* iwork = NULL;
lapack_int liwork = -1;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_dtrsyl3", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
if( LAPACKE_dge_nancheck( matrix_layout, m, m, a, lda ) ) {
return -7;
}
if( LAPACKE_dge_nancheck( matrix_layout, n, n, b, ldb ) ) {
return -9;
}
if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -11;
}
}
#endif
/* Query optimal working array sizes */
info = LAPACKE_dtrsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a, lda,
b, ldb, c, ldc, scale, &iwork_query, liwork,
swork_query, ldswork );
if( info != 0 ) {
goto exit_level_0;
}
ldswork = swork_query[0];
swork_size = ldswork * swork_query[1];
swork = (double*)LAPACKE_malloc( sizeof(double) * swork_size);
if( swork == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_0;
}
liwork = iwork_query;
iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork );
if ( iwork == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_1;
}
/* Call middle-level interface */
info = LAPACKE_dtrsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a,
lda, b, ldb, c, ldc, scale, iwork, liwork,
swork, ldswork );
/* Release memory and exit */
LAPACKE_free( iwork );
exit_level_1:
LAPACKE_free( swork );
exit_level_0:
if( info == LAPACK_WORK_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_dtrsyl3", info );
}
return info;
}

86
lapack-netlib/LAPACKE/src/lapacke_dtrsyl3_work.c Normal file
View File

@@ -0,0 +1,86 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_dtrsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const double* a, lapack_int lda,
const double* b, lapack_int ldb, double* c,
lapack_int ldc, double* scale,
lapack_int* iwork, lapack_int liwork,
double* swork, lapack_int ldswork )
{
lapack_int info = 0;
if( matrix_layout == LAPACK_COL_MAJOR ) {
/* Call LAPACK function and adjust info */
LAPACK_dtrsyl3( &trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc,
scale, iwork, &liwork, swork, &ldswork, &info );
if( info < 0 ) {
info = info - 1;
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int lda_t = MAX(1,m);
lapack_int ldb_t = MAX(1,n);
lapack_int ldc_t = MAX(1,m);
double* a_t = NULL;
double* b_t = NULL;
double* c_t = NULL;
/* Check leading dimension(s) */
if( lda < m ) {
info = -8;
LAPACKE_xerbla( "LAPACKE_dtrsyl3_work", info );
return info;
}
if( ldb < n ) {
info = -10;
LAPACKE_xerbla( "LAPACKE_dtrsyl3_work", info );
return info;
}
if( ldc < n ) {
info = -12;
LAPACKE_xerbla( "LAPACKE_dtrsyl3_work", info );
return info;
}
/* Allocate memory for temporary array(s) */
a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,m) );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_0;
}
b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,n) );
if( b_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
}
c_t = (double*)LAPACKE_malloc( sizeof(double) * ldc_t * MAX(1,n) );
if( c_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_2;
}
/* Transpose input matrices */
LAPACKE_dge_trans( matrix_layout, m, m, a, lda, a_t, lda_t );
LAPACKE_dge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t );
LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t );
/* Call LAPACK function and adjust info */
LAPACK_dtrsyl3( &trana, &tranb, &isgn, &m, &n, a_t, &lda_t, b_t, &ldb_t,
c_t, &ldc_t, scale, iwork, &liwork, swork, &ldswork,
&info );
if( info < 0 ) {
info = info - 1;
}
/* Transpose output matrices */
LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc );
/* Release memory and exit */
LAPACKE_free( c_t );
exit_level_2:
LAPACKE_free( b_t );
exit_level_1:
LAPACKE_free( a_t );
exit_level_0:
if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_dtrsyl3_work", info );
}
} else {
info = -1;
LAPACKE_xerbla( "LAPACKE_dtrsyl3_work", info );
}
return info;
}

1
lapack-netlib/LAPACKE/src/lapacke_sgesvdq.c
View File

@@ -48,7 +48,6 @@ lapack_int LAPACKE_sgesvdq( int matrix_layout, char joba, char jobp,
lapack_int lrwork = -1;
float* rwork = NULL;
float rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_sgesvdq", -1 );
return -1;

68
lapack-netlib/LAPACKE/src/lapacke_strsyl3.c Normal file
View File

@@ -0,0 +1,68 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_strsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const float* a, lapack_int lda, const float* b,
lapack_int ldb, float* c, lapack_int ldc,
float* scale )
{
lapack_int info = 0;
float swork_query[2];
float* swork = NULL;
lapack_int ldswork = -1;
lapack_int swork_size = -1;
lapack_int iwork_query;
lapack_int* iwork = NULL;
lapack_int liwork = -1;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_strsyl3", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
if( LAPACKE_sge_nancheck( matrix_layout, m, m, a, lda ) ) {
return -7;
}
if( LAPACKE_sge_nancheck( matrix_layout, n, n, b, ldb ) ) {
return -9;
}
if( LAPACKE_sge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -11;
}
}
#endif
/* Query optimal working array sizes */
info = LAPACKE_strsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a, lda,
b, ldb, c, ldc, scale, &iwork_query, liwork,
swork_query, ldswork );
if( info != 0 ) {
goto exit_level_0;
}
ldswork = swork_query[0];
swork_size = ldswork * swork_query[1];
swork = (float*)LAPACKE_malloc( sizeof(float) * swork_size);
if( swork == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_0;
}
liwork = iwork_query;
iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork );
if ( iwork == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_1;
}
/* Call middle-level interface */
info = LAPACKE_strsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a,
lda, b, ldb, c, ldc, scale, iwork, liwork,
swork, ldswork );
/* Release memory and exit */
LAPACKE_free( iwork );
exit_level_1:
LAPACKE_free( swork );
exit_level_0:
if( info == LAPACK_WORK_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_strsyl3", info );
}
return info;
}

86
lapack-netlib/LAPACKE/src/lapacke_strsyl3_work.c Normal file
View File

@@ -0,0 +1,86 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_strsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const float* a, lapack_int lda,
const float* b, lapack_int ldb, float* c,
lapack_int ldc, float* scale,
lapack_int* iwork, lapack_int liwork,
float* swork, lapack_int ldswork )
{
lapack_int info = 0;
if( matrix_layout == LAPACK_COL_MAJOR ) {
/* Call LAPACK function and adjust info */
LAPACK_strsyl3( &trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc,
scale, iwork, &liwork, swork, &ldswork, &info );
if( info < 0 ) {
info = info - 1;
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int lda_t = MAX(1,m);
lapack_int ldb_t = MAX(1,n);
lapack_int ldc_t = MAX(1,m);
float* a_t = NULL;
float* b_t = NULL;
float* c_t = NULL;
/* Check leading dimension(s) */
if( lda < m ) {
info = -8;
LAPACKE_xerbla( "LAPACKE_strsyl3_work", info );
return info;
}
if( ldb < n ) {
info = -10;
LAPACKE_xerbla( "LAPACKE_strsyl3_work", info );
return info;
}
if( ldc < n ) {
info = -12;
LAPACKE_xerbla( "LAPACKE_strsyl3_work", info );
return info;
}
/* Allocate memory for temporary array(s) */
a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,m) );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_0;
}
b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,n) );
if( b_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
}
c_t = (float*)LAPACKE_malloc( sizeof(float) * ldc_t * MAX(1,n) );
if( c_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_2;
}
/* Transpose input matrices */
LAPACKE_sge_trans( matrix_layout, m, m, a, lda, a_t, lda_t );
LAPACKE_sge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t );
LAPACKE_sge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t );
/* Call LAPACK function and adjust info */
LAPACK_strsyl3( &trana, &tranb, &isgn, &m, &n, a_t, &lda_t, b_t, &ldb_t,
c_t, &ldc_t, scale, iwork, &liwork, swork, &ldswork,
&info );
if( info < 0 ) {
info = info - 1;
}
/* Transpose output matrices */
LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc );
/* Release memory and exit */
LAPACKE_free( c_t );
exit_level_2:
LAPACKE_free( b_t );
exit_level_1:
LAPACKE_free( a_t );
exit_level_0:
if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_strsyl3_work", info );
}
} else {
info = -1;
LAPACKE_xerbla( "LAPACKE_strsyl3_work", info );
}
return info;
}

1
lapack-netlib/LAPACKE/src/lapacke_zgesvdq.c
View File

@@ -48,7 +48,6 @@ lapack_int LAPACKE_zgesvdq( int matrix_layout, char joba, char jobp,
lapack_int lrwork = -1;
double* rwork = NULL;
double rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_zgesvdq", -1 );
return -1;

56
lapack-netlib/LAPACKE/src/lapacke_ztrsyl3.c Normal file
View File

@@ -0,0 +1,56 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_ztrsyl3( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_double* a, lapack_int lda,
const lapack_complex_double* b, lapack_int ldb,
lapack_complex_double* c, lapack_int ldc,
double* scale )
{
lapack_int info = 0;
double swork_query[2];
double* swork = NULL;
lapack_int ldswork = -1;
lapack_int swork_size = -1;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_ztrsyl3", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
if( LAPACKE_zge_nancheck( matrix_layout, m, m, a, lda ) ) {
return -7;
}
if( LAPACKE_zge_nancheck( matrix_layout, n, n, b, ldb ) ) {
return -9;
}
if( LAPACKE_zge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -11;
}
}
#endif
/* Query optimal working array sizes */
info = LAPACKE_ztrsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a, lda,
b, ldb, c, ldc, scale, swork_query, ldswork );
if( info != 0 ) {
goto exit_level_0;
}
ldswork = swork_query[0];
swork_size = ldswork * swork_query[1];
swork = (double*)LAPACKE_malloc( sizeof(double) * swork_size);
if( swork == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_0;
}
/* Call middle-level interface */
info = LAPACKE_ztrsyl3_work( matrix_layout, trana, tranb, isgn, m, n, a,
lda, b, ldb, c, ldc, scale, swork, ldswork );
/* Release memory and exit */
LAPACKE_free( swork );
exit_level_0:
if( info == LAPACK_WORK_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_ztrsyl3", info );
}
return info;
}

88
lapack-netlib/LAPACKE/src/lapacke_ztrsyl3_work.c Normal file
View File

@@ -0,0 +1,88 @@
#include "lapacke_utils.h"
lapack_int LAPACKE_ztrsyl3_work( int matrix_layout, char trana, char tranb,
lapack_int isgn, lapack_int m, lapack_int n,
const lapack_complex_double* a, lapack_int lda,
const lapack_complex_double* b, lapack_int ldb,
lapack_complex_double* c, lapack_int ldc,
double* scale, double* swork,
lapack_int ldswork )
{
lapack_int info = 0;
if( matrix_layout == LAPACK_COL_MAJOR ) {
/* Call LAPACK function and adjust info */
LAPACK_ztrsyl3( &trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc,
scale, swork, &ldswork, &info );
if( info < 0 ) {
info = info - 1;
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int lda_t = MAX(1,m);
lapack_int ldb_t = MAX(1,n);
lapack_int ldc_t = MAX(1,m);
lapack_complex_double* a_t = NULL;
lapack_complex_double* b_t = NULL;
lapack_complex_double* c_t = NULL;
/* Check leading dimension(s) */
if( lda < m ) {
info = -8;
LAPACKE_xerbla( "LAPACKE_ztrsyl3_work", info );
return info;
}
if( ldb < n ) {
info = -10;
LAPACKE_xerbla( "LAPACKE_ztrsyl3_work", info );
return info;
}
if( ldc < n ) {
info = -12;
LAPACKE_xerbla( "LAPACKE_ztrsyl3_work", info );
return info;
}
/* Allocate memory for temporary array(s) */
a_t = (lapack_complex_double*)
LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,m) );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_0;
}
b_t = (lapack_complex_double*)
LAPACKE_malloc( sizeof(lapack_complex_double) * ldb_t * MAX(1,n) );
if( b_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
}
c_t = (lapack_complex_double*)
LAPACKE_malloc( sizeof(lapack_complex_double) * ldc_t * MAX(1,n) );
if( c_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_2;
}
/* Transpose input matrices */
LAPACKE_zge_trans( matrix_layout, m, m, a, lda, a_t, lda_t );
LAPACKE_zge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t );
LAPACKE_zge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t );
/* Call LAPACK function and adjust info */
LAPACK_ztrsyl3( &trana, &tranb, &isgn, &m, &n, a_t, &lda_t, b_t, &ldb_t,
c_t, &ldc_t, scale, swork, &ldswork, &info );
if( info < 0 ) {
info = info - 1;
}
/* Transpose output matrices */
LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc );
/* Release memory and exit */
LAPACKE_free( c_t );
exit_level_2:
LAPACKE_free( b_t );
exit_level_1:
LAPACKE_free( a_t );
exit_level_0:
if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_ztrsyl3_work", info );
}
} else {
info = -1;
LAPACKE_xerbla( "LAPACKE_ztrsyl3_work", info );
}
return info;
}