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

NAG CL Interface Introduction
Example description
/* nag_opt_handle_set_quadobj (e04rfc) Example Program.
 *
 * Copyright 2024 Numerical Algorithms Group.
 *
 * Mark 30.0, 2024.
 */

/* Compute the nearest correlation matrix in Frobenius norm using nonlinear
 * semidefinite programming. By default, preserve the nonzero structure of
 * the input matrix (preserve_structure = 1).
 */

#include <nag.h>
#include <stdio.h>

int main(void) {
  Integer preserve_structure = 1;

  Integer exit_status = 0;
  Integer dima, i, idblk, idx, inform, j, n, nblk, nnzasum, nnzh, nnzu, nnzua,
      nnzuc, nvar;
  double rinfo[32], stats[32];
  double *a = 0, *g = 0, *h = 0, *x = 0;
  Integer *icola = 0, *icolh = 0, *irowa = 0, *irowh = 0, *nnza = 0;
  void *handle = 0;
  /* Nag Types */
  NagError fail;

#define G(I, J) g[(J - 1) * n + I - 1]

  printf("nag_opt_handle_set_quadobj (e04rfc) Example Program Results\n\n");
  fflush(stdout);

  /* Skip heading in data file. */
  scanf("%*[^\n]");
  /* Read in the problem size and ignore the rest of the line. */
  scanf("%" NAG_IFMT "%*[^\n]", &n);

  /* Allocate memory for matrix G and read it in. */
  if (!(g = NAG_ALLOC(n * n, double))) {
    printf("Allocation failure\n");
    exit_status = -1;
    goto END;
  }
  for (i = 1; i <= n; i++)
    for (j = 1; j <= n; j++)
      scanf("%lf", &G(i, j));
  scanf("%*[^\n]");

  /* Symmetrize G:  G = (G + G')/2 */
  for (j = 1; j <= n; j++)
    for (i = 1; i <= j - 1; i++) {
      G(i, j) = (G(i, j) + G(j, i)) / 2.0;
      G(j, i) = G(i, j);
    }

  /* There are as many variables as nonzeros above the main diagonal in
   * the input matrix. The variables are corrections of these elements. */
  nvar = 0;
  for (j = 2; j <= n; j++)
    for (i = 1; i <= j - 1; i++)
      if (!preserve_structure || G(i, j) != 0.0)
        nvar++;

  /* nag_opt_handle_init (e04rac).
   * Initialize an empty problem handle with NVAR variables. */
  nag_opt_handle_init(&handle, nvar, NAGERR_DEFAULT);

  /* Set up the objective - minimize Frobenius norm of the corrections.
   * Our variables are stored as a vector thus, just minimize
   * sum of squares of the corrections --> H is identity matrix, c = 0.*/
  nnzh = nvar;
  if (!(x = NAG_ALLOC(nvar, double)) || !(irowh = NAG_ALLOC(nnzh, Integer)) ||
      !(icolh = NAG_ALLOC(nnzh, Integer)) || !(h = NAG_ALLOC(nnzh, double))) {
    printf("Allocation failure\n");
    exit_status = -1;
    goto END;
  }

  for (i = 0; i < nvar; i++) {
    /* irowh, icolh use 1-based indices */
    irowh[i] = i + 1;
    icolh[i] = i + 1;
    h[i] = 1.0;
  }

  /* nag_opt_handle_set_quadobj (e04rfc).
   * Add the quadratic objective to the handle.*/
  nag_opt_handle_set_quadobj(handle, 0, NULL, NULL, nnzh, irowh, icolh, h,
                             NAGERR_DEFAULT);

  /* Construct linear matrix inequality to request that
   * matrix G with corrections X is positive semidefinite.
   * (Don't forget the sign at A_0!)
   * How many nonzeros do we need? Full triangle for A_0 and
   * one nonzero element for each A_i. */
  nnzasum = n * (n + 1) / 2 + nvar;
  if (!(nnza = NAG_ALLOC(nvar + 1, Integer)) ||
      !(irowa = NAG_ALLOC(nnzasum, Integer)) ||
      !(icola = NAG_ALLOC(nnzasum, Integer)) ||
      !(a = NAG_ALLOC(nnzasum, double))) {
    printf("Allocation failure\n");
    exit_status = -1;
    goto END;
  }
  nnza[0] = n * (n + 1) / 2;
  for (j = 1; j <= nvar; j++)
    nnza[j] = 1;

  /* Copy G to A_0, only upper triangle with different sign (because -A_0)
   * and set the diagonal to 1.0 as that's what we want independently
   * of what was in G. */
  idx = 0;
  for (j = 1; j <= n; j++) {
    for (i = 1; i <= j - 1; i++) {
      irowa[idx] = i;
      icola[idx] = j;
      a[idx] = -G(i, j);
      idx++;
    }
    /* Unit diagonal. */
    irowa[idx] = j;
    icola[idx] = j;
    a[idx] = -1.0;
    idx++;
  }

  /* A_i has just one nonzero - it binds x_i with its position as
   * a correction. */
  for (j = 2; j <= n; j++)
    for (i = 1; i <= j - 1; i++)
      if (!preserve_structure || G(i, j) != 0.0) {
        irowa[idx] = i;
        icola[idx] = j;
        a[idx] = 1.0;
        idx++;
      }

  /* Just one matrix inequality of the dimension of the original matrix. */
  nblk = 1;
  dima = n;
  idblk = 0;
  /* nag_opt_handle_set_linconstr (e04rnc).
   * Add the linear matrix constraint to the problem formulation. */
  nag_opt_handle_set_linmatineq(handle, nvar, dima, nnza, nnzasum, irowa, icola,
                                a, nblk, NULL, &idblk, NAGERR_DEFAULT);

  /* Set optional arguments of the solver by calling
   * nag_opt_handle_opt_set (e04zmc). */
  nag_opt_handle_opt_set(handle, "Print Options = No", NAGERR_DEFAULT);
  nag_opt_handle_opt_set(handle, "Initial X = Automatic", NAGERR_DEFAULT);

  /* Pass the handle to the solver, we are not interested in
   * Lagrangian multipliers. */
  nnzu = 0;
  nnzuc = 0;
  nnzua = 0;
  INIT_FAIL(fail);
  /* nag_opt_handle_solve_pennon (e04svc). */
  nag_opt_handle_solve_pennon(handle, nvar, x, nnzu, NULL, nnzuc, NULL, nnzua,
                              NULL, rinfo, stats, &inform, &fail);
  if (fail.code != NE_NOERROR) {
    printf("Error from nag_opt_handle_solve_pennon (e04svc).\n%s\n",
           fail.message);
    exit_status = 1;
    goto END;
  }

  /* Form the new nearest correlation matrix as the sum
   * of G and the correction X. */
  idx = 0;
  for (j = 1; j <= n; j++) {
    for (i = 1; i <= j - 1; i++)
      if (!preserve_structure || G(i, j) != 0.0) {
        G(i, j) = G(i, j) + x[idx];
        idx++;
      }
    G(j, j) = 1.0;
  }

  /* nag_file_print_matrix_real_gen (x04cac).
   * Print the result as an upper triangular matrix. */
  nag_file_print_matrix_real_gen(Nag_ColMajor, Nag_UpperMatrix, Nag_NonUnitDiag,
                                 n, n, g, n, "Nearest Correlation Matrix", NULL,
                                 NAGERR_DEFAULT);

END:

  /* nag_opt_handle_free (e04rzc).
   * Destroy the problem handle and deallocate all the memory. */
  if (handle)
    nag_opt_handle_free(&handle, NAGERR_DEFAULT);

  NAG_FREE(a);
  NAG_FREE(g);
  NAG_FREE(h);
  NAG_FREE(x);
  NAG_FREE(icola);
  NAG_FREE(icolh);
  NAG_FREE(irowa);
  NAG_FREE(irowh);
  NAG_FREE(nnza);
  return exit_status;
}