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; }