From 7fd3d47b0321b50f193422c82e5676ee7d9ea750 Mon Sep 17 00:00:00 2001 From: sergey-v-kuznetsov Date: Fri, 9 Aug 2024 17:17:35 -0700 Subject: [PATCH] PR contains bug fixes found in ?tfsm --- LAPACKE/src/lapacke_ctfsm.c | 4 +++- LAPACKE/src/lapacke_ctfsm_work.c | 8 +++++--- LAPACKE/src/lapacke_dtfsm.c | 4 +++- LAPACKE/src/lapacke_dtfsm_work.c | 8 +++++--- LAPACKE/src/lapacke_stfsm.c | 4 +++- LAPACKE/src/lapacke_stfsm_work.c | 8 +++++--- LAPACKE/src/lapacke_ztfsm.c | 4 +++- LAPACKE/src/lapacke_ztfsm_work.c | 10 ++++++---- SRC/ctfsm.f | 5 +++-- SRC/dtfsm.f | 3 ++- SRC/stfsm.f | 3 ++- SRC/ztfsm.f | 3 ++- 12 files changed, 42 insertions(+), 22 deletions(-) diff --git a/LAPACKE/src/lapacke_ctfsm.c b/LAPACKE/src/lapacke_ctfsm.c index ab9d8d1b02..fc75890bd5 100644 --- a/LAPACKE/src/lapacke_ctfsm.c +++ b/LAPACKE/src/lapacke_ctfsm.c @@ -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; } } diff --git a/LAPACKE/src/lapacke_ctfsm_work.c b/LAPACKE/src/lapacke_ctfsm_work.c index 98bc661d55..50f123579c 100644 --- a/LAPACKE/src/lapacke_ctfsm_work.c +++ b/LAPACKE/src/lapacke_ctfsm_work.c @@ -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, diff --git a/LAPACKE/src/lapacke_dtfsm.c b/LAPACKE/src/lapacke_dtfsm.c index 8ce40723cd..c0a33f3188 100644 --- a/LAPACKE/src/lapacke_dtfsm.c +++ b/LAPACKE/src/lapacke_dtfsm.c @@ -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; } } diff --git a/LAPACKE/src/lapacke_dtfsm_work.c b/LAPACKE/src/lapacke_dtfsm_work.c index 0857b45f7c..938de2f96e 100644 --- a/LAPACKE/src/lapacke_dtfsm_work.c +++ b/LAPACKE/src/lapacke_dtfsm_work.c @@ -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, diff --git a/LAPACKE/src/lapacke_stfsm.c b/LAPACKE/src/lapacke_stfsm.c index 890a5e5c2d..23c8730c8c 100644 --- a/LAPACKE/src/lapacke_stfsm.c +++ b/LAPACKE/src/lapacke_stfsm.c @@ -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; } } diff --git a/LAPACKE/src/lapacke_stfsm_work.c b/LAPACKE/src/lapacke_stfsm_work.c index 9687741f99..c601472d64 100644 --- a/LAPACKE/src/lapacke_stfsm_work.c +++ b/LAPACKE/src/lapacke_stfsm_work.c @@ -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, diff --git a/LAPACKE/src/lapacke_ztfsm.c b/LAPACKE/src/lapacke_ztfsm.c index e20bca24b7..43ea9aabe8 100644 --- a/LAPACKE/src/lapacke_ztfsm.c +++ b/LAPACKE/src/lapacke_ztfsm.c @@ -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; } } diff --git a/LAPACKE/src/lapacke_ztfsm_work.c b/LAPACKE/src/lapacke_ztfsm_work.c index 00b0917cb3..11e269598f 100644 --- a/LAPACKE/src/lapacke_ztfsm_work.c +++ b/LAPACKE/src/lapacke_ztfsm_work.c @@ -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 ); diff --git a/SRC/ctfsm.f b/SRC/ctfsm.f index e381f476ac..f7cc01caed 100644 --- a/SRC/ctfsm.f +++ b/SRC/ctfsm.f @@ -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 diff --git a/SRC/dtfsm.f b/SRC/dtfsm.f index 7b75a8d285..6d7f28a5e6 100644 --- a/SRC/dtfsm.f +++ b/SRC/dtfsm.f @@ -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 diff --git a/SRC/stfsm.f b/SRC/stfsm.f index c167f80c09..813b56f858 100644 --- a/SRC/stfsm.f +++ b/SRC/stfsm.f @@ -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 diff --git a/SRC/ztfsm.f b/SRC/ztfsm.f index 98d1820690..184f367df7 100644 --- a/SRC/ztfsm.f +++ b/SRC/ztfsm.f @@ -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