int main(void)
{
/* Local scalars */
lapack_int m, m_i;
lapack_int n, n_i;
lapack_int lda, lda_i;
lapack_int lda_r;
lapack_int lwork, lwork_i;
lapack_int info, info_i;
lapack_int i;
int failed;
/* Local arrays */
double *a = NULL, *a_i = NULL;
double *tau = NULL, *tau_i = NULL;
double *work = NULL, *work_i = NULL;
double *a_save = NULL;
double *tau_save = NULL;
double *a_r = NULL;
/* Iniitialize the scalar parameters */
init_scalars_dgeqrf( &m, &n, &lda, &lwork );
lda_r = n+2;
m_i = m;
n_i = n;
lda_i = lda;
lwork_i = lwork;
/* Allocate memory for the LAPACK routine arrays */
a = (double *)LAPACKE_malloc( lda*n * sizeof(double) );
tau = (double *)LAPACKE_malloc( MIN(m,n) * sizeof(double) );
work = (double *)LAPACKE_malloc( lwork * sizeof(double) );
/* Allocate memory for the C interface function arrays */
a_i = (double *)LAPACKE_malloc( lda*n * sizeof(double) );
tau_i = (double *)LAPACKE_malloc( MIN(m,n) * sizeof(double) );
work_i = (double *)LAPACKE_malloc( lwork * sizeof(double) );
/* Allocate memory for the backup arrays */
a_save = (double *)LAPACKE_malloc( lda*n * sizeof(double) );
tau_save = (double *)LAPACKE_malloc( MIN(m,n) * sizeof(double) );
/* Allocate memory for the row-major arrays */
a_r = (double *)LAPACKE_malloc( m*(n+2) * sizeof(double) );
/* Initialize input arrays */
init_a( lda*n, a );
init_tau( (MIN(m,n)), tau );
init_work( lwork, work );
/* Backup the ouptut arrays */
for( i = 0; i < lda*n; i++ ) {
a_save[i] = a[i];
}
for( i = 0; i < (MIN(m,n)); i++ ) {
tau_save[i] = tau[i];
}
/* Call the LAPACK routine */
dgeqrf_( &m, &n, a, &lda, tau, work, &lwork, &info );
/* Initialize input data, call the column-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < (MIN(m,n)); i++ ) {
tau_i[i] = tau_save[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_dgeqrf_work( LAPACK_COL_MAJOR, m_i, n_i, a_i, lda_i, tau_i,
work_i, lwork_i );
failed = compare_dgeqrf( a, a_i, tau, tau_i, info, info_i, lda, m, n );
if( failed == 0 ) {
printf( "PASSED: column-major middle-level interface to dgeqrf\n" );
} else {
printf( "FAILED: column-major middle-level interface to dgeqrf\n" );
}
/* Initialize input data, call the column-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < (MIN(m,n)); i++ ) {
tau_i[i] = tau_save[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_dgeqrf( LAPACK_COL_MAJOR, m_i, n_i, a_i, lda_i, tau_i );
failed = compare_dgeqrf( a, a_i, tau, tau_i, info, info_i, lda, m, n );
if( failed == 0 ) {
printf( "PASSED: column-major high-level interface to dgeqrf\n" );
} else {
printf( "FAILED: column-major high-level interface to dgeqrf\n" );
}
/* Initialize input data, call the row-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < (MIN(m,n)); i++ ) {
tau_i[i] = tau_save[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_i, lda, a_r, n+2 );
info_i = LAPACKE_dgeqrf_work( LAPACK_ROW_MAJOR, m_i, n_i, a_r, lda_r, tau_i,
work_i, lwork_i );
LAPACKE_dge_trans( LAPACK_ROW_MAJOR, m, n, a_r, n+2, a_i, lda );
failed = compare_dgeqrf( a, a_i, tau, tau_i, info, info_i, lda, m, n );
if( failed == 0 ) {
printf( "PASSED: row-major middle-level interface to dgeqrf\n" );
} else {
printf( "FAILED: row-major middle-level interface to dgeqrf\n" );
}
/* Initialize input data, call the row-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < (MIN(m,n)); i++ ) {
tau_i[i] = tau_save[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
/* Init row_major arrays */
LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_i, lda, a_r, n+2 );
info_i = LAPACKE_dgeqrf( LAPACK_ROW_MAJOR, m_i, n_i, a_r, lda_r, tau_i );
LAPACKE_dge_trans( LAPACK_ROW_MAJOR, m, n, a_r, n+2, a_i, lda );
failed = compare_dgeqrf( a, a_i, tau, tau_i, info, info_i, lda, m, n );
if( failed == 0 ) {
printf( "PASSED: row-major high-level interface to dgeqrf\n" );
} else {
printf( "FAILED: row-major high-level interface to dgeqrf\n" );
}
/* Release memory */
if( a != NULL ) {
LAPACKE_free( a );
}
if( a_i != NULL ) {
LAPACKE_free( a_i );
}
if( a_r != NULL ) {
LAPACKE_free( a_r );
}
if( a_save != NULL ) {
LAPACKE_free( a_save );
}
if( tau != NULL ) {
LAPACKE_free( tau );
}
if( tau_i != NULL ) {
LAPACKE_free( tau_i );
}
if( tau_save != NULL ) {
LAPACKE_free( tau_save );
}
if( work != NULL ) {
LAPACKE_free( work );
}
if( work_i != NULL ) {
LAPACKE_free( work_i );
}
return 0;
}
/*
* NAME : simultaneous_iteration
* DESCRIPTION : permet d'effectuer la methode des iterations simultanees
* IN : nombre de ligne, nombre de colonne, nombre de valeurs propres à calculer, matrice
* OUT : /
* DEBUG : affichage de la matrice Q à chaque itération
*/
void simultaneous_iteration(int ligne, int colonne, int nb_eigen, double *A)
{
double *W = calloc(ligne * colonne, sizeof(double));
double *Q = calloc(ligne * colonne, sizeof(double));
double *Q_old = calloc(ligne * colonne, sizeof(double));
double *lambda = calloc(nb_eigen, sizeof(double));
double *med = calloc(ligne, sizeof(double));
double *err = calloc(nb_eigen, sizeof(double));
double tau[ligne];
for(int i = 0; i < nb_eigen; i++)
Q[i * nb_eigen + colonne] = 1.;
// DGEQRF computes a QR factorization of a real M-by-N matrix A = Q * R
LAPACKE_dgeqrf(LAPACK_ROW_MAJOR, ligne, nb_eigen, Q, nb_eigen, tau);
// DORGQR generates an M-by-N real matrix Q with orthonormal columns
LAPACKE_dorgqr(LAPACK_ROW_MAJOR, ligne, nb_eigen, nb_eigen, Q, nb_eigen, tau);
int k = 0;
do
{
// copie de Q dans Q_old
copy(ligne, nb_eigen, Q_old, Q);
// W = A * Q^k-1
matMat(ligne, nb_eigen, colonne, A, Q, W);
// Q * R = W
LAPACKE_dgeqrf(LAPACK_ROW_MAJOR, ligne, nb_eigen, W, nb_eigen, tau);
// W = Q
LAPACKE_dorgqr(LAPACK_ROW_MAJOR, ligne, nb_eigen, nb_eigen, W, nb_eigen, tau);;
#ifdef DEBUG
fprintf(stdout, "\nMatrice Q\n");
affichage(ligne, nb_eigen, W);
#endif
// copie de W dans Q
copy(ligne, nb_eigen, Q, W);
k++;
} while(norme_Frobeinius(ligne, nb_eigen, Q_old, Q) > 1E-6);
fprintf(stdout, "\nIterations %d - Norme = %e \n", k - 1, norme_Frobeinius(ligne, nb_eigen, Q_old, Q));
// W = AQ
matMat(ligne, nb_eigen, colonne, A, Q, W);
// calcul des valeurs propres
for(int j = 0; j < nb_eigen; j++)
{
for(int i = 0; i < ligne; i++)
med[i] = fabs(W[i * nb_eigen + j] / Q[i * nb_eigen + j]);
lambda[j] = mediane(ligne, med);
}
fprintf(stdout, "\nValeurs propres issues de la méthode\n");
affichage(nb_eigen, 1, lambda);
#ifdef DEBUG
fprintf(stdout, "\nMatrice Q\n");
affichage(ligne, nb_eigen, Q);
#endif
free(err);
free(lambda);
free(med);
free(W);
free(Q);
free(Q_old);
}
