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

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

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

int main(void) {
  /* Scalars */
  Integer i, ic, j, m, n, pda, pdph, pdu;
  Integer d_len, e_len, tau_len, tauq_len, taup_len;
  Integer exit_status = 0;
  NagError fail;
  Nag_OrderType order;
  /* Arrays */
  Complex *a = 0, *ph = 0, *tau = 0, *taup = 0, *tauq = 0, *u = 0;
  double *d = 0, *e = 0;

#ifdef NAG_COLUMN_MAJOR
#define A(I, J) a[(J - 1) * pda + I - 1]
#define U(I, J) u[(J - 1) * pdu + I - 1]
#define PH(I, J) ph[(J - 1) * pdph + I - 1]
  order = Nag_ColMajor;
#else
#define A(I, J) a[(I - 1) * pda + J - 1]
#define U(I, J) u[(I - 1) * pdu + J - 1]
#define PH(I, J) ph[(I - 1) * pdph + J - 1]
  order = Nag_RowMajor;
#endif

  INIT_FAIL(fail);

  printf("nag_lapackeig_zunmbr (f08kuc) Example Program Results\n");

  /* Skip heading in data file */
  scanf("%*[^\n] ");
  for (ic = 1; ic <= 2; ++ic) {
    scanf("%" NAG_IFMT "%" NAG_IFMT "%*[^\n] ", &m, &n);

#ifdef NAG_COLUMN_MAJOR
    pda = m;
    pdph = n;
    pdu = m;
#else
    pda = n;
    pdph = n;
    pdu = m;
#endif
    tau_len = n;
    taup_len = n;
    tauq_len = n;
    d_len = n;
    e_len = n - 1;

    /* Allocate memory */
    if (!(a = NAG_ALLOC(m * n, Complex)) || !(ph = NAG_ALLOC(n * n, Complex)) ||
        !(tau = NAG_ALLOC(tau_len, Complex)) ||
        !(taup = NAG_ALLOC(taup_len, Complex)) ||
        !(tauq = NAG_ALLOC(tauq_len, Complex)) ||
        !(u = NAG_ALLOC(m * m, Complex)) || !(d = NAG_ALLOC(d_len, double)) ||
        !(e = NAG_ALLOC(e_len, double))) {
      printf("Allocation failure\n");
      exit_status = -1;
      goto ENDL;
    }

    /* Read A from data file */
    for (i = 1; i <= m; ++i) {
      for (j = 1; j <= n; ++j)
        scanf(" ( %lf , %lf )", &A(i, j).re, &A(i, j).im);
    }
    scanf("%*[^\n] ");
    if (m >= n) {
      /* Compute the QR factorization of A */
      /* nag_lapackeig_zgeqrf (f08asc).
       * QR factorization of complex general rectangular matrix
       */
      nag_lapackeig_zgeqrf(order, m, n, a, pda, tau, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zgeqrf (f08asc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Copy A to U */
      for (i = 1; i <= m; ++i) {
        for (j = 1; j <= n; ++j) {
          U(i, j).re = A(i, j).re;
          U(i, j).im = A(i, j).im;
        }
      }
      /* Form Q explicitly, storing the result in U */
      /* nag_lapackeig_zungqr (f08atc).
       * Form all or part of unitary Q from QR factorization
       * determined by nag_lapackeig_zgeqrf (f08asc) or nag_lapackeig_zgeqpf
       * (f08bsc)
       */
      nag_lapackeig_zungqr(order, m, n, n, u, pdu, tau, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zungqr (f08atc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Copy R to PH (used as workspace) */
      for (i = 1; i <= n; ++i) {
        for (j = i; j <= n; ++j) {
          PH(i, j).re = A(i, j).re;
          PH(i, j).im = A(i, j).im;
        }
      }
      /* Set the strictly lower triangular part of R to zero */
      for (i = 2; i <= n; ++i) {
        for (j = 1; j <= MIN(i - 1, n - 1); ++j) {
          PH(i, j).re = 0.0;
          PH(i, j).im = 0.0;
        }
      }
      /* Bidiagonalize R */
      /* nag_lapackeig_zgebrd (f08ksc).
       * Unitary reduction of complex general rectangular matrix
       * to bidiagonal form
       */
      nag_lapackeig_zgebrd(order, n, n, ph, pdph, d, e, tauq, taup, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zgebrd (f08ksc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Update Q, storing the result in U */
      /* nag_lapackeig_zunmbr (f08kuc).
       * Apply unitary transformations from reduction to
       * bidiagonal form determined by nag_lapackeig_zgebrd (f08ksc)
       */
      nag_lapackeig_zunmbr(order, Nag_ApplyQ, Nag_RightSide, Nag_NoTrans, m, n,
                           n, ph, pdph, tauq, u, pdu, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zunmbr (f08kuc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Print bidiagonal form and matrix Q */
      printf("\nExample 1: bidiagonal matrix B\nDiagonal\n");
      for (i = 1; i <= n; ++i)
        printf("%8.4f%s", d[i - 1], i % 8 == 0 ? "\n" : " ");
      printf("\nSuperdiagonal\n");
      for (i = 1; i <= n - 1; ++i)
        printf("%8.4f%s", e[i - 1], i % 8 == 0 ? "\n" : " ");
      printf("\n\n");
      /* nag_file_print_matrix_complex_gen_comp (x04dbc).
       * Print complex general matrix (comprehensive)
       */
      fflush(stdout);
      nag_file_print_matrix_complex_gen_comp(
          order, Nag_GeneralMatrix, Nag_NonUnitDiag, m, n, u, pdu,
          Nag_BracketForm, "%7.4f", "Example 1: matrix Q", Nag_IntegerLabels, 0,
          Nag_IntegerLabels, 0, 80, 0, 0, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_file_print_matrix_complex_gen_comp (x04dbc)."
               "\n%s\n",
               fail.message);
        exit_status = 1;
        goto ENDL;
      }
    } else {
      /* Compute the LQ factorization of A */
      /* nag_lapackeig_zgelqf (f08avc).
       * LQ factorization of complex general rectangular matrix
       */
      nag_lapackeig_zgelqf(order, m, n, a, pda, tau, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zgelqf (f08avc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Copy A to PH */
      for (i = 1; i <= m; ++i) {
        for (j = 1; j <= n; ++j) {
          PH(i, j).re = A(i, j).re;
          PH(i, j).im = A(i, j).im;
        }
      }
      /* Form Q explicitly, storing the result in PH */
      /* nag_lapackeig_zunglq (f08awc).
       * Form all or part of unitary Q from LQ factorization
       * determined by nag_lapackeig_zgelqf (f08avc)
       */
      nag_lapackeig_zunglq(order, m, n, m, ph, pdph, tau, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zunglq (f08awc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Copy L to U (used as workspace) */
      for (i = 1; i <= m; ++i) {
        for (j = 1; j <= i; ++j) {
          U(i, j).re = A(i, j).re;
          U(i, j).im = A(i, j).im;
        }
      }
      /* Set the strictly upper triangular part of L to zero */
      for (i = 1; i <= m - 1; ++i) {
        for (j = i + 1; j <= m; ++j) {
          U(i, j).re = 0.0;
          U(i, j).im = 0.0;
        }
      }
      /* Bidiagonalize L */
      /* nag_lapackeig_zgebrd (f08ksc), see above. */
      nag_lapackeig_zgebrd(order, m, m, u, pdu, d, e, tauq, taup, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zgebrd (f08ksc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }
      /* Update P^H, storing the result in PH */
      /* nag_lapackeig_zunmbr (f08kuc), see above. */
      nag_lapackeig_zunmbr(order, Nag_ApplyP, Nag_LeftSide, Nag_ConjTrans, m, n,
                           m, u, pdu, taup, ph, pdph, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_lapackeig_zunmbr (f08kuc).\n%s\n", fail.message);
        exit_status = 1;
        goto ENDL;
      }

      /* Print bidiagonal form and matrix P^H */
      printf("\nExample 2: bidiagonal matrix B\n%s\n", "Diagonal");
      for (i = 1; i <= m; ++i)
        printf("%8.4f%s", d[i - 1], i % 8 == 0 ? "\n" : " ");
      printf("\nSuperdiagonal\n");
      for (i = 1; i <= m - 1; ++i)
        printf("%8.4f%s", e[i - 1], i % 8 == 0 ? "\n" : " ");
      printf("\n\n");
      /* nag_file_print_matrix_complex_gen_comp (x04dbc), see above. */
      fflush(stdout);
      nag_file_print_matrix_complex_gen_comp(
          order, Nag_GeneralMatrix, Nag_NonUnitDiag, m, n, ph, pdph,
          Nag_BracketForm, "%7.4f", "Example 2: matrix P^H", Nag_IntegerLabels,
          0, Nag_IntegerLabels, 0, 80, 0, 0, &fail);
      if (fail.code != NE_NOERROR) {
        printf("Error from nag_file_print_matrix_complex_gen_comp (x04dbc)."
               "\n%s\n",
               fail.message);
        exit_status = 1;
        goto ENDL;
      }
    }
  ENDL:
    NAG_FREE(a);
    NAG_FREE(ph);
    NAG_FREE(tau);
    NAG_FREE(taup);
    NAG_FREE(tauq);
    NAG_FREE(u);
    NAG_FREE(d);
    NAG_FREE(e);
  }
  NAG_FREE(a);
  NAG_FREE(ph);
  NAG_FREE(tau);
  NAG_FREE(taup);
  NAG_FREE(tauq);
  NAG_FREE(u);
  NAG_FREE(d);
  NAG_FREE(e);
  return exit_status;
}