Beispiel #1
0
/* Calculate matrices needed for stability analysis
 * and solve for spectrum is required.
 *
 * Modified by Ian Gates Sep 26, 1997.
 *
 * Modified by MMH 1/15/00.  Hacked out store_stability_problem.
 *
 * Modified by MMH 11/28/00.  Changed the call list so we could pass
 * x_dot, x_old, etc., to matrix_fill.  Some of the call list probably
 * isn't making any difference but I'd rather err on the cautious
 * side...
 *
 * Modified by MMH 12/18/00.  3D stability of 2D flow begins!  Broke
 * the (single) function into multiple parts because it was getting
 * too fat...
 */
int
solve_stability_problem(struct Aztec_Linear_Solver_System *ams,                 
			double x[],			/* Value of the solution vector */
			double delta_t,			/* Time step size */
			double theta,			/* Variable time integration parameter
							   explicit (theta = 1) to 
							   implicit (theta = 0) */
			double resid_vector[],
			double x_old[],			/* Value of the old solution vector */
			double x_older[],		/* */
			double xdot[],			/* Value of xdot predicted for new 
							   solution */
			double xdot_old[],		/* */
			double x_update[],		/* */
			int *converged,			/* Whether the Newton has converged */
			int *nprint,			/* Counter for time step number */
			int tnv,			/* Number of nodal results */
			int tnv_post,			/* Number of post processing results */
			struct Results_Description  *rd,
			int *gindex,
			int *p_gsize,
			double *gvec,
			double time_value,
			Exo_DB *exo,			/* Ptr to finite element mesh db */
			Dpi *dpi)			/* Ptr to distributed processing info */
{
  int res;

  fprintf(stderr, "\nWARNING: Linear Stability Analysis is not (and cannot be) compatible\n");
  fprintf(stderr, "  with all user-supplied boundary conditions (i.e., BC cards with\n");
  fprintf(stderr, "  the term USER in them).  If you are using some, and you want LSA,\n");
  fprintf(stderr, "  then you must modify your boundary conditions accordingly.\n\n");

  /* MMH:
   * Here's the trick!  x_old was not the same as x when it came time
   * to do transient calculations.  So things were off by a small
   * amount (a few nodes with < 1% difference, say).  But this small
   * difference caused large errors in the eigenvalues (10%).  I fixed
   * this 11/28/00. */
  dcopy1(NumUnknowns,x,x_old);
  dcopy1(NumUnknowns,x,x_older);

  if(!(Linear_Stability == LSA_3D_OF_2D || Linear_Stability == LSA_3D_OF_2D_SAVE))
    res = solve_full_stability_problem(ams, x, delta_t, theta, resid_vector, 
				       x_old, x_older, xdot, xdot_old,
				       x_update, converged, nprint, tnv,
				       tnv_post, rd, gindex, p_gsize, gvec,
				       time_value, exo, dpi);
  else
    res = solve_3D_of_2D_stability_problem(ams, x, delta_t, theta,
					   resid_vector, x_old, x_older,
					   xdot, xdot_old, x_update,
					   converged, nprint, tnv, tnv_post,
					   rd, gindex, p_gsize, gvec,
					   time_value, exo, dpi);
  return(res);
}/* END of routine solve_stability_problem */
Beispiel #2
0
/*
 * Initialize the preconditioner
 */
static int initPreconditioner(double diagb[], double emat[], int n,
  logical lreset, double yksk, double yrsr,
  double sk[], double yk[], double sr[], double yr[],
  logical upd1)
{
  double srds, yrsk, td, sds;
  int i;
  double *bsk;

  if (upd1)
  {
    dcopy1(n, diagb, emat);
    return 0;
  }

  bsk = malloc(sizeof(*bsk)*n);
  if (bsk == NULL) return -1;

  if (lreset)
  {
    for (i = 0; i < n; i++) bsk[i] = diagb[i] * sk[i];
    sds = ddot1(n, sk, bsk);
    if (yksk == 0.0) yksk = 1.0;
    if (sds == 0.0) sds = 1.0;
    for (i = 0; i < n; i++)
    {
      td = diagb[i];
      emat[i] = td - td * td * sk[i] * sk[i] / sds + yk[i] * yk[i] / yksk;
    }
  }
  else
  {
    for (i = 0; i < n; i++) bsk[i] = diagb[i] * sr[i];
    sds = ddot1(n, sr, bsk);
    srds = ddot1(n, sk, bsk);
    yrsk = ddot1(n, yr, sk);
    if (yrsr == 0.0) yrsr = 1.0;
    if (sds == 0.0) sds = 1.0;
    for (i = 0; i < n; i++)
    {
      td = diagb[i];
      bsk[i] = td * sk[i] - bsk[i] * srds / sds + yr[i] * yrsk / yrsr;
      emat[i] = td - td * td * sr[i] * sr[i] / sds + yr[i] * yr[i] / yrsr;
    }
    sds = ddot1(n, sk, bsk);
    if (yksk == 0.0) yksk = 1.0;
    if (sds == 0.0) sds = 1.0;
    for (i = 0; i < n; i++)
      emat[i] = emat[i] - bsk[i] * bsk[i] / sds + yk[i] * yk[i] / yksk;
  }

  free(bsk);
  return 0;
}
Beispiel #3
0
/*
 * This routine is a bounds-constrained truncated-newton method.
 * the truncated-newton method is preconditioned by a limited-memory
 * quasi-newton method (this preconditioning strategy is developed
 * in this routine) with a further diagonal scaling
 * (see routine diagonalscaling).
 */
static tnc_rc tnc_minimize(int n, double x[],
  double *f, double gfull[], tnc_function *function, void *state,
  double xscale[], double xoffset[], double *fscale,
  double low[], double up[], tnc_message messages,
  int maxCGit, int maxnfeval, int *nfeval, int *niter, double eta, double
  stepmx, double accuracy, double fmin, double ftol, double xtol, double
  pgtol, double rescale, tnc_callback *callback)
{
  double fLastReset, difnew, epsmch, epsred, oldgtp,
    difold, oldf, xnorm, newscale,
    gnorm, ustpmax, fLastConstraint, spe, yrsr, yksk,
    *temp = NULL, *sk = NULL, *yk = NULL, *diagb = NULL, *sr = NULL,
    *yr = NULL, *oldg = NULL, *pk = NULL, *g = NULL;
  double alpha = 0.0; /* Default unused value */
  int i, icycle, oldnfeval, *pivot = NULL, frc;
  logical lreset, newcon, upd1, remcon;
  tnc_rc rc = TNC_ENOMEM; /* Default error */

  *niter = 0;

  /* Allocate temporary vectors */
  oldg = malloc(sizeof(*oldg)*n);
   if (oldg == NULL) goto cleanup;
  g = malloc(sizeof(*g)*n);
   if (g == NULL) goto cleanup;
  temp = malloc(sizeof(*temp)*n);
   if (temp == NULL) goto cleanup;
  diagb = malloc(sizeof(*diagb)*n);
   if (diagb == NULL) goto cleanup;
  pk = malloc(sizeof(*pk)*n);
   if (pk == NULL) goto cleanup;

  sk = malloc(sizeof(*sk)*n);
   if (sk == NULL) goto cleanup;
  yk = malloc(sizeof(*yk)*n);
   if (yk == NULL) goto cleanup;
  sr = malloc(sizeof(*sr)*n);
   if (sr == NULL) goto cleanup;
  yr = malloc(sizeof(*yr)*n);
   if (yr == NULL) goto cleanup;

  pivot = malloc(sizeof(*pivot)*n);
   if (pivot == NULL) goto cleanup;

  /* Initialize variables */
  epsmch = mchpr1();

  difnew = 0.0;
  epsred = 0.05;
  upd1 = TNC_TRUE;
  icycle = n - 1;
  newcon = TNC_TRUE;

  /* Uneeded initialisations */
  lreset = TNC_FALSE;
  yrsr = 0.0;
  yksk = 0.0;

  /* Initial scaling */
  scalex(n, x, xscale, xoffset);
  (*f) *= *fscale;

  /* initial pivot calculation */
  setConstraints(n, x, pivot, xscale, xoffset, low, up);

  dcopy1(n, gfull, g);
  scaleg(n, g, xscale, *fscale);

  /* Test the lagrange multipliers to see if they are non-negative. */
  for (i = 0; i < n; i++)
    if (-pivot[i] * g[i] < 0.0)
      pivot[i] = 0;

  project(n, g, pivot);

  /* Set initial values to other parameters */
  gnorm = dnrm21(n, g);

  fLastConstraint = *f; /* Value at last constraint */
  fLastReset = *f; /* Value at last reset */

  if (messages & TNC_MSG_ITER) fprintf(stderr,
    "  NIT   NF   F                       GTG\n");
  if (messages & TNC_MSG_ITER) printCurrentIteration(n, *f / *fscale, gfull,
    *niter, *nfeval, pivot);

  /* Set the diagonal of the approximate hessian to unity. */
  for (i = 0; i < n; i++) diagb[i] = 1.0;

  /* Start of main iterative loop */
  while(TNC_TRUE)
  {
    /* Local minimum test */
    if (dnrm21(n, g) <= pgtol * (*fscale))
    {
      /* |PG| == 0.0 => local minimum */
      dcopy1(n, gfull, g);
      project(n, g, pivot);
      if (messages & TNC_MSG_INFO) fprintf(stderr,
        "tnc: |pg| = %g -> local minimum\n", dnrm21(n, g) / (*fscale));
      rc = TNC_LOCALMINIMUM;
      break;
    }

    /* Terminate if more than maxnfeval evaluations have been made */
    if (*nfeval >= maxnfeval)
    {
      rc = TNC_MAXFUN;
      break;
    }

    /* Rescale function if necessary */
    newscale = dnrm21(n, g);
    if ((newscale > epsmch) && (fabs(log10(newscale)) > rescale))
    {
      newscale = 1.0/newscale;

      *f *= newscale;
      *fscale *= newscale;
      gnorm *= newscale;
      fLastConstraint *= newscale;
      fLastReset *= newscale;
      difnew *= newscale;

      for (i = 0; i < n; i++) g[i] *= newscale;
      for (i = 0; i < n; i++) diagb[i] = 1.0;

      upd1 = TNC_TRUE;
      icycle = n - 1;
      newcon = TNC_TRUE;

      if (messages & TNC_MSG_INFO) fprintf(stderr,
        "tnc: fscale = %g\n", *fscale);
    }

    dcopy1(n, x, temp);
    project(n, temp, pivot);
    xnorm = dnrm21(n, temp);
    oldnfeval = *nfeval;

    /* Compute the new search direction */
    frc = tnc_direction(pk, diagb, x, g, n, maxCGit, maxnfeval, nfeval,
      upd1, yksk, yrsr, sk, yk, sr, yr,
      lreset, function, state, xscale, xoffset, *fscale,
      pivot, accuracy, gnorm, xnorm, low, up);

    if (frc == -1)
    {
      rc = TNC_ENOMEM;
      break;
    }

    if (frc)
    {
      rc = TNC_USERABORT;
      break;
    }

    if (!newcon)
    {
      if (!lreset)
      {
        /* Compute the accumulated step and its corresponding gradient
          difference. */
        dxpy1(n, sk, sr);
        dxpy1(n, yk, yr);
        icycle++;
      }
      else
      {
        /* Initialize the sum of all the changes */
        dcopy1(n, sk, sr);
        dcopy1(n, yk, yr);
        fLastReset = *f;
        icycle = 1;
      }
    }

    dcopy1(n, g, oldg);
    oldf = *f;
    oldgtp = ddot1(n, pk, g);

    /* Maximum unconstrained step length */
    ustpmax = stepmx / (dnrm21(n, pk) + epsmch);

    /* Maximum constrained step length */
    spe = stepMax(ustpmax, n, x, pk, pivot, low, up, xscale, xoffset);

    if (spe > 0.0)
    {
      ls_rc lsrc;
      /* Set the initial step length */
      alpha = initialStep(*f, fmin / (*fscale), oldgtp, spe);

      /* Perform the linear search */
      lsrc = linearSearch(n, function, state, low, up,
        xscale, xoffset, *fscale, pivot,
        eta, ftol, spe, pk, x, f, &alpha, gfull, maxnfeval, nfeval);

      if (lsrc == LS_ENOMEM)
      {
        rc = TNC_ENOMEM;
        break;
      }

      if (lsrc == LS_USERABORT)
      {
        rc = TNC_USERABORT;
        break;
      }

      if (lsrc == LS_FAIL)
      {
        rc = TNC_LSFAIL;
        break;
      }

      /* If we went up to the maximum unconstrained step, increase it */
      if (alpha >= 0.9 * ustpmax)
      {
        stepmx *= 1e2;
        if (messages & TNC_MSG_INFO) fprintf(stderr,
          "tnc: stepmx = %g\n", stepmx);
      }

      /* If we went up to the maximum constrained step,
         a new constraint was encountered */
      if (alpha - spe >= -epsmch * 10.0)
      {
        newcon = TNC_TRUE;
      }
      else
      {
        /* Break if the linear search has failed to find a lower point */
        if (lsrc != LS_OK)
        {
          if (lsrc == LS_MAXFUN) rc = TNC_MAXFUN;
          else rc = TNC_LSFAIL;
          break;
        }
        newcon = TNC_FALSE;
      }
    }
    else
    {
      /* Maximum constrained step == 0.0 => new constraint */
      newcon = TNC_TRUE;
    }

    if (newcon)
    {
      if(!addConstraint(n, x, pk, pivot, low, up, xscale, xoffset))
      {
        if(*nfeval == oldnfeval)
        {
          rc = TNC_NOPROGRESS;
          break;
        }
      }

      fLastConstraint = *f;
    }

    (*niter)++;

    /* Invoke the callback function */
    if (callback)
    {
      unscalex(n, x, xscale, xoffset);
      callback(x, state);
      scalex(n, x, xscale, xoffset);
    }

    /* Set up parameters used in convergence and resetting tests */
    difold = difnew;
    difnew = oldf - *f;

    /* If this is the first iteration of a new cycle, compute the
       percentage reduction factor for the resetting test */
    if (icycle == 1)
    {
      if (difnew > difold * 2.0) epsred += epsred;
      if (difnew < difold * 0.5) epsred *= 0.5;
    }

    dcopy1(n, gfull, g);
    scaleg(n, g, xscale, *fscale);

    dcopy1(n, g, temp);
    project(n, temp, pivot);
    gnorm = dnrm21(n, temp);

    /* Reset pivot */
    remcon = removeConstraint(oldgtp, gnorm, pgtol * (*fscale), *f,
      fLastConstraint, g, pivot, n);

    /* If a constraint is removed */
    if (remcon)
    {
      /* Recalculate gnorm and reset fLastConstraint */
      dcopy1(n, g, temp);
      project(n, temp, pivot);
      gnorm = dnrm21(n, temp);
      fLastConstraint = *f;
    }

    if (!remcon && !newcon)
    {
      /* No constraint removed & no new constraint : tests for convergence */
      if (fabs(difnew) <= ftol * (*fscale))
      {
        if (messages & TNC_MSG_INFO) fprintf(stderr,
          "tnc: |fn-fn-1] = %g -> convergence\n", fabs(difnew) / (*fscale));
        rc = TNC_FCONVERGED;
        break;
      }
      if (alpha * dnrm21(n, pk) <= xtol)
      {
        if (messages & TNC_MSG_INFO) fprintf(stderr,
          "tnc: |xn-xn-1] = %g -> convergence\n", alpha * dnrm21(n, pk));
        rc = TNC_XCONVERGED;
        break;
      }
    }

    project(n, g, pivot);

    if (messages & TNC_MSG_ITER) printCurrentIteration(n, *f / *fscale, gfull,
      *niter, *nfeval, pivot);

    /* Compute the change in the iterates and the corresponding change in the
      gradients */
    if (!newcon)
    {
      for (i = 0; i < n; i++)
      {
        yk[i] = g[i] - oldg[i];
        sk[i] = alpha * pk[i];
      }

      /* Set up parameters used in updating the preconditioning strategy */
      yksk = ddot1(n, yk, sk);

      if (icycle == (n - 1) || difnew < epsred * (fLastReset - *f))
        lreset = TNC_TRUE;
      else
      {
        yrsr = ddot1(n, yr, sr);
        if (yrsr <= 0.0) lreset = TNC_TRUE;
        else lreset = TNC_FALSE;
      }
      upd1 = TNC_FALSE;
    }
  }

  if (messages & TNC_MSG_ITER) printCurrentIteration(n, *f / *fscale, gfull,
    *niter, *nfeval, pivot);

  /* Unscaling */
  unscalex(n, x, xscale, xoffset);
  coercex(n, x, low, up);
  (*f) /= *fscale;

cleanup:
  if (oldg) free(oldg);
  if (g) free(g);
  if (temp) free(temp);
  if (diagb) free(diagb);
  if (pk) free(pk);

  if (sk) free(sk);
  if (yk) free(yk);
  if (sr) free(sr);
  if (yr) free(yr);

  if (pivot) free(pivot);

  return rc;
}
Beispiel #4
0
/*
 * Line search algorithm of gill and murray
 */
static ls_rc linearSearch(int n, tnc_function *function, void *state,
  double low[], double up[],
  double xscale[], double xoffset[], double fscale, int pivot[],
  double eta, double ftol, double xbnd,
  double p[], double x[], double *f,
  double *alpha, double gfull[], int maxnfeval, int *nfeval)
{
  double b1, big, tol, rmu, fpresn, fu, gu, fw, gw, gtest1, gtest2,
    oldf, fmin, gmin, rtsmll, step, a, b, e, u, ualpha, factor, scxbnd, xw,
    epsmch, reltol, abstol, tnytol, pe, xnorm, rteps;
  double *temp = NULL, *tempgfull = NULL, *newgfull = NULL;
  int maxlsit = 64, i, itcnt, frc;
  ls_rc rc;
  getptc_rc itest;
  logical braktd;

  rc = LS_ENOMEM;
  temp = malloc(sizeof(*temp)*n);
  if (temp == NULL) goto cleanup;
  tempgfull = malloc(sizeof(*tempgfull)*n);
  if (tempgfull == NULL) goto cleanup;
  newgfull = malloc(sizeof(*newgfull)*n);
  if (newgfull == NULL) goto cleanup;

  dcopy1(n, gfull, temp);
  scaleg(n, temp, xscale, fscale);
  gu = ddot1(n, temp, p);

  dcopy1(n, x, temp);
  project(n, temp, pivot);
  xnorm = dnrm21(n, temp);

  /* Compute the absolute and relative tolerances for the linear search */
  epsmch = mchpr1();
  rteps = sqrt(epsmch);
  pe = dnrm21(n, p) + epsmch;
  reltol = rteps * (xnorm + 1.0) / pe;
  abstol = -epsmch * (1.0 + fabs(*f)) / (gu - epsmch);

  /* Compute the smallest allowable spacing between points in the linear
    search */
  tnytol = epsmch * (xnorm + 1.0) / pe;

  rtsmll = epsmch;
  big = 1.0 / (epsmch * epsmch);
  itcnt = 0;

  /* Set the estimated relative precision in f(x). */
  fpresn = ftol;

  u = *alpha;
  fu = *f;
  fmin = *f;
  rmu = 1e-4;

  /* Setup */
  itest = getptcInit(&reltol, &abstol, tnytol, eta, rmu,
    xbnd, &u, &fu, &gu, alpha, &fmin, &gmin, &xw, &fw, &gw, &a, &b,
    &oldf, &b1, &scxbnd, &e, &step, &factor, &braktd, &gtest1, &gtest2, &tol);

  /* If itest == GETPTC_EVAL, the algorithm requires the function value to be
    calculated */
  while(itest == GETPTC_EVAL)
  {
    /* Test for too many iterations or too many function evals */
    if ((++itcnt > maxlsit) || ((*nfeval) >= maxnfeval)) break;

    ualpha = *alpha + u;
    for (i = 0; i < n; i++)
      temp[i] = x[i] + ualpha * p[i];

    /* Function evaluation */
    unscalex(n, temp, xscale, xoffset);
    coercex(n, temp, low, up);

    frc = function(temp, &fu, tempgfull, state);
    ++(*nfeval);
    if (frc)
    {
      rc = LS_USERABORT;
      goto cleanup;
    }

    fu *= fscale;

    dcopy1(n, tempgfull, temp);
    scaleg(n, temp, xscale, fscale);
    gu = ddot1(n, temp, p);

    itest = getptcIter(big, rtsmll, &reltol, &abstol, tnytol, fpresn,
      xbnd, &u, &fu, &gu, alpha, &fmin, &gmin, &xw, &fw, &gw, &a, &b,
      &oldf, &b1, &scxbnd, &e, &step, &factor, &braktd, &gtest1, &gtest2, &tol);

    /* New best point ? */
    if (*alpha == ualpha)
      dcopy1(n, tempgfull, newgfull);
  }

  if (itest == GETPTC_OK)
  {
    /* A successful search has been made */
    *f = fmin;
    daxpy1(n, *alpha, p, x);
    dcopy1(n, newgfull, gfull);
    rc = LS_OK;
  }
  /* Too many iterations ? */
  else if (itcnt > maxlsit) rc = LS_FAIL;
  /* If itest=GETPTC_FAIL or GETPTC_EINVAL a lower point could not be found */
  else if (itest != GETPTC_EVAL) rc = LS_FAIL;
  /* Too many function evaluations */
  else rc = LS_MAXFUN;

cleanup:
  if (temp) free(temp);
  if (tempgfull) free(tempgfull);
  if (newgfull) free(newgfull);

  return rc;
}
Beispiel #5
0
/*
 * This routine performs a preconditioned conjugate-gradient
 * iteration in order to solve the newton equations for a search
 * direction for a truncated-newton algorithm.
 * When the value of the quadratic model is sufficiently reduced,
 * the iteration is terminated.
 */
static int tnc_direction(double *zsol, double *diagb,
  double *x, double g[], int n,
  int maxCGit, int maxnfeval, int *nfeval,
  logical upd1, double yksk, double yrsr,
  double *sk, double *yk, double *sr, double *yr,
  logical lreset, tnc_function *function, void *state,
  double xscale[], double xoffset[], double fscale,
  int *pivot, double accuracy,
  double gnorm, double xnorm, double low[], double up[])
{
  double alpha, beta, qold, qnew, rhsnrm, tol, vgv, rz, rzold, qtest, pr, gtp;
  int i, k, frc;
  /* Temporary vectors */
  double *r = NULL, *zk = NULL, *v = NULL, *emat = NULL, *gv = NULL;

  /* No CG it. => dir = -grad */
  if (maxCGit == 0)
  {
    dcopy1(n, g, zsol);
    dneg1(n, zsol);
    project(n, zsol, pivot);
    return 0;
  }

  /* General initialization */
  rhsnrm = gnorm;
  tol = 1e-12;
  qold = 0.0;
  rzold = 0.0; /* Uneeded */

  frc = -1; /* ENOMEM here */
  r = malloc(sizeof(*r)*n); /* Residual */
  if (r == NULL) goto cleanup;
  v = malloc(sizeof(*v)*n);
  if (v == NULL) goto cleanup;
  zk = malloc(sizeof(*zk)*n);
  if (zk == NULL) goto cleanup;
  emat = malloc(sizeof(*emat)*n); /* Diagonal preconditoning matrix */
  if (emat == NULL) goto cleanup;
  gv = malloc(sizeof(*gv)*n); /* hessian times v */
  if (gv == NULL) goto cleanup;

  /* Initialization for preconditioned conjugate-gradient algorithm */
  frc = initPreconditioner(diagb, emat, n, lreset, yksk, yrsr, sk, yk, sr, yr,
    upd1);
  if (frc) goto cleanup;

  for (i = 0; i < n; i++)
  {
    r[i] = -g[i];
    v[i] = 0.0;
    zsol[i] = 0.0; /* Computed search direction */
  }

  /* Main iteration */
  for (k = 0; k < maxCGit; k++)
  {
    /* CG iteration to solve system of equations */
    project(n, r, pivot);
    frc = msolve(r, zk, n, sk, yk, diagb, sr, yr, upd1, yksk, yrsr, lreset);
    if (frc) goto cleanup;
    project(n, zk, pivot);
    rz = ddot1(n, r, zk);

    if ((rz / rhsnrm < tol) || ((*nfeval) >= (maxnfeval-1)))
    {
      /* Truncate algorithm in case of an emergency
         or too many function evaluations */
      if (k == 0)
      {
        dcopy1(n, g, zsol);
        dneg1(n, zsol);
        project(n, zsol, pivot);
      }
      break;
    }
    if (k == 0) beta = 0.0;
    else beta = rz / rzold;

    for (i = 0; i < n; i++)
      v[i] = zk[i] + beta * v[i];

    project(n, v, pivot);
    frc = hessianTimesVector(v, gv, n, x, g, function, state,
      xscale, xoffset, fscale, accuracy, xnorm, low, up);
    ++(*nfeval);
    if (frc) goto cleanup;
    project(n, gv, pivot);

    vgv = ddot1(n, v, gv);
    if (vgv / rhsnrm < tol)
    {
      /* Truncate algorithm in case of an emergency */
      if (k == 0)
      {
        frc = msolve(g, zsol, n, sk, yk, diagb, sr, yr, upd1, yksk, yrsr,
          lreset);
        if (frc) goto cleanup;
        dneg1(n, zsol);
        project(n, zsol, pivot);
      }
      break;
    }
    diagonalScaling(n, emat, v, gv, r);

    /* Compute linear step length */
    alpha = rz / vgv;

    /* Compute current solution and related vectors */
    daxpy1(n, alpha, v, zsol);
    daxpy1(n, -alpha, gv, r);

    /* Test for convergence */
    gtp = ddot1(n, zsol, g);
    pr = ddot1(n, r, zsol);
    qnew = (gtp + pr) * 0.5;
    qtest = (k + 1) * (1.0 - qold / qnew);
    if (qtest <= 0.5) break;

    /* Perform cautionary test */
    if (gtp > 0.0)
    {
      /* Truncate algorithm in case of an emergency */
      daxpy1(n, -alpha, v, zsol);
      break;
    }

    qold = qnew;
    rzold = rz;
  }

  /* Terminate algorithm */
  /* Store (or restore) diagonal preconditioning */
  dcopy1(n, emat, diagb);

cleanup:
  if (r) free(r);
  if (v) free(v);
  if (zk) free(zk);
  if (emat) free(emat);
  if (gv) free(gv);
  return frc;
}
Beispiel #6
0
void 
numerical_jacobian_fill(int ijaf[],	/* fill Vector of integer pointers into a matrix */
			double afill[], /* Vector of non-zero entries in the 
					 * coefficient matrix */
			double xf[],	/* fill Solution vector for the current processor */
			double rf[],    /* Residual vector for the current 
					 * processor */
			double delta_t, /* time step size */
		        double theta,   /* parameter to vary time integration 
                                         * from explicit (theta = 1) to 
				         *      implicit (theta = 0) */
			double x[],     /* Value current big solution vector holding everything*/
			double x_old[], /* Value of the old solution vector */
			double xdot[],  /* Value of xdot predicted for new solution */
			
			
			int Debug_Flag, /* flag for calculating numerical jacobian
					   -3 == calc num jac w/  rescaling */
			int node_to_fill[], /* this is a map from the */
			Exo_DB *exo,	    /* ptr to whole fe mesh */
			Dpi *dpi) /* ptr to parallel info */

/******************************************************************************
  This function compares the analytical jacobian entries calculated in matrix_fill
                         the numerical ones approximated by central difference method.  
  
  Author:          K. S. Chen (1511) (based on an earlier version by P. R. Schunk). 
  Date:            January 19, 1994

******************************************************************************/

{
  int i, j, k, ii, nn, kount, nnonzero, num_total_nodes;

  extern struct elem_side_bc_struct **First_Elem_Side_BC_Array;

  const double epsilon = 1.e-07;          

 
  double epsilon1=1.e-3;          
  dbl *aj_diag, *aj_off_diag, *nj, *resid_vector_old, *x_save, *scale;
  int *irow, *jcolumn, *nelem;


  fprintf(stderr,"\n Starting Numerical Jacobian Checker for Fill equation\n");

  nnonzero	  = fill_zeros+1;
  nn		  = ijaf[num_fill_unknowns]-ijaf[0]; /* total number of diagonal entries a[] */
  num_total_nodes = Num_Internal_Nodes + Num_Border_Nodes;

/* allocate arrays to hold jacobian and vector values */
  irow		   = (int *) array_alloc(1, nnonzero, sizeof(int));
  jcolumn	   = (int *) array_alloc(1, nnonzero, sizeof(int));
  nelem		   = (int *) array_alloc(1, nnonzero, sizeof(int));
  aj_diag	   = (double *) array_alloc(1, num_fill_unknowns, sizeof(double));
  aj_off_diag	   = (double *) array_alloc(1, nnonzero, sizeof(double));
  nj		   = (double *) array_alloc(1, nnonzero, sizeof(double));
  resid_vector_old = (double *) array_alloc(1, num_fill_unknowns, sizeof(double));
  x_save	   = (double *) array_alloc(1, num_fill_unknowns, sizeof(double));
  scale		   = (double *) array_alloc(1, num_fill_unknowns, sizeof(double));

  if (nj == NULL || scale == NULL) EH(-1, "No room for numerical jacobian arrays");
  
  if (Debug_Flag == -2) epsilon1 = 1.e-6;

  /* initialization */
  memset(aj_off_diag, 0, nnonzero*sizeof(dbl)); /* off-diagonal analytical jacobian elements */ 
  memset(nj, 0, nnonzero*sizeof(dbl));          /* numerical jacobian elements */ 
  memset(aj_diag, 0, num_fill_unknowns*sizeof(dbl));  /* diagonal analytical jacobian elements */ 

  
  /* first calculate the residual vector corresponding to the solution vector read in 
     the initial guess file; also calculate the analytical jacobian entries */
  
  af->Assemble_Residual		   = TRUE;
  af->Assemble_Jacobian		   = TRUE;  
  af->Assemble_LSA_Jacobian_Matrix = FALSE;
  af->Assemble_LSA_Mass_Matrix	   = FALSE;

  (void) fill_matrix(afill, ijaf, rf, xf, x, x_old, 
		     xdot, delta_t, theta, ADVECT, node_to_fill, 
		     First_Elem_Side_BC_Array, exo, dpi);

  if (Debug_Flag == -2) {
    /* Scale matrix first to get rid of problems with
       penalt parameter */
    row_sum_scale_MSR(num_fill_unknowns, afill, ijaf, rf, scale);
  }
  
  /* save solution vector and residual vector before numerical jacobian calculations */

  dcopy1( num_fill_unknowns, xf, x_save);
  dcopy1( num_fill_unknowns, rf, resid_vector_old);
  
  /* extract diagonal and off-diagonal elements from the coefficient matrix stored
     in sparse-storage format */

  dcopy1(num_fill_unknowns, afill, aj_diag);  /* diagonal elements */ 
  
  kount=0;                              /* off-diagonal elements */  
  for (i=0; i<num_fill_unknowns; i++)
    {
      nelem[i] = ijaf[i+1] - ijaf[i]; 
      for (k=0; k<nelem[i]; k++)
	{
	  irow[kount]=i;                   /* row # in global jacobian matrix */ 
	  ii = kount + num_fill_unknowns + 1; 
	  jcolumn[kount]=ijaf[ii];          /* column # in global jacobian matrix */ 
	  aj_off_diag[kount] = afill[ii]; 
	  kount=kount+1;
	}
    } 
  
  piksr2(nn, jcolumn, irow, aj_off_diag);  /* arrange coefficient matrix columnwise,*/
  /* in ascending column number order */   
  
  
  /* calculate numerical jacobian entries columnwise and then compare them with the
     analytical jacobian entries */
  
  for (j=0; j<num_fill_unknowns; j++)       /* loop over each column */  
    { 
      
      xf[j] = x_save[j] + epsilon;     /* perturb one variable at a time */  
      /* let big vector know of the change for load_fv */

      put_fill_vector(num_total_nodes, x, xf, node_to_fill);
      
      for (i=0; i<num_fill_unknowns; i++) 
	rf[i] = 0.0;         /* zero residual vector before its calculation */ 
      
      af->Assemble_Residual = TRUE;
      af->Assemble_Jacobian = FALSE;
      af->Assemble_LSA_Jacobian_Matrix = FALSE;
      af->Assemble_LSA_Mass_Matrix = FALSE;

      (void) fill_matrix(afill, ijaf, rf, xf, x, x_old, 
			 xdot, delta_t, theta, ADVECT, 
                         node_to_fill, First_Elem_Side_BC_Array, exo, dpi);
      
      if (Debug_Flag == -2) {
	/* Scale matrix first to get rid of problems with
	   penalt parameter */
	row_scaling(num_fill_unknowns, afill, ijaf, rf, scale);
      }
      
      for (i=0; i<num_fill_unknowns; i++)  /* cal numerical jacobian vector for column j */ 
	nj[i] = (rf[i] - resid_vector_old[i])/epsilon;  
      
      
      /* COMPARISON: analytical vs. numerical --- the diagonal element for column j */
      
      if(ABS(aj_diag[j] - nj[j]) > epsilon1)   
	fprintf(stderr, " aj=%-10.4g nj=%-10.4g resid=%-12.5g at unknown j = %d\n",
		aj_diag[j], nj[j], rf[j], j);
      
      
      /* COMPARISON: analytical vs. numerical ---  the off-diagonal elements for column j */
      
      for (k=0; k<(ijaf[num_fill_unknowns]-ijaf[0]); k++)
	{
	  if(jcolumn[k] == j)       /* match the column numbers */ 
	    {  
	      for (i=0; i<num_fill_unknowns; i++)
		{ 
		  if(i == irow[k])      /* match the row numbers */ 
		    { 
		      
		      if(ABS(aj_off_diag[k]-nj[i]) > epsilon1 && aj_off_diag[k] != 1.0e+06)  
			fprintf(stderr," aj=%-10.4g nj=%-10.4g at unknown j = %d row i = %d\n",
				aj_off_diag[k], nj[i], j, i); 
		    } 
		}   
	    }   
	}  
      
      xf[j] = xf[j] - epsilon;  /* return solution vector to its original state */     
      
    }                          /* End of for (j=0; j<num_fill_unknowns; j++) */  
  
  /* free arrays to hold jacobian and vector values */
  safe_free( (void *) irow) ;
  safe_free( (void *) jcolumn) ;
  safe_free( (void *) nelem) ;
  safe_free( (void *) aj_diag) ;
  safe_free( (void *) aj_off_diag) ;
  safe_free( (void *) nj) ;
  safe_free( (void *) resid_vector_old) ;
  safe_free( (void *) x_save) ;
  safe_free( (void *) scale) ;
  
}                             /*   End of function numerical_jacobian_fill  */
Beispiel #7
0
void
continue_problem (Comm_Ex *cx,	/* array of communications structures */
		  Exo_DB  *exo, /* ptr to the finite element mesh database */
		  Dpi     *dpi) /* distributed processing information */
{
  int    *ija=NULL;		/* column pointer array                         */
  double *a=NULL;		/* nonzero array                                */
  double *a_old=NULL;		/* nonzero array                                */
  double *x=NULL;		/* solution vector                              */

  int     iAC;			/* COUNTER                                      */
  double *x_AC = NULL;		/* SOLUTION VECTOR OF EXTRA UNKNOWNS            */
  double *x_AC_old=NULL;	/* old SOLUTION VECTOR OF EXTRA UNKNOWNS        */
  double *x_AC_dot=NULL;	
 
  int    *ija_attic=NULL;	/* storage for external dofs                    */

  int eb_indx, ev_indx;

  /* 
   * variables for path traversal 
   */
  double *x_old=NULL;		/* old solution vector                          */
  double *x_older=NULL;		/* older solution vector                        */
  double *x_oldest=NULL;	/* oldest solution vector saved                 */
  double *xdot=NULL;		/* current path derivative of soln              */
  double *xdot_old=NULL;
  double *x_update=NULL;


  double *x_sens=NULL;		/* solution sensitivity */
  double *x_sens_temp=NULL;	/* MMH thinks we need another one, so
				 * that when the solution is updated
				 * on a failure, it doesn't use the
				 * last computed x_sens b/c that might
				 * be crappy.  We should use the last
				 * known good one...  I haven't done
				 * the same thing with x_sens_p.
				 */
  double **x_sens_p=NULL;	/* solution sensitivity for parameters */
  int num_pvector=0;		/*  number of solution sensitivity vectors   */

#ifdef COUPLED_FILL
  struct Aztec_Linear_Solver_System *ams[NUM_ALSS]={NULL}; 
#else /* COUPLED_FILL */
  struct Aztec_Linear_Solver_System *ams[NUM_ALSS]={NULL, NULL}; 
#endif /* COUPLED_FILL */
                 /* sl_util_structs.h */

  double *resid_vector=NULL;	/* residual */
  double *resid_vector_sens=NULL;/* residual sensitivity */

  double *scale=NULL;		/* scale vector for modified newton */

  int 	 *node_to_fill = NULL;	

  int		n;		/* total number of path steps attempted */
  int		ni;		/* total number of nonlinear solves */
  int		nt;		/* total number of successful path steps */
  int		path_step_reform; /* counter for jacobian reformation stride */
  int		converged;	/* success or failure of Newton iteration */
  int		success_ds;	/* success or failure of path step */

  int           i, nprint=0, num_total_nodes;

  int           numProcUnknowns;
  int           const_delta_s, step_print;
  double        path_print, i_print;
  double	path,		/* Current value (should have solution here) */
                path1;		/* New value (would like to get solution here) */
  double	delta_s, delta_s_new, delta_s_old, delta_s_older, delta_s_oldest;
  double        delta_t;
  double	theta=0.0;
  double        damp;
  double        eps;
  double        lambda, lambdaEnd;
  double        timeValueRead = 0.0;

  /* 
   * ALC management variables
   */
  int  aldALC,			/* direction of continuation, == -1 =>
				   beginning value is greater than ending value. */
       alqALC;			/* is -1 when we're on our last step. */

  /*
   * Other local variables 
   */
  int	        error, err, is_steady_state, inewton;
  int 		*gindex = NULL, gsize;
  int		*p_gsize=NULL;
  double	*gvec=NULL;
  double        ***gvec_elem=NULL;
  double	err_dbl;
  FILE          *cl_aux=NULL, *file=NULL;
  
  struct Results_Description  *rd=NULL;
  
  int		tnv;		/* total number of nodal variables and kinds */
  int		tev;		/* total number of elem variables and kinds */
  int		tnv_post;	/* total number of nodal variables and kinds 
				   for post processing */
  int		tev_post;	/* total number of elem variables and kinds 
				   for post processing */
  int           iUC;            /* User-defined continuation condition index */

  int max_unk_elem, one, three; /* variables used as mf_setup arguments*/

  unsigned int matrix_systems_mask;

  double evol_local=0.0;
#ifdef PARALLEL
  double evol_global=0.0;
#endif

  static const char yo[]="continue_problem"; 

  /*
   * 		BEGIN EXECUTION
   */
#ifdef DEBUG
  fprintf(stderr, "%s() begins...\n", yo);
#endif

  is_steady_state = TRUE;

  p_gsize = &gsize;
  
  /* 
   * set aside space for gather global vectors to print to exoII file
   * note: this is temporary
   *
   * For 2D prototype problem:  allocate space for T, dx, dy arrays
   */
  if( strlen(Soln_OutFile) )
    {
      file = fopen(Soln_OutFile, "w");
      if (file == NULL) {
	DPRINTF(stderr, "%s:  opening soln file for writing\n", yo);
        EH(-1, "\t");
      }
    }
#ifdef PARALLEL
  check_parallel_error("Soln output file error");
#endif
  
  /*
   * Some preliminaries to help setup EXODUS II database output.
   */
#ifdef DEBUG
  fprintf(stderr, "cnt_nodal_vars() begins...\n");
#endif

  /*  
   * tnv_post is calculated in load_nodal_tkn
   * tev_post is calculated in load_elem_tkn
   */
  tnv = cnt_nodal_vars();
  tev = cnt_elem_vars();
  
#ifdef DEBUG
  fprintf(stderr, "Found %d total primitive nodal variables to output.\n", tnv);
  fprintf(stderr, "Found %d total primitive elem variables to output.\n", tev);
#endif
  
  if (tnv < 0)
    {
      DPRINTF(stderr, "%s:\tbad tnv.\n", yo);
      EH(-1, "\t");
    }
  
  rd = (struct Results_Description *) 
    smalloc(sizeof(struct Results_Description));

  if (rd == NULL) 
    EH(-1, "Could not grab Results Description.");

  (void) memset((void *) rd, 0, sizeof(struct Results_Description));
  
  rd->nev = 0;			/* number element variables in results */
  rd->ngv = 0;			/* number global variables in results */
  rd->nhv = 0;			/* number history variables in results */

  rd->ngv = 5;			/* number global variables in results 
				   see load_global_var_info for names*/
  error = load_global_var_info(rd, 0, "CONV");
  error = load_global_var_info(rd, 1, "NEWT_IT");
  error = load_global_var_info(rd, 2, "MAX_IT");
  error = load_global_var_info(rd, 3, "CONVRATE");
  error = load_global_var_info(rd, 4, "MESH_VOLUME");

  /* load nodal types, kinds, names */
  error = load_nodal_tkn(rd, 
                         &tnv, 
                         &tnv_post); 
  
  if (error)
    {
      DPRINTF(stderr, "%s:  problem with load_nodal_tkn()\n", yo);
      EH(-1,"\t");
    }

  /* load elem types, names */
  error = load_elem_tkn(rd,
			exo,
                        tev, 
                        &tev_post); 
  
  if (error)
    {
      DPRINTF(stderr, "%s:  problem with load_elem_tkn()\n", yo);
      EH(-1,"\t");
    }
#ifdef PARALLEL
  check_parallel_error("Results file error");
#endif

  /* 
   * Write out the names of the nodal variables that we will be sending to
   * the EXODUS II output file later.
   */
#ifdef DEBUG
  fprintf(stderr, "wr_result_prelim() starts...\n", tnv);
#endif

  gvec_elem = (double ***) smalloc ( (exo->num_elem_blocks)*sizeof(double **));
  for (i = 0; i < exo->num_elem_blocks; i++)
    gvec_elem[i] = (double **) smalloc ( (tev + tev_post)*sizeof(double *));

  wr_result_prelim_exo(rd, 
                       exo, 
                       ExoFileOut,
                       gvec_elem );

#ifdef DEBUG
  fprintf(stderr, "P_%d: wr_result_prelim_exo() ends...\n", ProcID, tnv);
#endif

  /* 
   * This gvec workhorse transports output variables as nodal based vectors
   * that are gather from the solution vector. Note: it is NOT a global
   * vector at all and only carries this processor's nodal variables to
   * the exodus database.
   */
  asdv(&gvec, Num_Node);

  /*
   * Allocate space and manipulate for all the nodes that this processor
   * is aware of...
   */
  num_total_nodes = dpi->num_universe_nodes;

  numProcUnknowns = NumUnknowns + NumExtUnknowns;

  /* allocate memory for Volume Constraint Jacobian */
  if ( nAC > 0)
    for(iAC=0;iAC<nAC;iAC++)
      augc[iAC].d_evol_dx = (double*) malloc(numProcUnknowns*sizeof(double));
  
  asdv(&resid_vector, numProcUnknowns);
  asdv(&resid_vector_sens, numProcUnknowns);
  asdv(&scale, numProcUnknowns);

  for (i = 0; i < NUM_ALSS; i++) 
    {
      ams[i] = alloc_struct_1(struct Aztec_Linear_Solver_System, 1);
    }

#ifdef MPI
  AZ_set_proc_config( ams[0]->proc_config, MPI_COMM_WORLD );
#ifndef COUPLED_FILL
  if( Explicit_Fill ) AZ_set_proc_config( ams[1]->proc_config, MPI_COMM_WORLD );
#endif /* not COUPLED_FILL */
#else /* MPI */
  AZ_set_proc_config( ams[0]->proc_config, 0 );
#ifndef COUPLED_FILL
  if( Explicit_Fill ) AZ_set_proc_config( ams[1]->proc_config, 0 );
#endif /* not COUPLED_FILL */
#endif /* MPI */

  /* 
   * allocate space for and initialize solution arrays 
   */
  asdv(&x,        numProcUnknowns);
  asdv(&x_old,    numProcUnknowns);
  asdv(&x_older,  numProcUnknowns);
  asdv(&x_oldest, numProcUnknowns);
  asdv(&xdot,     numProcUnknowns);
  asdv(&xdot_old, numProcUnknowns);
  asdv(&x_update, numProcUnknowns);
  
  asdv(&x_sens,   numProcUnknowns);
  asdv(&x_sens_temp,   numProcUnknowns);

  /*
   * Initialize solid inertia flag
   */
  set_solid_inertia();
  
  /*
   * FRIENDLY COMMAND LINE EQUIV
   */
  if( ProcID == 0 )
   {
      cl_aux = fopen("goma-cl.txt", "w+");

      fprintf(cl_aux, "goma -a -i input ");
      fprintf(cl_aux, "-cb %10.6e ", cont->BegParameterValue);
      fprintf(cl_aux, "-ce %10.6e ", cont->EndParameterValue);
      fprintf(cl_aux, "-cd %10.6e ", cont->Delta_s0);
      fprintf(cl_aux, "-cn %d ", cont->MaxPathSteps);
      fprintf(cl_aux, "-cmin %10.6e ", cont->Delta_s_min);
      fprintf(cl_aux, "-cmax %10.6e ", cont->Delta_s_max);
      fprintf(cl_aux, "-cm %d ", Continuation);
      fprintf(cl_aux, "-ct %d ", cont->upType);

      switch (cont->upType)
        {
        case 1:			/* BC TYPE */
          fprintf(cl_aux, "-c_bc %d ", cont->upBCID);
          fprintf(cl_aux, "-c_df %d ", cont->upDFID);
          break;
        case 2:			/* MAT TYPE */
          fprintf(cl_aux, "-c_mn %d ", cont->upMTID+1);
          fprintf(cl_aux, "-c_mp %d ", cont->upMPID);
          break;
        case 3:			/* AC TYPE */
          fprintf(cl_aux, "-c_ac %d ", cont->upBCID);
          fprintf(cl_aux, "-c_df %d ", cont->upDFID);
          break;
        case 4:			/* USER MAT TYPE */
          fprintf(cl_aux, "-c_mn %d ", cont->upMTID+1);
          fprintf(cl_aux, "-c_mp %d ", cont->upMPID);
          fprintf(cl_aux, "-c_md %d ", cont->upMDID);
          break;
        case 5:                 /* USER-DEFINED FUNCTION TYPE */
          /* NOTE:  This is not available via the command line! */
          break;
        case 6:                 /* ANGULAR CONTINUATION TYPE */
          /* NOTE:  This requires LOCA and is not available via the command line! */
          EH(-1, "Angular continuation is available only in LOCA!");
          break;
        default:
          fprintf(stderr, "%s: Bad cont->upType, %d\n", yo, cont->upType);
          EH(-1,"Bad cont->upType");
          break;			/* duh */
        }

      fprintf(cl_aux, "\n");

      fclose(cl_aux);
   }
#ifdef PARALLEL
  check_parallel_error("Continuation setup error");
#endif
  /*
   * FIRST ORDER CONTINUATION 
   */
  lambda       = cont->BegParameterValue;
  lambdaEnd    = cont->EndParameterValue;
  
  if (lambdaEnd > lambda)
    aldALC = +1;
  else
    aldALC = -1;

  delta_s_new  = 0.0;
  Delta_s0     = cont->Delta_s0;
  Delta_s_min  = cont->Delta_s_min;
  Delta_s_max  = cont->Delta_s_max;
  MaxPathSteps = cont->MaxPathSteps;
  PathMax      = cont->PathMax;
  eps          = cont->eps;
  
  if (Delta_s0 < 0.0 )
    {
      Delta_s0 = -Delta_s0;
      const_delta_s = 1;
    } 
  else 
    const_delta_s = 0;
  
  damp = 1.0;

  path = path1 = lambda;

  if (Debug_Flag && ProcID == 0)
    {
      fprintf(stderr,"MaxPathSteps: %d \tlambdaEnd: %f\n", MaxPathSteps, lambdaEnd);
      fprintf(stderr,"continuation in progress\n");
    }

  nprint = 0;

  if (Delta_s0 > Delta_s_max) 
    Delta_s0 = Delta_s_max;

  delta_s = delta_s_old = delta_s_older = Delta_s0;
      
  delta_t = 0.0;
  tran->delta_t = 0.0;      /*for Newmark-Beta terms in Lagrangian Solid*/

  /* Call prefront (or mf_setup) if necessary */
  if (Linear_Solver == FRONT)
    {
      /* Also got to define these because it wants pointers to these numbers */
      max_unk_elem = (MAX_PROB_VAR + MAX_CONC)*MDE;

      one = 1;
      three = 3;

      /* NOTE: We need a overall flag in the vn_glob struct that tells whether FULL_DG
	 is on anywhere in domain.  This assumes only one material.  See sl_front_setup for test.
	 that test needs to be in the input parser.  */
      if(vn_glob[0]->dg_J_model == FULL_DG) 
	max_unk_elem = (MAX_PROB_VAR + MAX_CONC)*MDE + 4*vn_glob[0]->modes*4*MDE;

#ifdef PARALLEL
  if (Num_Proc > 1) EH(-1, "Whoa.  No front allowed with nproc>1");  
  check_parallel_error("Front solver not allowed with nprocs>1");
#endif
	  
#ifdef HAVE_FRONT  
       err = mf_setup(&exo->num_elems, 
		     &NumUnknowns, 
		     &max_unk_elem, 
		     &three,
		     &one,
		     exo->elem_order_map,
		     fss->el_proc_assign,
		     fss->level,
		     fss->nopdof,
		     fss->ncn,
		     fss->constraint,
		     front_scratch_directory,
		     &fss->ntra); 
      EH(err,"problems in frontal setup ");

#else
      EH(-1,"Don't have frontal solver compiled and linked in");
#endif
    }


  /*
   *  if computing parameter sensitivities, allocate space for solution
   *  sensitivity vectors
   */

        for(i=0;i<nn_post_fluxes_sens;i++)     
	  {
	    num_pvector=MAX(num_pvector,pp_fluxes_sens[i]->vector_id);
	  }
        for(i=0;i<nn_post_data_sens;i++)        
	  {
	    num_pvector=MAX(num_pvector,pp_data_sens[i]->vector_id);
	  }

  if((nn_post_fluxes_sens + nn_post_data_sens) > 0)
    {
      num_pvector++;
      num_pvector = MAX(num_pvector,2);
         x_sens_p = Dmatrix_birth(num_pvector,numProcUnknowns);
    }
  else
    x_sens_p = NULL;

  if (nAC > 0)
    {
      asdv(&x_AC, nAC);
      asdv(&x_AC_old, nAC);
      asdv(&x_AC_dot, nAC);
    }

  /*
   * ADJUST NATURAL PARAMETER
   */
  update_parameterC(0, path1, x, xdot, x_AC, delta_s, cx, exo, dpi);


  /* Allocate sparse matrix */
  if( strcmp( Matrix_Format, "msr" ) == 0)
    {
      log_msg("alloc_MSR_sparse_arrays...");
      alloc_MSR_sparse_arrays(&ija, 
			      &a, 
			      &a_old, 
			      0, 
			      node_to_fill, 
			      exo, 
			      dpi);
      /*
       * An attic to store external dofs column names is needed when
       * running in parallel.
       */
      alloc_extern_ija_buffer(num_universe_dofs, 
			      num_internal_dofs+num_boundary_dofs, 
			      ija, &ija_attic);
      /*
       * Any necessary one time initialization of the linear
       * solver package (Aztec).
       */
      ams[JAC]->bindx   = ija;
      ams[JAC]->val     = a;
      ams[JAC]->belfry  = ija_attic;
      ams[JAC]->val_old = a_old;
	  
      /*
       * These point to nowhere since we're using MSR instead of VBR
       * format.
       */
      ams[JAC]->indx  = NULL;
      ams[JAC]->bpntr = NULL;
      ams[JAC]->rpntr = NULL;
      ams[JAC]->cpntr = NULL;
      ams[JAC]->npn      = dpi->num_internal_nodes + dpi->num_boundary_nodes;
      ams[JAC]->npn_plus = dpi->num_internal_nodes + dpi->num_boundary_nodes + dpi->num_external_nodes;

      ams[JAC]->npu      = num_internal_dofs+num_boundary_dofs;
      ams[JAC]->npu_plus = num_universe_dofs;

      ams[JAC]->nnz = ija[num_internal_dofs+num_boundary_dofs] - 1;
      ams[JAC]->nnz_plus = ija[num_universe_dofs];
    }
  else if(  strcmp( Matrix_Format, "vbr" ) == 0)
    {
      log_msg("alloc_VBR_sparse_arrays...");
      alloc_VBR_sparse_arrays (ams[JAC],
			       exo,
			       dpi);
      ija_attic = NULL;
      ams[JAC]->belfry  = ija_attic;

      a = ams[JAC]->val;
      if( !save_old_A ) a_old = ams[JAC]->val_old = NULL;
    }
  else if ( strcmp( Matrix_Format, "front") == 0 )
    {
      /* Don't allocate any sparse matrix space when using front */
      ams[JAC]->bindx   = NULL;
      ams[JAC]->val     = NULL;
      ams[JAC]->belfry  = NULL;
      ams[JAC]->val_old = NULL;
      ams[JAC]->indx  = NULL;
      ams[JAC]->bpntr = NULL;
      ams[JAC]->rpntr = NULL;
      ams[JAC]->cpntr = NULL;

    }
  else
    EH(-1,"Attempted to allocate unknown sparse matrix format");

  init_vec(x, cx, exo, dpi, x_AC, nAC, &timeValueRead);

  /*  if read ACs, update data floats */
  if (nAC > 0)
    if(augc[0].iread == 1)
	{
	  for(iAC=0 ; iAC<nAC ; iAC++)
	    { update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi);}
	}

  vzero(numProcUnknowns, &x_sens[0]);
  vzero(numProcUnknowns, &x_sens_temp[0]);

  /* 
   * set boundary conditions on the initial conditions 
   */

  nullify_dirichlet_bcs();

  find_and_set_Dirichlet(x, xdot, exo, dpi);

  exchange_dof(cx, dpi, x);

  dcopy1(numProcUnknowns,x,x_old);
  dcopy1(numProcUnknowns,x_old,x_older);
  dcopy1(numProcUnknowns,x_older,x_oldest);

  if(nAC > 0)
    dcopy1(nAC,x_AC, x_AC_old);

  /* 
   * initialize the counters for when to print out data 
   */
  path_print = path1;
  step_print = 1;
      
  matrix_systems_mask = 1;

  log_msg("sl_init()...");
  sl_init(matrix_systems_mask, ams, exo, dpi, cx);

  /*
  * Make sure the solver was properly initialized on all processors.
  */
#ifdef PARALLEL
  check_parallel_error("Solver initialization problems");
#endif

  ams[JAC]->options[AZ_keep_info] = 1;
  /* 
   * set the number of successful path steps to zero 
   */
  nt = 0;   

  /* 
   * LOOP THROUGH PARAMETER UNTIL MAX NUMBER 
   * OF STEPS SURPASSED
   */

  for(n = 0; n < MaxPathSteps; n++)
    {
      alqALC = 1;

      switch (aldALC)
	{
	case -1:			/* REDUCING PARAMETER DIRECTION */
	  if (path1 <= lambdaEnd)
	    { 
	      DPRINTF(stderr,"\n\t ******** LAST PATH STEP!\n");
	      alqALC = -1;
	      path1 = lambdaEnd;
	      delta_s = path-path1;
	    } 
	  break;
	case +1:			/* RISING PARAMETER DIRECTION */
	  if (path1 >= lambdaEnd)
	    { 
	      DPRINTF(stderr,"\n\t ******** LAST PATH STEP!\n");
	      alqALC = -1;
	      path1 = lambdaEnd;
	      delta_s = path1-path;
	    } 
	  break;
	default:
	  DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
          EH(-1,"\t");
	  break;		/* duh */
	}
#ifdef PARALLEL
  check_parallel_error("Bad aldALC");
#endif
	  
      /*
       * ADJUST NATURAL PARAMETER
       */
      update_parameterC(0, path1, x, xdot, x_AC, delta_s, 
			cx, exo, dpi);

      /*
       * IF STEP CHANGED, REDO FIRST ORDER PREDICTION
       */
      if(alqALC == -1)
	{
	  dcopy1(NumUnknowns,x_old,x);

	  switch (Continuation)
	    {
	    case ALC_ZEROTH:
	      break;
	    case  ALC_FIRST:
	      switch (aldALC)
		{
		case -1:
		  v1add(NumUnknowns, &x[0], -delta_s, &x_sens[0]);
		  break;
		case +1:
		  v1add(NumUnknowns, &x[0], +delta_s, &x_sens[0]);
		  break;
		default:
		  DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
                  EH(-1,"\t");
		  break;	/* duh */
		}
	      break;
	    default:
	      DPRINTF(stderr, "%s: Bad Continuation, %d\n", yo, Continuation);
              EH(-1,"\t");
	      break;		/* duh */
	    }
	}
#ifdef PARALLEL
  check_parallel_error("Bad Continuation");
#endif

      find_and_set_Dirichlet (x, xdot, exo, dpi); 

      exchange_dof(cx, dpi, x);

      if (ProcID == 0)
	{
	  fprintf(stderr, "\n\t----------------------------------");
	  switch (Continuation)
	    {
	    case ALC_ZEROTH:
	      DPRINTF(stderr, "\n\tZero Order Continuation:");
	      break;
	    case  ALC_FIRST:
	      DPRINTF(stderr, "\n\tFirst Order Continuation:");
	      break;
	    default:
	      DPRINTF(stderr, "%s: Bad Continuation, %d\n", yo, Continuation);
              EH(-1,"\t");
	      break;		/* duh */
	    }
	  DPRINTF(stderr, "\n\tStep number: %4d of %4d (max)", n+1, MaxPathSteps);
	  DPRINTF(stderr, "\n\tAttempting solution at:");
	  switch (cont->upType)
	    {
	    case 1:		/* BC */
	    case 3:		/* AC */
	      DPRINTF(stderr, "\n\tBCID=%3d DFID=%5d", cont->upBCID, cont->upDFID);
	      break;
	    case 2:		/* MT */
	      DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d", cont->upMTID, cont->upMPID);
	      break;
	    case 4:		/* UM */
	      DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d MDID=%3d", cont->upMTID, cont->upMPID, cont->upMDID);
	      break;

/* This case requires an inner switch block */
            case 5:             /* UF */
              for (iUC=0; iUC<nUC; iUC++)
                {
	          switch (cpuc[iUC].Type)
	            {
	              case 1:		/* BC */
	              case 3:		/* AC */
	                DPRINTF(stderr, "\n\tBCID=%3d DFID=%5d",
                                cpuc[iUC].BCID, cpuc[iUC].DFID);
	                break;
	              case 2:		/* MT */
	                DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d",
                                cpuc[iUC].MTID, cpuc[iUC].MPID);
	                break;
	              case 4:		/* UM */
	                DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d MDID=%3d",
                          cpuc[iUC].MTID, cpuc[iUC].MPID, cpuc[iUC].MDID);
	                break;
	              default:
	                DPRINTF(stderr, "%s: Bad user continuation type, %d\n",
                                yo, cont->upType);
                        EH(-1,"\t");
	                break;
                    }
	          DPRINTF(stderr, " Parameter= % 10.6e delta_s= %10.6e",
                    cpuc[iUC].value, (cpuc[iUC].value-cpuc[iUC].old_value) );
                }
	      break;

	    default:
	      DPRINTF(stderr, "%s: Bad cont->upType, %d\n", yo, cont->upType);
              EH(-1,"\t");
	      break;		/* duh */
	    }
          if (cont->upType != 5)
            {
	      DPRINTF(stderr, " Parameter= % 10.6e delta_s= %10.6e", path1, delta_s);
            }
	}
#ifdef PARALLEL
  check_parallel_error("Bad cont->upType");
#endif
	
      ni = 0;
      do {
	
#ifdef DEBUG
	DPRINTF(stderr, "%s: starting solve_nonlinear_problem\n", yo);
#endif
	err = solve_nonlinear_problem(ams[JAC], 
				      x, 
				      delta_t, 
				      theta,
				      x_old,
				      x_older, 
				      xdot,
				      xdot_old,
				      resid_vector, 
				      x_update,
				      scale, 
				      &converged, 
				      &nprint, 
				      tev, 
				      tev_post,
				      NULL,
				      rd,
				      gindex,
				      p_gsize,
				      gvec, 
				      gvec_elem, 
				      path1,
				      exo, 
				      dpi, 
				      cx, 
				      0, 
				      &path_step_reform,
				      is_steady_state,
				      x_AC, 
 				      x_AC_dot, 
				      path1, 
				      resid_vector_sens, 
				      x_sens_temp,
				      x_sens_p,
                                      NULL);
	  
#ifdef DEBUG
	fprintf(stderr, "%s: returned from solve_nonlinear_problem\n", yo);
#endif

	if (err == -1)
	  converged = 0;
	inewton = err;
	if (converged)
	  {
	    if (Write_Intermediate_Solutions == 0) {
#ifdef DEBUG
	      DPRINTF(stderr, "%s: write_solution call WIS\n", yo);
#endif
	      write_solution(ExoFileOut, resid_vector, x, x_sens_p,
			     x_old, xdot, xdot_old, tev, tev_post, NULL, rd, 
			     gindex, p_gsize, gvec, gvec_elem, &nprint, 
			     delta_s, theta, path1, NULL, exo, dpi);
#ifdef DEBUG
	      fprintf(stderr, "%s: write_solution end call WIS\n", yo);
#endif
	    }
#ifdef PARALLEL
	    check_parallel_error("Error writing exodusII file");
#endif

	    /*
	     * PRINT OUT VALUES OF EXTRA UNKNOWNS
	     * FROM AUGMENTING CONDITIONS
	     */
	    if (nAC > 0)
	      {
		DPRINTF(stderr, "\n------------------------------\n");
		DPRINTF(stderr, "Augmenting Conditions:    %4d\n", nAC);
		DPRINTF(stderr, "Number of extra unknowns: %4d\n\n", nAC);

		for (iAC = 0; iAC < nAC; iAC++)
                 {
		  if (augc[iAC].Type == AC_USERBC)
                   {
		    DPRINTF(stderr, "\tBC[%4d] DF[%4d] = %10.6e\n",
			    augc[iAC].BCID, augc[iAC].DFID, x_AC[iAC]);
                   }
                else if (augc[iAC].Type == AC_USERMAT ||
                           augc[iAC].Type == AC_FLUX_MAT  )
                   {
  		    DPRINTF(stderr, "\tMT[%4d] MP[%4d] = %10.6e\n",
			    augc[iAC].MTID, augc[iAC].MPID, x_AC[iAC]);
                   }
                  else if(augc[iAC].Type == AC_VOLUME)
                   {
                    evol_local = augc[iAC].evol;
#ifdef PARALLEL
                    if( Num_Proc > 1 ) {
                         MPI_Allreduce( &evol_local, &evol_global, 1, 
                                       MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
                    }
                    evol_local = evol_global;
#endif
                    DPRINTF(stderr, "\tMT[%4d] VC[%4d]=%10.6e Param=%10.6e\n",
                            augc[iAC].MTID, augc[iAC].VOLID, evol_local,
                            x_AC[iAC]);
                   }
		  else if(augc[iAC].Type == AC_POSITION)
                   {
                    evol_local = augc[iAC].evol;
#ifdef PARALLEL
                    if( Num_Proc > 1 ) {
                         MPI_Allreduce( &evol_local, &evol_global, 1, 
                                       MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
                    }
                    evol_local = evol_global;
#endif
                    DPRINTF(stderr, "\tMT[%4d] XY[%4d]=%10.6e Param=%10.6e\n",
                            augc[iAC].MTID, augc[iAC].VOLID, evol_local,
                            x_AC[iAC]);
                   }
                  else if(augc[iAC].Type == AC_FLUX)
                   {
                    DPRINTF(stderr, "\tBC[%4d] DF[%4d]=%10.6e\n",
                            augc[iAC].BCID, augc[iAC].DFID, x_AC[iAC]);
                   }
                 }
	      }

	    /*
	     * INTEGRATE FLUXES, FORCES
	     */
	    for (i = 0; i < nn_post_fluxes; i++)
	      err_dbl = evaluate_flux (exo, dpi, 
                                       pp_fluxes[i]->ss_id,
				       pp_fluxes[i]->flux_type ,
                                       pp_fluxes[i]->flux_type_name ,
				       pp_fluxes[i]->blk_id ,
				       pp_fluxes[i]->species_number,
				       pp_fluxes[i]->flux_filenm,
                                       pp_fluxes[i]->profile_flag,
				       x,xdot,NULL, delta_s,path1,1);

	    /*
	     * COMPUTE FLUX, FORCE SENSITIVITIES
	     */
	    for (i = 0; i < nn_post_fluxes_sens; i++)
	      err_dbl = evaluate_flux_sens (exo, dpi,
                                            pp_fluxes_sens[i]->ss_id,
					    pp_fluxes_sens[i]->flux_type ,
                                            pp_fluxes_sens[i]->flux_type_name ,
					    pp_fluxes_sens[i]->blk_id ,
					    pp_fluxes_sens[i]->species_number,
					    pp_fluxes_sens[i]->sens_type,
					    pp_fluxes_sens[i]->sens_id,
					    pp_fluxes_sens[i]->sens_flt,
					    pp_fluxes_sens[i]->sens_flt2,
					    pp_fluxes_sens[i]->vector_id,
					    pp_fluxes_sens[i]->flux_filenm,
                                            pp_fluxes_sens[i]->profile_flag,
					    x,xdot,x_sens_p,delta_s,path1,1);

 	    /*
      	     * Compute global volumetric quantities
      	     */
     	     for (i = 0; i < nn_volume; i++ ) {
       		evaluate_volume_integral(exo, dpi,
                                pp_volume[i]->volume_type,
                                pp_volume[i]->volume_name,
                                pp_volume[i]->blk_id,
                                pp_volume[i]->species_no,
                                pp_volume[i]->volume_fname,
                                pp_volume[i]->params,
                                NULL,  x, xdot, delta_s,
                                path1, 1);
     		}
 
	  }   /*  end of if converged block  */


	/*
	 * INCREMENT COUNTER
	 */
	ni++;

	/*
	 * DID IT CONVERGE ? 
	 * IF NOT, REDUCE STEP SIZE AND TRY AGAIN
	 */
	if (!converged)
	  {
	    if (ni > 5)
	      {
		puts("                                     ");
		puts(" ************************************");
		puts(" W: Did not converge in Newton steps.");
		puts("    Find better initial guess.       ");
		puts(" ************************************"); 
		/* This needs to have a return value of 0, indicating
		 * success, for the continuation script to not treat this
		 * as a failed command. */
		exit(0);
	      }

	    /*
	     * ADJUST STEP SIZE
	     */
	    DPRINTF(stderr, "\n\tFailed to converge:\n");

	    delta_s *= 0.5;

	    switch (aldALC)
	      {
	      case -1: 
		path1 = path - delta_s;
		break;
	      case +1: 
		path1 = path + delta_s;
		break;
	      default:
		DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
                EH(-1,"\t");
		break;		/* duh */
	      }
#ifdef PARALLEL
              check_parallel_error("Bad aldALC");
#endif

	    /*
	     * RESET
	     */
	    alqALC = 1;		/* If necessary, don't call this the last step... */

	    DPRINTF(stderr, "\n\tDecreasing step-length to %10.6e.\n", delta_s);

	    if (delta_s < Delta_s_min)
	      {
		puts("\n X: C step-length reduced below minimum.");
		puts("\n    Program terminated.\n");
		/* This needs to have a return value of 0, indicating
		 * success, for the continuation script to not treat this
		 * as a failed command. */
		exit(0);
	      } 
#ifdef PARALLEL
              check_parallel_error("\t");
#endif

	    /*
	     * ADJUST NATURAL PARAMETER
	     */
	    dcopy1(numProcUnknowns, x_old, x);
	    update_parameterC(0, path1, x, xdot, x_AC, delta_s, 
			      cx, exo, dpi);

	    /*
	     * GET ZERO OR FIRST ORDER PREDICTION
	     */
	    switch (Continuation)
	      {
	      case ALC_ZEROTH:
		break;
	      case  ALC_FIRST:
		switch (aldALC)
		  {
		  case -1: 
		    v1add(numProcUnknowns, &x[0], -delta_s, &x_sens[0]);
		    break;
		  case +1: 
		    v1add(numProcUnknowns, &x[0], +delta_s, &x_sens[0]);
		    break;
		  default:
		    DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
                    EH(-1,"\t");
		    break;		/* duh */
		  }
		break;
	      default:
		DPRINTF(stderr, "%s: Bad Continuation, %d\n", yo, Continuation);
                EH(-1,"\t");
		break;		/* duh */
	      }
#ifdef PARALLEL
              check_parallel_error("Bad Continuation");
#endif

	    /* MMH: Needed to put this in, o/w it may find that the
	     * solution and residual HAPPEN to satisfy the convergence
	     * criterion for the next newton solve...
	     */
	    find_and_set_Dirichlet(x, xdot, exo, dpi);

            exchange_dof(cx, dpi, x);

	    /*    Should be doing first order prediction on ACs
	     *    but for now, just reset the AC variables
	     */
	    if( nAC > 0)
	      {
		dcopy1(nAC, x_AC_old, x_AC);
		for(iAC=0 ; iAC<nAC ; iAC++)
		  { update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi);}
	      }
	  }   /*  end of !converged */
	  
      } while (converged == 0);

      /*
       * CONVERGED
       */
      nt++;

      if( Continuation == ALC_ZEROTH ) {
        DPRINTF(stderr, "\n\tStep accepted, parameter = %10.6e\n", path1);
       }
      else {
        DPRINTF(stderr, "\tStep accepted, parameter = %10.6e\n", path1);
       }

      /* 
       * check path step error, if too large do not enlarge path step 
       */
      if ((ni == 1) && (n != 0) && (!const_delta_s))
	{
	  delta_s_new = path_step_control(num_total_nodes, 
					  delta_s, delta_s_old, 
					  x, 
					  eps, 
					  &success_ds, 
					  cont->use_var_norm, inewton);
	  if (delta_s_new > Delta_s_max) 
	    delta_s_new = Delta_s_max;
	}
      else
	{
	  success_ds = 1;
	  delta_s_new = delta_s;
	}
	  
      /* 
       * determine whether to print out the data or not 
       */
      i_print = 0;
      if (nt == step_print)
	{
	  i_print = 1;
	  step_print += cont->print_freq;
	}
	  
      if (alqALC == -1) 
	i_print = 1;
	  
      if (i_print)
	{
	  error = write_ascii_soln(x, resid_vector, numProcUnknowns,
				   x_AC, nAC, path1, file);
	  if (error) {
	    DPRINTF(stdout, "%s:  error writing ASCII soln file\n", yo);
	  }
	  if (Write_Intermediate_Solutions == 0 ) {
	    write_solution(ExoFileOut, resid_vector, x, x_sens_p, 
			   x_old, xdot, xdot_old, tev, tev_post, NULL,
			   rd, gindex, p_gsize, gvec, gvec_elem, &nprint,
			   delta_s, theta, path1, NULL, exo, dpi);
	    nprint++;
	  }
	}
      
      /*
       * backup old solutions
       * can use previous solutions for prediction one day
       */
      dcopy1(numProcUnknowns,x_older,x_oldest);
      dcopy1(numProcUnknowns,x_old,x_older);
      dcopy1(numProcUnknowns, x, x_old);
      dcopy1(numProcUnknowns, x_sens_temp, x_sens);

      delta_s_oldest = delta_s_older;
      delta_s_older = delta_s_old;
      delta_s_old = delta_s;
      delta_s = delta_s_new;
  
      if( nAC > 0)
	dcopy1(nAC, x_AC, x_AC_old);

      /*
       * INCREMENT/DECREMENT PARAMETER
       */
      path  = path1;
	  
      switch (aldALC)
	{
	case -1: 
	  path1 = path - delta_s;
	  break;
	case +1: 
	  path1 = path + delta_s;
	  break;
	default:
	  DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
          EH(-1,"\t");
	  break;		/* duh */
	}

#ifdef PARALLEL
      check_parallel_error("Bad aldALC");
#endif
      /*
       * ADJUST NATURAL PARAMETER
       */
      update_parameterC(0, path1, x, xdot, x_AC, delta_s, 
			cx, exo, dpi);

      /*
	display_parameterC(path1, x, xdot, delta_s, 
	cx, exo, dpi);
      */		   

      /*
       * GET FIRST ORDER PREDICTION
       */
      switch (Continuation)
	{
	case ALC_ZEROTH:
	  break;
	case  ALC_FIRST:
	  switch (aldALC)
	    {
	    case -1: 
	      v1add(numProcUnknowns, &x[0], -delta_s, &x_sens[0]);
	      break;
	    case +1: 
	      v1add(numProcUnknowns, &x[0], +delta_s, &x_sens[0]);
	      break;
	    default:
	      DPRINTF(stderr, "%s: Bad aldALC, %d\n", yo, aldALC);
              EH(-1,"\t");
	      break;		/* duh */
	    }
	  break;
	}
#ifdef PARALLEL
      check_parallel_error("Bad aldALC");
#endif

      /*
       * CHECK END CONTINUATION
       */
      /*
      if (alqALC == -1)
	alqALC = 0;
      else
	alqALC = 1;
      */

      if (alqALC == -1)
	{
	  DPRINTF(stderr,"\n\n\t I will continue no more!\n\t No more continuation for you!\n");
	  goto free_and_clear;
	}
    } /* for(n = 0; n < MaxPathSteps; n++) */

  if(n == MaxPathSteps &&
     aldALC * (lambdaEnd - path) > 0)
    {
      DPRINTF(stderr, "\n\tFailed to reach end of hunt in maximum number of successful steps (%d).\n\tSorry.\n",
	      MaxPathSteps);
      /*
      EH(-1,"\t");
      */
    }
#ifdef PARALLEL
      check_parallel_error("Continuation error");
#endif


  /*
   * DONE CONTINUATION
   */
 free_and_clear: 

  /*
   * Transform the node point coordinates according to the
   * displacements and write out all the results using the
   * displaced coordinates. Set the displacement field to
   * zero, too.
   */
  if (Anneal_Mesh)
    {
#ifdef DEBUG
      fprintf(stderr, "%s: anneal_mesh()...\n", yo);
#endif
      err = anneal_mesh(x, tev, tev_post, NULL, rd, path1, exo, dpi);
#ifdef DEBUG
      fprintf(stderr, "%s: anneal_mesh()-done\n", yo);
#endif
      EH(err, "anneal_mesh() bad return.");
    }
#ifdef PARALLEL
      check_parallel_error("Trouble annealing mesh");
#endif

  /* 
   * Free a bunch of variables that aren't needed anymore 
   */
  safer_free((void **) &ROT_Types);
  safer_free((void **) &node_to_fill);

  safer_free( (void **) &resid_vector);
  safer_free( (void **) &resid_vector_sens);
  safer_free( (void **) &scale);
  safer_free( (void **) &x);

  if (nAC > 0)
    {
      safer_free( (void **) &x_AC);
      safer_free( (void **) &x_AC_old);
      safer_free( (void **) &x_AC_dot);
    }

  safer_free( (void **) &x_old); 
  safer_free( (void **) &x_older); 
  safer_free( (void **) &x_oldest); 
  safer_free( (void **) &xdot); 
  safer_free( (void **) &xdot_old); 
  safer_free( (void **) &x_update); 

  safer_free( (void **) &x_sens); 
  safer_free( (void **) &x_sens_temp); 

  if((nn_post_data_sens+nn_post_fluxes_sens) > 0)
          Dmatrix_death(x_sens_p,num_pvector,numProcUnknowns);

  for(i = 0; i < MAX_NUMBER_MATLS; i++) {
    for(n = 0; n < MAX_MODES; n++) {
      safer_free((void **) &(ve_glob[i][n]->gn));
      safer_free((void **) &(ve_glob[i][n]));
    }
    safer_free((void **) &(vn_glob[i]));
  }

  sl_free(matrix_systems_mask, ams);

  for (i = 0; i < NUM_ALSS; i++)
    safer_free((void **) &(ams[i]));

  safer_free( (void **) &gvec);

  i = 0;
  for ( eb_indx = 0; eb_indx < exo->num_elem_blocks; eb_indx++ )
    {
      for ( ev_indx = 0; ev_indx < rd->nev; ev_indx++ ) {
	if (exo->elem_var_tab[i++] == 1) {
	  safer_free((void **) &(gvec_elem [eb_indx][ev_indx]));
	}
      }
      safer_free((void **) &(gvec_elem [eb_indx]));
    }

  safer_free( (void **) &gvec_elem); 
  if (cpcc != NULL) safer_free( (void **) &cpcc);

  safer_free( (void **) &rd); 
  safer_free( (void **) &Local_Offset);
  safer_free( (void **) &Dolphin);

  if (file != NULL) fclose(file);

  return;

} /* END of routine continue_problem  */
Beispiel #8
0
void
hunt_problem(Comm_Ex *cx,	/* array of communications structures */
	     Exo_DB *exo,	/* ptr to the finite element mesh database */
	     Dpi *dpi)	        /* distributed processing information */
{
  int    *ija=NULL;           /* column pointer array                         */
  double *a=NULL;             /* nonzero array                                */
  double *a_old=NULL;         /* nonzero array                                */
  double *x=NULL;             /* solution vector                              */

  int     iAC;                /* COUNTER                                      */
  double *x_AC = NULL;        /* SOLUTION VECTOR OF EXTRA UNKNOWNS            */
  double *x_AC_old=NULL;      /* old SOLUTION VECTOR OF EXTRA UNKNOWNS        */
  double *x_AC_dot = NULL; 

  int     iHC;                /* COUNTER                                      */
  
  int    *ija_attic=NULL;     /* storage for external dofs                    */

  int eb_indx, ev_indx;

  /* 
   * variables for path traversal 
   */
  
  double *x_old=NULL;         /* old solution vector                          */
  double *x_older=NULL;       /* older solution vector                        */
  double *x_oldest=NULL;      /* oldest solution vector saved                 */
  double *xdot=NULL;          /* current path derivative of soln              */
  double *xdot_old=NULL;
  double *x_update=NULL;

  double *x_sens=NULL;        /* solution sensitivity */
  double **x_sens_p=NULL;     /* solution sensitivity for parameters */
  int num_pvector=0;          /*  number of solution sensitivity vectors */
#ifdef COUPLED_FILL
  struct Aztec_Linear_Solver_System *ams[NUM_ALSS]={NULL}; 
#else /* COUPLED_FILL */
  struct Aztec_Linear_Solver_System *ams[NUM_ALSS]={NULL, NULL}; 
#endif /* COUPLED_FILL */
                              /* sl_util_structs.h */

  double *resid_vector=NULL;  /* residual */
  double *resid_vector_sens=NULL;    /* residual sensitivity */
  double *scale=NULL;      /* scale vector for modified newton */

  int 	 *node_to_fill = NULL;	

  int		n;            /* total number of path steps attempted */
  int		ni;           /* total number of nonlinear solves */
  int		nt;           /* total number of successful path steps */
  int		path_step_reform; /* counter for jacobian reformation stride */
  int		converged;    /* success or failure of Newton iteration */
  int		success_ds;   /* success or failure of path step */

  int           i;

  int           nprint=0, num_total_nodes;

  int           numProcUnknowns;
  int           *const_delta_s=NULL;
  int           step_print;
  double        i_print;
  int good_mesh = TRUE;
  double	*path=NULL, *path1=NULL;
  double	*delta_s=NULL, *delta_s_new=NULL, *delta_s_old=NULL;
  double        *delta_s_older=NULL, *delta_s_oldest=NULL;
  double        *hDelta_s0=NULL, *hDelta_s_min=NULL, *hDelta_s_max=NULL;
  double        delta_t;
  double	theta=0.0;
  double        damp;
  double        eps;
  double        *lambda=NULL, *lambdaEnd=NULL;
  double	hunt_par, dhunt_par, hunt_par_old;	/* hunting continuation parameter */
  double        timeValueRead = 0.0;

  /* 
   * ALC management variables
   */

  int           alqALC;
  int           *aldALC=NULL; 

  /*
   * Other local variables 
   */
  
  int	        error, err, is_steady_state, inewton;
  int 		*gindex = NULL, gsize;
  int		*p_gsize=NULL;
  double	*gvec=NULL;
  double        ***gvec_elem;
  double	err_dbl;
  FILE          *file=NULL;
  double 	toler_org[3],damp_org;
  
  struct Results_Description  *rd=NULL;
  
  int		tnv;		/* total number of nodal variables and kinds */
  int		tev;		/* total number of elem variables and kinds */
  int		tnv_post;	/* total number of nodal variables and kinds 
					   for post processing */
  int		tev_post;	/* total number of elem variables and kinds 
					   for post processing */

  int max_unk_elem, one, three; /* variables used as mf_setup arguments*/

  unsigned int
  matrix_systems_mask;

  double evol_local=0.0;
#ifdef PARALLEL
  double evol_global=0.0;
#endif

  static char yo[]="hunt_problem"; 

  /*
   * 		BEGIN EXECUTION
   */

#ifdef DEBUG
  fprintf(stderr, "hunt_problem() begins...\n");
#endif

  toler_org[0] = custom_tol1;
  toler_org[1] = custom_tol2;
  toler_org[2] = custom_tol3;
  damp_org = damp_factor1;

  is_steady_state = TRUE;

  p_gsize = &gsize;
  
  /* 
   * set aside space for gather global vectors to print to exoII file
   * note: this is temporary
   *
   * For 2D prototype problem:  allocate space for T, dx, dy arrays
   */

  if( strlen( Soln_OutFile)  )
    {
#ifdef DEBUG
      printf("Trying to open \"%s\" for writing.\n", Soln_OutFile);
#endif
      file = fopen(Soln_OutFile, "w");
      if (file == NULL)  {
	DPRINTF(stderr, "%s:  opening soln file for writing\n", yo);
        EH(-1, "\t");
      }
    }
#ifdef PARALLEL
  check_parallel_error("Soln output file error");
#endif

  /*
   * Some preliminaries to help setup EXODUS II database output.
   */

#ifdef DEBUG
  fprintf(stderr, "cnt_nodal_vars() begins...\n");
#endif

  tnv = cnt_nodal_vars();
  /*  tnv_post is calculated in load_nodal_tkn*/
  tev = cnt_elem_vars();
  /*  tev_post is calculated in load_elem_tkn*/
  
#ifdef DEBUG
  fprintf(stderr, "Found %d total primitive nodal variables to output.\n", tnv);
  fprintf(stderr, "Found %d total primitive elem variables to output.\n", tev);
#endif
  
  if ( tnv < 0 )
    {
      DPRINTF(stderr, "%s:\tbad tnv.\n", yo);
      EH(-1, "\t");
    }

  if ( tev < 0 )
    {
      DPRINTF(stderr, "%s:\tMaybe bad tev? See goma design committee ;) \n", yo);
/*       exit(-1); */
    }
  
  rd = (struct Results_Description *) 
    smalloc(sizeof(struct Results_Description));

  if (rd == NULL) 
    { EH(-1, "Could not grab Results Description."); }
  (void) memset((void *) rd, 0, sizeof(struct Results_Description));
  
  rd->nev = 0;			/* number element variables in results */
  rd->ngv = 0;			/* number global variables in results */
  rd->nhv = 0;			/* number history variables in results */
  
  if ( is_steady_state == TRUE ) {
    rd->ngv = 5;			/* number global variables in results 
					   see load_global_var_info for names*/
    error = load_global_var_info(rd, 0, "CONV");
    error = load_global_var_info(rd, 1, "NEWT_IT");
    error = load_global_var_info(rd, 2, "MAX_IT");
    error = load_global_var_info(rd, 3, "CONVRATE");
    error = load_global_var_info(rd, 4, "MESH_VOLUME");
  }
  
  /* load nodal types, kinds, names */
  error = load_nodal_tkn( rd,
			  &tnv,
			  &tnv_post); /* load nodal types, kinds, names */
  
  if (error !=0)
    {
      DPRINTF(stderr, "%s:  problem with load_nodal_tkn()\n", yo);
      EH(-1,"\t");
    }

  /* load elem types, names */
  error = load_elem_tkn( rd,
			 exo,
			 tev, 
			 &tev_post); /* load elem types, names */
  
  if ( error !=0 )
    {
      DPRINTF(stderr, "%s:  problem with load_elem_tkn()\n", yo);
      EH(-1,"\t");
    }

  /* 
   * Write out the names of the nodal variables that we will be sending to
   * the EXODUS II output file later.
   */

#ifdef DEBUG
  fprintf(stderr, "wr_result_prelim() starts...\n", tnv);
#endif

  gvec_elem = (double ***) smalloc ( (exo->num_elem_blocks)*sizeof(double **));
  for (i = 0; i < exo->num_elem_blocks; i++) {
    gvec_elem[i] = (double **) smalloc ( (tev + tev_post)*sizeof(double *));
  }

  wr_result_prelim_exo( rd, 
                        exo, 
                        ExoFileOut,
                        gvec_elem );

#ifdef DEBUG
  fprintf(stderr, "P_%d: wr_result_prelim_exo() ends...\n", ProcID, tnv);
#endif

  /* 
   * This gvec workhorse transports output variables as nodal based vectors
   * that are gather from the solution vector. Note: it is NOT a global
   * vector at all and only carries this processor's nodal variables to
   * the exodus database.
   */

  asdv(&gvec, Num_Node);

  /*
   * Allocate space and manipulate for all the nodes that this processor
   * is aware of...
   */

  num_total_nodes = dpi->num_universe_nodes;

  numProcUnknowns = NumUnknowns + NumExtUnknowns;

  /* allocate memory for Volume Constraint Jacobian. ACS 2/99 */

  if ( nAC > 0)
    {
      for(iAC=0;iAC<nAC;iAC++) {
	augc[iAC].d_evol_dx = (double*) malloc(numProcUnknowns*sizeof(double));
      } }
  
  asdv(&resid_vector, numProcUnknowns);
  asdv(&resid_vector_sens, numProcUnknowns);
  asdv(&scale, numProcUnknowns);

  for (i=0;i<NUM_ALSS;i++) 
    {
      ams[i] = (struct Aztec_Linear_Solver_System *) 
	array_alloc(1, 1, sizeof(struct Aztec_Linear_Solver_System )); 
    }

#ifdef MPI
  AZ_set_proc_config( ams[0]->proc_config, MPI_COMM_WORLD );
#ifndef COUPLED_FILL
  if( Explicit_Fill ) AZ_set_proc_config( ams[1]->proc_config, MPI_COMM_WORLD );
#endif /* not COUPLED_FILL */
#else /* MPI */
  AZ_set_proc_config( ams[0]->proc_config, 0 );
#ifndef COUPLED_FILL
  if( Explicit_Fill ) AZ_set_proc_config( ams[1]->proc_config, 0 );
#endif /* not COUPLED_FILL */
#endif /* MPI */

  /*
   * allocate space for and initialize solution arrays
   */

  asdv(&x,        numProcUnknowns);
  asdv(&x_old,    numProcUnknowns);
  asdv(&x_older,  numProcUnknowns);
  asdv(&x_oldest, numProcUnknowns);
  asdv(&xdot,     numProcUnknowns);
  asdv(&xdot_old, numProcUnknowns);
  asdv(&x_update, numProcUnknowns);

  asdv(&x_sens, numProcUnknowns);

  /*
   * Initialize solid inertia flag
   */
  set_solid_inertia();

  /*
   * ALLOCATE ALL THOSE WORK VECTORS FOR HUNTING
   */

  asdv(&lambda,         nHC);
  asdv(&lambdaEnd,      nHC);
  asdv(&path,           nHC);
  asdv(&path1,          nHC);
  asdv(&hDelta_s0,      nHC);
  asdv(&hDelta_s_min,   nHC);
  asdv(&hDelta_s_max,   nHC);
  asdv(&delta_s,        nHC);
  asdv(&delta_s_new,    nHC);
  asdv(&delta_s_old,    nHC);
  asdv(&delta_s_older,  nHC);
  asdv(&delta_s_oldest, nHC);

  aldALC        = Ivector_birth(nHC);
  const_delta_s = Ivector_birth(nHC);

  /*

   HUNTING BY ZERO AND FIRST ORDER CONTINUATION

  */

  alqALC = 1;

  damp = 1.0;

  delta_t = 0.0;
  tran->delta_t = 0.0;      /*for Newmark-Beta terms in Lagrangian Solid*/

  nprint = 0;

  MaxPathSteps      = cont->MaxPathSteps;
  eps               = cont->eps;

  for (iHC=0;iHC<nHC;iHC++) {

    const_delta_s[iHC] = 0;

    lambda[iHC]       = hunt[iHC].BegParameterValue;
    lambdaEnd[iHC]    = hunt[iHC].EndParameterValue;

    if ((lambdaEnd[iHC]-lambda[iHC]) > 0.0)
    {
      aldALC[iHC] = +1;
    }
    else
    {
      aldALC[iHC] = -1;
    } 

    if (hunt[iHC].ramp == 1) {
      hunt[iHC].Delta_s0 = fabs(lambdaEnd[iHC]-lambda[iHC])/((double)(MaxPathSteps-1));
      const_delta_s[iHC] = 1;
    }

    hDelta_s0[iHC]     = hunt[iHC].Delta_s0;
    hDelta_s_min[iHC]  = hunt[iHC].Delta_s_min;
    hDelta_s_max[iHC]  = hunt[iHC].Delta_s_max;

    path[iHC] = path1[iHC] = lambda[iHC];

    if (Debug_Flag && ProcID == 0) {
      fprintf(stderr,"MaxPathSteps: %d \tlambdaEnd: %f\n", MaxPathSteps, lambdaEnd[iHC]);
      fprintf(stderr,"continuation in progress\n");
    }

    if (hDelta_s0[iHC] > hDelta_s_max[iHC]) 
    {
      hDelta_s0[iHC] = hDelta_s_max[iHC];
    }

    delta_s[iHC] = delta_s_old[iHC] = delta_s_older[iHC] = hDelta_s0[iHC];
      
    /*
     * ADJUST NATURAL PARAMETER
     */
	
    update_parameterHC(iHC, path1[iHC], x, xdot, x_AC, delta_s[iHC], cx, exo, dpi); 
  }

  /*  define continuation parameter */

  if(hunt[0].EndParameterValue == hunt[0].BegParameterValue)
 	{	hunt_par = 1.0;	}
  else
 	{
	  hunt_par = (path1[0]-hunt[0].BegParameterValue)
	      /(hunt[0].EndParameterValue - hunt[0].BegParameterValue)  ;
          hunt_par=fabs(hunt_par);
 	}
  hunt_par_old = hunt_par;

  /* Call prefront (or mf_setup) if necessary */
  if (Linear_Solver == FRONT)
  {
    /* Also got to define these because it wants pointers to these numbers */
	  
    max_unk_elem = (MAX_PROB_VAR + MAX_CONC)*MDE;
    one = 1;
    three = 3;

    /* NOTE: We need a overall flag in the vn_glob struct that tells whether FULL_DG
       is on anywhere in domain.  This assumes only one material.  See sl_front_setup for test.
       that test needs to be in the input parser.  */

    if(vn_glob[0]->dg_J_model == FULL_DG) 
    {
      max_unk_elem = (MAX_PROB_VAR + MAX_CONC)*MDE + 4*vn_glob[0]->modes*4*MDE;
    }

    if (Num_Proc > 1) EH(-1, "Whoa.  No front allowed with nproc>1");  
	  
#ifdef HAVE_FRONT  
    err = mf_setup(&exo->num_elems, 
		   &NumUnknowns, 
		   &max_unk_elem, 
		   &three,
		   &one,
		   exo->elem_order_map,
		   fss->el_proc_assign,
		   fss->level,
		   fss->nopdof,
		   fss->ncn,
		   fss->constraint,
		   front_scratch_directory,
		   &fss->ntra);
    EH(err,"problems in frontal setup ");

#else
    EH(-1,"Don't have frontal solver compiled and linked in");
#endif
  }


  /*
         *  if compute parameter sensitivities, allocate space for solution
         *  sensitivity vectors
         */

        for(i=0;i<nn_post_fluxes_sens;i++)      {
          num_pvector=MAX(num_pvector,pp_fluxes_sens[i]->vector_id);}
        for(i=0;i<nn_post_data_sens;i++)        {
          num_pvector=MAX(num_pvector,pp_data_sens[i]->vector_id);}

  if((nn_post_fluxes_sens + nn_post_data_sens) > 0)
  {
    num_pvector++;
    num_pvector = MAX(num_pvector,2);
        x_sens_p = Dmatrix_birth(num_pvector,numProcUnknowns);
  }
  else
  {
    x_sens_p = NULL;
  }


  if (nAC > 0)
  {
    asdv(&x_AC, nAC);
    asdv(&x_AC_old, nAC);
    asdv(&x_AC_dot, nAC);
  }

  /* Allocate sparse matrix */

  if( strcmp( Matrix_Format, "msr" ) == 0)
  {
    log_msg("alloc_MSR_sparse_arrays...");
    alloc_MSR_sparse_arrays(&ija, 
			    &a, 
			    &a_old, 
			    0, 
			    node_to_fill, 
			    exo, 
			    dpi);
    /*
     * An attic to store external dofs column names is needed when
     * running in parallel.
     */

    alloc_extern_ija_buffer(num_universe_dofs, 
			    num_internal_dofs+num_boundary_dofs, 
			    ija, &ija_attic);
    /*
     * Any necessary one time initialization of the linear
     * solver package (Aztec).
     */
      
    ams[JAC]->bindx   = ija;
    ams[JAC]->val     = a;
    ams[JAC]->belfry  = ija_attic;
    ams[JAC]->val_old = a_old;
	  
    /*
     * These point to nowhere since we're using MSR instead of VBR
     * format.
     */
      
    ams[JAC]->indx  = NULL;
    ams[JAC]->bpntr = NULL;
    ams[JAC]->rpntr = NULL;
    ams[JAC]->cpntr = NULL;
    ams[JAC]->npn      = dpi->num_internal_nodes + dpi->num_boundary_nodes;
    ams[JAC]->npn_plus = dpi->num_internal_nodes + dpi->num_boundary_nodes + dpi->num_external_nodes;

    ams[JAC]->npu      = num_internal_dofs+num_boundary_dofs;
    ams[JAC]->npu_plus = num_universe_dofs;

    ams[JAC]->nnz = ija[num_internal_dofs+num_boundary_dofs] - 1;
    ams[JAC]->nnz_plus = ija[num_universe_dofs];

  }
  else if(  strcmp( Matrix_Format, "vbr" ) == 0)
  {
    log_msg("alloc_VBR_sparse_arrays...");
    alloc_VBR_sparse_arrays ( ams[JAC],
			      exo,
			      dpi);
    ija_attic = NULL;
    ams[JAC]->belfry  = ija_attic;

    a = ams[JAC]->val;
    if( !save_old_A ) a_old = ams[JAC]->val_old;
  }
  else if ( strcmp( Matrix_Format, "front") == 0 )
    {
      /* Don't allocate any sparse matrix space when using front */
      ams[JAC]->bindx   = NULL;
      ams[JAC]->val     = NULL;
      ams[JAC]->belfry  = NULL;
      ams[JAC]->val_old = NULL;
      ams[JAC]->indx  = NULL;
      ams[JAC]->bpntr = NULL;
      ams[JAC]->rpntr = NULL;
      ams[JAC]->cpntr = NULL;

    }
  else
  {
    EH(-1,"Attempted to allocate unknown sparse matrix format");
  }

  init_vec(x, cx, exo, dpi, x_AC, nAC, &timeValueRead);

/*  if read ACs, update data floats */
  if (nAC > 0)
  {
    if(augc[0].iread == 1)
      {
	for(iAC=0 ; iAC<nAC ; iAC++)	
	  { update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi); }
      }
  }


  /* 
       * set boundary conditions on the initial conditions 
       */

  find_and_set_Dirichlet(x, xdot, exo, dpi);

  exchange_dof(cx, dpi, x);

  dcopy1(numProcUnknowns,x,x_old);
  dcopy1(numProcUnknowns,x_old,x_older);
  dcopy1(numProcUnknowns,x_older,x_oldest);

  if( nAC > 0)
  {
    dcopy1(nAC,x_AC, x_AC_old);}

  /* 
       * initialize the counters for when to print out data 
       */

  step_print = 1;

  matrix_systems_mask = 1;
      
  log_msg("sl_init()...");
  sl_init(matrix_systems_mask, ams, exo, dpi, cx);

#ifdef PARALLEL
  /*
  * Make sure the solver was properly initialized on all processors.
  */
  check_parallel_error("Solver initialization problems");
#endif

      ams[JAC]->options[AZ_keep_info] = 1;

    DPRINTF(stderr, "\nINITIAL ELEMENT QUALITY CHECK---\n");
    good_mesh = element_quality(exo, x, ams[0]->proc_config);

  /* 
       * set the number of successful path steps to zero 
       */

  nt = 0;   

  /* 
       * LOOP THROUGH PARAMETER UNTIL MAX NUMBER 
       * OF STEPS SURPASSED
       */

  for (n=0;n<MaxPathSteps;n++) {

    alqALC = 1;

    for (iHC=0;iHC<nHC;iHC++) {
	
      switch (aldALC[iHC]) {
      case -1: /* REDUCING PARAMETER DIRECTION */
	  if (path1[iHC] <= lambdaEnd[iHC]) { 
	    alqALC = -1;
	    path1[iHC] = lambdaEnd[iHC];
	    delta_s[iHC] = path[iHC]-path1[iHC];
	  } 
	  break;
      case +1: /* RISING PARAMETER DIRECTION */
	  if (path1[iHC] >= lambdaEnd[iHC]) { 
	    alqALC = -1;
	    path1[iHC] = lambdaEnd[iHC];
	    delta_s[iHC] = path1[iHC]-path[iHC];
	  } 
	  break;
      }

      /*
       * ADJUST NATURAL PARAMETER
       */

      update_parameterHC(iHC, path1[iHC], x, xdot, x_AC, delta_s[iHC], cx, exo, dpi); 
    }   /*  end of iHC loop */

  	if(hunt[0].EndParameterValue == hunt[0].BegParameterValue)
 		{	hunt_par = 1.0;	}
	else
 		{
		  hunt_par = (path1[0]-hunt[0].BegParameterValue)
		      /(hunt[0].EndParameterValue - hunt[0].BegParameterValue)  ;
                  hunt_par=fabs(hunt_par);
 		}

    /*
     * IF STEP CHANGED, REDO FIRST ORDER PREDICTION
     */

    if(alqALC == -1)
    {
      DPRINTF(stderr,"\n\t ******** LAST PATH STEP!\n");
      dcopy1(numProcUnknowns,x_old,x);

      dhunt_par = hunt_par-hunt_par_old;
      switch (Continuation) {
      case HUN_ZEROTH:
          break;
      case  HUN_FIRST:
          v1add(numProcUnknowns, &x[0], dhunt_par, &x_sens[0]);
	  break;
      }
    }

    /* 
     * reset Dirichlet condition Mask, node->DBC to -1 where it
     * is set in order for Dirichlet conditions to be 
     * set appropriately for each path step 
     */
	  
    nullify_dirichlet_bcs();
	  
    find_and_set_Dirichlet (x, xdot, exo, dpi); 

    exchange_dof(cx, dpi, x);

    if(ProcID ==0) {
      DPRINTF(stderr, "\n\t----------------------------------");
      switch (Continuation) {
      case HUN_ZEROTH:
	  DPRINTF(stderr, "\n\tZero Order Hunting:");
	  break;
      case  HUN_FIRST:
	  DPRINTF(stderr, "\n\tFirst Order Hunting:");
	  break; }
      DPRINTF(stderr, "\n\tStep number: %4d of %4d (max)", n+1, MaxPathSteps);
      DPRINTF(stderr, "\n\tAttempting solution at: theta = %g",hunt_par);
      for (iHC=0;iHC<nHC;iHC++) {
	switch (hunt[iHC].Type) {
	case 1: /* BC */
	    DPRINTF(stderr, "\n\tBCID=%3d DFID=%5d", hunt[iHC].BCID, hunt[iHC].DFID);
	    break;
	case 2: /* MT */
	    DPRINTF(stderr, "\n\tMTID=%3d MPID=%5d", hunt[iHC].MTID, hunt[iHC].MPID);
	    break;
 	case 3: /* AC */
 	    DPRINTF(stderr, "\n\tACID=%3d DFID=%5d", hunt[iHC].BCID, hunt[iHC].DFID);
 	    break;
	}
	DPRINTF(stderr, " Parameter= % 10.6e delta_s= %10.6e", path1[iHC], delta_s[iHC]);
      }
    }
	
    ni = 0;
    do {

#ifdef DEBUG
      fprintf(stderr, "%s: starting solve_nonlinear_problem\n", yo);
#endif
      err = solve_nonlinear_problem(ams[JAC], 
				    x, 
				    delta_t, 
				    theta,
				    x_old,
				    x_older, 
				    xdot,
				    xdot_old,
				    resid_vector,
				    x_update,
				    scale, 
				    &converged, 
				    &nprint, 
				    tev, 
				    tev_post,
				    NULL,
				    rd,
				    gindex,
				    p_gsize,
				    gvec, 
				    gvec_elem, 
 				    path1[0],
				    exo, 
				    dpi, 
				    cx, 
				    0, 
				    &path_step_reform,
				    is_steady_state,
				    x_AC,
 				    x_AC_dot,
				    hunt_par,
				    resid_vector_sens,
				    x_sens,
				    x_sens_p,
                                    NULL);

#ifdef DEBUG
      fprintf(stderr, "%s: returned from solve_nonlinear_problem\n", yo);
#endif

      if (err == -1) converged = 0;
      inewton = err;
      if (converged)
      {
	EH(error, "error writing ASCII soln file."); /* srs need to check */

	if (Write_Intermediate_Solutions == 0) {    
#ifdef DEBUG
	  fprintf(stderr, "%s: write_solution call WIS\n", yo);
#endif
	  write_solution(ExoFileOut, resid_vector, x, x_sens_p, x_old, 
			 xdot, xdot_old, tev, tev_post,NULL,  rd, gindex,
			 p_gsize, gvec, gvec_elem, &nprint, delta_s[0], 
 			 theta, path1[0], NULL, exo, dpi);
#ifdef DEBUG
	  fprintf(stderr, "%s: write_solution end call WIS\n", yo);
#endif
	}

	/*
	 * PRINT OUT VALUES OF EXTRA UNKNOWNS 
	 * FROM AUGMENTING CONDITIONS 
	 */

	if (nAC > 0) 
          {
	    
	    DPRINTF(stderr, "\n------------------------------\n");
	    DPRINTF(stderr, "Augmenting Conditions:    %4d\n", nAC);
	    DPRINTF(stderr, "Number of extra unknowns: %4d\n\n", nAC);

            for (iAC = 0; iAC < nAC; iAC++)
             {
              if (augc[iAC].Type == AC_USERBC)
               {
                DPRINTF(stderr, "\tAC[%4d] DF[%4d] = %10.6e\n",
                        augc[iAC].BCID, augc[iAC].DFID, x_AC[iAC]);
               }
              else if (augc[iAC].Type == AC_USERMAT  ||
                       augc[iAC].Type == AC_FLUX_MAT )
               {
                DPRINTF(stderr, "\n MT[%4d] MP[%4d] = %10.6e\n",
                        augc[iAC].MTID, augc[iAC].MPID, x_AC[iAC]);
               }
              else if(augc[iAC].Type == AC_VOLUME)
               {
                evol_local = augc[iAC].evol;
#ifdef PARALLEL
                if( Num_Proc > 1 ) {
                     MPI_Allreduce( &evol_local, &evol_global, 1,
                                    MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
                }
                evol_local = evol_global;
#endif
                DPRINTF(stderr, "\tMT[%4d] VC[%4d]=%10.6e Param=%10.6e\n",
                        augc[iAC].MTID, augc[iAC].VOLID, evol_local,
                        x_AC[iAC]);
               }
	      else if(augc[iAC].Type == AC_POSITION)
               {
                evol_local = augc[iAC].evol;
#ifdef PARALLEL
                if( Num_Proc > 1 ) {
                     MPI_Allreduce( &evol_local, &evol_global, 1,
                                    MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD);
                }
                evol_local = evol_global;
#endif
                DPRINTF(stderr, "\tMT[%4d] XY[%4d]=%10.6e Param=%10.6e\n",
                        augc[iAC].MTID, augc[iAC].VOLID, evol_local,
                        x_AC[iAC]);
               }
               else if(augc[iAC].Type == AC_FLUX)
               {
                DPRINTF(stderr, "\tBC[%4d] DF[%4d]=%10.6e\n",
                        augc[iAC].BCID, augc[iAC].DFID, x_AC[iAC]);
               }
             }
	  }

      /* Check element quality */
      good_mesh = element_quality(exo, x, ams[0]->proc_config);

	/*
	     
	  INTEGRATE FLUXES, FORCES  

	*/

	for (i = 0; i < nn_post_fluxes; i++)
	{
	  err_dbl = evaluate_flux ( exo, dpi, 
                                    pp_fluxes[i]->ss_id, 
				    pp_fluxes[i]->flux_type ,
                                    pp_fluxes[i]->flux_type_name ,
				    pp_fluxes[i]->blk_id , 
				    pp_fluxes[i]->species_number, 
				    pp_fluxes[i]->flux_filenm,
                                    pp_fluxes[i]->profile_flag,
 				    x,xdot,NULL,delta_s[0],path1[0],1); 
	}


	/*
	  COMPUTE FLUX, FORCE SENSITIVITIES
	*/


	for (i = 0; i < nn_post_fluxes_sens; i++)
	{
	  err_dbl = evaluate_flux_sens ( exo, dpi,
                                         pp_fluxes_sens[i]->ss_id,
					 pp_fluxes_sens[i]->flux_type ,
                                         pp_fluxes_sens[i]->flux_type_name ,
					 pp_fluxes_sens[i]->blk_id ,
					 pp_fluxes_sens[i]->species_number,
					 pp_fluxes_sens[i]->sens_type,
					 pp_fluxes_sens[i]->sens_id,
					 pp_fluxes_sens[i]->sens_flt,
					 pp_fluxes_sens[i]->sens_flt2,
					 pp_fluxes_sens[i]->vector_id,
					 pp_fluxes_sens[i]->flux_filenm,
                                         pp_fluxes_sens[i]->profile_flag,
 					 x,xdot,x_sens_p,delta_s[0],path1[0],1);
	}
 	/*
      	 * Compute global volumetric quantities
      	 */
     	 for (i = 0; i < nn_volume; i++ ) {
       		evaluate_volume_integral(exo, dpi,
                                pp_volume[i]->volume_type,
                                pp_volume[i]->volume_name,
                                pp_volume[i]->blk_id,
                                pp_volume[i]->species_no,
                                pp_volume[i]->volume_fname,
                                pp_volume[i]->params,
                                NULL,  x, xdot, delta_s[0],
                                path1[0], 1);
     		}

      } /* end of if converged block */

      /*
       * INCREMENT COUNTER
       */
   
      ni++;

      /*
       * 
       * DID IT CONVERGE ? 
       * IF NOT, REDUCE STEP SIZE AND TRY AGAIN
       * 
       */

      if (!converged) {

	if (ni > 10) {
 	  DPRINTF(stderr,"\n ************************************\n");
 	  DPRINTF(stderr," W: Did not converge in Newton steps.\n");
 	  DPRINTF(stderr,"    Find better initial guess.       \n");
 	  DPRINTF(stderr," ************************************\n"); 
 	  exit(0);
	}

        /*
         * ADJUST STEP SIZE - unless failed on first step
         */

        if ( nt != 0 )
        {
	DPRINTF(stderr, "\n\tFailed to converge:\n");

	for (iHC=0;iHC<nHC;iHC++) {

	  delta_s[iHC] *= 0.5;

	  switch (aldALC[iHC]) {
	  case -1: 
	      path1[iHC] = path[iHC] - delta_s[iHC];
	      break;
	  case +1: 
	      path1[iHC] = path[iHC] + delta_s[iHC];
	      break;
	  }

	  /*
	   * RESET
	   */

	  alqALC = 1;

	  DPRINTF(stderr, "Decreasing step-length to %10.6e.\n", delta_s[iHC]);

	  if (delta_s[iHC] < hDelta_s_min[iHC]) {
 	    DPRINTF(stderr,"\n X: C step-length reduced below minimum.");
 	    DPRINTF(stderr,"\n    Program terminated.\n");
	    /* This needs to have a return value of 0, indicating
	     * success, for the continuation script to not treat this
	     * as a failed command. */
	    exit(0);
	  } 
#ifdef PARALLEL
              check_parallel_error("\t");
#endif

	  /*
	   * ADJUST NATURAL PARAMETER
	   */
	    
	  update_parameterHC(iHC, path1[iHC], x, xdot, x_AC, delta_s[iHC], cx, exo, dpi);
	}  /* end of iHC loop  */

  	if(hunt[0].EndParameterValue == hunt[0].BegParameterValue)
 		{	hunt_par = 1.0;	}
	else
 		{
	  	hunt_par = (path1[0]-hunt[0].BegParameterValue)
	     	 /(hunt[0].EndParameterValue - hunt[0].BegParameterValue)  ;
                hunt_par=fabs(hunt_par);
 		}

	/*
	 * GET ZERO OR FIRST ORDER PREDICTION
	 */

	dhunt_par = hunt_par-hunt_par_old;

	switch (Continuation) {
	case HUN_ZEROTH:
	    vcopy(numProcUnknowns, &x[0], 1.0, &x_old[0]);
	    break;
	case  HUN_FIRST:
	    v2sum(numProcUnknowns, &x[0], 1.0, &x_old[0], dhunt_par, &x_sens[0]);
            break;
	}
	
	/* MMH: Needed to put this in, o/w it may find that the
         * solution and residual HAPPEN to satisfy the convergence
         * criterion for the next newton solve...
         */
        find_and_set_Dirichlet(x, xdot, exo, dpi);
	
        exchange_dof(cx, dpi, x);

	if (nAC > 0)
          {
	    dcopy1(nAC, x_AC_old, x_AC);
	    for(iAC=0 ; iAC<nAC ; iAC++)	
	      { update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi); }
	  }

  		if(hunt[0].EndParameterValue == hunt[0].BegParameterValue)
 			{	hunt_par = 1.0;	}
  		else
 			{
	  		hunt_par = (path1[0]-hunt[0].BegParameterValue)
	      			/(hunt[0].EndParameterValue - hunt[0].BegParameterValue)  ;
                        hunt_par=fabs(hunt_par);
 			}

 	}
 	else if (inewton == -1)
 	{
 	DPRINTF(stderr,"\nHmm... trouble on first step \n  Let's try some more relaxation  \n");
 	      if((damp_factor1 <= 1. && damp_factor1 >= 0.) &&
 	         (damp_factor2 <= 1. && damp_factor2 >= 0.) &&
        		 (damp_factor3 <= 1. && damp_factor3 >= 0.))
 		{
 		custom_tol1 *= 0.01;
 		custom_tol2 *= 0.01;
 		custom_tol3 *= 0.01;
 	DPRINTF(stderr,"  custom tolerances %g %g %g  \n",custom_tol1,custom_tol2,custom_tol3);
 		}
 		else
 		{
 		damp_factor1 *= 0.5;
 	DPRINTF(stderr,"  damping factor %g  \n",damp_factor1);
 		}
 
 	    vcopy(numProcUnknowns, &x[0], 1.0, &x_old[0]);
 	
 	/* MMH: Needed to put this in, o/w it may find that the
          * solution and residual HAPPEN to satisfy the convergence
          * criterion for the next newton solve...
          */
         find_and_set_Dirichlet(x, xdot, exo, dpi);
 	
         exchange_dof(cx, dpi, x);
 
 
 	if (nAC > 0)
          {
 	    dcopy1(nAC, x_AC_old, x_AC);
 	    for(iAC=0 ; iAC<nAC ; iAC++)	
 	      { update_parameterAC(iAC, x, xdot, x_AC, cx, exo, dpi); }
 	  }
 
 	}
 	else 
 	{
 	DPRINTF(stderr,"\nHmm... could not converge on first step\n Let's try some more iterations\n");
 	      if((damp_factor1 <= 1. && damp_factor1 >= 0.) &&
 	         (damp_factor2 <= 1. && damp_factor2 >= 0.) &&
        		 (damp_factor3 <= 1. && damp_factor3 >= 0.))
 		{
 		custom_tol1 *= 100.;
 		custom_tol2 *= 100.;
 		custom_tol3 *= 100.;
 	DPRINTF(stderr,"  custom tolerances %g %g %g  \n",custom_tol1,custom_tol2,custom_tol3);
 		}
 		else
 		{
 		damp_factor1 *= 2.0;
		damp_factor1 = MIN(damp_factor1,1.0);
 	DPRINTF(stderr,"  damping factor %g  \n",damp_factor1);
 		}
 	}
 

      }  /* end of !converged */

    } while (converged == 0);

    /*
     * CONVERGED
     */
    nt++;
    custom_tol1 = toler_org[0];
    custom_tol2 = toler_org[1];
    custom_tol3 = toler_org[2];
    damp_factor1 = damp_org;
    DPRINTF(stderr,
	    "\n\tStep accepted, theta (proportion complete) = %10.6e\n",
	    hunt_par);
    for (iHC=0;iHC<nHC;iHC++) {
      switch (hunt[iHC].Type) {
      case 1:		/* BC */
	  DPRINTF(stderr, "\tStep accepted, BCID=%3d DFID=%5d",
		  hunt[iHC].BCID, hunt[iHC].DFID);
	  break;
      case 2:		/* MT */
	  DPRINTF(stderr, "\tStep accepted, MTID=%3d MPID=%5d",
		  hunt[iHC].MTID, hunt[iHC].MPID);
	  break;
      case 3:		/* AC */
	  DPRINTF(stderr, "\tStep accepted, ACID=%3d DFID=%5d",
 		  hunt[iHC].BCID, hunt[iHC].DFID);
 	  break;
      }
      DPRINTF(stderr, " Parameter= % 10.6e\n", path1[iHC]);
    }

    /* 
     * check path step error, if too large do not enlarge path step 
     */

    for (iHC=0;iHC<nHC;iHC++) {

      if ((ni == 1) && (n != 0) && (!const_delta_s[iHC])) 
      {
	delta_s_new[iHC] = path_step_control(num_total_nodes, 
					     delta_s[iHC], delta_s_old[iHC], 
					     x, 
					     eps, 
					     &success_ds, 
					     cont->use_var_norm, inewton);
	if (delta_s_new[iHC] > hDelta_s_max[iHC]) {delta_s_new[iHC] = hDelta_s_max[iHC];}
      }
      else 
      {
	success_ds = 1;
	delta_s_new[iHC] = delta_s[iHC];
      }
    }
	  
    /* 
     * determine whether to print out the data or not 
     */

    i_print = 0;
    if (nt == step_print) {
      i_print = 1;
      step_print += cont->print_freq; }

    if (alqALC == -1) 
    { i_print = 1; }
	  
    if (i_print) {
      error = write_ascii_soln(x, resid_vector, numProcUnknowns,
 			       x_AC, nAC, path1[0], file);
      if (error) {
	DPRINTF(stderr, "%s:  error writing ASCII soln file\n", yo);
      }	  
      if ( Write_Intermediate_Solutions == 0 ) {
	write_solution(ExoFileOut, resid_vector, x, x_sens_p, 
		       x_old, xdot, xdot_old, tev, tev_post, NULL, 
		       rd, gindex, p_gsize, gvec, gvec_elem, &nprint,
 		       delta_s[0], theta, path1[0], NULL, exo, dpi);
	nprint++;
      }
    }
	  
    /*
     * backup old solutions
     * can use previous solutions for prediction one day
     */
	  
    dcopy1(numProcUnknowns,x_older,x_oldest);
    dcopy1(numProcUnknowns,x_old,x_older);
    dcopy1(numProcUnknowns,x,x_old);

    dcopy1(nHC,delta_s_older,delta_s_oldest);
    dcopy1(nHC,delta_s_old  ,delta_s_older );
    dcopy1(nHC,delta_s      ,delta_s_old   );
    dcopy1(nHC,delta_s_new  ,delta_s       );
/*
    delta_s_oldest = delta_s_older;
    delta_s_older = delta_s_old;
    delta_s_old = delta_s;
    delta_s = delta_s_new;
*/
    hunt_par_old=hunt_par;
    if ( nAC > 0) {
      dcopy1(nAC, x_AC, x_AC_old);
    }

    /*
     * INCREMENT/DECREMENT PARAMETER
     */


    for (iHC=0;iHC<nHC;iHC++) {

      path[iHC]  = path1[iHC];
	  
      switch (aldALC[iHC]) {
      case -1: 
	  path1[iHC] = path[iHC] - delta_s[iHC];
	  break;
      case +1: 
	  path1[iHC] = path[iHC] + delta_s[iHC];
	  break;
      }
	  
      /*
       * ADJUST NATURAL PARAMETER
       */
	
      update_parameterHC(iHC, path1[iHC], x, xdot, x_AC, delta_s[iHC], cx, exo, dpi); 
    }  /*  end of iHC loop */

    /*
     * GET FIRST ORDER PREDICTION
     */

	  if(hunt[0].EndParameterValue == hunt[0].BegParameterValue)
 		{	hunt_par = 1.0;	}
  		else
 		{
	  	hunt_par = (path1[0]-hunt[0].BegParameterValue)
	      		/(hunt[0].EndParameterValue - hunt[0].BegParameterValue)  ;
                hunt_par=fabs(hunt_par);
 		}
    dhunt_par = hunt_par-hunt_par_old;
    switch (Continuation) {
    case HUN_ZEROTH:
	break;
    case  HUN_FIRST:
	v1add(numProcUnknowns, &x[0], dhunt_par, &x_sens[0]);
        break; }

        if (!good_mesh) goto free_and_clear;

    /*
     * 
     * CHECK END CONTINUATION
     *  
     */

    if (alqALC == -1)
    { alqALC = 0; }
    else
    { alqALC = 1; }

    if (alqALC == 0) {
      DPRINTF(stderr,"\n\n\t I will continue no more!\n\t No more continuation for you!\n");
      goto free_and_clear;
    }
	
  } /* n */

      if(n == MaxPathSteps &&
	 aldALC[0] * (lambdaEnd[0] - path[0]) > 0)
	{
	  DPRINTF(stderr,"\n\tFailed to reach end of hunt in maximum number of successful steps (%d).\n\tSorry.\n",
		  MaxPathSteps);
 	  exit(0);
	}
#ifdef PARALLEL
      check_parallel_error("Hunting error");
#endif

  /*
   * DONE CONTINUATION
   */

 free_and_clear: 

  /*
   * Transform the node point coordinates according to the
   * displacements and write out all the results using the
   * displaced coordinates. Set the displacement field to
   * zero, too.
   */

  if (Anneal_Mesh) {
#ifdef DEBUG
    fprintf(stderr, "%s: anneal_mesh()...\n", yo);
#endif
    err = anneal_mesh(x, tev, tev_post, NULL, rd, path1[0], exo, dpi);
#ifdef DEBUG
    DPRINTF(stderr, "%s: anneal_mesh()-done\n", yo);
#endif
    EH(err, "anneal_mesh() bad return.");
  }

  /* 
   * Free a bunch of variables that aren't needed anymore 
   */
  safer_free((void **) &ROT_Types);
  safer_free((void **) &node_to_fill);

  safer_free( (void **) &resid_vector);
  safer_free( (void **) &resid_vector_sens);
  safer_free( (void **) &scale);
  safer_free( (void **) &x);

  if (nAC > 0) {
    safer_free( (void **) &x_AC);
    safer_free( (void **) &x_AC_old);
    safer_free( (void **) &x_AC_dot);
  }

  safer_free( (void **) &x_old); 
  safer_free( (void **) &x_older); 
  safer_free( (void **) &x_oldest); 
  safer_free( (void **) &xdot); 
  safer_free( (void **) &xdot_old); 
  safer_free( (void **) &x_update); 

  safer_free( (void **) &x_sens); 

  if((nn_post_data_sens+nn_post_fluxes_sens) > 0)
          Dmatrix_death(x_sens_p,num_pvector,numProcUnknowns);

  for(i = 0; i < MAX_NUMBER_MATLS; i++) {
    for(n = 0; n < MAX_MODES; n++) {
      safer_free((void **) &(ve_glob[i][n]->gn));
      safer_free((void **) &(ve_glob[i][n]));
    }
    safer_free((void **) &(vn_glob[i]));
  }

  sl_free(matrix_systems_mask, ams);

  for (i=0;i<NUM_ALSS;i++) {
    safer_free( (void**) &(ams[i]));
  }					

  safer_free( (void **) &gvec);

  safer_free( (void **) &lambda);
  safer_free( (void **) &lambdaEnd);
  safer_free( (void **) &path);
  safer_free( (void **) &path1);
  safer_free( (void **) &hDelta_s0);
  safer_free( (void **) &hDelta_s_min);
  safer_free( (void **) &hDelta_s_max);
  safer_free( (void **) &delta_s);
  safer_free( (void **) &delta_s_new);
  safer_free( (void **) &delta_s_old);
  safer_free( (void **) &delta_s_older);
  safer_free( (void **) &delta_s_oldest);

  Ivector_death(&aldALC[0], nHC);
  Ivector_death(&const_delta_s[0], nHC);

  i = 0;
  for ( eb_indx = 0; eb_indx < exo->num_elem_blocks; eb_indx++ ) {
    for ( ev_indx = 0; ev_indx < rd->nev; ev_indx++ ) {
      if ( exo->elem_var_tab[i++] == 1 ) {
        safer_free ((void **) &(gvec_elem [eb_indx][ev_indx]) );
      }
    }
    safer_free ((void **) &(gvec_elem [eb_indx]));
  }

  safer_free( (void **) &gvec_elem); 

  safer_free( (void **) &rd);
  safer_free( (void **) &Local_Offset);
  safer_free( (void **) &Dolphin);

  if( strlen( Soln_OutFile)  )
    {
       fclose(file);
    }

  return;

} /* END of routine hunt_problem  */
Beispiel #9
0
int
get_new_coord(double *new_coord[DIM],
	      double *x,
	      const Exo_DB *exo )
{
  int p,i,j;
  int dim = exo->num_dim;
  int num_nodes = exo->num_nodes;
  int displacement_somewhere = FALSE;
  int ln;
  int *moved;
  int e_start = exo->eb_ptr[0];
  int e_end   = exo->eb_ptr[exo->num_elem_blocks];
  int ielem;
  int gnn;
  int var;
  double phi[MDE];

  for(p = 0; p < dim; p++)
    {
      new_coord[p] = (double *) calloc(num_nodes, sizeof(double));
      dcopy1( num_nodes, Coor[p], new_coord[p] );
    }

  for(p = 0; p < upd->Num_Mat; p++)
    displacement_somewhere |= ( pd_glob[p]->e[R_MESH1] );

  if ( displacement_somewhere == FALSE ) return (FALSE );

  moved = (int *) calloc( num_nodes, sizeof(int) );


  /*
   * Loop through nodes, find displacement, and add it into 
   * the coordinate
   */


  for(ielem = e_start; ielem < e_end; ielem++)
    {
      double displacement[DIM];

      load_elem_dofptr(ielem, exo, x, x, x, x, x, 1);

      for(ln = 0; ln < ei->num_local_nodes; ln++)
	{
	  double xi[3] = {0.0, 0.0, 0.0};
	  
	  find_nodal_stu(ln, ei->ielem_type, xi, xi+1, xi+2);

	  gnn = exo->elem_node_list[ exo->elem_node_pntr[ielem] + ln ] ;

	  memset(displacement, 0, sizeof(double)*DIM);
	  
	  if( moved[gnn] != 1 )
	    {
	      for(p = 0; p < DIM; p++)
		{
		  var = MESH_DISPLACEMENT1 + p;
		  
		  for(i = 0; i < ei->dof[var]; i++)
		    {
		      phi[i] = newshape(xi, 
					ei->ielem_type, 
					PSI, 
					ei->dof_list[var][i], 
					ei->ielem_shape,
					pd->i[var],
					i);
		    }

		  if( pd->v[var] )
		    {
		      for(j = 0; j < ei->dof[var]; j++)
			{
			  displacement[p] += *esp->d[p][j] * phi[j];
			}
		      moved[gnn] = 1;
		    }
		  else
		    displacement[p] = 0.0;
		}
	    }

	  for(p = 0; p < dim; p++)
	    new_coord[p][gnn] += displacement[p];
	}
    }

  safer_free((void **) &moved);
  
  return( TRUE );
}