/* nag_matop_real_modified_cholesky (f01mdc) Example Program.
*
* Copyright 2024 Numerical Algorithms Group.
*
* Mark 30.1, 2024.
*/
#include <math.h>
#include <nag.h>
#include <stdio.h>
int main(void) {
#define A(I, J) a[(J - 1) * n + I - 1]
#define D(I, J) d[(J - 1) * n + I - 1]
#define E(I, J) e[(J - 1) * n + I - 1]
#define ORIG_A(I, J) orig_a[(J - 1) * n + I - 1]
/* Scalars */
Integer exit_status = 0;
double delta, res;
Integer i, j, n, pda;
/* Arrays */
char uplo_c[40];
double *a = 0, *d = 0, *e = 0, *eigs = 0, *offdiag = 0, *orig_a = 0;
Integer *ipiv = 0;
/* Nag Types */
Nag_OrderType order;
Nag_UploType uplo;
NagError fail;
INIT_FAIL(fail);
/* Output preamble */
printf("nag_matop_real_modified_cholesky (f01mdc)");
printf(" Example Program Results\n\n");
fflush(stdout);
/* Read in the problem size and uplo */
scanf("%*[^\n] ");
scanf("%" NAG_IFMT "%*[^\n] ", &n);
scanf("%39s %*[^\n] ", uplo_c);
/* nag_enum_name_to_value (x04nac).
* Converts NAG enum member name to value
*/
uplo = (Nag_UploType)nag_enum_name_to_value(uplo_c);
pda = n;
order = Nag_ColMajor;
if (!(a = NAG_ALLOC(pda * n, double)) || !(d = NAG_ALLOC(n * n, double)) ||
!(e = NAG_ALLOC(n * n, double)) || !(offdiag = NAG_ALLOC(n, double)) ||
!(orig_a = NAG_ALLOC(n * n, double)) || !(eigs = NAG_ALLOC(n, double)) ||
!(ipiv = NAG_ALLOC(n, Integer))) {
printf("Allocation failure\n");
exit_status = -1;
goto END;
}
/* Read in the matrix A */
for (i = 1; i <= n; i++)
for (j = 1; j <= i; j++)
scanf("%lf", &A(i, j));
scanf("%*[^\n] ");
/* Store the original matrix A for use later */
for (j = 1; j <= n; j++)
for (i = j; i <= n; i++)
if (uplo == Nag_Lower) {
ORIG_A(i, j) = A(i, j);
ORIG_A(j, i) = A(i, j);
} else {
ORIG_A(i, j) = A(j, i);
ORIG_A(j, i) = A(j, i);
}
/* nag_gen_real_mat_print (x04cac).
* Print real general matrix (easy-to-use)
*/
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, n, n,
orig_a, n, "Original Matrix A", NULL, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n", fail.message);
exit_status = 1;
goto END;
}
/* Compute delta
* nag_dsy_norm (f16rcc).
* 1-norm, infinity-norm, Frobenius norm, largest absolute
* element, real general matrix
*/
nag_dsy_norm(order, Nag_OneNorm, uplo, n, orig_a, pda, &res, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_dsy_norm (f16rcc).\n%s\n", fail.message);
exit_status = 2;
goto END;
}
delta = sqrt(X02AJC) * res;
printf("\n Delta:%12.4e \n", delta);
printf("\n");
fflush(stdout);
/* nag_matop_real_modified_cholesky (f01mdc)
* Compute the modified Cholesky factorization of A
*/
nag_matop_real_modified_cholesky(uplo, n, a, pda, offdiag, ipiv, delta,
&fail);
if (fail.code != NE_NOERROR) {
printf("Error nag_matop_real_modified_cholesky (f01mdc).\n%s\n",
fail.message);
exit_status = 3;
goto END;
}
/* Construct the matrix D and display it */
for (j = 1; j <= n; j++)
for (i = 1; i <= n; i++)
D(i, j) = 0.0;
for (i = 1; i <= n; i++)
D(i, i) = A(i, i);
if (uplo == Nag_Lower) {
for (i = 1; i < n; i++) {
D(i + 1, i) = offdiag[i - 1];
D(i, i + 1) = offdiag[i - 1];
}
} else {
for (i = 2; i <= n; i++) {
D(i - 1, i) = offdiag[i - 1];
D(i, i - 1) = offdiag[i - 1];
}
}
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, n, n, d, n,
"Block Diagonal Matrix D", NULL, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n", fail.message);
exit_status = 4;
goto END;
}
printf("\n");
fflush(stdout);
/* Compute the eigenvalues of D and print them
* nag_dsyev (f08fac).
* Computes all eigenvalues and, optionally, eigenvectors of a real
* symmetric matrix
*/
nag_dsyev(order, Nag_EigVals, Nag_Upper, n, d, n, eigs, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_dsyev (f08fac).\n%s\n", fail.message);
exit_status = 5;
goto END;
}
/* nag_gen_real_mat_print (x04cac).
* Print real general matrix (easy-to-use)
*/
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, 1, n, eigs,
1, "Eigenvalues of D", NULL, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n", fail.message);
exit_status = 6;
goto END;
}
printf("\n");
fflush(stdout);
/* Compute the perturbed matrix A + E
* nag_matop_real_mod_chol_perturbed_a (f01mec)
* Compute the modified Cholesky factorization of A
*/
nag_matop_real_mod_chol_perturbed_a(uplo, n, a, pda, offdiag, ipiv, &fail);
if (fail.code != NE_NOERROR) {
printf("Error nag_matop_real_mod_chol_perturbed_a (f01mec).\n%s\n",
fail.message);
exit_status = 7;
goto END;
}
/* Construct the Matrix E and display it */
if (uplo == Nag_Lower) {
for (j = 1; j <= n; j++) {
E(j, j) = ORIG_A(j, j) - A(j, j);
for (i = j + 1; i <= n; i++) {
E(i, j) = ORIG_A(i, j) - A(i, j);
E(j, i) = E(i, j);
}
}
} else {
for (j = 1; j <= n; j++) {
E(j, j) = ORIG_A(j, j) - A(j, j);
for (i = 1; i < j; i++) {
E(i, j) = ORIG_A(i, j) - A(i, j);
E(j, i) = E(i, j);
}
}
}
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, n, n, e, n,
"Perturbation Matrix E", NULL, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n", fail.message);
exit_status = 8;
goto END;
}
/* Compute Frobenius-norm of E
* nag_dsy_norm (f16rcc).
* 1-norm, infinity-norm, Frobenius norm, largest absolute
* element, real general matrix
*/
nag_dsy_norm(order, Nag_FrobeniusNorm, uplo, n, e, n, &res, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_dsy_norm (f16rac).\n%s\n", fail.message);
exit_status = 9;
goto END;
}
/* Display Frobenius-norm of E */
printf("\n Frobenius Norm of E:%12.4f \n\n", res);
END:
NAG_FREE(a);
NAG_FREE(d);
NAG_FREE(e);
NAG_FREE(eigs);
NAG_FREE(ipiv);
NAG_FREE(offdiag);
NAG_FREE(orig_a);
return exit_status;
}