Date: 2013-07-02T14:51:36+00:00

Actual source code: ex14.c
petsc-3.4.2 2013-07-02

      1: static const char help[] = "Toy hydrostatic ice flow with multigrid in 3D.\n\
      2: \n\
      3: Solves the hydrostatic (aka Blatter/Pattyn/First Order) equations for ice sheet flow\n\
      4: using multigrid.  The ice uses a power-law rheology with \"Glen\" exponent 3 (corresponds\n\
      5: to p=4/3 in a p-Laplacian).  The focus is on ISMIP-HOM experiments which assume periodic\n\
      6: boundary conditions in the x- and y-directions.\n\
      7: \n\
      8: Equations are rescaled so that the domain size and solution are O(1), details of this scaling\n\
      9: can be controlled by the options -units_meter, -units_second, and -units_kilogram.\n\
     10: \n\
     11: A VTK StructuredGrid output file can be written using the option -o filename.vts\n\
     12: \n\n";

     14: /*
     15: The equations for horizontal velocity (u,v) are

     17:   - [eta (4 u_x + 2 v_y)]_x - [eta (u_y + v_x)]_y - [eta u_z]_z + rho g s_x = 0
     18:   - [eta (4 v_y + 2 u_x)]_y - [eta (u_y + v_x)]_x - [eta v_z]_z + rho g s_y = 0

     20: where

     22:   eta = B/2 (epsilon + gamma)^((p-2)/2)

     24: is the nonlinear effective viscosity with regularization epsilon and hardness parameter B,
     25: written in terms of the second invariant

     27:   gamma = u_x^2 + v_y^2 + u_x v_y + (1/4) (u_y + v_x)^2 + (1/4) u_z^2 + (1/4) v_z^2

     29: The surface boundary conditions are the natural conditions.  The basal boundary conditions
     30: are either no-slip, or Navier (linear) slip with spatially variant friction coefficient beta^2.

     32: In the code, the equations for (u,v) are multiplied through by 1/(rho g) so that residuals are O(1).

     34: The discretization is Q1 finite elements, managed by a DMDA.  The grid is never distorted in the
     35: map (x,y) plane, but the bed and surface may be bumpy.  This is handled as usual in FEM, through
     36: the Jacobian of the coordinate transformation from a reference element to the physical element.

     38: Since ice-flow is tightly coupled in the z-direction (within columns), the DMDA is managed
     39: specially so that columns are never distributed, and are always contiguous in memory.
     40: This amounts to reversing the meaning of X,Y,Z compared to the DMDA's internal interpretation,
     41: and then indexing as vec[i][j][k].  The exotic coarse spaces require 2D DMDAs which are made to
     42: use compatible domain decomposition relative to the 3D DMDAs.

     44: */

     46: #include <petscts.h>
     47: #include <petscdmda.h>
     48: #include <petscdmcomposite.h>
     49: #include <ctype.h>              /* toupper() */

     51: #if defined __SSE2__
     52: #  include <emmintrin.h>
     53: #endif

     55: /* The SSE2 kernels are only for PetscScalar=double on architectures that support it */
     56: #define USE_SSE2_KERNELS (!defined NO_SSE2                              \
     57:                           && !defined PETSC_USE_COMPLEX                 \
     58:                           && !defined PETSC_USE_REAL_SINGLE           \
     59:                           && defined __SSE2__)

     61: #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
     62: #  if defined __cplusplus       /* C++ restrict is nonstandard and compilers have inconsistent rules about where it can be used */
     63: #    define restrict
     64: #  else
     65: #    define restrict PETSC_RESTRICT
     66: #  endif
     67: #endif

     69: static PetscClassId THI_CLASSID;

     71: typedef enum {QUAD_GAUSS,QUAD_LOBATTO} QuadratureType;
     72: static const char *QuadratureTypes[] = {"gauss","lobatto","QuadratureType","QUAD_",0};
     73: static const PetscReal HexQWeights[8] = {1,1,1,1,1,1,1,1};
     74: static const PetscReal HexQNodes[]    = {-0.57735026918962573, 0.57735026918962573};
     75: #define G 0.57735026918962573
     76: #define H (0.5*(1.+G))
     77: #define L (0.5*(1.-G))
     78: #define M (-0.5)
     79: #define P (0.5)
     80: /* Special quadrature: Lobatto in horizontal, Gauss in vertical */
     81: static const PetscReal HexQInterp_Lobatto[8][8] = {{H,0,0,0,L,0,0,0},
     82:                                                    {0,H,0,0,0,L,0,0},
     83:                                                    {0,0,H,0,0,0,L,0},
     84:                                                    {0,0,0,H,0,0,0,L},
     85:                                                    {L,0,0,0,H,0,0,0},
     86:                                                    {0,L,0,0,0,H,0,0},
     87:                                                    {0,0,L,0,0,0,H,0},
     88:                                                    {0,0,0,L,0,0,0,H}};
     89: static const PetscReal HexQDeriv_Lobatto[8][8][3] = {
     90:   {{M*H,M*H,M},{P*H,0,0}  ,{0,0,0}    ,{0,P*H,0}  ,{M*L,M*L,P},{P*L,0,0}  ,{0,0,0}    ,{0,P*L,0}  },
     91:   {{M*H,0,0}  ,{P*H,M*H,M},{0,P*H,0}  ,{0,0,0}    ,{M*L,0,0}  ,{P*L,M*L,P},{0,P*L,0}  ,{0,0,0}    },
     92:   {{0,0,0}    ,{0,M*H,0}  ,{P*H,P*H,M},{M*H,0,0}  ,{0,0,0}    ,{0,M*L,0}  ,{P*L,P*L,P},{M*L,0,0}  },
     93:   {{0,M*H,0}  ,{0,0,0}    ,{P*H,0,0}  ,{M*H,P*H,M},{0,M*L,0}  ,{0,0,0}    ,{P*L,0,0}  ,{M*L,P*L,P}},
     94:   {{M*L,M*L,M},{P*L,0,0}  ,{0,0,0}    ,{0,P*L,0}  ,{M*H,M*H,P},{P*H,0,0}  ,{0,0,0}    ,{0,P*H,0}  },
     95:   {{M*L,0,0}  ,{P*L,M*L,M},{0,P*L,0}  ,{0,0,0}    ,{M*H,0,0}  ,{P*H,M*H,P},{0,P*H,0}  ,{0,0,0}    },
     96:   {{0,0,0}    ,{0,M*L,0}  ,{P*L,P*L,M},{M*L,0,0}  ,{0,0,0}    ,{0,M*H,0}  ,{P*H,P*H,P},{M*H,0,0}  },
     97:   {{0,M*L,0}  ,{0,0,0}    ,{P*L,0,0}  ,{M*L,P*L,M},{0,M*H,0}  ,{0,0,0}    ,{P*H,0,0}  ,{M*H,P*H,P}}};
     98: /* Stanndard Gauss */
     99: static const PetscReal HexQInterp_Gauss[8][8] = {{H*H*H,L*H*H,L*L*H,H*L*H, H*H*L,L*H*L,L*L*L,H*L*L},
    100:                                                  {L*H*H,H*H*H,H*L*H,L*L*H, L*H*L,H*H*L,H*L*L,L*L*L},
    101:                                                  {L*L*H,H*L*H,H*H*H,L*H*H, L*L*L,H*L*L,H*H*L,L*H*L},
    102:                                                  {H*L*H,L*L*H,L*H*H,H*H*H, H*L*L,L*L*L,L*H*L,H*H*L},
    103:                                                  {H*H*L,L*H*L,L*L*L,H*L*L, H*H*H,L*H*H,L*L*H,H*L*H},
    104:                                                  {L*H*L,H*H*L,H*L*L,L*L*L, L*H*H,H*H*H,H*L*H,L*L*H},
    105:                                                  {L*L*L,H*L*L,H*H*L,L*H*L, L*L*H,H*L*H,H*H*H,L*H*H},
    106:                                                  {H*L*L,L*L*L,L*H*L,H*H*L, H*L*H,L*L*H,L*H*H,H*H*H}};
    107: static const PetscReal HexQDeriv_Gauss[8][8][3] = {
    108:   {{M*H*H,H*M*H,H*H*M},{P*H*H,L*M*H,L*H*M},{P*L*H,L*P*H,L*L*M},{M*L*H,H*P*H,H*L*M}, {M*H*L,H*M*L,H*H*P},{P*H*L,L*M*L,L*H*P},{P*L*L,L*P*L,L*L*P},{M*L*L,H*P*L,H*L*P}},
    109:   {{M*H*H,L*M*H,L*H*M},{P*H*H,H*M*H,H*H*M},{P*L*H,H*P*H,H*L*M},{M*L*H,L*P*H,L*L*M}, {M*H*L,L*M*L,L*H*P},{P*H*L,H*M*L,H*H*P},{P*L*L,H*P*L,H*L*P},{M*L*L,L*P*L,L*L*P}},
    110:   {{M*L*H,L*M*H,L*L*M},{P*L*H,H*M*H,H*L*M},{P*H*H,H*P*H,H*H*M},{M*H*H,L*P*H,L*H*M}, {M*L*L,L*M*L,L*L*P},{P*L*L,H*M*L,H*L*P},{P*H*L,H*P*L,H*H*P},{M*H*L,L*P*L,L*H*P}},
    111:   {{M*L*H,H*M*H,H*L*M},{P*L*H,L*M*H,L*L*M},{P*H*H,L*P*H,L*H*M},{M*H*H,H*P*H,H*H*M}, {M*L*L,H*M*L,H*L*P},{P*L*L,L*M*L,L*L*P},{P*H*L,L*P*L,L*H*P},{M*H*L,H*P*L,H*H*P}},
    112:   {{M*H*L,H*M*L,H*H*M},{P*H*L,L*M*L,L*H*M},{P*L*L,L*P*L,L*L*M},{M*L*L,H*P*L,H*L*M}, {M*H*H,H*M*H,H*H*P},{P*H*H,L*M*H,L*H*P},{P*L*H,L*P*H,L*L*P},{M*L*H,H*P*H,H*L*P}},
    113:   {{M*H*L,L*M*L,L*H*M},{P*H*L,H*M*L,H*H*M},{P*L*L,H*P*L,H*L*M},{M*L*L,L*P*L,L*L*M}, {M*H*H,L*M*H,L*H*P},{P*H*H,H*M*H,H*H*P},{P*L*H,H*P*H,H*L*P},{M*L*H,L*P*H,L*L*P}},
    114:   {{M*L*L,L*M*L,L*L*M},{P*L*L,H*M*L,H*L*M},{P*H*L,H*P*L,H*H*M},{M*H*L,L*P*L,L*H*M}, {M*L*H,L*M*H,L*L*P},{P*L*H,H*M*H,H*L*P},{P*H*H,H*P*H,H*H*P},{M*H*H,L*P*H,L*H*P}},
    115:   {{M*L*L,H*M*L,H*L*M},{P*L*L,L*M*L,L*L*M},{P*H*L,L*P*L,L*H*M},{M*H*L,H*P*L,H*H*M}, {M*L*H,H*M*H,H*L*P},{P*L*H,L*M*H,L*L*P},{P*H*H,L*P*H,L*H*P},{M*H*H,H*P*H,H*H*P}}};
    116: static const PetscReal (*HexQInterp)[8],(*HexQDeriv)[8][3];
    117: /* Standard 2x2 Gauss quadrature for the bottom layer. */
    118: static const PetscReal QuadQInterp[4][4] = {{H*H,L*H,L*L,H*L},
    119:                                             {L*H,H*H,H*L,L*L},
    120:                                             {L*L,H*L,H*H,L*H},
    121:                                             {H*L,L*L,L*H,H*H}};
    122: static const PetscReal QuadQDeriv[4][4][2] = {
    123:   {{M*H,M*H},{P*H,M*L},{P*L,P*L},{M*L,P*H}},
    124:   {{M*H,M*L},{P*H,M*H},{P*L,P*H},{M*L,P*L}},
    125:   {{M*L,M*L},{P*L,M*H},{P*H,P*H},{M*H,P*L}},
    126:   {{M*L,M*H},{P*L,M*L},{P*H,P*L},{M*H,P*H}}};
    127: #undef G
    128: #undef H
    129: #undef L
    130: #undef M
    131: #undef P

    133: #define HexExtract(x,i,j,k,n) do {              \
    134:     (n)[0] = (x)[i][j][k];                      \
    135:     (n)[1] = (x)[i+1][j][k];                    \
    136:     (n)[2] = (x)[i+1][j+1][k];                  \
    137:     (n)[3] = (x)[i][j+1][k];                    \
    138:     (n)[4] = (x)[i][j][k+1];                    \
    139:     (n)[5] = (x)[i+1][j][k+1];                  \
    140:     (n)[6] = (x)[i+1][j+1][k+1];                \
    141:     (n)[7] = (x)[i][j+1][k+1];                  \
    142:   } while (0)

    144: #define HexExtractRef(x,i,j,k,n) do {           \
    145:     (n)[0] = &(x)[i][j][k];                     \
    146:     (n)[1] = &(x)[i+1][j][k];                   \
    147:     (n)[2] = &(x)[i+1][j+1][k];                 \
    148:     (n)[3] = &(x)[i][j+1][k];                   \
    149:     (n)[4] = &(x)[i][j][k+1];                   \
    150:     (n)[5] = &(x)[i+1][j][k+1];                 \
    151:     (n)[6] = &(x)[i+1][j+1][k+1];               \
    152:     (n)[7] = &(x)[i][j+1][k+1];                 \
    153:   } while (0)

    155: #define QuadExtract(x,i,j,n) do {               \
    156:     (n)[0] = (x)[i][j];                         \
    157:     (n)[1] = (x)[i+1][j];                       \
    158:     (n)[2] = (x)[i+1][j+1];                     \
    159:     (n)[3] = (x)[i][j+1];                       \
    160:   } while (0)

    162: static PetscScalar Sqr(PetscScalar a) {return a*a;}

    164: static void HexGrad(const PetscReal dphi[][3],const PetscReal zn[],PetscReal dz[])
    165: {
    166:   PetscInt i;
    167:   dz[0] = dz[1] = dz[2] = 0;
    168:   for (i=0; i<8; i++) {
    169:     dz[0] += dphi[i][0] * zn[i];
    170:     dz[1] += dphi[i][1] * zn[i];
    171:     dz[2] += dphi[i][2] * zn[i];
    172:   }
    173: }

    175: static void HexComputeGeometry(PetscInt q,PetscReal hx,PetscReal hy,const PetscReal dz[restrict],PetscReal phi[restrict],PetscReal dphi[restrict][3],PetscReal *restrict jw)
    176: {
    177:   const PetscReal
    178:     jac[3][3] = {{hx/2,0,0}, {0,hy/2,0}, {dz[0],dz[1],dz[2]}}
    179:   ,ijac[3][3] = {{1/jac[0][0],0,0}, {0,1/jac[1][1],0}, {-jac[2][0]/(jac[0][0]*jac[2][2]),-jac[2][1]/(jac[1][1]*jac[2][2]),1/jac[2][2]}}
    180:   ,jdet = jac[0][0]*jac[1][1]*jac[2][2];
    181:   PetscInt i;

    183:   for (i=0; i<8; i++) {
    184:     const PetscReal *dphir = HexQDeriv[q][i];
    185:     phi[i] = HexQInterp[q][i];
    186:     dphi[i][0] = dphir[0]*ijac[0][0] + dphir[1]*ijac[1][0] + dphir[2]*ijac[2][0];
    187:     dphi[i][1] = dphir[0]*ijac[0][1] + dphir[1]*ijac[1][1] + dphir[2]*ijac[2][1];
    188:     dphi[i][2] = dphir[0]*ijac[0][2] + dphir[1]*ijac[1][2] + dphir[2]*ijac[2][2];
    189:   }
    190:   *jw = 1.0 * jdet;
    191: }

    193: typedef struct _p_THI   *THI;
    194: typedef struct _n_Units *Units;

    196: typedef struct {
    197:   PetscScalar u,v;
    198: } Node;

    200: typedef struct {
    201:   PetscScalar b;                /* bed */
    202:   PetscScalar h;                /* thickness */
    203:   PetscScalar beta2;            /* friction */
    204: } PrmNode;

    206: #define FieldSize(ntype) ((PetscInt)(sizeof(ntype)/sizeof(PetscScalar)))
    207: #define FieldOffset(ntype,member) ((PetscInt)(offsetof(ntype,member)/sizeof(PetscScalar)))
    208: #define FieldIndex(ntype,i,member) ((PetscInt)((i)*FieldSize(ntype) + FieldOffset(ntype,member)))
    209: #define NODE_SIZE FieldSize(Node)
    210: #define PRMNODE_SIZE FieldSize(PrmNode)

    212: typedef struct {
    213:   PetscReal min,max,cmin,cmax;
    214: } PRange;

    216: struct _p_THI {
    217:   PETSCHEADER(int);
    218:   void      (*initialize)(THI,PetscReal x,PetscReal y,PrmNode *p);
    219:   PetscInt  nlevels;
    220:   PetscInt  zlevels;
    221:   PetscReal Lx,Ly,Lz;           /* Model domain */
    222:   PetscReal alpha;              /* Bed angle */
    223:   Units     units;
    224:   PetscReal dirichlet_scale;
    225:   PetscReal ssa_friction_scale;
    226:   PetscReal inertia;
    227:   PRange    eta;
    228:   PRange    beta2;
    229:   struct {
    230:     PetscReal Bd2,eps,exponent,glen_n;
    231:   } viscosity;
    232:   struct {
    233:     PetscReal irefgam,eps2,exponent;
    234:   } friction;
    235:   struct {
    236:     PetscReal rate,exponent,refvel;
    237:   } erosion;
    238:   PetscReal rhog;
    239:   PetscBool no_slip;
    240:   PetscBool verbose;
    241:   MatType   mattype;
    242:   char      *monitor_basename;
    243:   PetscInt  monitor_interval;
    244: };

    246: struct _n_Units {
    247:   /* fundamental */
    248:   PetscReal meter;
    249:   PetscReal kilogram;
    250:   PetscReal second;
    251:   /* derived */
    252:   PetscReal Pascal;
    253:   PetscReal year;
    254: };

    256: static void PrmHexGetZ(const PrmNode pn[],PetscInt k,PetscInt zm,PetscReal zn[])
    257: {
    258:   const PetscScalar zm1 = zm-1,
    259:     znl[8] = {pn[0].b + pn[0].h*(PetscScalar)k/zm1,
    260:               pn[1].b + pn[1].h*(PetscScalar)k/zm1,
    261:               pn[2].b + pn[2].h*(PetscScalar)k/zm1,
    262:               pn[3].b + pn[3].h*(PetscScalar)k/zm1,
    263:               pn[0].b + pn[0].h*(PetscScalar)(k+1)/zm1,
    264:               pn[1].b + pn[1].h*(PetscScalar)(k+1)/zm1,
    265:               pn[2].b + pn[2].h*(PetscScalar)(k+1)/zm1,
    266:               pn[3].b + pn[3].h*(PetscScalar)(k+1)/zm1};
    267:   PetscInt i;
    268:   for (i=0; i<8; i++) zn[i] = PetscRealPart(znl[i]);
    269: }

    273: /* Compute a gradient of all the 2D fields at four quadrature points.  Output for [quadrature_point][direction].field_name */
    274: static PetscErrorCode QuadComputeGrad4(const PetscReal dphi[][4][2],PetscReal hx,PetscReal hy,const PrmNode pn[4],PrmNode dp[4][2])
    275: {
    277:   PetscInt       q,i,f;
    278:   const PetscScalar (*restrict pg)[PRMNODE_SIZE] = (const PetscScalar(*)[PRMNODE_SIZE])pn; /* Get generic array pointers to the node */
    279:   PetscScalar (*restrict dpg)[2][PRMNODE_SIZE]   = (PetscScalar(*)[2][PRMNODE_SIZE])dp;

    282:   PetscMemzero(dpg,4*sizeof(dpg[0]));
    283:   for (q=0; q<4; q++) {
    284:     for (i=0; i<4; i++) {
    285:       for (f=0; f<PRMNODE_SIZE; f++) {
    286:         dpg[q][0][f] += dphi[q][i][0]/hx * pg[i][f];
    287:         dpg[q][1][f] += dphi[q][i][1]/hy * pg[i][f];
    288:       }
    289:     }
    290:   }
    291:   return(0);
    292: }

    294: static inline PetscReal StaggeredMidpoint2D(PetscScalar a,PetscScalar b,PetscScalar c,PetscScalar d)
    295: {return 0.5*PetscRealPart(0.75*a + 0.75*b + 0.25*c + 0.25*d);}
    296: static inline PetscReal UpwindFlux1D(PetscReal u,PetscReal hL,PetscReal hR)
    297: {return (u > 0) ? hL*u : hR*u;}

    299: #define UpwindFluxXW(x3,x2,h,i,j,k,dj) UpwindFlux1D(StaggeredMidpoint2D(x3[i][j][k].u,x3[i-1][j][k].u, x3[i-1][j+dj][k].u,x3[i][k+dj][k].u), \
    300:                                                     PetscRealPart(0.75*x2[i-1][j  ].h+0.25*x2[i-1][j+dj].h), PetscRealPart(0.75*x2[i  ][j  ].h+0.25*x2[i  ][j+dj].h))
    301: #define UpwindFluxXE(x3,x2,h,i,j,k,dj) UpwindFlux1D(StaggeredMidpoint2D(x3[i][j][k].u,x3[i+1][j][k].u, x3[i+1][j+dj][k].u,x3[i][k+dj][k].u), \
    302:                                                     PetscRealPart(0.75*x2[i  ][j  ].h+0.25*x2[i  ][j+dj].h), PetscRealPart(0.75*x2[i+1][j  ].h+0.25*x2[i+1][j+dj].h))
    303: #define UpwindFluxYS(x3,x2,h,i,j,k,di) UpwindFlux1D(StaggeredMidpoint2D(x3[i][j][k].v,x3[i][j-1][k].v, x3[i+di][j-1][k].v,x3[i+di][j][k].v), \
    304:                                                     PetscRealPart(0.75*x2[i  ][j-1].h+0.25*x2[i+di][j-1].h), PetscRealPart(0.75*x2[i  ][j  ].h+0.25*x2[i+di][j  ].h))
    305: #define UpwindFluxYN(x3,x2,h,i,j,k,di) UpwindFlux1D(StaggeredMidpoint2D(x3[i][j][k].v,x3[i][j+1][k].v, x3[i+di][j+1][k].v,x3[i+di][j][k].v), \
    306:                                                     PetscRealPart(0.75*x2[i  ][j  ].h+0.25*x2[i+di][j  ].h), PetscRealPart(0.75*x2[i  ][j+1].h+0.25*x2[i+di][j+1].h))

    308: static void PrmNodeGetFaceMeasure(const PrmNode **p,PetscInt i,PetscInt j,PetscScalar h[])
    309: {
    310:   /* West */
    311:   h[0] = StaggeredMidpoint2D(p[i][j].h,p[i-1][j].h,p[i-1][j-1].h,p[i][j-1].h);
    312:   h[1] = StaggeredMidpoint2D(p[i][j].h,p[i-1][j].h,p[i-1][j+1].h,p[i][j+1].h);
    313:   /* East */
    314:   h[2] = StaggeredMidpoint2D(p[i][j].h,p[i+1][j].h,p[i+1][j+1].h,p[i][j+1].h);
    315:   h[3] = StaggeredMidpoint2D(p[i][j].h,p[i+1][j].h,p[i+1][j-1].h,p[i][j-1].h);
    316:   /* South */
    317:   h[4] = StaggeredMidpoint2D(p[i][j].h,p[i][j-1].h,p[i+1][j-1].h,p[i+1][j].h);
    318:   h[5] = StaggeredMidpoint2D(p[i][j].h,p[i][j-1].h,p[i-1][j-1].h,p[i-1][j].h);
    319:   /* North */
    320:   h[6] = StaggeredMidpoint2D(p[i][j].h,p[i][j+1].h,p[i-1][j+1].h,p[i-1][j].h);
    321:   h[7] = StaggeredMidpoint2D(p[i][j].h,p[i][j+1].h,p[i+1][j+1].h,p[i+1][j].h);
    322: }

    324: /* Tests A and C are from the ISMIP-HOM paper (Pattyn et al. 2008) */
    325: static void THIInitialize_HOM_A(THI thi,PetscReal x,PetscReal y,PrmNode *p)
    326: {
    327:   Units units = thi->units;
    328:   PetscReal s = -x*sin(thi->alpha);
    329:   p->b = s - 1000*units->meter + 500*units->meter * sin(x*2*PETSC_PI/thi->Lx) * sin(y*2*PETSC_PI/thi->Ly);
    330:   p->h = s - p->b;
    331:   p->beta2 = -1e-10;             /* This value is not used, but it should not be huge because that would change the finite difference step size  */
    332: }

    334: static void THIInitialize_HOM_C(THI thi,PetscReal x,PetscReal y,PrmNode *p)
    335: {
    336:   Units units = thi->units;
    337:   PetscReal s = -x*sin(thi->alpha);
    338:   p->b = s - 1000*units->meter;
    339:   p->h = s - p->b;
    340:   /* tau_b = beta2 v   is a stress (Pa).
    341:    * This is a big number in our units (it needs to balance the driving force from the surface), so we scale it by 1/rhog, just like the residual. */
    342:   p->beta2 = 1000 * (1 + sin(x*2*PETSC_PI/thi->Lx)*sin(y*2*PETSC_PI/thi->Ly)) * units->Pascal * units->year / units->meter / thi->rhog;
    343: }

    345: /* These are just toys */

    347: /* From Fred Herman */
    348: static void THIInitialize_HOM_F(THI thi,PetscReal x,PetscReal y,PrmNode *p)
    349: {
    350:   Units units = thi->units;
    351:   PetscReal s = -x*sin(thi->alpha);
    352:   p->b = s - 1000*units->meter + 100*units->meter * sin(x*2*PETSC_PI/thi->Lx);/* * sin(y*2*PETSC_PI/thi->Ly); */
    353:   p->h = s - p->b;
    354:   p->h = (1-(atan((x-thi->Lx/2)/1.)+PETSC_PI/2.)/PETSC_PI)*500*units->meter+1*units->meter;
    355:   s = PetscRealPart(p->b + p->h);
    356:   p->beta2 = -1e-10;
    357:   /*  p->beta2 = 1000 * units->Pascal * units->year / units->meter; */
    358: }

    360: /* Same bed as test A, free slip everywhere except for a discontinuous jump to a circular sticky region in the middle. */
    361: static void THIInitialize_HOM_X(THI thi,PetscReal xx,PetscReal yy,PrmNode *p)
    362: {
    363:   Units units = thi->units;
    364:   PetscReal x = xx*2*PETSC_PI/thi->Lx - PETSC_PI,y = yy*2*PETSC_PI/thi->Ly - PETSC_PI; /* [-pi,pi] */
    365:   PetscReal r = PetscSqrtReal(x*x + y*y),s = -x*sin(thi->alpha);
    366:   p->b = s - 1000*units->meter + 500*units->meter * sin(x + PETSC_PI) * sin(y + PETSC_PI);
    367:   p->h = s - p->b;
    368:   p->beta2 = 1000 * (r < 1 ? 2 : 0) * units->Pascal * units->year / units->meter / thi->rhog;
    369: }

    371: /* Like Z, but with 200 meter cliffs */
    372: static void THIInitialize_HOM_Y(THI thi,PetscReal xx,PetscReal yy,PrmNode *p)
    373: {
    374:   Units units = thi->units;
    375:   PetscReal x = xx*2*PETSC_PI/thi->Lx - PETSC_PI,y = yy*2*PETSC_PI/thi->Ly - PETSC_PI; /* [-pi,pi] */
    376:   PetscReal r = PetscSqrtReal(x*x + y*y),s = -x*sin(thi->alpha);
    377:   p->b = s - 1000*units->meter + 500*units->meter * sin(x + PETSC_PI) * sin(y + PETSC_PI);
    378:   if (PetscRealPart(p->b) > -700*units->meter) p->b += 200*units->meter;
    379:   p->h = s - p->b;
    380:   p->beta2 = 1000 * (1. + sin(PetscSqrtReal(16*r))/PetscSqrtReal(1e-2 + 16*r)*cos(x*3/2)*cos(y*3/2)) * units->Pascal * units->year / units->meter / thi->rhog;
    381: }

    383: /* Same bed as A, smoothly varying slipperiness, similar to MATLAB's "sombrero" (uncorrelated with bathymetry) */
    384: static void THIInitialize_HOM_Z(THI thi,PetscReal xx,PetscReal yy,PrmNode *p)
    385: {
    386:   Units units = thi->units;
    387:   PetscReal x = xx*2*PETSC_PI/thi->Lx - PETSC_PI,y = yy*2*PETSC_PI/thi->Ly - PETSC_PI; /* [-pi,pi] */
    388:   PetscReal r = PetscSqrtReal(x*x + y*y),s = -x*sin(thi->alpha);
    389:   p->b = s - 1000*units->meter + 500*units->meter * sin(x + PETSC_PI) * sin(y + PETSC_PI);
    390:   p->h = s - p->b;
    391:   p->beta2 = 1000 * (1. + sin(PetscSqrtReal(16*r))/PetscSqrtReal(1e-2 + 16*r)*cos(x*3/2)*cos(y*3/2)) * units->Pascal * units->year / units->meter / thi->rhog;
    392: }

    394: static void THIFriction(THI thi,PetscReal rbeta2,PetscReal gam,PetscReal *beta2,PetscReal *dbeta2)
    395: {
    396:   if (thi->friction.irefgam == 0) {
    397:     Units units = thi->units;
    398:     thi->friction.irefgam = 1./(0.5*PetscSqr(100 * units->meter / units->year));
    399:     thi->friction.eps2 = 0.5*PetscSqr(1.e-4 / thi->friction.irefgam);
    400:   }
    401:   if (thi->friction.exponent == 0) {
    402:     *beta2  = rbeta2;
    403:     *dbeta2 = 0;
    404:   } else {
    405:     *beta2  = rbeta2 * pow(thi->friction.eps2 + gam*thi->friction.irefgam,thi->friction.exponent);
    406:     *dbeta2 = thi->friction.exponent * *beta2 / (thi->friction.eps2 + gam*thi->friction.irefgam) * thi->friction.irefgam;
    407:   }
    408: }

    410: static void THIViscosity(THI thi,PetscReal gam,PetscReal *eta,PetscReal *deta)
    411: {
    412:   PetscReal Bd2,eps,exponent;
    413:   if (thi->viscosity.Bd2 == 0) {
    414:     Units units = thi->units;
    415:     const PetscReal
    416:       n = thi->viscosity.glen_n,                        /* Glen exponent */
    417:       p = 1. + 1./n,                                    /* for Stokes */
    418:       A = 1.e-16 * pow(units->Pascal,-n) / units->year, /* softness parameter (Pa^{-n}/s) */
    419:       B = pow(A,-1./n);                                 /* hardness parameter */
    420:     thi->viscosity.Bd2      = B/2;
    421:     thi->viscosity.exponent = (p-2)/2;
    422:     thi->viscosity.eps      = 0.5*PetscSqr(1e-5 / units->year);
    423:   }
    424:   Bd2      = thi->viscosity.Bd2;
    425:   exponent = thi->viscosity.exponent;
    426:   eps      = thi->viscosity.eps;
    427:   *eta     = Bd2 * pow(eps + gam,exponent);
    428:   *deta    = exponent * (*eta) / (eps + gam);
    429: }

    431: static void THIErosion(THI thi,const Node *vel,PetscScalar *erate,Node *derate)
    432: {
    433:   const PetscScalar magref2 = 1.e-10 + (PetscSqr(vel->u) + PetscSqr(vel->v)) / PetscSqr(thi->erosion.refvel),
    434:                     rate    = -thi->erosion.rate*PetscPowScalar(magref2, 0.5*thi->erosion.exponent);
    435:   if (erate) *erate = rate;
    436:   if (derate) {
    437:     if (thi->erosion.exponent == 1) {
    438:       derate->u = 0;
    439:       derate->v = 0;
    440:     } else {
    441:       derate->u = 0.5*thi->erosion.exponent * rate / magref2 * 2. * vel->u / PetscSqr(thi->erosion.refvel);
    442:       derate->v = 0.5*thi->erosion.exponent * rate / magref2 * 2. * vel->v / PetscSqr(thi->erosion.refvel);
    443:     }
    444:   }
    445: }

    447: static void RangeUpdate(PetscReal *min,PetscReal *max,PetscReal x)
    448: {
    449:   if (x < *min) *min = x;
    450:   if (x > *max) *max = x;
    451: }

    453: static void PRangeClear(PRange *p)
    454: {
    455:   p->cmin = p->min = 1e100;
    456:   p->cmax = p->max = -1e100;
    457: }

    461: static PetscErrorCode PRangeMinMax(PRange *p,PetscReal min,PetscReal max)
    462: {

    465:   p->cmin = min;
    466:   p->cmax = max;
    467:   if (min < p->min) p->min = min;
    468:   if (max > p->max) p->max = max;
    469:   return(0);
    470: }

    474: static PetscErrorCode THIDestroy(THI *thi)
    475: {

    479:   if (--((PetscObject)(*thi))->refct > 0) return(0);
    480:   PetscFree((*thi)->units);
    481:   PetscFree((*thi)->mattype);
    482:   PetscFree((*thi)->monitor_basename);
    483:   PetscHeaderDestroy(thi);
    484:   return(0);
    485: }

    489: static PetscErrorCode THICreate(MPI_Comm comm,THI *inthi)
    490: {
    491:   static PetscBool registered = PETSC_FALSE;
    492:   THI              thi;
    493:   Units            units;
    494:   char             monitor_basename[PETSC_MAX_PATH_LEN] = "thi-";
    495:   PetscErrorCode   ierr;

    498:   *inthi = 0;
    499:   if (!registered) {
    500:     PetscClassIdRegister("Toy Hydrostatic Ice",&THI_CLASSID);
    501:     registered = PETSC_TRUE;
    502:   }
    503:   PetscHeaderCreate(thi,_p_THI,0,THI_CLASSID,"THI","Toy Hydrostatic Ice","THI",comm,THIDestroy,0);

    505:   PetscNew(struct _n_Units,&thi->units);

    507:   units           = thi->units;
    508:   units->meter    = 1e-2;
    509:   units->second   = 1e-7;
    510:   units->kilogram = 1e-12;

    512:   PetscOptionsBegin(comm,NULL,"Scaled units options","");
    513:   {
    514:     PetscOptionsReal("-units_meter","1 meter in scaled length units","",units->meter,&units->meter,NULL);
    515:     PetscOptionsReal("-units_second","1 second in scaled time units","",units->second,&units->second,NULL);
    516:     PetscOptionsReal("-units_kilogram","1 kilogram in scaled mass units","",units->kilogram,&units->kilogram,NULL);
    517:   }
    518:   PetscOptionsEnd();
    519:   units->Pascal = units->kilogram / (units->meter * PetscSqr(units->second));
    520:   units->year   = 31556926. * units->second, /* seconds per year */

    522:   thi->Lx              = 10.e3;
    523:   thi->Ly              = 10.e3;
    524:   thi->Lz              = 1000;
    525:   thi->nlevels         = 1;
    526:   thi->dirichlet_scale = 1;
    527:   thi->verbose         = PETSC_FALSE;

    529:   thi->viscosity.glen_n = 3.;
    530:   thi->erosion.rate     = 1e-3; /* m/a */
    531:   thi->erosion.exponent = 1.;
    532:   thi->erosion.refvel   = 1.;   /* m/a */

    534:   PetscOptionsBegin(comm,NULL,"Toy Hydrostatic Ice options","");
    535:   {
    536:     QuadratureType quad       = QUAD_GAUSS;
    537:     char           homexp[]   = "A";
    538:     char           mtype[256] = MATSBAIJ;
    539:     PetscReal      L,m = 1.0;
    540:     PetscBool      flg;
    541:     L    = thi->Lx;
    542:     PetscOptionsReal("-thi_L","Domain size (m)","",L,&L,&flg);
    543:     if (flg) thi->Lx = thi->Ly = L;
    544:     PetscOptionsReal("-thi_Lx","X Domain size (m)","",thi->Lx,&thi->Lx,NULL);
    545:     PetscOptionsReal("-thi_Ly","Y Domain size (m)","",thi->Ly,&thi->Ly,NULL);
    546:     PetscOptionsReal("-thi_Lz","Z Domain size (m)","",thi->Lz,&thi->Lz,NULL);
    547:     PetscOptionsString("-thi_hom","ISMIP-HOM experiment (A or C)","",homexp,homexp,sizeof(homexp),NULL);
    548:     switch (homexp[0] = toupper(homexp[0])) {
    549:     case 'A':
    550:       thi->initialize = THIInitialize_HOM_A;
    551:       thi->no_slip    = PETSC_TRUE;
    552:       thi->alpha      = 0.5;
    553:       break;
    554:     case 'C':
    555:       thi->initialize = THIInitialize_HOM_C;
    556:       thi->no_slip    = PETSC_FALSE;
    557:       thi->alpha      = 0.1;
    558:       break;
    559:     case 'F':
    560:       thi->initialize = THIInitialize_HOM_F;
    561:       thi->no_slip    = PETSC_FALSE;
    562:       thi->alpha      = 0.5;
    563:       break;
    564:     case 'X':
    565:       thi->initialize = THIInitialize_HOM_X;
    566:       thi->no_slip    = PETSC_FALSE;
    567:       thi->alpha      = 0.3;
    568:       break;
    569:     case 'Y':
    570:       thi->initialize = THIInitialize_HOM_Y;
    571:       thi->no_slip    = PETSC_FALSE;
    572:       thi->alpha      = 0.5;
    573:       break;
    574:     case 'Z':
    575:       thi->initialize = THIInitialize_HOM_Z;
    576:       thi->no_slip    = PETSC_FALSE;
    577:       thi->alpha      = 0.5;
    578:       break;
    579:     default:
    580:       SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_SUP,"HOM experiment '%c' not implemented",homexp[0]);
    581:     }
    582:     PetscOptionsEnum("-thi_quadrature","Quadrature to use for 3D elements","",QuadratureTypes,(PetscEnum)quad,(PetscEnum*)&quad,NULL);
    583:     switch (quad) {
    584:     case QUAD_GAUSS:
    585:       HexQInterp = HexQInterp_Gauss;
    586:       HexQDeriv  = HexQDeriv_Gauss;
    587:       break;
    588:     case QUAD_LOBATTO:
    589:       HexQInterp = HexQInterp_Lobatto;
    590:       HexQDeriv  = HexQDeriv_Lobatto;
    591:       break;
    592:     }
    593:     PetscOptionsReal("-thi_alpha","Bed angle (degrees)","",thi->alpha,&thi->alpha,NULL);
    594:     PetscOptionsReal("-thi_viscosity_glen_n","Exponent in Glen flow law, 1=linear, infty=ideal plastic",NULL,thi->viscosity.glen_n,&thi->viscosity.glen_n,NULL);
    595:     PetscOptionsReal("-thi_friction_m","Friction exponent, 0=Coulomb, 1=Navier","",m,&m,NULL);
    596:     thi->friction.exponent = (m-1)/2;
    597:     PetscOptionsReal("-thi_erosion_rate","Rate of erosion relative to sliding velocity at reference velocity (m/a)",NULL,thi->erosion.rate,&thi->erosion.rate,NULL);
    598:     PetscOptionsReal("-thi_erosion_exponent","Power of sliding velocity appearing in erosion relation",NULL,thi->erosion.exponent,&thi->erosion.exponent,NULL);
    599:     PetscOptionsReal("-thi_erosion_refvel","Reference sliding velocity for erosion (m/a)",NULL,thi->erosion.refvel,&thi->erosion.refvel,NULL);
    600:     thi->erosion.rate   *= units->meter / units->year;
    601:     thi->erosion.refvel *= units->meter / units->year;
    602:     PetscOptionsReal("-thi_dirichlet_scale","Scale Dirichlet boundary conditions by this factor","",thi->dirichlet_scale,&thi->dirichlet_scale,NULL);
    603:     PetscOptionsReal("-thi_ssa_friction_scale","Scale slip boundary conditions by this factor in SSA (2D) assembly","",thi->ssa_friction_scale,&thi->ssa_friction_scale,NULL);
    604:     PetscOptionsReal("-thi_inertia","Coefficient of accelaration term in velocity system, physical is almost zero",NULL,thi->inertia,&thi->inertia,NULL);
    605:     PetscOptionsInt("-thi_nlevels","Number of levels of refinement","",thi->nlevels,&thi->nlevels,NULL);
    606:     PetscOptionsList("-thi_mat_type","Matrix type","MatSetType",MatList,mtype,(char*)mtype,sizeof(mtype),NULL);
    607:     PetscStrallocpy(mtype,&thi->mattype);
    608:     PetscOptionsBool("-thi_verbose","Enable verbose output (like matrix sizes and statistics)","",thi->verbose,&thi->verbose,NULL);
    609:     PetscOptionsString("-thi_monitor","Basename to write state files to",NULL,monitor_basename,monitor_basename,sizeof(monitor_basename),&flg);
    610:     if (flg) {
    611:       PetscStrallocpy(monitor_basename,&thi->monitor_basename);
    612:       thi->monitor_interval = 1;
    613:       PetscOptionsInt("-thi_monitor_interval","Frequency at which to write state files",NULL,thi->monitor_interval,&thi->monitor_interval,NULL);
    614:     }
    615:   }
    616:   PetscOptionsEnd();

    618:   /* dimensionalize */
    619:   thi->Lx    *= units->meter;
    620:   thi->Ly    *= units->meter;
    621:   thi->Lz    *= units->meter;
    622:   thi->alpha *= PETSC_PI / 180;

    624:   PRangeClear(&thi->eta);
    625:   PRangeClear(&thi->beta2);

    627:   {
    628:     PetscReal u       = 1000*units->meter/(3e7*units->second),
    629:               gradu   = u / (100*units->meter),eta,deta,
    630:               rho     = 910 * units->kilogram/pow(units->meter,3),
    631:               grav    = 9.81 * units->meter/PetscSqr(units->second),
    632:               driving = rho * grav * sin(thi->alpha) * 1000*units->meter;
    633:     THIViscosity(thi,0.5*gradu*gradu,&eta,&deta);
    634:     thi->rhog = rho * grav;
    635:     if (thi->verbose) {
    636:       PetscPrintf(PetscObjectComm((PetscObject)thi),"Units: meter %8.2g  second %8.2g  kg %8.2g  Pa %8.2g\n",units->meter,units->second,units->kilogram,units->Pascal);
    637:       PetscPrintf(PetscObjectComm((PetscObject)thi),"Domain (%6.2g,%6.2g,%6.2g), pressure %8.2g, driving stress %8.2g\n",thi->Lx,thi->Ly,thi->Lz,rho*grav*1e3*units->meter,driving);
    638:       PetscPrintf(PetscObjectComm((PetscObject)thi),"Large velocity 1km/a %8.2g, velocity gradient %8.2g, eta %8.2g, stress %8.2g, ratio %8.2g\n",u,gradu,eta,2*eta*gradu,2*eta*gradu/driving);
    639:       THIViscosity(thi,0.5*PetscSqr(1e-3*gradu),&eta,&deta);
    640:       PetscPrintf(PetscObjectComm((PetscObject)thi),"Small velocity 1m/a  %8.2g, velocity gradient %8.2g, eta %8.2g, stress %8.2g, ratio %8.2g\n",1e-3*u,1e-3*gradu,eta,2*eta*1e-3*gradu,2*eta*1e-3*gradu/driving);
    641:     }
    642:   }

    644:   *inthi = thi;
    645:   return(0);
    646: }

    650: /* Our problem is periodic, but the domain has a mean slope of alpha so the bed does not line up between the upstream
    651:  * and downstream ends of the domain.  This function fixes the ghost values so that the domain appears truly periodic in
    652:  * the horizontal. */
    653: static PetscErrorCode THIFixGhosts(THI thi,DM da3,DM da2,Vec X3,Vec X2)
    654: {
    656:   DMDALocalInfo  info;
    657:   PrmNode        **x2;
    658:   PetscInt       i,j;

    661:   DMDAGetLocalInfo(da3,&info);
    662:   /* VecView(X2,PETSC_VIEWER_STDOUT_WORLD); */
    663:   DMDAVecGetArray(da2,X2,&x2);
    664:   for (i=info.gzs; i<info.gzs+info.gzm; i++) {
    665:     if (i > -1 && i < info.mz) continue;
    666:     for (j=info.gys; j<info.gys+info.gym; j++) {
    667:       x2[i][j].b += sin(thi->alpha) * thi->Lx * (i<0 ? 1.0 : -1.0);
    668:     }
    669:   }
    670:   DMDAVecRestoreArray(da2,X2,&x2);
    671:   /* VecView(X2,PETSC_VIEWER_STDOUT_WORLD); */
    672:   return(0);
    673: }

    677: static PetscErrorCode THIInitializePrm(THI thi,DM da2prm,PrmNode **p)
    678: {
    679:   PetscInt       i,j,xs,xm,ys,ym,mx,my;

    683:   DMDAGetGhostCorners(da2prm,&ys,&xs,0,&ym,&xm,0);
    684:   DMDAGetInfo(da2prm,0, &my,&mx,0, 0,0,0, 0,0,0,0,0,0);
    685:   for (i=xs; i<xs+xm; i++) {
    686:     for (j=ys; j<ys+ym; j++) {
    687:       PetscReal xx = thi->Lx*i/mx,yy = thi->Ly*j/my;
    688:       thi->initialize(thi,xx,yy,&p[i][j]);
    689:     }
    690:   }
    691:   return(0);
    692: }

    696: static PetscErrorCode THIInitial(THI thi,DM pack,Vec X)
    697: {
    698:   DM             da3,da2;
    699:   PetscInt       i,j,k,xs,xm,ys,ym,zs,zm,mx,my;
    700:   PetscReal      hx,hy;
    701:   PrmNode        **prm;
    702:   Node           ***x;
    703:   Vec            X3g,X2g,X2;

    707:   DMCompositeGetEntries(pack,&da3,&da2);
    708:   DMCompositeGetAccess(pack,X,&X3g,&X2g);
    709:   DMGetLocalVector(da2,&X2);

    711:   DMDAGetInfo(da3,0, 0,&my,&mx, 0,0,0, 0,0,0,0,0,0);
    712:   DMDAGetCorners(da3,&zs,&ys,&xs,&zm,&ym,&xm);
    713:   DMDAVecGetArray(da3,X3g,&x);
    714:   DMDAVecGetArray(da2,X2,&prm);

    716:   THIInitializePrm(thi,da2,prm);

    718:   hx = thi->Lx / mx;
    719:   hy = thi->Ly / my;
    720:   for (i=xs; i<xs+xm; i++) {
    721:     for (j=ys; j<ys+ym; j++) {
    722:       for (k=zs; k<zs+zm; k++) {
    723:         const PetscScalar zm1      = zm-1,
    724:                           drivingx = thi->rhog * (prm[i+1][j].b+prm[i+1][j].h - prm[i-1][j].b-prm[i-1][j].h) / (2*hx),
    725:                           drivingy = thi->rhog * (prm[i][j+1].b+prm[i][j+1].h - prm[i][j-1].b-prm[i][j-1].h) / (2*hy);
    726:         x[i][j][k].u = 0. * drivingx * prm[i][j].h*(PetscScalar)k/zm1;
    727:         x[i][j][k].v = 0. * drivingy * prm[i][j].h*(PetscScalar)k/zm1;
    728:       }
    729:     }
    730:   }

    732:   DMDAVecRestoreArray(da3,X3g,&x);
    733:   DMDAVecRestoreArray(da2,X2,&prm);

    735:   DMLocalToGlobalBegin(da2,X2,INSERT_VALUES,X2g);
    736:   DMLocalToGlobalEnd  (da2,X2,INSERT_VALUES,X2g);
    737:   DMRestoreLocalVector(da2,&X2);

    739:   DMCompositeRestoreAccess(pack,X,&X3g,&X2g);
    740:   return(0);
    741: }

    743: static void PointwiseNonlinearity(THI thi,const Node n[restrict 8],const PetscReal phi[restrict 3],PetscReal dphi[restrict 8][3],PetscScalar *restrict u,PetscScalar *restrict v,PetscScalar du[restrict 3],PetscScalar dv[restrict 3],PetscReal *eta,PetscReal *deta)
    744: {
    745:   PetscInt    l,ll;
    746:   PetscScalar gam;

    748:   du[0] = du[1] = du[2] = 0;
    749:   dv[0] = dv[1] = dv[2] = 0;
    750:   *u    = 0;
    751:   *v    = 0;
    752:   for (l=0; l<8; l++) {
    753:     *u += phi[l] * n[l].u;
    754:     *v += phi[l] * n[l].v;
    755:     for (ll=0; ll<3; ll++) {
    756:       du[ll] += dphi[l][ll] * n[l].u;
    757:       dv[ll] += dphi[l][ll] * n[l].v;
    758:     }
    759:   }
    760:   gam = Sqr(du[0]) + Sqr(dv[1]) + du[0]*dv[1] + 0.25*Sqr(du[1]+dv[0]) + 0.25*Sqr(du[2]) + 0.25*Sqr(dv[2]);
    761:   THIViscosity(thi,PetscRealPart(gam),eta,deta);
    762: }

    766: static PetscErrorCode THIFunctionLocal_3D(DMDALocalInfo *info,const Node ***x,const PrmNode **prm,const Node ***xdot,Node ***f,THI thi)
    767: {
    768:   PetscInt       xs,ys,xm,ym,zm,i,j,k,q,l;
    769:   PetscReal      hx,hy,etamin,etamax,beta2min,beta2max;

    773:   xs = info->zs;
    774:   ys = info->ys;
    775:   xm = info->zm;
    776:   ym = info->ym;
    777:   zm = info->xm;
    778:   hx = thi->Lx / info->mz;
    779:   hy = thi->Ly / info->my;

    781:   etamin   = 1e100;
    782:   etamax   = 0;
    783:   beta2min = 1e100;
    784:   beta2max = 0;

    786:   for (i=xs; i<xs+xm; i++) {
    787:     for (j=ys; j<ys+ym; j++) {
    788:       PrmNode pn[4],dpn[4][2];
    789:       QuadExtract(prm,i,j,pn);
    790:       QuadComputeGrad4(QuadQDeriv,hx,hy,pn,dpn);
    791:       for (k=0; k<zm-1; k++) {
    792:         PetscInt  ls = 0;
    793:         Node      n[8],ndot[8],*fn[8];
    794:         PetscReal zn[8],etabase = 0;
    795:         PrmHexGetZ(pn,k,zm,zn);
    796:         HexExtract(x,i,j,k,n);
    797:         HexExtract(xdot,i,j,k,ndot);
    798:         HexExtractRef(f,i,j,k,fn);
    799:         if (thi->no_slip && k == 0) {
    800:           for (l=0; l<4; l++) n[l].u = n[l].v = 0;
    801:           /* The first 4 basis functions lie on the bottom layer, so their contribution is exactly 0, hence we can skip them */
    802:           ls = 4;
    803:         }
    804:         for (q=0; q<8; q++) {
    805:           PetscReal   dz[3],phi[8],dphi[8][3],jw,eta,deta;
    806:           PetscScalar du[3],dv[3],u,v,udot=0,vdot=0;
    807:           for (l=ls; l<8; l++) {
    808:             udot += HexQInterp[q][l]*ndot[l].u;
    809:             vdot += HexQInterp[q][l]*ndot[l].v;
    810:           }
    811:           HexGrad(HexQDeriv[q],zn,dz);
    812:           HexComputeGeometry(q,hx,hy,dz,phi,dphi,&jw);
    813:           PointwiseNonlinearity(thi,n,phi,dphi,&u,&v,du,dv,&eta,&deta);
    814:           jw /= thi->rhog;      /* scales residuals to be O(1) */
    815:           if (q == 0) etabase = eta;
    816:           RangeUpdate(&etamin,&etamax,eta);
    817:           for (l=ls; l<8; l++) { /* test functions */
    818:             const PetscScalar ds[2] = {dpn[q%4][0].h+dpn[q%4][0].b, dpn[q%4][1].h+dpn[q%4][1].b};
    819:             const PetscReal   pp    = phi[l],*dp = dphi[l];
    820:             fn[l]->u += dp[0]*jw*eta*(4.*du[0]+2.*dv[1]) + dp[1]*jw*eta*(du[1]+dv[0]) + dp[2]*jw*eta*du[2] + pp*jw*thi->rhog*ds[0];
    821:             fn[l]->v += dp[1]*jw*eta*(2.*du[0]+4.*dv[1]) + dp[0]*jw*eta*(du[1]+dv[0]) + dp[2]*jw*eta*dv[2] + pp*jw*thi->rhog*ds[1];
    822:             fn[l]->u += pp*jw*udot*thi->inertia*pp;
    823:             fn[l]->v += pp*jw*vdot*thi->inertia*pp;
    824:           }
    825:         }
    826:         if (k == 0) { /* we are on a bottom face */
    827:           if (thi->no_slip) {
    828:             /* Note: Non-Galerkin coarse grid operators are very sensitive to the scaling of Dirichlet boundary
    829:             * conditions.  After shenanigans above, etabase contains the effective viscosity at the closest quadrature
    830:             * point to the bed.  We want the diagonal entry in the Dirichlet condition to have similar magnitude to the
    831:             * diagonal entry corresponding to the adjacent node.  The fundamental scaling of the viscous part is in
    832:             * diagu, diagv below.  This scaling is easy to recognize by considering the finite difference operator after
    833:             * scaling by element size.  The no-slip Dirichlet condition is scaled by this factor, and also in the
    834:             * assembled matrix (see the similar block in THIJacobianLocal).
    835:             *
    836:             * Note that the residual at this Dirichlet node is linear in the state at this node, but also depends
    837:             * (nonlinearly in general) on the neighboring interior nodes through the local viscosity.  This will make
    838:             * a matrix-free Jacobian have extra entries in the corresponding row.  We assemble only the diagonal part,
    839:             * so the solution will exactly satisfy the boundary condition after the first linear iteration.
    840:             */
    841:             const PetscReal   hz    = PetscRealPart(pn[0].h)/(zm-1.);
    842:             const PetscScalar diagu = 2*etabase/thi->rhog*(hx*hy/hz + hx*hz/hy + 4*hy*hz/hx),diagv = 2*etabase/thi->rhog*(hx*hy/hz + 4*hx*hz/hy + hy*hz/hx);
    843:             fn[0]->u = thi->dirichlet_scale*diagu*x[i][j][k].u;
    844:             fn[0]->v = thi->dirichlet_scale*diagv*x[i][j][k].v;
    845:           } else {              /* Integrate over bottom face to apply boundary condition */
    846:             for (q=0; q<4; q++) { /* We remove the explicit scaling of the residual by 1/rhog because beta2 already has that scaling to be O(1) */
    847:               const PetscReal jw = 0.25*hx*hy,*phi = QuadQInterp[q];
    848:               PetscScalar     u  =0,v=0,rbeta2=0;
    849:               PetscReal       beta2,dbeta2;
    850:               for (l=0; l<4; l++) {
    851:                 u     += phi[l]*n[l].u;
    852:                 v     += phi[l]*n[l].v;
    853:                 rbeta2 += phi[l]*pn[l].beta2;
    854:               }
    855:               THIFriction(thi,PetscRealPart(rbeta2),PetscRealPart(u*u+v*v)/2,&beta2,&dbeta2);
    856:               RangeUpdate(&beta2min,&beta2max,beta2);
    857:               for (l=0; l<4; l++) {
    858:                 const PetscReal pp = phi[l];
    859:                 fn[ls+l]->u += pp*jw*beta2*u;
    860:                 fn[ls+l]->v += pp*jw*beta2*v;
    861:               }
    862:             }
    863:           }
    864:         }
    865:       }
    866:     }
    867:   }

    869:   PRangeMinMax(&thi->eta,etamin,etamax);
    870:   PRangeMinMax(&thi->beta2,beta2min,beta2max);
    871:   return(0);
    872: }

    876: static PetscErrorCode THIFunctionLocal_2D(DMDALocalInfo *info,const Node ***x,const PrmNode **prm,const PrmNode **prmdot,PrmNode **f,THI thi)
    877: {
    878:   PetscInt xs,ys,xm,ym,zm,i,j,k;

    881:   xs = info->zs;
    882:   ys = info->ys;
    883:   xm = info->zm;
    884:   ym = info->ym;
    885:   zm = info->xm;

    887:   for (i=xs; i<xs+xm; i++) {
    888:     for (j=ys; j<ys+ym; j++) {
    889:       PetscScalar div = 0,erate,h[8];
    890:       PrmNodeGetFaceMeasure(prm,i,j,h);
    891:       for (k=0; k<zm; k++) {
    892:         PetscScalar weight = (k==0 || k == zm-1) ? 0.5/(zm-1) : 1.0/(zm-1);
    893:         if (0) {                /* centered flux */
    894:           div += (- weight*h[0] * StaggeredMidpoint2D(x[i][j][k].u,x[i-1][j][k].u, x[i-1][j-1][k].u,x[i][j-1][k].u)
    895:                   - weight*h[1] * StaggeredMidpoint2D(x[i][j][k].u,x[i-1][j][k].u, x[i-1][j+1][k].u,x[i][j+1][k].u)
    896:                   + weight*h[2] * StaggeredMidpoint2D(x[i][j][k].u,x[i+1][j][k].u, x[i+1][j+1][k].u,x[i][j+1][k].u)
    897:                   + weight*h[3] * StaggeredMidpoint2D(x[i][j][k].u,x[i+1][j][k].u, x[i+1][j-1][k].u,x[i][j-1][k].u)
    898:                   - weight*h[4] * StaggeredMidpoint2D(x[i][j][k].v,x[i][j-1][k].v, x[i+1][j-1][k].v,x[i+1][j][k].v)
    899:                   - weight*h[5] * StaggeredMidpoint2D(x[i][j][k].v,x[i][j-1][k].v, x[i-1][j-1][k].v,x[i-1][j][k].v)
    900:                   + weight*h[6] * StaggeredMidpoint2D(x[i][j][k].v,x[i][j+1][k].v, x[i-1][j+1][k].v,x[i-1][j][k].v)
    901:                   + weight*h[7] * StaggeredMidpoint2D(x[i][j][k].v,x[i][j+1][k].v, x[i+1][j+1][k].v,x[i+1][j][k].v));
    902:         } else {                /* Upwind flux */
    903:           div += weight*(-UpwindFluxXW(x,prm,h,i,j,k, 1)
    904:                          -UpwindFluxXW(x,prm,h,i,j,k,-1)
    905:                          +UpwindFluxXE(x,prm,h,i,j,k, 1)
    906:                          +UpwindFluxXE(x,prm,h,i,j,k,-1)
    907:                          -UpwindFluxYS(x,prm,h,i,j,k, 1)
    908:                          -UpwindFluxYS(x,prm,h,i,j,k,-1)
    909:                          +UpwindFluxYN(x,prm,h,i,j,k, 1)
    910:                          +UpwindFluxYN(x,prm,h,i,j,k,-1));
    911:         }
    912:       }
    913:       /* printf("div[%d][%d] %g\n",i,j,div); */
    914:       THIErosion(thi,&x[i][j][0],&erate,NULL);
    915:       f[i][j].b     = prmdot[i][j].b - erate;
    916:       f[i][j].h     = prmdot[i][j].h + div;
    917:       f[i][j].beta2 = prmdot[i][j].beta2;
    918:     }
    919:   }
    920:   return(0);
    921: }

    925: static PetscErrorCode THIFunction(TS ts,PetscReal t,Vec X,Vec Xdot,Vec F,void *ctx)
    926: {
    928:   THI            thi = (THI)ctx;
    929:   DM             pack,da3,da2;
    930:   Vec            X3,X2,Xdot3,Xdot2,F3,F2,F3g,F2g;
    931:   const Node     ***x3,***xdot3;
    932:   const PrmNode  **x2,**xdot2;
    933:   Node           ***f3;
    934:   PrmNode        **f2;
    935:   DMDALocalInfo  info3;

    938:   TSGetDM(ts,&pack);
    939:   DMCompositeGetEntries(pack,&da3,&da2);
    940:   DMDAGetLocalInfo(da3,&info3);
    941:   DMCompositeGetLocalVectors(pack,&X3,&X2);
    942:   DMCompositeGetLocalVectors(pack,&Xdot3,&Xdot2);
    943:   DMCompositeScatter(pack,X,X3,X2);
    944:   THIFixGhosts(thi,da3,da2,X3,X2);
    945:   DMCompositeScatter(pack,Xdot,Xdot3,Xdot2);

    947:   DMGetLocalVector(da3,&F3);
    948:   DMGetLocalVector(da2,&F2);
    949:   VecZeroEntries(F3);

    951:   DMDAVecGetArray(da3,X3,&x3);
    952:   DMDAVecGetArray(da2,X2,&x2);
    953:   DMDAVecGetArray(da3,Xdot3,&xdot3);
    954:   DMDAVecGetArray(da2,Xdot2,&xdot2);
    955:   DMDAVecGetArray(da3,F3,&f3);
    956:   DMDAVecGetArray(da2,F2,&f2);

    958:   THIFunctionLocal_3D(&info3,x3,x2,xdot3,f3,thi);
    959:   THIFunctionLocal_2D(&info3,x3,x2,xdot2,f2,thi);

    961:   DMDAVecRestoreArray(da3,X3,&x3);
    962:   DMDAVecRestoreArray(da2,X2,&x2);
    963:   DMDAVecRestoreArray(da3,Xdot3,&xdot3);
    964:   DMDAVecRestoreArray(da2,Xdot2,&xdot2);
    965:   DMDAVecRestoreArray(da3,F3,&f3);
    966:   DMDAVecRestoreArray(da2,F2,&f2);

    968:   DMCompositeRestoreLocalVectors(pack,&X3,&X2);
    969:   DMCompositeRestoreLocalVectors(pack,&Xdot3,&Xdot2);

    971:   VecZeroEntries(F);
    972:   DMCompositeGetAccess(pack,F,&F3g,&F2g);
    973:   DMLocalToGlobalBegin(da3,F3,ADD_VALUES,F3g);
    974:   DMLocalToGlobalEnd  (da3,F3,ADD_VALUES,F3g);
    975:   DMLocalToGlobalBegin(da2,F2,INSERT_VALUES,F2g);
    976:   DMLocalToGlobalEnd  (da2,F2,INSERT_VALUES,F2g);

    978:   if (thi->verbose) {
    979:     PetscViewer viewer;
    980:     PetscViewerASCIIGetStdout(PetscObjectComm((PetscObject)thi),&viewer);
    981:     PetscViewerASCIIPrintf(viewer,"3D_Velocity residual (bs=2):\n");
    982:     PetscViewerASCIIPushTab(viewer);
    983:     VecView(F3,viewer);
    984:     PetscViewerASCIIPopTab(viewer);
    985:     PetscViewerASCIIPrintf(viewer,"2D_Fields residual (bs=3):\n");
    986:     PetscViewerASCIIPushTab(viewer);
    987:     VecView(F2,viewer);
    988:     PetscViewerASCIIPopTab(viewer);
    989:   }

    991:   DMCompositeRestoreAccess(pack,F,&F3g,&F2g);

    993:   DMRestoreLocalVector(da3,&F3);
    994:   DMRestoreLocalVector(da2,&F2);
    995:   return(0);
    996: }

    1000: static PetscErrorCode THIMatrixStatistics(THI thi,Mat B,PetscViewer viewer)
    1001: {
    1003:   PetscReal      nrm;
    1004:   PetscInt       m;
    1005:   PetscMPIInt    rank;

    1008:   MatNorm(B,NORM_FROBENIUS,&nrm);
    1009:   MatGetSize(B,&m,0);
    1010:   MPI_Comm_rank(PetscObjectComm((PetscObject)B),&rank);
    1011:   if (!rank) {
    1012:     PetscScalar val0,val2;
    1013:     MatGetValue(B,0,0,&val0);
    1014:     MatGetValue(B,2,2,&val2);
    1015:     PetscViewerASCIIPrintf(viewer,"Matrix dim %8d  norm %8.2e, (0,0) %8.2e  (2,2) %8.2e, eta [%8.2e,%8.2e] beta2 [%8.2e,%8.2e]\n",m,nrm,PetscRealPart(val0),PetscRealPart(val2),thi->eta.cmin,thi->eta.cmax,thi->beta2.cmin,thi->beta2.cmax);
    1016:   }
    1017:   return(0);
    1018: }

    1022: static PetscErrorCode THISurfaceStatistics(DM pack,Vec X,PetscReal *min,PetscReal *max,PetscReal *mean)
    1023: {
    1025:   DM             da3,da2;
    1026:   Vec            X3,X2;
    1027:   Node           ***x;
    1028:   PetscInt       i,j,xs,ys,zs,xm,ym,zm,mx,my,mz;
    1029:   PetscReal      umin = 1e100,umax=-1e100;
    1030:   PetscScalar    usum =0.0,gusum;

    1033:   DMCompositeGetEntries(pack,&da3,&da2);
    1034:   DMCompositeGetAccess(pack,X,&X3,&X2);
    1035:   *min = *max = *mean = 0;
    1036:   DMDAGetInfo(da3,0, &mz,&my,&mx, 0,0,0, 0,0,0,0,0,0);
    1037:   DMDAGetCorners(da3,&zs,&ys,&xs,&zm,&ym,&xm);
    1038:   if (zs != 0 || zm != mz) SETERRQ(PETSC_COMM_SELF,1,"Unexpected decomposition");
    1039:   DMDAVecGetArray(da3,X3,&x);
    1040:   for (i=xs; i<xs+xm; i++) {
    1041:     for (j=ys; j<ys+ym; j++) {
    1042:       PetscReal u = PetscRealPart(x[i][j][zm-1].u);
    1043:       RangeUpdate(&umin,&umax,u);
    1044:       usum += u;
    1045:     }
    1046:   }
    1047:   DMDAVecRestoreArray(da3,X3,&x);
    1048:   DMCompositeRestoreAccess(pack,X,&X3,&X2);

    1050:   MPI_Allreduce(&umin,min,1,MPIU_REAL,MPIU_MIN,PetscObjectComm((PetscObject)da3));
    1051:   MPI_Allreduce(&umax,max,1,MPIU_REAL,MPIU_MAX,PetscObjectComm((PetscObject)da3));
    1052:   MPI_Allreduce(&usum,&gusum,1,MPIU_SCALAR,MPIU_SUM,PetscObjectComm((PetscObject)da3));
    1053:   *mean = PetscRealPart(gusum) / (mx*my);
    1054:   return(0);
    1055: }

    1059: static PetscErrorCode THISolveStatistics(THI thi,TS ts,PetscInt coarsened,const char name[])
    1060: {
    1061:   MPI_Comm       comm;
    1062:   DM             pack;
    1063:   Vec            X,X3,X2;

    1067:   PetscObjectGetComm((PetscObject)thi,&comm);
    1068:   TSGetDM(ts,&pack);
    1069:   TSGetSolution(ts,&X);
    1070:   DMCompositeGetAccess(pack,X,&X3,&X2);
    1071:   PetscPrintf(comm,"Solution statistics after solve: %s\n",name);
    1072:   {
    1073:     PetscInt            its,lits;
    1074:     SNESConvergedReason reason;
    1075:     SNES                snes;
    1076:     TSGetSNES(ts,&snes);
    1077:     SNESGetIterationNumber(snes,&its);
    1078:     SNESGetConvergedReason(snes,&reason);
    1079:     SNESGetLinearSolveIterations(snes,&lits);
    1080:     PetscPrintf(comm,"%s: Number of SNES iterations = %d, total linear iterations = %d\n",SNESConvergedReasons[reason],its,lits);
    1081:   }
    1082:   {
    1083:     PetscReal   nrm2,tmin[3]={1e100,1e100,1e100},tmax[3]={-1e100,-1e100,-1e100},min[3],max[3];
    1084:     PetscInt    i,j,m;
    1085:     PetscScalar *x;
    1086:     VecNorm(X3,NORM_2,&nrm2);
    1087:     VecGetLocalSize(X3,&m);
    1088:     VecGetArray(X3,&x);
    1089:     for (i=0; i<m; i+=2) {
    1090:       PetscReal u = PetscRealPart(x[i]),v = PetscRealPart(x[i+1]),c = PetscSqrtReal(u*u+v*v);
    1091:       tmin[0] = PetscMin(u,tmin[0]);
    1092:       tmin[1] = PetscMin(v,tmin[1]);
    1093:       tmin[2] = PetscMin(c,tmin[2]);
    1094:       tmax[0] = PetscMax(u,tmax[0]);
    1095:       tmax[1] = PetscMax(v,tmax[1]);
    1096:       tmax[2] = PetscMax(c,tmax[2]);
    1097:     }
    1098:     VecRestoreArray(X,&x);
    1099:     MPI_Allreduce(tmin,min,3,MPIU_REAL,MPIU_MIN,PetscObjectComm((PetscObject)thi));
    1100:     MPI_Allreduce(tmax,max,3,MPIU_REAL,MPIU_MAX,PetscObjectComm((PetscObject)thi));
    1101:     /* Dimensionalize to meters/year */
    1102:     nrm2 *= thi->units->year / thi->units->meter;
    1103:     for (j=0; j<3; j++) {
    1104:       min[j] *= thi->units->year / thi->units->meter;
    1105:       max[j] *= thi->units->year / thi->units->meter;
    1106:     }
    1107:     PetscPrintf(comm,"|X|_2 %g   u in [%g, %g]   v in [%g, %g]   c in [%g, %g] \n",nrm2,min[0],max[0],min[1],max[1],min[2],max[2]);
    1108:     {
    1109:       PetscReal umin,umax,umean;
    1110:       THISurfaceStatistics(pack,X,&umin,&umax,&umean);
    1111:       umin  *= thi->units->year / thi->units->meter;
    1112:       umax  *= thi->units->year / thi->units->meter;
    1113:       umean *= thi->units->year / thi->units->meter;
    1114:       PetscPrintf(comm,"Surface statistics: u in [%12.6e, %12.6e] mean %12.6e\n",umin,umax,umean);
    1115:     }
    1116:     /* These values stay nondimensional */
    1117:     PetscPrintf(comm,"Global eta range   [%g, %g], converged range [%g, %g]\n",thi->eta.min,thi->eta.max,thi->eta.cmin,thi->eta.cmax);
    1118:     PetscPrintf(comm,"Global beta2 range [%g, %g], converged range [%g, %g]\n",thi->beta2.min,thi->beta2.max,thi->beta2.cmin,thi->beta2.cmax);
    1119:   }
    1120:   PetscPrintf(comm,"\n");
    1121:   DMCompositeRestoreAccess(pack,X,&X3,&X2);
    1122:   return(0);
    1123: }

    1125: static inline PetscInt DMDALocalIndex3D(DMDALocalInfo *info,PetscInt i,PetscInt j,PetscInt k)
    1126: {return ((i-info->gzs)*info->gym + (j-info->gys))*info->gxm + (k-info->gxs);}
    1127: static inline PetscInt DMDALocalIndex2D(DMDALocalInfo *info,PetscInt i,PetscInt j)
    1128: {return (i-info->gzs)*info->gym + (j-info->gys);}

    1132: static PetscErrorCode THIJacobianLocal_Momentum(DMDALocalInfo *info,const Node ***x,const PrmNode **prm,Mat B,Mat Bcpl,THI thi)
    1133: {
    1134:   PetscInt       xs,ys,xm,ym,zm,i,j,k,q,l,ll;
    1135:   PetscReal      hx,hy;

    1139:   xs = info->zs;
    1140:   ys = info->ys;
    1141:   xm = info->zm;
    1142:   ym = info->ym;
    1143:   zm = info->xm;
    1144:   hx = thi->Lx / info->mz;
    1145:   hy = thi->Ly / info->my;

    1147:   for (i=xs; i<xs+xm; i++) {
    1148:     for (j=ys; j<ys+ym; j++) {
    1149:       PrmNode pn[4],dpn[4][2];
    1150:       QuadExtract(prm,i,j,pn);
    1151:       QuadComputeGrad4(QuadQDeriv,hx,hy,pn,dpn);
    1152:       for (k=0; k<zm-1; k++) {
    1153:         Node        n[8];
    1154:         PetscReal   zn[8],etabase = 0;
    1155:         PetscScalar Ke[8*NODE_SIZE][8*NODE_SIZE],Kcpl[8*NODE_SIZE][4*PRMNODE_SIZE];
    1156:         PetscInt    ls = 0;

    1158:         PrmHexGetZ(pn,k,zm,zn);
    1159:         HexExtract(x,i,j,k,n);
    1160:         PetscMemzero(Ke,sizeof(Ke));
    1161:         PetscMemzero(Kcpl,sizeof(Kcpl));
    1162:         if (thi->no_slip && k == 0) {
    1163:           for (l=0; l<4; l++) n[l].u = n[l].v = 0;
    1164:           ls = 4;
    1165:         }
    1166:         for (q=0; q<8; q++) {
    1167:           PetscReal   dz[3],phi[8],dphi[8][3],jw,eta,deta;
    1168:           PetscScalar du[3],dv[3],u,v;
    1169:           HexGrad(HexQDeriv[q],zn,dz);
    1170:           HexComputeGeometry(q,hx,hy,dz,phi,dphi,&jw);
    1171:           PointwiseNonlinearity(thi,n,phi,dphi,&u,&v,du,dv,&eta,&deta);
    1172:           jw /= thi->rhog;      /* residuals are scaled by this factor */
    1173:           if (q == 0) etabase = eta;
    1174:           for (l=ls; l<8; l++) { /* test functions */
    1175:             const PetscReal pp=phi[l],*restrict dp = dphi[l];
    1176:             for (ll=ls; ll<8; ll++) { /* trial functions */
    1177:               const PetscReal *restrict dpl = dphi[ll];
    1178:               PetscScalar dgdu,dgdv;
    1179:               dgdu = 2.*du[0]*dpl[0] + dv[1]*dpl[0] + 0.5*(du[1]+dv[0])*dpl[1] + 0.5*du[2]*dpl[2];
    1180:               dgdv = 2.*dv[1]*dpl[1] + du[0]*dpl[1] + 0.5*(du[1]+dv[0])*dpl[0] + 0.5*dv[2]*dpl[2];
    1181:               /* Picard part */
    1182:               Ke[l*2+0][ll*2+0] += dp[0]*jw*eta*4.*dpl[0] + dp[1]*jw*eta*dpl[1] + dp[2]*jw*eta*dpl[2];
    1183:               Ke[l*2+0][ll*2+1] += dp[0]*jw*eta*2.*dpl[1] + dp[1]*jw*eta*dpl[0];
    1184:               Ke[l*2+1][ll*2+0] += dp[1]*jw*eta*2.*dpl[0] + dp[0]*jw*eta*dpl[1];
    1185:               Ke[l*2+1][ll*2+1] += dp[1]*jw*eta*4.*dpl[1] + dp[0]*jw*eta*dpl[0] + dp[2]*jw*eta*dpl[2];
    1186:               /* extra Newton terms */
    1187:               Ke[l*2+0][ll*2+0] += dp[0]*jw*deta*dgdu*(4.*du[0]+2.*dv[1]) + dp[1]*jw*deta*dgdu*(du[1]+dv[0]) + dp[2]*jw*deta*dgdu*du[2];
    1188:               Ke[l*2+0][ll*2+1] += dp[0]*jw*deta*dgdv*(4.*du[0]+2.*dv[1]) + dp[1]*jw*deta*dgdv*(du[1]+dv[0]) + dp[2]*jw*deta*dgdv*du[2];
    1189:               Ke[l*2+1][ll*2+0] += dp[1]*jw*deta*dgdu*(4.*dv[1]+2.*du[0]) + dp[0]*jw*deta*dgdu*(du[1]+dv[0]) + dp[2]*jw*deta*dgdu*dv[2];
    1190:               Ke[l*2+1][ll*2+1] += dp[1]*jw*deta*dgdv*(4.*dv[1]+2.*du[0]) + dp[0]*jw*deta*dgdv*(du[1]+dv[0]) + dp[2]*jw*deta*dgdv*dv[2];
    1191:               /* inertial part */
    1192:               Ke[l*2+0][ll*2+0] += pp*jw*thi->inertia*pp;
    1193:               Ke[l*2+1][ll*2+1] += pp*jw*thi->inertia*pp;
    1194:             }
    1195:             for (ll=0; ll<4; ll++) { /* Trial functions for surface/bed */
    1196:               const PetscReal dpl[] = {QuadQDeriv[q%4][ll][0]/hx, QuadQDeriv[q%4][ll][1]/hy}; /* surface = h + b */
    1197:               Kcpl[FieldIndex(Node,l,u)][FieldIndex(PrmNode,ll,h)] += pp*jw*thi->rhog*dpl[0];
    1198:               Kcpl[FieldIndex(Node,l,u)][FieldIndex(PrmNode,ll,b)] += pp*jw*thi->rhog*dpl[0];
    1199:               Kcpl[FieldIndex(Node,l,v)][FieldIndex(PrmNode,ll,h)] += pp*jw*thi->rhog*dpl[1];
    1200:               Kcpl[FieldIndex(Node,l,v)][FieldIndex(PrmNode,ll,b)] += pp*jw*thi->rhog*dpl[1];
    1201:             }
    1202:           }
    1203:         }
    1204:         if (k == 0) { /* on a bottom face */
    1205:           if (thi->no_slip) {
    1206:             const PetscReal   hz    = PetscRealPart(pn[0].h)/(zm-1);
    1207:             const PetscScalar diagu = 2*etabase/thi->rhog*(hx*hy/hz + hx*hz/hy + 4*hy*hz/hx),diagv = 2*etabase/thi->rhog*(hx*hy/hz + 4*hx*hz/hy + hy*hz/hx);
    1208:             Ke[0][0] = thi->dirichlet_scale*diagu;
    1209:             Ke[0][1] = 0;
    1210:             Ke[1][0] = 0;
    1211:             Ke[1][1] = thi->dirichlet_scale*diagv;
    1212:           } else {
    1213:             for (q=0; q<4; q++) { /* We remove the explicit scaling by 1/rhog because beta2 already has that scaling to be O(1) */
    1214:               const PetscReal jw = 0.25*hx*hy,*phi = QuadQInterp[q];
    1215:               PetscScalar     u  =0,v=0,rbeta2=0;
    1216:               PetscReal       beta2,dbeta2;
    1217:               for (l=0; l<4; l++) {
    1218:                 u      += phi[l]*n[l].u;
    1219:                 v      += phi[l]*n[l].v;
    1220:                 rbeta2 += phi[l]*pn[l].beta2;
    1221:               }
    1222:               THIFriction(thi,PetscRealPart(rbeta2),PetscRealPart(u*u+v*v)/2,&beta2,&dbeta2);
    1223:               for (l=0; l<4; l++) {
    1224:                 const PetscReal pp = phi[l];
    1225:                 for (ll=0; ll<4; ll++) {
    1226:                   const PetscReal ppl = phi[ll];
    1227:                   Ke[l*2+0][ll*2+0] += pp*jw*beta2*ppl + pp*jw*dbeta2*u*u*ppl;
    1228:                   Ke[l*2+0][ll*2+1] +=                   pp*jw*dbeta2*u*v*ppl;
    1229:                   Ke[l*2+1][ll*2+0] +=                   pp*jw*dbeta2*v*u*ppl;
    1230:                   Ke[l*2+1][ll*2+1] += pp*jw*beta2*ppl + pp*jw*dbeta2*v*v*ppl;
    1231:                 }
    1232:               }
    1233:             }
    1234:           }
    1235:         }
    1236:         {
    1237:           const PetscInt rc3blocked[8] = {
    1238:             DMDALocalIndex3D(info,i+0,j+0,k+0),
    1239:             DMDALocalIndex3D(info,i+1,j+0,k+0),
    1240:             DMDALocalIndex3D(info,i+1,j+1,k+0),
    1241:             DMDALocalIndex3D(info,i+0,j+1,k+0),
    1242:             DMDALocalIndex3D(info,i+0,j+0,k+1),
    1243:             DMDALocalIndex3D(info,i+1,j+0,k+1),
    1244:             DMDALocalIndex3D(info,i+1,j+1,k+1),
    1245:             DMDALocalIndex3D(info,i+0,j+1,k+1)
    1246:           },col2blocked[PRMNODE_SIZE*4] = {
    1247:             DMDALocalIndex2D(info,i+0,j+0),
    1248:             DMDALocalIndex2D(info,i+1,j+0),
    1249:             DMDALocalIndex2D(info,i+1,j+1),
    1250:             DMDALocalIndex2D(info,i+0,j+1)
    1251:           };
    1252: #if !defined COMPUTE_LOWER_TRIANGULAR /* fill in lower-triangular part, this is really cheap compared to computing the entries */
    1253:           for (l=0; l<8; l++) {
    1254:             for (ll=l+1; ll<8; ll++) {
    1255:               Ke[ll*2+0][l*2+0] = Ke[l*2+0][ll*2+0];
    1256:               Ke[ll*2+1][l*2+0] = Ke[l*2+0][ll*2+1];
    1257:               Ke[ll*2+0][l*2+1] = Ke[l*2+1][ll*2+0];
    1258:               Ke[ll*2+1][l*2+1] = Ke[l*2+1][ll*2+1];
    1259:             }
    1260:           }
    1261: #endif
    1262:           MatSetValuesBlockedLocal(B,8,rc3blocked,8,rc3blocked,&Ke[0][0],ADD_VALUES); /* velocity-velocity coupling can use blocked insertion */
    1263:           {                     /* The off-diagonal part cannot (yet) */
    1264:             PetscInt row3scalar[NODE_SIZE*8],col2scalar[PRMNODE_SIZE*4];
    1265:             for (l=0; l<8; l++) for (ll=0; ll<NODE_SIZE; ll++) row3scalar[l*NODE_SIZE+ll] = rc3blocked[l]*NODE_SIZE+ll;
    1266:             for (l=0; l<4; l++) for (ll=0; ll<PRMNODE_SIZE; ll++) col2scalar[l*PRMNODE_SIZE+ll] = col2blocked[l]*PRMNODE_SIZE+ll;
    1267:             MatSetValuesLocal(Bcpl,8*NODE_SIZE,row3scalar,4*PRMNODE_SIZE,col2scalar,&Kcpl[0][0],ADD_VALUES);
    1268:           }
    1269:         }
    1270:       }
    1271:     }
    1272:   }
    1273:   return(0);
    1274: }

    1278: static PetscErrorCode THIJacobianLocal_2D(DMDALocalInfo *info,const Node ***x3,const PrmNode **x2,const PrmNode **xdot2,PetscReal a,Mat B22,Mat B21,THI thi)
    1279: {
    1281:   PetscInt       xs,ys,xm,ym,zm,i,j,k;

    1284:   xs = info->zs;
    1285:   ys = info->ys;
    1286:   xm = info->zm;
    1287:   ym = info->ym;
    1288:   zm = info->xm;

    1290:   if (zm > 1024) SETERRQ(((PetscObject)info->da)->comm,PETSC_ERR_SUP,"Need to allocate more space");
    1291:   for (i=xs; i<xs+xm; i++) {
    1292:     for (j=ys; j<ys+ym; j++) {
    1293:       {                         /* Self-coupling */
    1294:         const PetscInt    row[]  = {DMDALocalIndex2D(info,i,j)};
    1295:         const PetscInt    col[]  = {DMDALocalIndex2D(info,i,j)};
    1296:         const PetscScalar vals[] = {
    1297:           a,0,0,
    1298:           0,a,0,
    1299:           0,0,a
    1300:         };
    1301:         MatSetValuesBlockedLocal(B22,1,row,1,col,vals,INSERT_VALUES);
    1302:       }
    1303:       for (k=0; k<zm; k++) {    /* Coupling to velocity problem */
    1304:         /* Use a cheaper quadrature than for residual evaluation, because it is much sparser */
    1305:         const PetscInt row[]  = {FieldIndex(PrmNode,DMDALocalIndex2D(info,i,j),h)};
    1306:         const PetscInt cols[] = {
    1307:           FieldIndex(Node,DMDALocalIndex3D(info,i-1,j,k),u),
    1308:           FieldIndex(Node,DMDALocalIndex3D(info,i  ,j,k),u),
    1309:           FieldIndex(Node,DMDALocalIndex3D(info,i+1,j,k),u),
    1310:           FieldIndex(Node,DMDALocalIndex3D(info,i,j-1,k),v),
    1311:           FieldIndex(Node,DMDALocalIndex3D(info,i,j  ,k),v),
    1312:           FieldIndex(Node,DMDALocalIndex3D(info,i,j+1,k),v)
    1313:         };
    1314:         const PetscScalar
    1315:           w  = (k && k<zm-1) ? 0.5 : 0.25,
    1316:           hW = w*(x2[i-1][j  ].h+x2[i  ][j  ].h)/(zm-1.),
    1317:           hE = w*(x2[i  ][j  ].h+x2[i+1][j  ].h)/(zm-1.),
    1318:           hS = w*(x2[i  ][j-1].h+x2[i  ][j  ].h)/(zm-1.),
    1319:           hN = w*(x2[i  ][j  ].h+x2[i  ][j+1].h)/(zm-1.);
    1320:         PetscScalar *vals,
    1321:                      vals_upwind[] = {((PetscRealPart(x3[i][j][k].u) > 0) ? -hW : 0),
    1322:                                       ((PetscRealPart(x3[i][j][k].u) > 0) ? +hE : -hW),
    1323:                                       ((PetscRealPart(x3[i][j][k].u) > 0) ?  0  : +hE),
    1324:                                       ((PetscRealPart(x3[i][j][k].v) > 0) ? -hS : 0),
    1325:                                       ((PetscRealPart(x3[i][j][k].v) > 0) ? +hN : -hS),
    1326:                                       ((PetscRealPart(x3[i][j][k].v) > 0) ?  0  : +hN)},
    1327:                      vals_centered[] = {-0.5*hW, 0.5*(-hW+hE), 0.5*hE,
    1328:                                         -0.5*hS, 0.5*(-hS+hN), 0.5*hN};
    1329:         vals = 1 ? vals_upwind : vals_centered;
    1330:         if (k == 0) {
    1331:           Node derate;
    1332:           THIErosion(thi,&x3[i][j][0],NULL,&derate);
    1333:           vals[1] -= derate.u;
    1334:           vals[4] -= derate.v;
    1335:         }
    1336:         MatSetValuesLocal(B21,1,row,6,cols,vals,INSERT_VALUES);
    1337:       }
    1338:     }
    1339:   }
    1340:   return(0);
    1341: }

    1345: static PetscErrorCode THIJacobian(TS ts,PetscReal t,Vec X,Vec Xdot,PetscReal a,Mat *A,Mat *B,MatStructure *mstr,void *ctx)
    1346: {
    1348:   THI            thi = (THI)ctx;
    1349:   DM             pack,da3,da2;
    1350:   Vec            X3,X2,Xdot2;
    1351:   Mat            B11,B12,B21,B22;
    1352:   DMDALocalInfo  info3;
    1353:   IS             *isloc;
    1354:   const Node     ***x3;
    1355:   const PrmNode  **x2,**xdot2;

    1358:   TSGetDM(ts,&pack);
    1359:   DMCompositeGetEntries(pack,&da3,&da2);
    1360:   DMDAGetLocalInfo(da3,&info3);
    1361:   DMCompositeGetLocalVectors(pack,&X3,&X2);
    1362:   DMCompositeGetLocalVectors(pack,NULL,&Xdot2);
    1363:   DMCompositeScatter(pack,X,X3,X2);
    1364:   THIFixGhosts(thi,da3,da2,X3,X2);
    1365:   DMCompositeScatter(pack,Xdot,NULL,Xdot2);

    1367:   MatZeroEntries(*B);

    1369:   DMCompositeGetLocalISs(pack,&isloc);
    1370:   MatGetLocalSubMatrix(*B,isloc[0],isloc[0],&B11);
    1371:   MatGetLocalSubMatrix(*B,isloc[0],isloc[1],&B12);
    1372:   MatGetLocalSubMatrix(*B,isloc[1],isloc[0],&B21);
    1373:   MatGetLocalSubMatrix(*B,isloc[1],isloc[1],&B22);

    1375:   DMDAVecGetArray(da3,X3,&x3);
    1376:   DMDAVecGetArray(da2,X2,&x2);
    1377:   DMDAVecGetArray(da2,Xdot2,&xdot2);

    1379:   THIJacobianLocal_Momentum(&info3,x3,x2,B11,B12,thi);

    1381:   /* Need to switch from ADD_VALUES to INSERT_VALUES */
    1382:   MatAssemblyBegin(*B,MAT_FLUSH_ASSEMBLY);
    1383:   MatAssemblyEnd(*B,MAT_FLUSH_ASSEMBLY);

    1385:   THIJacobianLocal_2D(&info3,x3,x2,xdot2,a,B22,B21,thi);

    1387:   DMDAVecRestoreArray(da3,X3,&x3);
    1388:   DMDAVecRestoreArray(da2,X2,&x2);
    1389:   DMDAVecRestoreArray(da2,Xdot2,&xdot2);

    1391:   MatRestoreLocalSubMatrix(*B,isloc[0],isloc[0],&B11);
    1392:   MatRestoreLocalSubMatrix(*B,isloc[0],isloc[1],&B12);
    1393:   MatRestoreLocalSubMatrix(*B,isloc[1],isloc[0],&B21);
    1394:   MatRestoreLocalSubMatrix(*B,isloc[1],isloc[1],&B22);
    1395:   ISDestroy(&isloc[0]);
    1396:   ISDestroy(&isloc[1]);
    1397:   PetscFree(isloc);

    1399:   DMCompositeRestoreLocalVectors(pack,&X3,&X2);
    1400:   DMCompositeRestoreLocalVectors(pack,0,&Xdot2);

    1402:   MatAssemblyBegin(*B,MAT_FINAL_ASSEMBLY);
    1403:   MatAssemblyEnd(*B,MAT_FINAL_ASSEMBLY);
    1404:   if (*A != *B) {
    1405:     MatAssemblyBegin(*A,MAT_FINAL_ASSEMBLY);
    1406:     MatAssemblyEnd(*A,MAT_FINAL_ASSEMBLY);
    1407:   }
    1408:   *mstr = SAME_NONZERO_PATTERN;
    1409:   if (thi->verbose) {THIMatrixStatistics(thi,*B,PETSC_VIEWER_STDOUT_WORLD);}
    1410:   return(0);
    1411: }

    1415: /* VTK's XML formats are so brain-dead that they can't handle multiple grids in the same file.  Since the communication
    1416:  * can be shared between the two grids, we write two files at once, one for velocity (living on a 3D grid defined by
    1417:  * h=thickness and b=bed) and another for all properties living on the 2D grid.
    1418:  */
    1419: static PetscErrorCode THIDAVecView_VTK_XML(THI thi,DM pack,Vec X,const char filename[],const char filename2[])
    1420: {
    1421:   const PetscInt dof   = NODE_SIZE,dof2 = PRMNODE_SIZE;
    1422:   Units          units = thi->units;
    1423:   MPI_Comm       comm;
    1425:   PetscViewer    viewer3,viewer2;
    1426:   PetscMPIInt    rank,size,tag,nn,nmax,nn2,nmax2;
    1427:   PetscInt       mx,my,mz,r,range[6];
    1428:   PetscScalar    *x,*x2;
    1429:   DM             da3,da2;
    1430:   Vec            X3,X2;

    1433:   PetscObjectGetComm((PetscObject)thi,&comm);
    1434:   DMCompositeGetEntries(pack,&da3,&da2);
    1435:   DMCompositeGetAccess(pack,X,&X3,&X2);
    1436:   DMDAGetInfo(da3,0, &mz,&my,&mx, 0,0,0, 0,0,0,0,0,0);
    1437:   MPI_Comm_size(comm,&size);
    1438:   MPI_Comm_rank(comm,&rank);
    1439:   PetscViewerASCIIOpen(comm,filename,&viewer3);
    1440:   PetscViewerASCIIOpen(comm,filename2,&viewer2);
    1441:   PetscViewerASCIIPrintf(viewer3,"<VTKFile type=\"StructuredGrid\" version=\"0.1\" byte_order=\"LittleEndian\">\n");
    1442:   PetscViewerASCIIPrintf(viewer2,"<VTKFile type=\"StructuredGrid\" version=\"0.1\" byte_order=\"LittleEndian\">\n");
    1443:   PetscViewerASCIIPrintf(viewer3,"  <StructuredGrid WholeExtent=\"%d %d %d %d %d %d\">\n",0,mz-1,0,my-1,0,mx-1);
    1444:   PetscViewerASCIIPrintf(viewer2,"  <StructuredGrid WholeExtent=\"%d %d %d %d %d %d\">\n",0,0,0,my-1,0,mx-1);

    1446:   DMDAGetCorners(da3,range,range+1,range+2,range+3,range+4,range+5);
    1447:   PetscMPIIntCast(range[3]*range[4]*range[5]*dof,&nn);
    1448:   MPI_Reduce(&nn,&nmax,1,MPI_INT,MPI_MAX,0,comm);
    1449:   PetscMPIIntCast(range[4]*range[5]*dof2,&nn2);
    1450:   MPI_Reduce(&nn2,&nmax2,1,MPI_INT,MPI_MAX,0,comm);
    1451:   tag  = ((PetscObject)viewer3)->tag;
    1452:   VecGetArray(X3,&x);
    1453:   VecGetArray(X2,&x2);
    1454:   if (!rank) {
    1455:     PetscScalar *array,*array2;
    1456:     PetscMalloc2(nmax,PetscScalar,&array,nmax2,PetscScalar,&array2);
    1457:     for (r=0; r<size; r++) {
    1458:       PetscInt i,j,k,f,xs,xm,ys,ym,zs,zm;
    1459:       Node     *y3;
    1460:       PetscScalar (*y2)[PRMNODE_SIZE];
    1461:       MPI_Status status;
    1462:       if (r) {
    1463:         MPI_Recv(range,6,MPIU_INT,r,tag,comm,MPI_STATUS_IGNORE);
    1464:       }
    1465:       zs = range[0];ys = range[1];xs = range[2];zm = range[3];ym = range[4];xm = range[5];
    1466:       if (xm*ym*zm*dof > nmax) SETERRQ(PETSC_COMM_SELF,1,"should not happen");
    1467:       if (r) {
    1468:         MPI_Recv(array,nmax,MPIU_SCALAR,r,tag,comm,&status);
    1469:         MPI_Get_count(&status,MPIU_SCALAR,&nn);
    1470:         if (nn != xm*ym*zm*dof) SETERRQ(PETSC_COMM_SELF,1,"corrupt da3 send");
    1471:         y3   = (Node*)array;
    1472:         MPI_Recv(array2,nmax2,MPIU_SCALAR,r,tag,comm,&status);
    1473:         MPI_Get_count(&status,MPIU_SCALAR,&nn2);
    1474:         if (nn2 != xm*ym*dof2) SETERRQ(PETSC_COMM_SELF,1,"corrupt da2 send");
    1475:         y2 = (PetscScalar(*)[PRMNODE_SIZE])array2;
    1476:       } else {
    1477:         y3 = (Node*)x;
    1478:         y2 = (PetscScalar(*)[PRMNODE_SIZE])x2;
    1479:       }
    1480:       PetscViewerASCIIPrintf(viewer3,"    <Piece Extent=\"%d %d %d %d %d %d\">\n",zs,zs+zm-1,ys,ys+ym-1,xs,xs+xm-1);
    1481:       PetscViewerASCIIPrintf(viewer2,"    <Piece Extent=\"%d %d %d %d %d %d\">\n",0,0,ys,ys+ym-1,xs,xs+xm-1);

    1483:       PetscViewerASCIIPrintf(viewer3,"      <Points>\n");
    1484:       PetscViewerASCIIPrintf(viewer2,"      <Points>\n");
    1485:       PetscViewerASCIIPrintf(viewer3,"        <DataArray type=\"Float32\" NumberOfComponents=\"3\" format=\"ascii\">\n");
    1486:       PetscViewerASCIIPrintf(viewer2,"        <DataArray type=\"Float32\" NumberOfComponents=\"3\" format=\"ascii\">\n");
    1487:       for (i=xs; i<xs+xm; i++) {
    1488:         for (j=ys; j<ys+ym; j++) {
    1489:           PetscReal
    1490:             xx = thi->Lx*i/mx,
    1491:             yy = thi->Ly*j/my,
    1492:             b  = PetscRealPart(y2[i*ym+j][FieldOffset(PrmNode,b)]),
    1493:             h  = PetscRealPart(y2[i*ym+j][FieldOffset(PrmNode,h)]);
    1494:           for (k=zs; k<zs+zm; k++) {
    1495:             PetscReal zz = b + h*k/(mz-1.);
    1496:             PetscViewerASCIIPrintf(viewer3,"%f %f %f\n",xx,yy,zz);
    1497:           }
    1498:           PetscViewerASCIIPrintf(viewer2,"%f %f %f\n",xx,yy,(double)0.0);
    1499:         }
    1500:       }
    1501:       PetscViewerASCIIPrintf(viewer3,"        </DataArray>\n");
    1502:       PetscViewerASCIIPrintf(viewer2,"        </DataArray>\n");
    1503:       PetscViewerASCIIPrintf(viewer3,"      </Points>\n");
    1504:       PetscViewerASCIIPrintf(viewer2,"      </Points>\n");

    1506:       {                         /* Velocity and rank (3D) */
    1507:         PetscViewerASCIIPrintf(viewer3,"      <PointData>\n");
    1508:         PetscViewerASCIIPrintf(viewer3,"        <DataArray type=\"Float32\" Name=\"velocity\" NumberOfComponents=\"3\" format=\"ascii\">\n");
    1509:         for (i=0; i<nn/dof; i++) {
    1510:           PetscViewerASCIIPrintf(viewer3,"%f %f %f\n",PetscRealPart(y3[i].u)*units->year/units->meter,PetscRealPart(y3[i].v)*units->year/units->meter,0.0);
    1511:         }
    1512:         PetscViewerASCIIPrintf(viewer3,"        </DataArray>\n");

    1514:         PetscViewerASCIIPrintf(viewer3,"        <DataArray type=\"Int32\" Name=\"rank\" NumberOfComponents=\"1\" format=\"ascii\">\n");
    1515:         for (i=0; i<nn; i+=dof) {
    1516:           PetscViewerASCIIPrintf(viewer3,"%d\n",r);
    1517:         }
    1518:         PetscViewerASCIIPrintf(viewer3,"        </DataArray>\n");
    1519:         PetscViewerASCIIPrintf(viewer3,"      </PointData>\n");
    1520:       }

    1522:       {                         /* 2D */
    1523:         PetscViewerASCIIPrintf(viewer2,"      <PointData>\n");
    1524:         for (f=0; f<PRMNODE_SIZE; f++) {
    1525:           const char *fieldname;
    1526:           DMDAGetFieldName(da2,f,&fieldname);
    1527:           PetscViewerASCIIPrintf(viewer2,"        <DataArray type=\"Float32\" Name=\"%s\" format=\"ascii\">\n",fieldname);
    1528:           for (i=0; i<nn2/PRMNODE_SIZE; i++) {
    1529:             PetscViewerASCIIPrintf(viewer2,"%g\n",y2[i][f]);
    1530:           }
    1531:           PetscViewerASCIIPrintf(viewer2,"        </DataArray>\n");
    1532:         }
    1533:         PetscViewerASCIIPrintf(viewer2,"      </PointData>\n");
    1534:       }

    1536:       PetscViewerASCIIPrintf(viewer3,"    </Piece>\n");
    1537:       PetscViewerASCIIPrintf(viewer2,"    </Piece>\n");
    1538:     }
    1539:     PetscFree2(array,array2);
    1540:   } else {
    1541:     MPI_Send(range,6,MPIU_INT,0,tag,comm);
    1542:     MPI_Send(x,nn,MPIU_SCALAR,0,tag,comm);
    1543:     MPI_Send(x2,nn2,MPIU_SCALAR,0,tag,comm);
    1544:   }
    1545:   VecRestoreArray(X3,&x);
    1546:   VecRestoreArray(X2,&x2);
    1547:   PetscViewerASCIIPrintf(viewer3,"  </StructuredGrid>\n");
    1548:   PetscViewerASCIIPrintf(viewer2,"  </StructuredGrid>\n");

    1550:   DMCompositeRestoreAccess(pack,X,&X3,&X2);
    1551:   PetscViewerASCIIPrintf(viewer3,"</VTKFile>\n");
    1552:   PetscViewerASCIIPrintf(viewer2,"</VTKFile>\n");
    1553:   PetscViewerDestroy(&viewer3);
    1554:   PetscViewerDestroy(&viewer2);
    1555:   return(0);
    1556: }

    1560: static PetscErrorCode THITSMonitor(TS ts,PetscInt step,PetscReal t,Vec X,void *ctx)
    1561: {
    1563:   THI            thi = (THI)ctx;
    1564:   DM             pack;
    1565:   char           filename3[PETSC_MAX_PATH_LEN],filename2[PETSC_MAX_PATH_LEN];

    1568:   PetscPrintf(PetscObjectComm((PetscObject)ts),"%3D: t=%G\n",step,t);
    1569:   if (thi->monitor_interval && step % thi->monitor_interval) return(0);
    1570:   TSGetDM(ts,&pack);
    1571:   PetscSNPrintf(filename3,sizeof(filename3),"%s-3d-%03d.vts",thi->monitor_basename,step);
    1572:   PetscSNPrintf(filename2,sizeof(filename2),"%s-2d-%03d.vts",thi->monitor_basename,step);
    1573:   THIDAVecView_VTK_XML(thi,pack,X,filename3,filename2);
    1574:   return(0);
    1575: }

    1580: static PetscErrorCode THICreateDM3d(THI thi,DM *dm3d)
    1581: {
    1582:   MPI_Comm       comm;
    1583:   PetscInt       M    = 3,N = 3,P = 2;
    1584:   DM             da;

    1588:   PetscObjectGetComm((PetscObject)thi,&comm);
    1589:   PetscOptionsBegin(comm,NULL,"Grid resolution options","");
    1590:   {
    1591:     PetscOptionsInt("-M","Number of elements in x-direction on coarse level","",M,&M,NULL);
    1592:     N    = M;
    1593:     PetscOptionsInt("-N","Number of elements in y-direction on coarse level (if different from M)","",N,&N,NULL);
    1594:     PetscOptionsInt("-P","Number of elements in z-direction on coarse level","",P,&P,NULL);
    1595:   }
    1596:   PetscOptionsEnd();
    1597:   DMDACreate3d(comm,DMDA_BOUNDARY_NONE,DMDA_BOUNDARY_PERIODIC,DMDA_BOUNDARY_PERIODIC,DMDA_STENCIL_BOX,P,N,M,1,PETSC_DETERMINE,PETSC_DETERMINE,sizeof(Node)/sizeof(PetscScalar),1,0,0,0,&da);
    1598:   DMDASetFieldName(da,0,"x-velocity");
    1599:   DMDASetFieldName(da,1,"y-velocity");
    1600:   *dm3d = da;
    1601:   return(0);
    1602: }

    1606: int main(int argc,char *argv[])
    1607: {
    1608:   MPI_Comm       comm;
    1609:   DM             pack,da3,da2;
    1610:   TS             ts;
    1611:   THI            thi;
    1612:   Vec            X;
    1613:   Mat            B;
    1614:   PetscInt       i,steps;
    1615:   PetscReal      ftime;

    1618:   PetscInitialize(&argc,&argv,0,help);
    1619:   comm = PETSC_COMM_WORLD;

    1621:   THICreate(comm,&thi);
    1622:   THICreateDM3d(thi,&da3);
    1623:   {
    1624:     PetscInt        Mx,My,mx,my,s;
    1625:     DMDAStencilType st;
    1626:     DMDAGetInfo(da3,0, 0,&My,&Mx, 0,&my,&mx, 0,&s,0,0,0,&st);
    1627:     DMDACreate2d(PetscObjectComm((PetscObject)thi),DMDA_BOUNDARY_PERIODIC,DMDA_BOUNDARY_PERIODIC,st,My,Mx,my,mx,sizeof(PrmNode)/sizeof(PetscScalar),s,0,0,&da2);
    1628:   }

    1630:   PetscObjectSetName((PetscObject)da3,"3D_Velocity");
    1631:   DMSetOptionsPrefix(da3,"f3d_");
    1632:   DMDASetFieldName(da3,0,"u");
    1633:   DMDASetFieldName(da3,1,"v");
    1634:   PetscObjectSetName((PetscObject)da2,"2D_Fields");
    1635:   DMSetOptionsPrefix(da2,"f2d_");
    1636:   DMDASetFieldName(da2,0,"b");
    1637:   DMDASetFieldName(da2,1,"h");
    1638:   DMDASetFieldName(da2,2,"beta2");
    1639:   DMCompositeCreate(comm,&pack);
    1640:   DMCompositeAddDM(pack,da3);
    1641:   DMCompositeAddDM(pack,da2);
    1642:   DMDestroy(&da3);
    1643:   DMDestroy(&da2);
    1644:   DMSetUp(pack);
    1645:   DMCreateMatrix(pack,NULL,&B);
    1646:   MatSetOption(B,MAT_NEW_NONZERO_LOCATION_ERR,PETSC_FALSE);
    1647:   MatSetOptionsPrefix(B,"thi_");

    1649:   for (i=0; i<thi->nlevels; i++) {
    1650:     PetscReal Lx = thi->Lx / thi->units->meter,Ly = thi->Ly / thi->units->meter,Lz = thi->Lz / thi->units->meter;
    1651:     PetscInt  Mx,My,Mz;
    1652:     DMCompositeGetEntries(pack,&da3,&da2);
    1653:     DMDAGetInfo(da3,0, &Mz,&My,&Mx, 0,0,0, 0,0,0,0,0,0);
    1654:     PetscPrintf(PetscObjectComm((PetscObject)thi),"Level %d domain size (m) %8.2g x %8.2g x %8.2g, num elements %3d x %3d x %3d (%8d), size (m) %g x %g x %g\n",i,Lx,Ly,Lz,Mx,My,Mz,Mx*My*Mz,Lx/Mx,Ly/My,1000./(Mz-1));
    1655:   }

    1657:   DMCreateGlobalVector(pack,&X);
    1658:   THIInitial(thi,pack,X);

    1660:   TSCreate(comm,&ts);
    1661:   TSSetDM(ts,pack);
    1662:   TSSetProblemType(ts,TS_NONLINEAR);
    1663:   TSMonitorSet(ts,THITSMonitor,thi,NULL);
    1664:   TSSetType(ts,TSTHETA);
    1665:   TSSetIFunction(ts,NULL,THIFunction,thi);
    1666:   TSSetIJacobian(ts,B,B,THIJacobian,thi);
    1667:   TSSetDuration(ts,100,10.0);
    1668:   TSSetSolution(ts,X);
    1669:   TSSetInitialTimeStep(ts,0.,1e-3);
    1670:   TSSetFromOptions(ts);

    1672:   TSSolve(ts,X);
    1673:   TSGetSolveTime(ts,&ftime);
    1674:   TSGetTimeStepNumber(ts,&steps);
    1675:   PetscPrintf(PETSC_COMM_WORLD,"Steps %D  final time %G\n",steps,ftime);

    1677:   if (0) {THISolveStatistics(thi,ts,0,"Full");}

    1679:   {
    1680:     PetscBool flg;
    1681:     char      filename[PETSC_MAX_PATH_LEN] = "";
    1682:     PetscOptionsGetString(NULL,"-o",filename,sizeof(filename),&flg);
    1683:     if (flg) {
    1684:       THIDAVecView_VTK_XML(thi,pack,X,filename,NULL);
    1685:     }
    1686:   }

    1688:   VecDestroy(&X);
    1689:   MatDestroy(&B);
    1690:   DMDestroy(&pack);
    1691:   TSDestroy(&ts);
    1692:   THIDestroy(&thi);
    1693:   PetscFinalize();
    1694:   return 0;
    1695: }