Skip to content

Commit

Permalink
Merge pull request Reference-LAPACK#742 from ACSimon33/LAPACKE_xLARFB…
Browse files Browse the repository at this point in the history 
…_nancheck

Lapacke x larfb nancheck
  • Loading branch information
@langou
langou authored Oct 31, 2022
2 parents 20b45b9 + 6ef9ae9 commit 1e7759a
Show file tree
Hide file tree
Showing 19 changed files with 822 additions and 401 deletions.
16 changes: 16 additions & 0 deletions LAPACKE/include/lapacke_utils.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,10 @@ void LAPACKE_ctp_trans( int matrix_layout, char uplo, char diag,
void LAPACKE_ctr_trans( int matrix_layout, char uplo, char diag, lapack_int n,
const lapack_complex_float *in, lapack_int ldin,
lapack_complex_float *out, lapack_int ldout );
void LAPACKE_ctz_trans( int matrix_layout, char direct, char uplo,
char diag, lapack_int m, lapack_int n,
const lapack_complex_float *in, lapack_int ldin,
lapack_complex_float *out, lapack_int ldout );

void LAPACKE_dgb_trans( int matrix_layout, lapack_int m, lapack_int n,
lapack_int kl, lapack_int ku,
Expand Down Expand Up @@ -178,6 +182,10 @@ void LAPACKE_dtp_trans( int matrix_layout, char uplo, char diag,
void LAPACKE_dtr_trans( int matrix_layout, char uplo, char diag, lapack_int n,
const double *in, lapack_int ldin,
double *out, lapack_int ldout );
void LAPACKE_dtz_trans( int matrix_layout, char direct, char uplo,
char diag, lapack_int m, lapack_int n,
const double *in, lapack_int ldin,
double *out, lapack_int ldout );

void LAPACKE_sgb_trans( int matrix_layout, lapack_int m, lapack_int n,
lapack_int kl, lapack_int ku,
Expand Down Expand Up @@ -228,6 +236,10 @@ void LAPACKE_stp_trans( int matrix_layout, char uplo, char diag,
void LAPACKE_str_trans( int matrix_layout, char uplo, char diag, lapack_int n,
const float *in, lapack_int ldin,
float *out, lapack_int ldout );
void LAPACKE_stz_trans( int matrix_layout, char direct, char uplo,
char diag, lapack_int m, lapack_int n,
const float *in, lapack_int ldin,
float *out, lapack_int ldout );

void LAPACKE_zgb_trans( int matrix_layout, lapack_int m, lapack_int n,
lapack_int kl, lapack_int ku,
Expand Down Expand Up @@ -284,6 +296,10 @@ void LAPACKE_ztp_trans( int matrix_layout, char uplo, char diag,
void LAPACKE_ztr_trans( int matrix_layout, char uplo, char diag, lapack_int n,
const lapack_complex_double *in, lapack_int ldin,
lapack_complex_double *out, lapack_int ldout );
void LAPACKE_ztz_trans( int matrix_layout, char direct, char uplo,
char diag, lapack_int m, lapack_int n,
const lapack_complex_double *in, lapack_int ldin,
lapack_complex_double *out, lapack_int ldout );

/* NaN checkers */
#define LAPACK_SISNAN( x ) ( x != x )
Expand Down
68 changes: 19 additions & 49 deletions LAPACKE/src/lapacke_clarfb.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,67 +42,37 @@ lapack_int LAPACKE_clarfb( int matrix_layout, char side, char trans, char direct
lapack_int info = 0;
lapack_int ldwork;
lapack_complex_float* work = NULL;
lapack_int ncols_v, nrows_v;
lapack_int nrows_v, ncols_v;
lapack_logical left, col, forward;
char uplo;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_clarfb", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
lapack_int lrv, lcv; /* row, column stride */
if( matrix_layout == LAPACK_COL_MAJOR ) {
lrv = 1;
lcv = ldv;
} else {
lrv = ldv;
lcv = 1;
}
ncols_v = LAPACKE_lsame( storev, 'c' ) ? k :
( ( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( side, 'r' ) ) ? n : 1) );
left = LAPACKE_lsame( side, 'l' );
col = LAPACKE_lsame( storev, 'c' );
forward = LAPACKE_lsame( direct, 'f' );

nrows_v = ( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( side, 'r' ) ) ? n :
( LAPACKE_lsame( storev, 'r' ) ? k : 1) );
if( LAPACKE_cge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -13;
nrows_v = ( col && left ) ? m : ( ( col && !left ) ? n : ( !col ? k : 1) );
ncols_v = ( !col && left ) ? m : ( ( !col && !left ) ? n : ( col ? k : 1 ) );
uplo = ( ( left && col ) || !( left || col ) ) ? 'l' : 'u';

if( !forward && ( col && k > nrows_v ) || ( !col && k > ncols_v )) {
LAPACKE_xerbla( "LAPACKE_clarfb", -8 );
return -8;
}
if( LAPACKE_ctz_nancheck( matrix_layout, direct, uplo, 'u',
nrows_v, ncols_v, v, ldv ) ) {
return -9;
}
if( LAPACKE_cge_nancheck( matrix_layout, k, k, t, ldt ) ) {
return -11;
}
if( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( direct, 'f' ) ) {
if( LAPACKE_ctr_nancheck( matrix_layout, 'l', 'u', k, v, ldv ) )
return -9;
if( LAPACKE_cge_nancheck( matrix_layout, nrows_v-k, ncols_v,
&v[k*lrv], ldv ) )
return -9;
} else if( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( direct, 'b' ) ) {
if( k > nrows_v ) {
LAPACKE_xerbla( "LAPACKE_clarfb", -8 );
return -8;
}
if( LAPACKE_ctr_nancheck( matrix_layout, 'u', 'u', k,
&v[(nrows_v-k)*lrv], ldv ) )
return -9;
if( LAPACKE_cge_nancheck( matrix_layout, nrows_v-k, ncols_v, v, ldv ) )
return -9;
} else if( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( direct, 'f' ) ) {
if( LAPACKE_ctr_nancheck( matrix_layout, 'u', 'u', k, v, ldv ) )
return -9;
if( LAPACKE_cge_nancheck( matrix_layout, nrows_v, ncols_v-k,
&v[k*lrv], ldv ) )
return -9;
} else if( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( direct, 'b' ) ) {
if( k > ncols_v ) {
LAPACKE_xerbla( "LAPACKE_clarfb", -8 );
return -8;
}
if( LAPACKE_ctr_nancheck( matrix_layout, 'l', 'u', k,
&v[(ncols_v-k)*lcv], ldv ) )
return -9;
if( LAPACKE_cge_nancheck( matrix_layout, nrows_v, ncols_v-k, v, ldv ) )
return -9;
if( LAPACKE_cge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -13;
}
}
#endif
Expand Down
57 changes: 17 additions & 40 deletions LAPACKE/src/lapacke_clarfb_work.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,8 @@ lapack_int LAPACKE_clarfb_work( int matrix_layout, char side, char trans,
{
lapack_int info = 0;
lapack_int nrows_v, ncols_v;
lapack_logical left, col, forward;
char uplo;
lapack_int ldc_t, ldt_t, ldv_t;
lapack_complex_float *v_t = NULL, *t_t = NULL, *c_t = NULL;
if( matrix_layout == LAPACK_COL_MAJOR ) {
Expand All @@ -52,16 +54,14 @@ lapack_int LAPACKE_clarfb_work( int matrix_layout, char side, char trans,
info = info - 1;
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
nrows_v = ( LAPACKE_lsame( storev, 'c' ) &&
LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'c' ) &&
LAPACKE_lsame( side, 'r' ) ) ? n :
( LAPACKE_lsame( storev, 'r' ) ? k : 1) );
ncols_v = LAPACKE_lsame( storev, 'c' ) ? k :
( ( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( side, 'r' ) ) ? n : 1) );
left = LAPACKE_lsame( side, 'l' );
col = LAPACKE_lsame( storev, 'c' );
forward = LAPACKE_lsame( direct, 'f' );

nrows_v = ( col && left ) ? m : ( ( col && !left ) ? n : ( !col ? k : 1) );
ncols_v = ( !col && left ) ? m : ( ( !col && !left ) ? n : ( col ? k : 1 ) );
uplo = ( ( left && col ) || !( left || col ) ) ? 'l' : 'u';

ldc_t = MAX(1,m);
ldt_t = MAX(1,k);
ldv_t = MAX(1,nrows_v);
Expand All @@ -81,6 +81,11 @@ lapack_int LAPACKE_clarfb_work( int matrix_layout, char side, char trans,
LAPACKE_xerbla( "LAPACKE_clarfb_work", info );
return info;
}
if( !forward && ( col && k > nrows_v ) || ( !col && k > ncols_v )) {
info = -8;
LAPACKE_xerbla( "LAPACKE_clarfb_work", info );
return info;
}
/* Allocate memory for temporary array(s) */
v_t = (lapack_complex_float*)
LAPACKE_malloc( sizeof(lapack_complex_float) *
Expand All @@ -102,36 +107,8 @@ lapack_int LAPACKE_clarfb_work( int matrix_layout, char side, char trans,
goto exit_level_2;
}
/* Transpose input matrices */
if( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( direct, 'f' ) ) {
LAPACKE_ctr_trans( matrix_layout, 'l', 'u', k, v, ldv, v_t, ldv_t );
LAPACKE_cge_trans( matrix_layout, nrows_v-k, ncols_v, &v[k*ldv], ldv,
&v_t[k], ldv_t );
} else if( LAPACKE_lsame( storev, 'c' ) &&
LAPACKE_lsame( direct, 'b' ) ) {
if( k > nrows_v ) {
LAPACKE_xerbla( "LAPACKE_clarfb_work", -8 );
return -8;
}
LAPACKE_ctr_trans( matrix_layout, 'u', 'u', k, &v[(nrows_v-k)*ldv],
ldv, &v_t[nrows_v-k], ldv_t );
LAPACKE_cge_trans( matrix_layout, nrows_v-k, ncols_v, v, ldv, v_t,
ldv_t );
} else if( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( direct, 'f' ) ) {
LAPACKE_ctr_trans( matrix_layout, 'u', 'u', k, v, ldv, v_t, ldv_t );
LAPACKE_cge_trans( matrix_layout, nrows_v, ncols_v-k, &v[k], ldv,
&v_t[k*ldv_t], ldv_t );
} else if( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( direct, 'b' ) ) {
if( k > ncols_v ) {
LAPACKE_xerbla( "LAPACKE_clarfb_work", -8 );
return -8;
}
LAPACKE_ctr_trans( matrix_layout, 'l', 'u', k, &v[ncols_v-k], ldv,
&v_t[(ncols_v-k)*ldv_t], ldv_t );
LAPACKE_cge_trans( matrix_layout, nrows_v, ncols_v-k, v, ldv, v_t,
ldv_t );
}
LAPACKE_ctz_trans( matrix_layout, direct, uplo, 'u', nrows_v, ncols_v,
v, ldv, v_t, ldv_t );
LAPACKE_cge_trans( matrix_layout, k, k, t, ldt, t_t, ldt_t );
LAPACKE_cge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t );
/* Call LAPACK function and adjust info */
Expand Down
68 changes: 19 additions & 49 deletions LAPACKE/src/lapacke_dlarfb.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,67 +41,37 @@ lapack_int LAPACKE_dlarfb( int matrix_layout, char side, char trans, char direct
lapack_int info = 0;
lapack_int ldwork;
double* work = NULL;
lapack_int ncols_v, nrows_v;
lapack_int nrows_v, ncols_v;
lapack_logical left, col, forward;
char uplo;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_dlarfb", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
if( LAPACKE_get_nancheck() ) {
/* Optionally check input matrices for NaNs */
lapack_int lrv, lcv; /* row, column stride */
if( matrix_layout == LAPACK_COL_MAJOR ) {
lrv = 1;
lcv = ldv;
} else {
lrv = ldv;
lcv = 1;
}
ncols_v = LAPACKE_lsame( storev, 'c' ) ? k :
( ( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( side, 'r' ) ) ? n : 1) );
left = LAPACKE_lsame( side, 'l' );
col = LAPACKE_lsame( storev, 'c' );
forward = LAPACKE_lsame( direct, 'f' );

nrows_v = ( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( side, 'r' ) ) ? n :
( LAPACKE_lsame( storev, 'r' ) ? k : 1) );
if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -13;
nrows_v = ( col && left ) ? m : ( ( col && !left ) ? n : ( !col ? k : 1) );
ncols_v = ( !col && left ) ? m : ( ( !col && !left ) ? n : ( col ? k : 1 ) );
uplo = ( ( left && col ) || !( left || col ) ) ? 'l' : 'u';

if( !forward && ( col && k > nrows_v ) || ( !col && k > ncols_v )) {
LAPACKE_xerbla( "LAPACKE_dlarfb", -8 );
return -8;
}
if( LAPACKE_dtz_nancheck( matrix_layout, direct, uplo, 'u',
nrows_v, ncols_v, v, ldv ) ) {
return -9;
}
if( LAPACKE_dge_nancheck( matrix_layout, k, k, t, ldt ) ) {
return -11;
}
if( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( direct, 'f' ) ) {
if( LAPACKE_dtr_nancheck( matrix_layout, 'l', 'u', k, v, ldv ) )
return -9;
if( LAPACKE_dge_nancheck( matrix_layout, nrows_v-k, ncols_v,
&v[k*lrv], ldv ) )
return -9;
} else if( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( direct, 'b' ) ) {
if( k > nrows_v ) {
LAPACKE_xerbla( "LAPACKE_dlarfb", -8 );
return -8;
}
if( LAPACKE_dtr_nancheck( matrix_layout, 'u', 'u', k,
&v[(nrows_v-k)*lrv], ldv ) )
return -9;
if( LAPACKE_dge_nancheck( matrix_layout, nrows_v-k, ncols_v, v, ldv ) )
return -9;
} else if( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( direct, 'f' ) ) {
if( LAPACKE_dtr_nancheck( matrix_layout, 'u', 'u', k, v, ldv ) )
return -9;
if( LAPACKE_dge_nancheck( matrix_layout, nrows_v, ncols_v-k,
&v[k*lrv], ldv ) )
return -9;
} else if( LAPACKE_lsame( storev, 'r' ) && LAPACKE_lsame( direct, 'b' ) ) {
if( k > ncols_v ) {
LAPACKE_xerbla( "LAPACKE_dlarfb", -8 );
return -8;
}
if( LAPACKE_dtr_nancheck( matrix_layout, 'l', 'u', k,
&v[(ncols_v-k)*lcv], ldv ) )
return -9;
if( LAPACKE_dge_nancheck( matrix_layout, nrows_v, ncols_v-k, v, ldv ) )
return -9;
if( LAPACKE_dge_nancheck( matrix_layout, m, n, c, ldc ) ) {
return -13;
}
}
#endif
Expand Down
57 changes: 17 additions & 40 deletions LAPACKE/src/lapacke_dlarfb_work.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,6 +41,8 @@ lapack_int LAPACKE_dlarfb_work( int matrix_layout, char side, char trans,
{
lapack_int info = 0;
lapack_int nrows_v, ncols_v;
lapack_logical left, col, forward;
char uplo;
lapack_int ldc_t, ldt_t, ldv_t;
double *v_t = NULL, *t_t = NULL, *c_t = NULL;
if( matrix_layout == LAPACK_COL_MAJOR ) {
Expand All @@ -51,16 +53,14 @@ lapack_int LAPACKE_dlarfb_work( int matrix_layout, char side, char trans,
info = info - 1;
}
} else if( matrix_layout == LAPACK_ROW_MAJOR ) {
nrows_v = ( LAPACKE_lsame( storev, 'c' ) &&
LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'c' ) &&
LAPACKE_lsame( side, 'r' ) ) ? n :
( LAPACKE_lsame( storev, 'r' ) ? k : 1) );
ncols_v = LAPACKE_lsame( storev, 'c' ) ? k :
( ( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( side, 'l' ) ) ? m :
( ( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( side, 'r' ) ) ? n : 1) );
left = LAPACKE_lsame( side, 'l' );
col = LAPACKE_lsame( storev, 'c' );
forward = LAPACKE_lsame( direct, 'f' );

nrows_v = ( col && left ) ? m : ( ( col && !left ) ? n : ( !col ? k : 1) );
ncols_v = ( !col && left ) ? m : ( ( !col && !left ) ? n : ( col ? k : 1 ) );
uplo = ( ( left && col ) || !( left || col ) ) ? 'l' : 'u';

ldc_t = MAX(1,m);
ldt_t = MAX(1,k);
ldv_t = MAX(1,nrows_v);
Expand All @@ -80,6 +80,11 @@ lapack_int LAPACKE_dlarfb_work( int matrix_layout, char side, char trans,
LAPACKE_xerbla( "LAPACKE_dlarfb_work", info );
return info;
}
if( !forward && ( col && k > nrows_v ) || ( !col && k > ncols_v )) {
info = -8;
LAPACKE_xerbla( "LAPACKE_dlarfb_work", info );
return info;
}
/* Allocate memory for temporary array(s) */
v_t = (double*)
LAPACKE_malloc( sizeof(double) * ldv_t * MAX(1,ncols_v) );
Expand All @@ -98,36 +103,8 @@ lapack_int LAPACKE_dlarfb_work( int matrix_layout, char side, char trans,
goto exit_level_2;
}
/* Transpose input matrices */
if( LAPACKE_lsame( storev, 'c' ) && LAPACKE_lsame( direct, 'f' ) ) {
LAPACKE_dtr_trans( matrix_layout, 'l', 'u', k, v, ldv, v_t, ldv_t );
LAPACKE_dge_trans( matrix_layout, nrows_v-k, ncols_v, &v[k*ldv], ldv,
&v_t[k], ldv_t );
} else if( LAPACKE_lsame( storev, 'c' ) &&
LAPACKE_lsame( direct, 'b' ) ) {
if( k > nrows_v ) {
LAPACKE_xerbla( "LAPACKE_dlarfb_work", -8 );
return -8;
}
LAPACKE_dtr_trans( matrix_layout, 'u', 'u', k, &v[(nrows_v-k)*ldv],
ldv, &v_t[nrows_v-k], ldv_t );
LAPACKE_dge_trans( matrix_layout, nrows_v-k, ncols_v, v, ldv, v_t,
ldv_t );
} else if( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( direct, 'f' ) ) {
LAPACKE_dtr_trans( matrix_layout, 'u', 'u', k, v, ldv, v_t, ldv_t );
LAPACKE_dge_trans( matrix_layout, nrows_v, ncols_v-k, &v[k], ldv,
&v_t[k*ldv_t], ldv_t );
} else if( LAPACKE_lsame( storev, 'r' ) &&
LAPACKE_lsame( direct, 'b' ) ) {
if( k > ncols_v ) {
LAPACKE_xerbla( "LAPACKE_dlarfb_work", -8 );
return -8;
}
LAPACKE_dtr_trans( matrix_layout, 'l', 'u', k, &v[ncols_v-k], ldv,
&v_t[(ncols_v-k)*ldv_t], ldv_t );
LAPACKE_dge_trans( matrix_layout, nrows_v, ncols_v-k, v, ldv, v_t,
ldv_t );
}
LAPACKE_dtz_trans( matrix_layout, direct, uplo, 'u', nrows_v, ncols_v,
v, ldv, v_t, ldv_t );
LAPACKE_dge_trans( matrix_layout, k, k, t, ldt, t_t, ldt_t );
LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t );
/* Call LAPACK function and adjust info */
Expand Down
Loading

0 comments on commit 1e7759a

Please sign in to comment.