Actual source code: util2.c

  1: /*$Id: util2.c,v 1.17 2000/11/10 19:38:34 balay Exp $*/

  3: /*
  4:    This file contains utility routines for finite difference
  5:    approximation of Jacobian matrices.  This functionality for
  6:    the TS component will eventually be incorporated as part of
  7:    the base PETSc libraries.
  8: */
 9:  #include src/ts/tsimpl.h
 10:  #include src/snes/snesimpl.h
 11:  #include src/fortran/custom/zpetsc.h

 13: int RHSFunction(TS,double,Vec,Vec,void*);
 14: int RHSJacobianFD(TS,double,Vec,Mat*,Mat*,MatStructure *,void*);

 16: /* -------------------------------------------------------------------*/

 18: /* Temporary interface routine; this will be eliminated soon! */
 19: #ifdef PETSC_HAVE_FORTRAN_CAPS
 20: #define setcroutinefromfortran_ SETCROUTINEFROMFORTRAN
 21: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 22: #define setcroutinefromfortran_ setcroutinefromfortran
 23: #endif

 25: EXTERN_C_BEGIN

 27: void PETSC_STDCALL setcroutinefromfortran_(TS ts,Mat A,Mat B,int *__ierr)
 28: {
 29:     *__TSSetRHSJacobian((TS)PetscToPointer(*(int*)(ts)),
 30:                                (Mat)PetscToPointer(*(int*)(A)),
 31:                                (Mat)PetscToPointer(*(int*)(B)),RHSJacobianFD,PETSC_NULL);
 32: }

 34: EXTERN_C_END


 37: /* -------------------------------------------------------------------*/
 38: /*
 39:    RHSJacobianFD - Computes the Jacobian using finite differences.

 41:    Input Parameters:
 42: .  ts - TS context
 43: .  xx1 - compute Jacobian at this point
 44: .  ctx - application's function context, as set with SNESSetFunction()

 46:    Output Parameters:
 47: .  J - Jacobian
 48: .  B - preconditioner, same as Jacobian
 49: .  flag - matrix flag

 51:    Notes:
 52:    This routine is slow and expensive, and is not currently optimized
 53:    to take advantage of sparsity in the problem.

 55:    Sparse approximations using colorings are also available and
 56:    would be a much better alternative!
 57: */
 58: int RHSJacobianFD(TS ts,double t,Vec xx1,Mat *J,Mat *B,MatStructure *flag,void *ctx)
 59: {
 60:   Vec      jj1,jj2,xx2;
 61:   int      i,ierr,N,start,end,j;
 62:   Scalar   dx,mone = -1.0,*y,scale,*xx,wscale;
 63:   double   amax,epsilon = 1.e-8; /* assumes double precision */
 64:   double   dx_min = 1.e-16,dx_par = 1.e-1;
 65:   MPI_Comm comm;

 67:   VecDuplicate(xx1,&jj1);
 68:   VecDuplicate(xx1,&jj2);
 69:   VecDuplicate(xx1,&xx2);

 71:   PetscObjectGetComm((PetscObject)xx1,&comm);
 72:   MatZeroEntries(*J);

 74:   VecGetSize(xx1,&N);
 75:   VecGetOwnershipRange(xx1,&start,&end);
 76:   TSComputeRHSFunction(ts,ts->ptime,xx1,jj1);

 78:   /* Compute Jacobian approximation, 1 column at a time.
 79:       xx1 = current iterate, jj1 = F(xx1)
 80:       xx2 = perturbed iterate, jj2 = F(xx2)
 81:    */
 82:   VecGetArray(xx1,&xx);
 83:   for (i=0; i<N; i++) {
 84:     VecCopy(xx1,xx2);
 85:     if (i>= start && i<end) {
 86:       dx = xx[i-start];
 87: #if !defined(PETSC_USE_COMPLEX)
 88:       if (dx < dx_min && dx >= 0.0) dx = dx_par;
 89:       else if (dx < 0.0 && dx > -dx_min) dx = -dx_par;
 90: #else
 91:       if (PetscAbsScalar(dx) < dx_min && PetscRealPart(dx) >= 0.0) dx = dx_par;
 92:       else if (PetscRealPart(dx) < 0.0 && PetscAbsScalar(dx) < dx_min) dx = -dx_par;
 93: #endif
 94:       dx *= epsilon;
 95:       wscale = 1.0/dx;
 96:       VecSetValues(xx2,1,&i,&dx,ADD_VALUES);
 97:     } else {
 98:       wscale = 0.0;
 99:     }
100:     TSComputeRHSFunction(ts,t,xx2,jj2);
101:     VecAXPY(&mone,jj1,jj2);
102:     /* Communicate scale to all processors */
103:     MPI_Allreduce(&wscale,&scale,1,MPIU_SCALAR,PetscSum_Op,comm);
104:     VecScale(&scale,jj2);
105:     VecGetArray(jj2,&y);
106:     VecNorm(jj2,NORM_INFINITY,&amax);
107:     amax *= 1.e-14;
108:     for (j=start; j<end; j++) {
109:       if (PetscAbsScalar(y[j-start]) > amax) {
110:         MatSetValues(*J,1,&j,1,&i,y+j-start,INSERT_VALUES);
111:       }
112:     }
113:     VecRestoreArray(jj2,&y);
114:   }

116:   VecRestoreArray(xx1,&xx);
117:   MatAssemblyBegin(*J,MAT_FINAL_ASSEMBLY);
118:   MatAssemblyEnd(*J,MAT_FINAL_ASSEMBLY);
119:   *flag =  DIFFERENT_NONZERO_PATTERN;

121:   VecDestroy(jj1);
122:   VecDestroy(jj2);
123:   VecDestroy(xx2);

125:   return 0;
126: }