NAG Library Manual, Mark 30.2
Interfaces:  FL   CL   CPP   AD 

NAG CL Interface Introduction
Example description
/* nag_matop_real_modified_cholesky (f01mdc) Example Program.
 *
 * Copyright 2024 Numerical Algorithms Group.
 *
 * Mark 30.2, 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;
}