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

Add a BLAS3-based triangular Sylvester equation solver (Reference-LAPACK PR 651)

This commit is contained in:
Martin Kroeker 2022-11-13 23:07:10 +01:00 committed by GitHub
parent 4bc918a791
commit 7eb2653268
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 596 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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; lapack_int lrwork = -1;
float* rwork = NULL; float* rwork = NULL;
float rwork_query; float rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_cgesvdq", -1 ); LAPACKE_xerbla( "LAPACKE_cgesvdq", -1 );
return -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; lapack_int lrwork = -1;
double* rwork = NULL; double* rwork = NULL;
double rwork_query; double rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_dgesvdq", -1 ); LAPACKE_xerbla( "LAPACKE_dgesvdq", -1 );
return -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; lapack_int lrwork = -1;
float* rwork = NULL; float* rwork = NULL;
float rwork_query; float rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_sgesvdq", -1 ); LAPACKE_xerbla( "LAPACKE_sgesvdq", -1 );
return -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; lapack_int lrwork = -1;
double* rwork = NULL; double* rwork = NULL;
double rwork_query; double rwork_query;
lapack_int i;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_zgesvdq", -1 ); LAPACKE_xerbla( "LAPACKE_zgesvdq", -1 );
return -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;
}