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

NAG CL Interface Introduction
Example description
/* nag_eigen_real_gen_sparse_arnoldi (f02ekc) Example Program.
 *
 * Copyright 2024 Numerical Algorithms Group.
 *
 * Mark 30.2, 2024.
 */

#include <math.h>
#include <nag.h>

/* User-defined Functions */
#ifdef __cplusplus
extern "C" {
#endif
static void NAG_CALL myoption(Integer icomm[], double com[], Integer *istat,
                              Nag_Comm *comm);

static void NAG_CALL mymonit(Integer ncv, Integer niter, Integer nconv,
                             const Complex w[], const double rzest[],
                             Integer *istat, Nag_Comm *comm);
#ifdef __cplusplus
}
#endif

int main(void) {
  /* Scalars */
  double one = 1.0, two = 2.0, three = 3.0;
  double h, rho, s, sigma;
  Integer exit_status = 0;
  Integer fileid, fmode, i, imon, k, maxit, mode;
  Integer n, nconv, ncv, nev, nnz, nx, prtlvl, tdv;

  /* Local Arrays */
  Complex *w = 0;
  double *a = 0, *resid = 0, *v = 0;
  double user[1];
  Integer *icolzp = 0, *irowix = 0;
  Integer iuser[5];
  const char *filename = "f02ekce.monit";

  /* Nag Types */
  Nag_Comm comm;
  NagError fail;

  INIT_FAIL(fail);

  comm.user = user;
  comm.iuser = iuser;
  user[0] = 0.0;
  iuser[0] = 0;

  /* Output preamble */
  printf("nag_eigen_real_gen_sparse_arnoldi (f02ekc) ");
  printf("Example Program Results\n\n");
  fflush(stdout);

  /* Skip heading in data file */
  scanf("%*[^\n] ");

  /* Read in problem size and parameters */
  scanf("%" NAG_IFMT "%*[^\n]%" NAG_IFMT "%*[^\n]%" NAG_IFMT "", &nx, &nev,
        &ncv);
  scanf("%*[^\n]%lf%*[^\n]%lf%*[^\n]", &rho, &sigma);

  n = nx * nx;
  nnz = 3 * n - 2;
  tdv = n;

  if (!(resid = NAG_ALLOC((ncv), double)) || !(a = NAG_ALLOC((nnz), double)) ||
      !(icolzp = NAG_ALLOC((n + 1), Integer)) ||
      !(irowix = NAG_ALLOC((nnz), Integer)) ||
      !(w = NAG_ALLOC((ncv), Complex)) ||
      !(v = NAG_ALLOC((tdv) * (ncv), double))) {
    printf("Allocation failure\n");
    exit_status = -1;
    goto END;
  }

  /* Construct  A in compressed column storage (CCS) format where:
   *   A_{i,i}   = 2 + i
   *   A_{i+1,i) = 3
   *   A_{i,i+1} = rho/(2n+2) - 1
   */
  h = one / (double)(n + 1);
  s = rho * h / two - one;
  a[0] = two + one;
  a[1] = three;
  icolzp[0] = 1;
  irowix[0] = 1;
  irowix[1] = 2;

  k = 3;
  for (i = 2; i <= n - 1; i++) {
    icolzp[i - 1] = k;
    irowix[k - 1] = i - 1;
    irowix[k] = i;
    irowix[k + 1] = i + 1;
    a[k - 1] = s;
    a[k] = two + (double)(i);
    a[k + 1] = three;
    k = k + 3;
  }

  icolzp[n - 1] = k;
  icolzp[n] = k + 2;
  irowix[k - 1] = n - 1;
  irowix[k] = n;
  a[k - 1] = s;
  a[k] = two + (double)(n);

  /* Set some options via iuser array and routine argument OPTION.
   * iuser[0] = print level, iuser[1] = iteration limit,
   * iuser[2]>0 means shifted-invert mode
   * iuser[3]>0 means print monitoring info.
   */
  scanf("%" NAG_IFMT "%*[^\n]%" NAG_IFMT "%*[^\n]", &prtlvl, &maxit);
  scanf("%" NAG_IFMT "%*[^\n]%" NAG_IFMT "%*[^\n]", &mode, &imon);

  if (imon > 0) {
    /* Open the monitoring file for writing using
     * nag_file_open (x04acc):
     *   open unit number for reading, writing or appending, and
     *   associate unit with named file
     */
    /* If prtlvl >=10 internal monitoring information in addition to whatever is
     * written to fileid using mymonit.
     */
    fmode = 1;
    nag_file_open(filename, fmode, &fileid, &fail);
    if (fail.code != NE_NOERROR) {
      printf("Error from nag_file_open (x04acc) %s\n", fail.message);
      exit_status = 1;
      goto END;
    }
    iuser[4] = fileid;
  }

  iuser[0] = prtlvl;
  iuser[1] = maxit;
  iuser[2] = mode;
  iuser[3] = imon;

  /* Compute eigenvalues and eigenvectors using
   * nag_eigen_real_gen_sparse_arnoldi (f02ekc):
   *   selected eigenvalues of real general matrix driver.
   */
  nag_eigen_real_gen_sparse_arnoldi(n, nnz, a, icolzp, irowix, nev, ncv, sigma,
                                    mymonit, myoption, &nconv, w, v, tdv, resid,
                                    &comm, &fail);
  if (fail.code != NE_NOERROR) {
    printf("Error from nag_eigen_real_gen_sparse_arnoldi (f02ekc)\n%s\n",
           fail.message);
    exit_status = 1;
    goto END;
  }

  if (imon > 0) {
    /* Close the monitoring file using
     * nag_file_close (x04adc):
     *   close file associated with given unit number
     */
    nag_file_close(fileid, &fail);
    if (fail.code != NE_NOERROR) {
      printf("Error from nag_file_close (x04adc) %s\n", fail.message);
      exit_status = 1;
      goto END;
    }
  }

  printf(" The %4" NAG_IFMT " ", nconv);
  printf(" Ritz values of closest to %13.5e are \n", sigma);
  for (i = 1; i <= nconv; i++) {
    /* nag_machine_precision (x02ajc) */
    if (resid[i - 1] > (double)(100 * n) * nag_machine_precision) {
      printf("%7" NAG_IFMT "  ( %13.5e, %13.5e) ", i, w[i - 1].re, w[i - 1].im);
      printf("%13.5e\n", resid[i - 1]);
    } else {
      printf("%8" NAG_IFMT "  ( %13.5e, %13.5e) \n", i, w[i - 1].re,
             w[i - 1].im);
    }
  }

END:

  NAG_FREE(w);
  NAG_FREE(a);
  NAG_FREE(v);
  NAG_FREE(resid);
  NAG_FREE(icolzp);
  NAG_FREE(irowix);
  return exit_status;
}

static void NAG_CALL myoption(Integer icomm[], double com[], Integer *istat,
                              Nag_Comm *comm) {
  NagError fail1;
  char rec[26];

  INIT_FAIL(fail1);

  if (comm->iuser[0] > 0) {
    sprintf(rec, "Print Level=%5" NAG_IFMT, comm->iuser[0]);
    fail1.code = 1;
    /* Set print level using
     * nag_sparseig_real_option (f12adc)
     * Set a single option from a string.
     */
    nag_sparseig_real_option(rec, icomm, com, &fail1);
    *istat = MAX(*istat, fail1.code);
  }

  if (comm->iuser[1] > 100) {
    sprintf(rec, "Iteration Limit=%5" NAG_IFMT, comm->iuser[1]);
    fail1.code = 1;
    /* Set iteration limit using
     * nag_sparseig_real_option (f12adc)
     * Set a single option from a string.
     */
    nag_sparseig_real_option(rec, icomm, com, &fail1);
    *istat = MAX(*istat, fail1.code);
  }

  if (comm->iuser[2] > 0) {
    fail1.code = 1;
    /* Set computational mode to shifted inverse real. */
    nag_sparseig_real_option("Shifted Inverse Real", icomm, com, &fail1);
    *istat = MAX(*istat, fail1.code);
  }

  if (comm->iuser[3] > 0) {
    fail1.code = 1;
    /* Switch monitoring on and use the fileid stored in iuser[4]. */
    sprintf(rec, "Monitoring=%5" NAG_IFMT, comm->iuser[4]);
    nag_sparseig_real_option(rec, icomm, com, &fail1);
    *istat = MAX(*istat, fail1.code);
  }
}

static void NAG_CALL mymonit(Integer ncv, Integer niter, Integer nconv,
                             const Complex w[], const double rzest[],
                             Integer *istat, Nag_Comm *comm) {
  Integer i;
  char line[100];

  if (comm->iuser[3] > 0) {

    /* Write lines to the file we opened for monitoring using
     * nag_file_line_write (x04bac):
     *   write formatted record to external file.
     */

    if (niter == 1 && comm->iuser[2] > 0) {
      sprintf(line, " Arnoldi basis vectors used: %4" NAG_IFMT "\n", ncv);
      nag_file_line_write(comm->iuser[4], line);
      sprintf(line, " The following Ritz values (mu) are related to the\n");
      nag_file_line_write(comm->iuser[4], line);
      sprintf(line, " true eigenvalues (lambda) by lambda = sigma + 1/mu\n");
      nag_file_line_write(comm->iuser[4], line);
    }
    sprintf(line, "\n Iteration number %4" NAG_IFMT "\n", niter);
    nag_file_line_write(comm->iuser[4], line);
    sprintf(line,
            " Ritz values converged so far (%4" NAG_IFMT ") and their Ritz "
            "estimates:\n",
            nconv);
    nag_file_line_write(comm->iuser[4], line);

    for (i = 1; i <= nconv; i++) {
      sprintf(line, "  %4" NAG_IFMT " (%13.5e,%13.5e) %13.5e\n", i, w[i - 1].re,
              w[i - 1].im, rzest[i - 1]);
      nag_file_line_write(comm->iuser[4], line);
    }
    sprintf(line, " Next (unconverged) Ritz value:\n");
    nag_file_line_write(comm->iuser[4], line);
    sprintf(line, "  %4" NAG_IFMT " (%13.5e,%13.5e)\n", nconv + 1, w[nconv].re,
            w[nconv].im);
    nag_file_line_write(comm->iuser[4], line);
  }
  *istat = 0;
}