phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #1042 from sergey-v-kuznetsov/lapacke_tfsm_fixes

Browse Source
This commit is contained in:
langou
2024-08-09 19:21:37 -07:00
committed by GitHub
parent 3c351aad41 7fd3d47b03
commit dd49b19c08
12 changed files with 42 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files
LAPACKE/src/lapacke_ctfsm.c
+3 -1
View File
@@ -44,9 +44,11 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm)( int matrix_layout, char transr, char side,
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
lapack_int mn = m;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Optionally check input matrices for NaNs */
if( IS_C_NONZERO(alpha) ) {
if( API_SUFFIX(LAPACKE_ctf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
if( API_SUFFIX(LAPACKE_ctf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
return -10;
}
}
LAPACKE/src/lapacke_ctfsm_work.c
+5 -3
View File
@@ -48,10 +48,12 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm_work)( int matrix_layout, char transr, char
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int ldb_t = MAX(1,m);
lapack_int mn = m;
lapack_complex_float* b_t = NULL;
lapack_complex_float* a_t = NULL;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Check leading dimension(s) */
if( ldb < n ) {
if( ldb < m ) {
info = -12;
API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_ctfsm_work", info );
return info;
@@ -66,7 +68,7 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm_work)( int matrix_layout, char transr, char
if( IS_C_NONZERO(alpha) ) {
a_t = (lapack_complex_float*)
LAPACKE_malloc( sizeof(lapack_complex_float) *
( MAX(1,n) * MAX(2,n+1) ) / 2 );
( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
@@ -77,7 +79,7 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm_work)( int matrix_layout, char transr, char
API_SUFFIX(LAPACKE_cge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
}
if( IS_C_NONZERO(alpha) ) {
API_SUFFIX(LAPACKE_ctf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
API_SUFFIX(LAPACKE_ctf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
}
/* Call LAPACK function and adjust info */
LAPACK_ctfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,
LAPACKE/src/lapacke_dtfsm.c
+3 -1
View File
@@ -44,8 +44,10 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm)( int matrix_layout, char transr, char side,
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
lapack_int mn = m;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
if( IS_D_NONZERO(alpha) ) {
if( API_SUFFIX(LAPACKE_dtf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
if( API_SUFFIX(LAPACKE_dtf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
return -10;
}
}
LAPACKE/src/lapacke_dtfsm_work.c
+5 -3
View File
@@ -47,10 +47,12 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm_work)( int matrix_layout, char transr, char
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int ldb_t = MAX(1,m);
lapack_int mn = m;
double* b_t = NULL;
double* a_t = NULL;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Check leading dimension(s) */
if( ldb < n ) {
if( ldb < m ) {
info = -12;
API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dtfsm_work", info );
return info;
@@ -64,7 +66,7 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm_work)( int matrix_layout, char transr, char
if( IS_D_NONZERO(alpha) ) {
a_t = (double*)
LAPACKE_malloc( sizeof(double) *
( MAX(1,n) * MAX(2,n+1) ) / 2 );
( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
@@ -75,7 +77,7 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm_work)( int matrix_layout, char transr, char
API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
}
if( IS_D_NONZERO(alpha) ) {
API_SUFFIX(LAPACKE_dtf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
API_SUFFIX(LAPACKE_dtf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
}
/* Call LAPACK function and adjust info */
LAPACK_dtfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,
LAPACKE/src/lapacke_stfsm.c
+3 -1
View File
@@ -43,9 +43,11 @@ lapack_int API_SUFFIX(LAPACKE_stfsm)( int matrix_layout, char transr, char side,
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
lapack_int mn = m;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Optionally check input matrices for NaNs */
if( IS_S_NONZERO(alpha) ) {
if( API_SUFFIX(LAPACKE_stf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
if( API_SUFFIX(LAPACKE_stf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
return -10;
}
}
LAPACKE/src/lapacke_stfsm_work.c
+5 -3
View File
@@ -47,10 +47,12 @@ lapack_int API_SUFFIX(LAPACKE_stfsm_work)( int matrix_layout, char transr, char
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int ldb_t = MAX(1,m);
lapack_int mn = MAX(1,m);
float* b_t = NULL;
float* a_t = NULL;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Check leading dimension(s) */
if( ldb < n ) {
if( ldb < m ) {
info = -12;
API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_stfsm_work", info );
return info;
@@ -63,7 +65,7 @@ lapack_int API_SUFFIX(LAPACKE_stfsm_work)( int matrix_layout, char transr, char
}
if( IS_S_NONZERO(alpha) ) {
a_t = (float*)
LAPACKE_malloc( sizeof(float) * ( MAX(1,n) * MAX(2,n+1) ) / 2 );
LAPACKE_malloc( sizeof(float) * ( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
@@ -74,7 +76,7 @@ lapack_int API_SUFFIX(LAPACKE_stfsm_work)( int matrix_layout, char transr, char
API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
}
if( IS_S_NONZERO(alpha) ) {
API_SUFFIX(LAPACKE_stf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
API_SUFFIX(LAPACKE_stf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
}
/* Call LAPACK function and adjust info */
LAPACK_stfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,
LAPACKE/src/lapacke_ztfsm.c
+3 -1
View File
@@ -44,9 +44,11 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm)( int matrix_layout, char transr, char side,
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
lapack_int mn = m;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Optionally check input matrices for NaNs */
if( IS_Z_NONZERO(alpha) ) {
if( API_SUFFIX(LAPACKE_ztf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
if( API_SUFFIX(LAPACKE_ztf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
return -10;
}
}
LAPACKE/src/lapacke_ztfsm_work.c
+6 -4
View File
@@ -48,10 +48,12 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm_work)( int matrix_layout, char transr, char
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
lapack_int ldb_t = MAX(1,m);
lapack_int mn = m;
lapack_complex_double* b_t = NULL;
lapack_complex_double* a_t = NULL;
if( LAPACKE_lsame( side, 'r' ) ) mn = n;
/* Check leading dimension(s) */
if( ldb < n ) {
if( ldb < m ) {
info = -12;
API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_ztfsm_work", info );
return info;
@@ -66,7 +68,7 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm_work)( int matrix_layout, char transr, char
if( IS_Z_NONZERO(alpha) ) {
a_t = (lapack_complex_double*)
LAPACKE_malloc( sizeof(lapack_complex_double) *
( MAX(1,n) * MAX(2,n+1) ) / 2 );
( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
if( a_t == NULL ) {
info = LAPACK_TRANSPOSE_MEMORY_ERROR;
goto exit_level_1;
@@ -77,14 +79,14 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm_work)( int matrix_layout, char transr, char
API_SUFFIX(LAPACKE_zge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
}
if( IS_Z_NONZERO(alpha) ) {
API_SUFFIX(LAPACKE_ztf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
API_SUFFIX(LAPACKE_ztf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
}
/* Call LAPACK function and adjust info */
LAPACK_ztfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,
b_t, &ldb_t );
info = 0; /* LAPACK call is ok! */
/* Transpose output matrices */
API_SUFFIX(LAPACKE_zge_trans)( LAPACK_COL_MAJOR, m, n, b_t, ldb_t, b, ldb );
LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, b_t, ldb_t, b, ldb );
/* Release memory and exit */
if( IS_Z_NONZERO(alpha) ) {
LAPACKE_free( a_t );
SRC/ctfsm.f
+3 -2
View File
@@ -140,8 +140,9 @@
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension (N*(N+1)/2)
*> NT = N*(N+1)/2. On entry, the matrix A in RFP Format.
*> A is COMPLEX array, dimension (NT)
*> NT = N*(N+1)/2 if SIDE='R' and NT = M*(M+1)/2 otherwise.
*> On entry, the matrix A in RFP Format.
*> RFP Format is described by TRANSR, UPLO and N as follows:
*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
SRC/dtfsm.f
+2 -1
View File
@@ -141,7 +141,8 @@
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (NT)
*> NT = N*(N+1)/2. On entry, the matrix A in RFP Format.
*> NT = N*(N+1)/2 if SIDE='R' and NT = M*(M+1)/2 otherwise.
*> On entry, the matrix A in RFP Format.
*> RFP Format is described by TRANSR, UPLO and N as follows:
*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
SRC/stfsm.f
+2 -1
View File
@@ -141,7 +141,8 @@
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension (NT)
*> NT = N*(N+1)/2. On entry, the matrix A in RFP Format.
*> NT = N*(N+1)/2 if SIDE='R' and NT = M*(M+1)/2 otherwise.
*> On entry, the matrix A in RFP Format.
*> RFP Format is described by TRANSR, UPLO and N as follows:
*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
SRC/ztfsm.f
+2 -1
View File
@@ -141,7 +141,8 @@
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (N*(N+1)/2)
*> NT = N*(N+1)/2. On entry, the matrix A in RFP Format.
*> NT = N*(N+1)/2 if SIDE='R' and NT = M*(M+1)/2 otherwise.
*> On entry, the matrix A in RFP Format.
*> RFP Format is described by TRANSR, UPLO and N as follows:
*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If