コード例 #1
0
ファイル: arraydense.c プロジェクト: inria-parkas/sundialsml
int main(int argc, char** argv)
{
    realtype **a = newDenseMat(NROWS, NCOLS);
    realtype **b = newDenseMat(NROWS, NCOLS);
    sundials_ml_index p[NROWS] = { 0.0 };
    realtype s[NROWS] = { 5.0, 18.0, 6.0 };
    int i, j;

    for (i=0; i < NROWS; ++i) {
	for (j=0; j < NCOLS; ++j) {
	    a[j][i] = a_init[i][j];
	}
    }

    printf("initially: a=\n");
    print_mat(a, NROWS, NCOLS);
    printf("\n");

#if SUNDIALS_LIB_VERSION >= 260
    {
	realtype x[NCOLS] = { 1.0,  2.0, 3.0 };
	realtype y[NROWS] = { 0.0 };
	printf("matvec: y=\n");
	denseMatvec(a, x, y, NROWS, NCOLS);
	print_vec(y, NROWS);
	printf("\n");
    }
#endif

    denseCopy(a, b, NROWS, NCOLS);
    denseScale(2.0, b, NROWS, NCOLS);
    printf("scale copy x2: b=\n");
    print_mat(b, NROWS, NCOLS);
    printf("\n");

    denseAddIdentity(b, NROWS);
    printf("add identity: b=\n");
    print_mat(b, NROWS, NCOLS);
    printf("\n");

    denseGETRF(a, NROWS, NCOLS, p);
    printf("getrf: a=\n");
    print_mat(a, NROWS, NCOLS);
    printf("\n       p=\n");
    print_pivots(p, NROWS);
    printf("\n");

    denseGETRS(a, NROWS, p, s);
    printf("getrs: s=\n");
    print_vec(s, NROWS);

    destroyMat(a);
    destroyMat(b);

    return 0;
}
コード例 #2
0
ファイル: dls_ml.c プロジェクト: gasche/sundialsml
CAMLprim value c_arraydensematrix_getrf(value va, value vp)
{
    CAMLparam2(va, vp);

    struct caml_ba_array *ba = ARRAY2_DATA(va);
    intnat m = ba->dim[1];
    intnat n = ba->dim[0];

#if SUNDIALS_ML_SAFE == 1
    if (ARRAY1_LEN(vp) < n)
	caml_invalid_argument("ArrayDenseMatrix.getrf: p is too small.");
#endif

    int r = denseGETRF(ARRAY2_ACOLS(va), m, n, LONG_ARRAY(vp));

    if (r != 0) {
	caml_raise_with_arg(DLS_EXN(ZeroDiagonalElement),
			    Val_long(r));
    }
    CAMLreturn (Val_unit);
}
コード例 #3
0
/*
 This routine generates the block-diagonal part of the Jacobian
 corresponding to the interaction rates, multiplies by -gamma, adds
 the identity matrix, and calls denseGETRF to do the LU decomposition of
 each diagonal block. The computation of the diagonal blocks uses
 the preset block and grouping information. One block per group is
 computed. The Jacobian elements are generated by difference
 quotients using calls to the routine fblock.

 This routine can be regarded as a prototype for the general case
 of a block-diagonal preconditioner. The blocks are of size mp, and
 there are ngrp=ngx*ngy blocks computed in the block-grouping scheme.
*/
static int Precond(realtype t, N_Vector c, N_Vector fc,
                   booleantype jok, booleantype *jcurPtr, realtype gamma,
                   void *user_data, N_Vector vtemp1, N_Vector vtemp2,
                   N_Vector vtemp3)
{
    realtype ***P;
    long int **pivot, ier;
    int i, if0, if00, ig, igx, igy, j, jj, jx, jy;
    int *jxr, *jyr, ngrp, ngx, ngy, mxmp, flag;
    long int mp;
    realtype uround, fac, r, r0, save, srur;
    realtype *f1, *fsave, *cdata, *rewtdata;
    WebData wdata;
    void *cvode_mem;
    N_Vector rewt;

    wdata = (WebData) user_data;
    cvode_mem = wdata->cvode_mem;
    cdata = NV_DATA_S(c);
    rewt = wdata->rewt;
    flag = CVodeGetErrWeights(cvode_mem, rewt);
    if(check_flag(&flag, "CVodeGetErrWeights", 1)) return(1);
    rewtdata = NV_DATA_S(rewt);

    uround = UNIT_ROUNDOFF;

    P = wdata->P;
    pivot = wdata->pivot;
    jxr = wdata->jxr;
    jyr = wdata->jyr;
    mp = wdata->mp;
    srur = wdata->srur;
    ngrp = wdata->ngrp;
    ngx = wdata->ngx;
    ngy = wdata->ngy;
    mxmp = wdata->mxmp;
    fsave = wdata->fsave;

    /* Make mp calls to fblock to approximate each diagonal block of Jacobian.
       Here, fsave contains the base value of the rate vector and
       r0 is a minimum increment factor for the difference quotient. */

    f1 = NV_DATA_S(vtemp1);

    fac = N_VWrmsNorm (fc, rewt);
    r0 = RCONST(1000.0)*ABS(gamma)*uround*NEQ*fac;
    if (r0 == ZERO) r0 = ONE;

    for (igy = 0; igy < ngy; igy++) {
        jy = jyr[igy];
        if00 = jy*mxmp;
        for (igx = 0; igx < ngx; igx++) {
            jx = jxr[igx];
            if0 = if00 + jx*mp;
            ig = igx + igy*ngx;
            /* Generate ig-th diagonal block */
            for (j = 0; j < mp; j++) {
                /* Generate the jth column as a difference quotient */
                jj = if0 + j;
                save = cdata[jj];
                r = MAX(srur*ABS(save),r0/rewtdata[jj]);
                cdata[jj] += r;
                fac = -gamma/r;
                fblock (t, cdata, jx, jy, f1, wdata);
                for (i = 0; i < mp; i++) {
                    P[ig][j][i] = (f1[i] - fsave[if0+i])*fac;
                }
                cdata[jj] = save;
            }
        }
    }

    /* Add identity matrix and do LU decompositions on blocks. */

    for (ig = 0; ig < ngrp; ig++) {
        denseAddIdentity(P[ig], mp);
        ier = denseGETRF(P[ig], mp, mp, pivot[ig]);
        if (ier != 0) return(1);
    }

    *jcurPtr = TRUE;
    return(0);
}
コード例 #4
0
ファイル: kinFoodWeb_kry.c プロジェクト: A1kmm/modml-solver
static int PrecSetupBD(N_Vector cc, N_Vector cscale,
                       N_Vector fval, N_Vector fscale,
                       void *user_data,
                       N_Vector vtemp1, N_Vector vtemp2)
{
  realtype r, r0, uround, sqruround, xx, yy, delx, dely, csave, fac;
  realtype *cxy, *scxy, **Pxy, *ratesxy, *Pxycol, perturb_rates[NUM_SPECIES];
  long int i, j, jx, jy, ret;
  UserData data;
  
  data = (UserData) user_data;
  delx = data->dx;
  dely = data->dy;
  
  uround = data->uround;
  sqruround = data->sqruround;
  fac = N_VWL2Norm(fval, fscale);
  r0 = THOUSAND * uround * fac * NEQ;
  if(r0 == ZERO) r0 = ONE;
  
  /* Loop over spatial points; get size NUM_SPECIES Jacobian block at each */
  for (jy = 0; jy < MY; jy++) {
    yy = jy*dely;
    
    for (jx = 0; jx < MX; jx++) {
      xx = jx*delx;
      Pxy = (data->P)[jx][jy];
      cxy = IJ_Vptr(cc,jx,jy);
      scxy= IJ_Vptr(cscale,jx,jy);
      ratesxy = IJ_Vptr((data->rates),jx,jy);
      
      /* Compute difference quotients of interaction rate fn. */
      for (j = 0; j < NUM_SPECIES; j++) {
        
        csave = cxy[j];  /* Save the j,jx,jy element of cc */
        r = MAX(sqruround*ABS(csave), r0/scxy[j]);
        cxy[j] += r; /* Perturb the j,jx,jy element of cc */
        fac = ONE/r;
        
        WebRate(xx, yy, cxy, perturb_rates, data);
        
        /* Restore j,jx,jy element of cc */
        cxy[j] = csave;
        
        /* Load the j-th column of difference quotients */
        Pxycol = Pxy[j];
        for (i = 0; i < NUM_SPECIES; i++)
          Pxycol[i] = (perturb_rates[i] - ratesxy[i]) * fac;
        
        
      } /* end of j loop */
      
      /* Do LU decomposition of size NUM_SPECIES preconditioner block */
      ret = denseGETRF(Pxy, NUM_SPECIES, NUM_SPECIES, (data->pivot)[jx][jy]);
      if (ret != 0) return(1);
      
    } /* end of jx loop */
    
  } /* end of jy loop */
  
  return(0);  
}
コード例 #5
0
long int DenseGETRF(DlsMat A, long int *p)
{
  return(denseGETRF(A->cols, A->M, A->N, p));
}
コード例 #6
0
ファイル: cvsDiurnal_kry.c プロジェクト: luca-heltai/sundials
static int Precond(realtype tn, N_Vector u, N_Vector fu,
                   booleantype jok, booleantype *jcurPtr, realtype gamma,
                   void *user_data, N_Vector vtemp1, N_Vector vtemp2,
                   N_Vector vtemp3)
{
  realtype c1, c2, cydn, cyup, diag, ydn, yup, q4coef, dely, verdco, hordco;
  realtype **(*P)[MY], **(*Jbd)[MY];
  long int *(*pivot)[MY], ier;
  int jx, jy;
  realtype *udata, **a, **j;
  UserData data;
  
  /* Make local copies of pointers in user_data, and of pointer to u's data */
  
  data = (UserData) user_data;
  P = data->P;
  Jbd = data->Jbd;
  pivot = data->pivot;
  udata = N_VGetArrayPointer_Serial(u);
  
  if (jok) {
    
    /* jok = TRUE: Copy Jbd to P */
    
    for (jy=0; jy < MY; jy++)
      for (jx=0; jx < MX; jx++)
        denseCopy(Jbd[jx][jy], P[jx][jy], NUM_SPECIES, NUM_SPECIES);
    
    *jcurPtr = FALSE;
    
  }
  
  else {
    /* jok = FALSE: Generate Jbd from scratch and copy to P */
    
    /* Make local copies of problem variables, for efficiency. */
    
    q4coef = data->q4;
    dely = data->dy;
    verdco = data->vdco;
    hordco  = data->hdco;
    
    /* Compute 2x2 diagonal Jacobian blocks (using q4 values 
       computed on the last f call).  Load into P. */
    
    for (jy=0; jy < MY; jy++) {
      ydn = YMIN + (jy - RCONST(0.5))*dely;
      yup = ydn + dely;
      cydn = verdco*SUNRexp(RCONST(0.2)*ydn);
      cyup = verdco*SUNRexp(RCONST(0.2)*yup);
      diag = -(cydn + cyup + TWO*hordco);
      for (jx=0; jx < MX; jx++) {
        c1 = IJKth(udata,1,jx,jy);
        c2 = IJKth(udata,2,jx,jy);
        j = Jbd[jx][jy];
        a = P[jx][jy];
        IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
        IJth(j,1,2) = -Q2*c1 + q4coef;
        IJth(j,2,1) = Q1*C3 - Q2*c2;
        IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
        denseCopy(j, a, NUM_SPECIES, NUM_SPECIES);
      }
    }
    
    *jcurPtr = TRUE;
    
  }
  
  /* Scale by -gamma */
  
  for (jy=0; jy < MY; jy++)
    for (jx=0; jx < MX; jx++)
      denseScale(-gamma, P[jx][jy], NUM_SPECIES, NUM_SPECIES);
  
  /* Add identity matrix and do LU decompositions on blocks in place. */
  
  for (jx=0; jx < MX; jx++) {
    for (jy=0; jy < MY; jy++) {
      denseAddIdentity(P[jx][jy], NUM_SPECIES);
      ier = denseGETRF(P[jx][jy], NUM_SPECIES, NUM_SPECIES, pivot[jx][jy]);
      if (ier != 0) return(1);
    }
  }
  
  return(0);
}
コード例 #7
0
static int Precondbd(realtype tt, N_Vector cc,
                     N_Vector cp, N_Vector rr, 
                     realtype cj, void *user_data,
                     N_Vector tempv1, N_Vector tempv2, N_Vector tempv3)
{
  int flag, thispe;
  realtype uround;
  realtype xx, yy, *cxy, *ewtxy, cctemp, **Pxy, *ratesxy, *Pxycol, *cpxy;
  realtype inc, sqru, fac, perturb_rates[NUM_SPECIES];
  int is, js, ix, jy, ret;
  UserData webdata;
  void *mem;
  N_Vector ewt;
  realtype hh;

  webdata = (UserData)user_data;
  uround = UNIT_ROUNDOFF;
  sqru = SUNRsqrt(uround);
  thispe = webdata->thispe;

  mem = webdata->ida_mem;
  ewt = webdata->ewt;
  flag = IDAGetErrWeights(mem, ewt);
  check_flag(&flag, "IDAGetErrWeights", 1, thispe);
  flag = IDAGetCurrentStep(mem, &hh);
  check_flag(&flag, "IDAGetCurrentStep", 1, thispe);

  for (jy = 0; jy < mysub; jy++) {
    yy = (jy + jysub*mysub)*dy;

    for (ix = 0; ix < mxsub; ix++) {
      xx = (ix+ ixsub*mxsub)*dx;
      Pxy = (webdata->PP)[ix][jy];
      cxy = IJ_Vptr(cc,ix,jy); 
      cpxy = IJ_Vptr(cp,ix,jy); 
      ewtxy= IJ_Vptr(ewt,ix,jy);
      ratesxy = IJ_Vptr(rates,ix,jy);

      for (js = 0; js < ns; js++) {
        inc = sqru*(SUNMAX(SUNRabs(cxy[js]), SUNMAX(hh*SUNRabs(cpxy[js]), ONE/ewtxy[js])));
        cctemp = cxy[js];  /* Save the (js,ix,jy) element of cc. */
        cxy[js] += inc;    /* Perturb the (js,ix,jy) element of cc. */
        fac = -ONE/inc;
        
        WebRates(xx, yy, cxy, perturb_rates, webdata);
        
        Pxycol = Pxy[js];

        for (is = 0; is < ns; is++)
          Pxycol[is] = (perturb_rates[is] - ratesxy[is])*fac;
        
        if (js < np) Pxycol[js] += cj; /* Add partial with respect to cp. */
        
        cxy[js] = cctemp; /* Restore (js,ix,jy) element of cc. */
        
      } /* End of js loop. */
      
      /* Do LU decomposition of matrix block for grid point (ix,jy). */
      ret = denseGETRF(Pxy, ns, ns, (webdata->pivot)[ix][jy]);
      
      if (ret != 0) return(1);
      
    } /* End of ix loop. */
  } /* End of jy loop. */
  
  return(0);

}
コード例 #8
0
static int Precond(realtype tn, N_Vector u, N_Vector fu,
                   booleantype jok, booleantype *jcurPtr, 
                   realtype gamma, void *user_data, 
                   N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
  realtype c1, c2, cydn, cyup, diag, ydn, yup, q4coef, dely, verdco, hordco;
  realtype **(*P)[MYSUB], **(*Jbd)[MYSUB];
  int nvmxsub, ier, offset;
  long int *(*pivot)[MYSUB];
  int lx, ly, jy, isuby;
  realtype *udata, **a, **j;
  HYPRE_ParVector uhyp;
  UserData data;
  
  /* Make local copies of pointers in user_data, pointer to u's data,
     and PE index pair */
  data = (UserData) user_data;
  P = data->P;
  Jbd = data->Jbd;
  pivot = data->pivot;
  isuby = data->isuby;
  nvmxsub = data->nvmxsub;

  uhyp  = N_VGetVector_ParHyp(u);
  udata = hypre_VectorData(hypre_ParVectorLocalVector(uhyp));

  if (jok) {

    /* jok = TRUE: Copy Jbd to P */
    for (ly = 0; ly < MYSUB; ly++)
      for (lx = 0; lx < MXSUB; lx++)
        denseCopy(Jbd[lx][ly], P[lx][ly], NVARS, NVARS);

  *jcurPtr = FALSE;

  }

  else {

    /* jok = FALSE: Generate Jbd from scratch and copy to P */

    /* Make local copies of problem variables, for efficiency */
    q4coef = data->q4;
    dely = data->dy;
    verdco = data->vdco;
    hordco  = data->hdco;
    
    /* Compute 2x2 diagonal Jacobian blocks (using q4 values 
     c*omputed on the last f call).  Load into P. */
    for (ly = 0; ly < MYSUB; ly++) {
      jy = ly + isuby*MYSUB;
      ydn = YMIN + (jy - RCONST(0.5))*dely;
      yup = ydn + dely;
      cydn = verdco*SUNRexp(RCONST(0.2)*ydn);
      cyup = verdco*SUNRexp(RCONST(0.2)*yup);
      diag = -(cydn + cyup + RCONST(2.0)*hordco);
      for (lx = 0; lx < MXSUB; lx++) {
        offset = lx*NVARS + ly*nvmxsub;
        c1 = udata[offset];
        c2 = udata[offset+1];
        j = Jbd[lx][ly];
        a = P[lx][ly];
        IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
        IJth(j,1,2) = -Q2*c1 + q4coef;
        IJth(j,2,1) = Q1*C3 - Q2*c2;
        IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
        denseCopy(j, a, NVARS, NVARS);
      }
    }

    *jcurPtr = TRUE;

  }

  /* Scale by -gamma */
  for (ly = 0; ly < MYSUB; ly++)
    for (lx = 0; lx < MXSUB; lx++)
      denseScale(-gamma, P[lx][ly], NVARS, NVARS);

  /* Add identity matrix and do LU decompositions on blocks in place */
  for (lx = 0; lx < MXSUB; lx++) {
    for (ly = 0; ly < MYSUB; ly++) {
      denseAddIdentity(P[lx][ly], NVARS);
      ier = denseGETRF(P[lx][ly], NVARS, NVARS, pivot[lx][ly]);
      if (ier != 0) return(1);
    }
  }

  return(0);
}
コード例 #9
0
static int PrecondB(realtype t, N_Vector c, 
                    N_Vector cB, N_Vector fcB, booleantype jok, 
                    booleantype *jcurPtr, realtype gamma,
                    void *user_data)
{
  int N, retval;
  realtype ***P;
  sunindextype **pivot;
  int i, if0, if00, ig, igx, igy, j, jj, jx, jy;
  int *jxr, *jyr, ngrp, ngx, ngy, mxmp;
  sunindextype mp, denseretval;
  realtype uround, fac, r, r0, save, srur;
  realtype *f1, *fsave, *cdata, *rewtdata;
  void *cvode_mem;
  WebData wdata;
  N_Vector rewt;

  wdata = (WebData) user_data;
  cvode_mem = CVodeGetAdjCVodeBmem(wdata->cvode_mem, wdata->indexB);
  if(check_retval((void *)cvode_mem, "CVadjGetCVodeBmem", 0)) return(1);
  rewt = wdata->rewt;
  retval = CVodeGetErrWeights(cvode_mem, rewt);
  if(check_retval(&retval, "CVodeGetErrWeights", 1)) return(1);

  cdata = N_VGetArrayPointer(c);
  rewtdata = N_VGetArrayPointer(rewt);

  uround = UNIT_ROUNDOFF;

  P = wdata->P;
  pivot = wdata->pivot;
  jxr = wdata->jxr;
  jyr = wdata->jyr;
  mp = wdata->mp;
  srur = wdata->srur;
  ngrp = wdata->ngrp;
  ngx = wdata->ngx;
  ngy = wdata->ngy;
  mxmp = wdata->mxmp;
  fsave = wdata->fsave;

  /* Make mp calls to fblock to approximate each diagonal block of Jacobian.
     Here, fsave contains the base value of the rate vector and 
     r0 is a minimum increment factor for the difference quotient. */

  f1 = N_VGetArrayPointer(wdata->vtemp);
  fac = N_VWrmsNorm (fcB, rewt);
  N = NEQ;
  r0 = RCONST(1000.0)*SUNRabs(gamma)*uround*N*fac;
  if (r0 == ZERO) r0 = ONE;

  for (igy = 0; igy < ngy; igy++) {
    jy = jyr[igy];
    if00 = jy*mxmp;
    for (igx = 0; igx < ngx; igx++) { 
      jx = jxr[igx];
      if0 = if00 + jx*mp;
      ig = igx + igy*ngx; 
      /* Generate ig-th diagonal block */
      for (j = 0; j < mp; j++) {
        /* Generate the jth column as a difference quotient */
        jj = if0 + j; 
        save = cdata[jj];
        r = SUNMAX(srur*SUNRabs(save),r0/rewtdata[jj]);
        cdata[jj] += r;
        fac = gamma/r;
        fblock (t, cdata, jx, jy, f1, wdata);
        for (i = 0; i < mp; i++) {
          P[ig][i][j] = (f1[i] - fsave[if0+i])*fac;
        }
        cdata[jj] = save;
      }
    }
  }

  /* Add identity matrix and do LU decompositions on blocks. */

   for (ig = 0; ig < ngrp; ig++) {
     denseAddIdentity(P[ig], mp);
     denseretval = denseGETRF(P[ig], mp, mp, pivot[ig]);
     if (denseretval != 0) return(1);
   }

  *jcurPtr = SUNTRUE;
  return(0);
}
コード例 #10
0
static int Precond(realtype tn, N_Vector y, N_Vector fy, booleantype jok,
                   booleantype *jcurPtr, realtype gamma, void *user_data,
                   N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
  realtype c1, c2, czdn, czup, diag, zdn, zup, q4coef, delz, verdco, hordco;
  realtype **(*P)[MZ], **(*Jbd)[MZ];
  long int *(*pivot)[MZ];
  int ier, jx, jz;
  realtype *ydata, **a, **j;
  UserData data;
  realtype Q1, Q2, C3, A3, A4, KH, VEL, KV0;

  /* Make local copies of pointers in user_data, and of pointer to y's data */
  data = (UserData) user_data;
  P = data->P;
  Jbd = data->Jbd;
  pivot = data->pivot;
  ydata = NV_DATA_S(y);

  /* Load problem coefficients and parameters */
  Q1 = data->p[0];
  Q2 = data->p[1];
  C3 = data->p[2];
  A3 = data->p[3];
  A4 = data->p[4];
  KH = data->p[5];
  VEL = data->p[6];
  KV0 = data->p[7];

  if (jok) {

  /* jok = TRUE: Copy Jbd to P */

    for (jz=0; jz < MZ; jz++)
      for (jx=0; jx < MX; jx++)
        denseCopy(Jbd[jx][jz], P[jx][jz], NUM_SPECIES, NUM_SPECIES);

  *jcurPtr = FALSE;

  }

  else {
  /* jok = FALSE: Generate Jbd from scratch and copy to P */

  /* Make local copies of problem variables, for efficiency. */

  q4coef = data->q4;
  delz = data->dz;
  verdco = data->vdco;
  hordco  = data->hdco;

  /* Compute 2x2 diagonal Jacobian blocks (using q4 values 
     computed on the last f call).  Load into P. */

    for (jz=0; jz < MZ; jz++) {
      zdn = ZMIN + (jz - RCONST(0.5))*delz;
      zup = zdn + delz;
      czdn = verdco*EXP(RCONST(0.2)*zdn);
      czup = verdco*EXP(RCONST(0.2)*zup);
      diag = -(czdn + czup + RCONST(2.0)*hordco);
      for (jx=0; jx < MX; jx++) {
        c1 = IJKth(ydata,1,jx,jz);
        c2 = IJKth(ydata,2,jx,jz);
        j = Jbd[jx][jz];
        a = P[jx][jz];
        IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
        IJth(j,1,2) = -Q2*c1 + q4coef;
        IJth(j,2,1) = Q1*C3 - Q2*c2;
        IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
        denseCopy(j, a, NUM_SPECIES, NUM_SPECIES);
      }
    }

  *jcurPtr = TRUE;

  }

  /* Scale by -gamma */

    for (jz=0; jz < MZ; jz++)
      for (jx=0; jx < MX; jx++)
        denseScale(-gamma, P[jx][jz], NUM_SPECIES, NUM_SPECIES);

  /* Add identity matrix and do LU decompositions on blocks in place. */

  for (jx=0; jx < MX; jx++) {
    for (jz=0; jz < MZ; jz++) {
      denseAddIdentity(P[jx][jz], NUM_SPECIES);
      ier = denseGETRF(P[jx][jz], NUM_SPECIES, NUM_SPECIES, pivot[jx][jz]);
      if (ier != 0) return(1);
    }
  }

  return(0);
}
コード例 #11
0
ファイル: idaFoodWeb_kry.c プロジェクト: luca-heltai/sundials
static int Precond(realtype tt, 
		   N_Vector cc, N_Vector cp, N_Vector rr, 
		   realtype cj, void *user_data,
		   N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
  int flag;
  realtype uround, xx, yy, del_x, del_y;
  realtype **Pxy, *ratesxy, *Pxycol, *cxy, *cpxy, *ewtxy, cctmp;
  realtype inc, fac, sqru, perturb_rates[NUM_SPECIES];
  int is, js, jx, jy, ret;
  void *mem;
  N_Vector ewt;
  realtype hh;
  UserData webdata;

  webdata = (UserData) user_data;
  del_x = webdata->dx;
  del_y = webdata->dy;

  uround = UNIT_ROUNDOFF;
  sqru = SUNRsqrt(uround);

  mem = webdata->ida_mem;
  ewt = webdata->ewt;
  flag = IDAGetErrWeights(mem, ewt);
  if(check_flag(&flag, "IDAGetErrWeights", 1)) return(1);
  flag = IDAGetCurrentStep(mem, &hh);
  if(check_flag(&flag, "IDAGetCurrentStep", 1)) return(1);

  for (jy = 0; jy < MY; jy++) {
    yy = jy * del_y;
    
    for (jx = 0; jx < MX; jx++) {
      xx = jx * del_x;
      Pxy = (webdata->PP)[jx][jy];
      cxy = IJ_Vptr(cc, jx, jy);
      cpxy = IJ_Vptr(cp, jx, jy);
      ewtxy = IJ_Vptr(ewt, jx, jy);
      ratesxy = IJ_Vptr((webdata->rates), jx, jy);

      for (js = 0; js < NUM_SPECIES; js++) {
	inc = sqru*(SUNMAX(SUNRabs(cxy[js]), SUNMAX(hh*SUNRabs(cpxy[js]), ONE/ewtxy[js])));
	cctmp = cxy[js];
	cxy[js] += inc;
	fac = -ONE/inc;

	WebRates(xx, yy, cxy, perturb_rates, webdata);

	Pxycol = Pxy[js];
	
	for (is = 0; is < NUM_SPECIES; is++)
	  Pxycol[is] = (perturb_rates[is] - ratesxy[is])*fac;

	if (js < 1) Pxycol[js] += cj;
	
	cxy[js] = cctmp;
      }

      ret = denseGETRF(Pxy, NUM_SPECIES, NUM_SPECIES, (webdata->pivot)[jx][jy]);

      if (ret != 0) return(1);
    }
  }

  return(0);

}