/* nag_dgees (f08pac) Example Program. * * Copyright 2013 Numerical Algorithms Group. * * Mark 24, 2013. */ #include #include #include #include #include #include #include #include #ifdef __cplusplus extern "C" { #endif static Nag_Boolean NAG_CALL select_fun(const double wr, const double wi); #ifdef __cplusplus } #endif int main(void) { /* Scalars */ double alpha, anorm, beta, eps, norm; Integer i, j, n, pda, pdc, pdd, pdvs, sdim; Integer exit_status = 0; /* Arrays */ double *a = 0, *c = 0, *d = 0, *vs = 0, *wi = 0, *wr = 0; /* Nag Types */ NagError fail; Nag_OrderType order; #ifdef NAG_COLUMN_MAJOR #define A(I, J) a[(J-1)*pda + I - 1] order = Nag_ColMajor; #else #define A(I, J) a[(I-1)*pda + J - 1] order = Nag_RowMajor; #endif INIT_FAIL(fail); printf("nag_dgees (f08pac) Example Program Results\n\n"); /* Skip heading in data file */ scanf("%*[^\n]"); scanf("%ld%*[^\n]", &n); if (n < 0) { printf("Invalid n\n"); exit_status = 1; return exit_status; } pda = n; pdc = n; pdd = n; pdvs = n; /* Allocate memory */ if (!(a = NAG_ALLOC(n * n, double)) || !(c = NAG_ALLOC(n * n, double)) || !(d = NAG_ALLOC(n * n, double)) || !(vs = NAG_ALLOC(n * n, double)) || !(wi = NAG_ALLOC(n, double)) || !(wr = NAG_ALLOC(n, double))) { printf("Allocation failure\n"); exit_status = -1; goto END; } /* Read in the matrix A */ for (i = 1; i <= n; ++i) for (j = 1; j <= n; ++j) scanf("%lf", &A(i, j)); scanf("%*[^\n]"); /* Copy A to D: nag_dge_copy (f16qfc), * real valued general matrix copy. */ nag_dge_copy(order, Nag_NoTrans, n, n, a, pda, d, pdd, &fail); if (fail.code != NE_NOERROR) { printf("Error from nag_dge_copy (f16qfc).\n%s\n", fail.message); exit_status = 1; goto END; } /* nag_dge_norm (f16rac): Find norm of matrix A for use later * in relative error test. */ nag_dge_norm(order, Nag_OneNorm, n, n, a, pda, &anorm, &fail); if (fail.code != NE_NOERROR) { printf("Error from nag_dge_norm (f16rac).\n%s\n", fail.message); exit_status = 1; goto END; } /* nag_gen_real_mat_print (x04cac): Print Matrix A. */ fflush(stdout); nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, n, n, a, pda, "Matrix A", 0, &fail); printf("\n"); if (fail.code != NE_NOERROR) { printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n", fail.message); exit_status = 1; goto END; } /* Find the Schur factorization of A using nag_dgees (f08pac). */ nag_dgees(order, Nag_Schur, Nag_SortEigVals, select_fun, n, a, pda, &sdim, wr, wi, vs, pdvs, &fail); if (fail.code != NE_NOERROR && fail.code != NE_SCHUR_REORDER_SELECT) { printf("Error from nag_dgees (f08pac).\n%s\n", fail.message); exit_status = 1; goto END; } /* Reconstruct A from Schur Factorization Z*T*Trans(Z) where T is upper * triangular and stored in A. This can be done using the following steps: * i. C = Z*T (nag_dgemm, f16yac), * ii. D = D-C*trans(Z) (nag_dgemm, f16yac). */ alpha = 1.0; beta = 0.0; nag_dgemm(order, Nag_NoTrans, Nag_NoTrans, n, n, n, alpha, vs, pdvs, a, pda, beta, c, pdc, &fail); if (fail.code != NE_NOERROR) { printf("Error from nag_dgemm (f16yac).\n%s\n", fail.message); exit_status = 1; goto END; } /* nag_dgemm (f16yac): * Compute D = A - C*Z^T. */ alpha = -1.0; beta = 1.0; nag_dgemm(order, Nag_NoTrans, Nag_Trans, n, n, n, alpha, c, pdc, vs, pdvs, beta, d, pdd, &fail); if (fail.code != NE_NOERROR) { printf("Error from nag_dgemm (f16yac).\n%s\n", fail.message); exit_status = 1; goto END; } /* nag_dge_norm (f16rac): Find norm of difference matrix D and print * warning if it is too large relative to norm of A. */ nag_dge_norm(order, Nag_OneNorm, n, n, d, pdd, &norm, &fail); if (fail.code != NE_NOERROR) { printf("Error from nag_dge_norm (f16rac).\n%s\n", fail.message); exit_status = 1; goto END; } /* Get the machine precision, using nag_machine_precision (x02ajc) */ eps = nag_machine_precision; if (norm > pow(eps,0.8)*MAX(anorm,1.0)) { printf("||A-(Z*T*Z^T)||/||A|| is larger than expected.\n" "Schur factorization has failed.\n"); exit_status = 1; goto END; } /* Print details on eigenvalues */ printf("Number of eigenvalues for which select is true = %4ld\n\n", sdim); if (fail.code == NE_SCHUR_REORDER_SELECT) { printf(" ** Note that rounding errors mean that leading eigenvalues in the" " Schur form\n no longer satisfy select(lambda) = Nag_TRUE\n\n"); } else { printf("The selected eigenvalues are:\n"); for (i=0;i0.0 && ai==0.0 ? Nag_TRUE : Nag_FALSE); }