int check_orthogonality(int M, int N, int LDQ, double *Q)
{
double alpha, beta;
double normQ;
int info_ortho;
int i;
int minMN = min(M, N);
double eps;
double *work = (double *)malloc(minMN*sizeof(double));
eps = LAPACKE_dlamch_work('e');
alpha = 1.0;
beta = -1.0;
/* Build the idendity matrix USE DLASET?*/
double *Id = (double *) malloc(minMN*minMN*sizeof(double));
memset((void*)Id, 0, minMN*minMN*sizeof(double));
for (i = 0; i < minMN; i++)
Id[i*minMN+i] = (double)1.0;
/* Perform Id - Q'Q */
if (M >= N)
cblas_dsyrk(CblasColMajor, CblasUpper, CblasTrans, N, M, alpha, Q, LDQ, beta, Id, N);
else
cblas_dsyrk(CblasColMajor, CblasUpper, CblasNoTrans, M, N, alpha, Q, LDQ, beta, Id, M);
normQ = LAPACKE_dlansy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), 'u', minMN, Id, minMN, work);
printf("============\n");
printf("Checking the orthogonality of Q \n");
printf("||Id-Q'*Q||_oo / (N*eps) = %e \n",normQ/(minMN*eps));
if ( isnan(normQ / (minMN * eps)) || (normQ / (minMN * eps) > 10.0) ) {
printf("-- Orthogonality is suspicious ! \n");
info_ortho=1;
}
else {
printf("-- Orthogonality is CORRECT ! \n");
info_ortho=0;
}
free(work); free(Id);
return info_ortho;
}
/*-------------------------------------------------------------------
* Check the orthogonality of Q
*/
static int check_orthogonality(int M, int N, double *Q, int LDQ, double eps)
{
double alpha = 1.0;
double beta = -1.0;
double normQ, result;
int info_ortho;
int minMN = min(M, N);
double *work = (double *)malloc(minMN*sizeof(double));
/* Build the idendity matrix */
double *Id = (double *) malloc(minMN*minMN*sizeof(double));
LAPACKE_dlaset_work(LAPACK_COL_MAJOR, 'A', minMN, minMN, 0., 1., Id, minMN);
/* Perform Id - Q'Q */
if (M >= N)
cblas_dsyrk(CblasColMajor, CblasUpper, CblasTrans, N, M, alpha, Q, LDQ, beta, Id, N);
else
cblas_dsyrk(CblasColMajor, CblasUpper, CblasNoTrans, M, N, alpha, Q, LDQ, beta, Id, M);
normQ = LAPACKE_dlansy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), 'U', minMN, Id, minMN, work);
result = normQ / (minMN * eps);
printf("============\n");
printf("Checking the orthogonality of Q \n");
printf("||Id-Q'*Q||_oo / (minMN*eps) = %e \n", result);
if ( isnan(result) || isinf(result) || (result > 60.0) ) {
printf("-- Orthogonality is suspicious ! \n");
info_ortho=1;
}
else {
printf("-- Orthogonality is CORRECT ! \n");
info_ortho=0;
}
free(work); free(Id);
return info_ortho;
}
double LAPACKE_dlansy( int matrix_layout, char norm, char uplo, lapack_int n,
const double* a, lapack_int lda )
{
lapack_int info = 0;
double res = 0.;
double* work = NULL;
if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) {
LAPACKE_xerbla( "LAPACKE_dlansy", -1 );
return -1;
}
#ifndef LAPACK_DISABLE_NAN_CHECK
/* Optionally check input matrices for NaNs */
if( LAPACKE_dsy_nancheck( matrix_layout, uplo, n, a, lda ) ) {
return -5;
}
#endif
/* Allocate memory for working array(s) */
if( LAPACKE_lsame( norm, 'i' ) || LAPACKE_lsame( norm, '1' ) ||
LAPACKE_lsame( norm, 'O' ) ) {
work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,n) );
if( work == NULL ) {
info = LAPACK_WORK_MEMORY_ERROR;
goto exit_level_0;
}
}
/* Call middle-level interface */
res = LAPACKE_dlansy_work( matrix_layout, norm, uplo, n, a, lda, work );
/* Release memory and exit */
if( LAPACKE_lsame( norm, 'i' ) || LAPACKE_lsame( norm, '1' ) ||
LAPACKE_lsame( norm, 'O' ) ) {
LAPACKE_free( work );
}
exit_level_0:
if( info == LAPACK_WORK_MEMORY_ERROR ) {
LAPACKE_xerbla( "LAPACKE_dlansy", info );
}
return res;
}
