Пример #1
0
/**==============================================================================
 * Copy whole structure from device memory to host memory
 */
void copy_gpu_mem_to_gpu(Grid_gpu *pG_host, Grid_gpu *pG_gpu_dev) {
  cudaError_t code;
  code = cudaMemcpy(pG_host, pG_gpu_dev, sizeof(Grid_gpu), cudaMemcpyDeviceToHost);
  if(code != cudaSuccess) {
    ath_error("[copy_gpu_to_gpu_mem] error: %s\n", cudaGetErrorString(code));
  }
}
void update_starparticles(GridS *pG, Cons1DS ***x1Flux, Cons1DS ***x2Flux,
                          Cons1DS ***x3Flux)
{
  StarParListS *pList=NULL;
  StarParS *pStar=NULL;
  int ip,jp,kp;
  Real minv,dm,dM1,dM2,dM3;
  
  pList = pG->Lstars;
  while (pList) {
    pStar = &(pList->starpar);
    cc_ijk(pG,pStar->x1,pStar->x2,pStar->x3,&ip,&jp,&kp);
    
    mass_inflow(pG,pStar,x1Flux,x2Flux,x3Flux,&dm,&dM1,&dM2,&dM3);
    if (dm > 0.0) {
      minv = 1.0/(pStar->m+dm);
      pStar->v1 = (pStar->m*pStar->v1+dM1)*minv;
      pStar->v2 = (pStar->m*pStar->v2+dM2)*minv;
      pStar->v3 = (pStar->m*pStar->v3+dM3)*minv;
      pStar->m += dm;
      pStar->mdot = dm/pG->dt;
    }
    if(pStar->m < 0) ath_error("[update_SP] mass cannot be negative!\n");
    
    pList = pList->next;
  }
  return;
}
Пример #3
0
static void add_par_line(Block *bp, char *line)
{
  char *cp;
  char *name, *equal=NULL, *value=NULL, *hash=NULL, *comment=NULL, *nul;

  if(bp == NULL)
    ath_error("[add_par_line]: (no block name) while parsing line \n%s\n",line);

  name = skipwhite(line);           /* name */

  for(cp = name; *cp != '\0'; cp++){/* Find the first '=' and '#' */
    if(*cp == '='){
      if(equal == NULL){
	equal = cp;                 /* store the equals sign location */
	value = skipwhite(cp + 1);  /* value */
      }
    }
    if(*cp == '#'){
      hash = cp;                    /* store the hash sign location */
      comment = skipwhite(cp + 1);  /* comment */
      break;
    }
  }

  while(*cp != '\0') cp++;          /* Find the NUL terminator */
  nul = cp;

  if(equal == NULL)
    ath_error("No '=' found in line \"%s\"\n",line);

  str_term(equal);                  /* Terminate the name string */

  if(hash == NULL){
    str_term(nul);                  /* Terminate the value string */
  }
  else{
    str_term(hash);                 /* Terminate the value string */

    if(*comment == '\0')
      comment = NULL;               /* Comment field is empty */
    else
      str_term(nul);                /* Terminate the comment string */
  }

  add_par(bp,name,value,comment);
}
void dump_history_enroll(const ConsFun_t pfun, const char *label){

  if(usr_hst_cnt >= MAX_USR_H_COUNT)
    ath_error("[dump_history_enroll]: MAX_USR_H_COUNT = %d exceeded\n",
	      MAX_USR_H_COUNT);

/* Copy the label string */
  if((usr_label[usr_hst_cnt] = ath_strdup(label)) == NULL)
    ath_error("[dump_history_enroll]: Error on sim_strdup(\"%s\")\n",label);

/* Store the function pointer */
  phst_fun[usr_hst_cnt] = pfun;

  usr_hst_cnt++;

  return;

}
Пример #5
0
/*! \fn void ludcmp(Real **a, int n, int *indx, Real *d)
 *  \brief LU decomposition from Numerical Recipes
 *
 * Using Crout's method with partial pivoting
 * a is the input matrix, and is returned with LU decomposition readily made,
 * n is the matrix size, indx records the history of row permutation,
 * whereas d =1(-1) for even(odd) number of permutations.
 */
void ludcmp(Real **a, int n, int *indx, Real *d)
{
  int i,imax,j,k;
  Real big,dum,sum,temp;
  Real *rowscale;  /* the implicit scaling of each row */

  rowscale = (Real*)calloc_1d_array(n, sizeof(Real));
  *d=1.0;  /* No row interchanges yet */

  for (i=0;i<n;i++)
  { /* Loop over rows to get the implicit scaling information */
    big=0.0;
    for (j=0;j<n;j++)
      if ((temp=fabs(a[i][j])) > big) big=temp;
    if (big == 0.0) ath_error("[LUdecomp]:Input matrix is singular!");
    rowscale[i]=1.0/big;  /* Save the scaling */
  }

  for (j=0;j<n;j++) { /* Loop over columns of Crout's method */
    /* Calculate the upper block */
    for (i=0;i<j;i++) {
      sum=a[i][j];
      for (k=0;k<i;k++) sum -= a[i][k]*a[k][j];
      a[i][j]=sum;
    }
    /* Calculate the lower block (first step) */
    big=0.0;
    for (i=j;i<n;i++) {
      sum=a[i][j];
      for (k=0;k<j;k++)
        sum -= a[i][k]*a[k][j];
      a[i][j]=sum;
      /* search for the largest pivot element */
      if ( (dum=rowscale[i]*fabs(sum)) >= big) {
        big=dum;
        imax=i;
      }
    }
    /* row interchange */
    if (j != imax) {
      for (k=0;k<n;k++) {
        dum=a[imax][k];
        a[imax][k]=a[j][k];
        a[j][k]=dum;
      }
      *d = -(*d);
      rowscale[imax]=rowscale[j];
    }
    indx[j]=imax; /* record row interchange history */
    /* Calculate the lower block (second step) */
    if (a[j][j] == 0.0) a[j][j]=TINY_NUMBER;
    dum=1.0/(a[j][j]);
    for (i=j+1;i<n;i++) a[i][j] *= dum;
  }
  free(rowscale);
}
Пример #6
0
void problem(DomainS *pDomain)
{
  GridS *pGrid = pDomain->Grid;
  int i, is = pGrid->is, ie = pGrid->ie;
  int j, js = pGrid->js, je = pGrid->je;
  int k, ks = pGrid->ks, ke = pGrid->ke;
  int ir,irefine,nx2;
  Real d_in,p_in,d_out,p_out,Ly,rootdx2;

/* Set up the grid bounds for initializing the grid */
  if (pGrid->Nx[0] <= 1 || pGrid->Nx[1] <= 1) {
    ath_error("[problem]: This problem requires Nx1 > 1, Nx2 > 1\n");
  }

  d_in = par_getd("problem","d_in");
  p_in = par_getd("problem","p_in");

  d_out = par_getd("problem","d_out");
  p_out = par_getd("problem","p_out");

/* Find number of Nx2 cells on root grid.  At x=0, interface is at nx2/2 */

  irefine = 1;
  for (ir=1;ir<=pDomain->Level;ir++) irefine *= 2;

  Ly = pDomain->RootMaxX[1] - pDomain->RootMinX[1];
  rootdx2 = pGrid->dx2*((double)(irefine));
  nx2 = (int)(Ly/rootdx2);
  nx2 /= 2;

/* Initialize the grid */
  for (k=ks; k<=ke; k++) {
    for (j=js; j<=je; j++) {
      for (i=is; i<=ie; i++) {
	pGrid->U[k][j][i].M1 = 0.0;
	pGrid->U[k][j][i].M2 = 0.0;
	pGrid->U[k][j][i].M3 = 0.0;

	if(((j-js + pDomain->Disp[1])+(i-is + pDomain->Disp[0])) > (nx2*irefine)) {
	  pGrid->U[k][j][i].d  = d_out;
#ifndef ISOTHERMAL
	  pGrid->U[k][j][i].E = p_out/Gamma_1;
#endif
	} else {
	  pGrid->U[k][j][i].d  = d_in;
#ifndef ISOTHERMAL
	  pGrid->U[k][j][i].E = p_in/Gamma_1;
#endif
	}
      }
    }
  }

  return;
}
Пример #7
0
static void *calloc_1d_array(size_t nc, size_t size)
{
  void *array;

  if ((array = (void *)calloc(nc,size)) == NULL) {
    ath_error("[calloc_1d] failed to allocate memory (%d of size %d)\n",
              (int)nc,(int)size);
    return NULL;
  }
  return array;
}
Пример #8
0
int initialize_code(){
#ifdef MPI_PARALLEL
/* Get my task id (rank in MPI) */
  if(MPI_SUCCESS != MPI_Comm_rank(MPI_COMM_WORLD,&(level0_Grid.my_id)))
    ath_error("Error on calling MPI_Comm_rank\n");

/* Get the number of processes */
  if(MPI_SUCCESS != MPI_Comm_size(MPI_COMM_WORLD,&(level0_Grid.nproc)))
    ath_error("Error on calling MPI_Comm_size\n");
#else
  level0_Grid.my_id = 0;
  level0_Grid.nproc = 1;
#endif

  par_open("/dev/null"); /* to trick athena into thinking it has opened a parameter file, will not work on windows */
  is_restart = 0;
  show_config_par();   /* Add the configure block to the parameter database */
  
  
  return 0;
}
Пример #9
0
void par_cmdline(int argc, char *argv[])
{
  int i;
  char *sp, *ep;
  char *block, *name, *value;
  Block *bp;
  Par *pp;
  int len;

  if (debug) printf("PAR_CMDLINE: \n");
  for (i=1; i<argc; i++) {
    block = argv[i];
    sp = strchr(block,'/');
    if ((sp = strchr(block,'/')) == NULL) continue;
    *sp = '\0';
    name = sp + 1;

    if((ep = strchr(name,'=')) == NULL){
      *sp = '/'; /* Repair argv[i] */
      continue;
    }
    *ep = '\0';
    value = ep + 1;

    if (debug) printf("PAR_CMDLINE: %s/%s=%s\n",block,name,value);
    bp = find_block(block);
    if (bp == NULL) ath_error("par_cmdline: Block \"%s\" not found\n",block);
    pp = find_par(bp,name);
    if (pp == NULL) ath_error("par_cmdline: Par \"%s\" not found\n",name);
    free(pp->value);
    pp->value = my_strdup(value);

    len = (int)strlen(value); /* Update the maximum Par value length */
    bp->max_value_len = len > bp->max_value_len ? len : bp->max_value_len;

/* Repair argv[i] */
    *sp = '/';
    *ep = '=';
  }
}
Пример #10
0
int main(int argc, char *argv[])
{
  int mytid;
/* int numprocs; */
  int  namelen;
  char processor_name[MPI_MAX_PROCESSOR_NAME];

  par_debug(0);

  if(MPI_SUCCESS != MPI_Init(&argc,&argv))
    ath_error("Error on calling MPI_Init\n");
/* Get the number of processes */
/* MPI_Comm_size(MPI_COMM_WORLD,&numprocs); */
/* Get my task id, or rank as it is called in MPI */
  MPI_Comm_rank(MPI_COMM_WORLD,&mytid);
/* Get the name of the processor or machine name */
  MPI_Get_processor_name(processor_name,&namelen);

  printf("My task id / rank = %d on %s\n",mytid, processor_name);

/* Parent and child have different jobs */
  if(mytid != 0)
    printf("My Parent's task id / rank = 0\n");
  else{
    printf("I am the Parent\n");

    if (argc == 1) {
      printf("Usage: %s par-file [block-name par-name]\n",argv[0]);
      exit(0);
    }

    par_open(argv[1]);
    par_cmdline(argc,argv);
    if (argc == 4) {
      char *cp = par_gets(argv[2],argv[3]);
      printf("PAR_GETS: %s.%s = \"%s\"\n",argv[2],argv[3],cp);
      printf("PAR_GETI: %s.%s = \"%d\" as integer\n",
        argv[2],argv[3],par_geti(argv[2],argv[3]));
      printf("PAR_GETD: %s.%s = \"%g\" as double\n",
        argv[2],argv[3],par_getd(argv[2],argv[3]));
      free(cp);
    }
  }
 
  par_dist_mpi(mytid,MPI_COMM_WORLD);
  par_dump(0,stdout);
  par_close();

  MPI_Finalize();

  return 0;
}
Пример #11
0
/**==============================================================================
 * Copy back grid structures from GPU device memory to
 * grid structure in host memory
 */
void copy_to_host_mem(Grid *pG, Grid_gpu *pG_gpu) {
  cudaError_t code;
  int i, Nx2T, Nx1T;

  if (pG->Nx2 > 1)
    Nx2T = pG->Nx2 + 2*nghost;
  else
    Nx2T = 1;

  if (pG->Nx1 > 1)
    Nx1T = pG->Nx1 + 2*nghost;
  else
    Nx1T = 1;

  /* Copy row by row */
  for(i=0; i<Nx2T; i++) {
    /* U */
    code = cudaMemcpy(pG->U[i], pG_gpu->U+i*Nx1T, sizeof(Gas)*Nx1T, cudaMemcpyDeviceToHost);
    if(code != cudaSuccess) {
      ath_error("[copy_to_host_mem U] error: %s\n", cudaGetErrorString(code));
    }
    /* B1i */
    code = cudaMemcpy(pG->B1i[i], pG_gpu->B1i+i*Nx1T, sizeof(Real)*Nx1T, cudaMemcpyDeviceToHost);
    if(code != cudaSuccess) {
      ath_error("[copy_to_host_mem B1i] error: %s\n", cudaGetErrorString(code));
    }
    /* B2i */
    code = cudaMemcpy(pG->B2i[i], pG_gpu->B2i+i*Nx1T, sizeof(Real)*Nx1T, cudaMemcpyDeviceToHost);
    if(code != cudaSuccess) {
      ath_error("[copy_to_host_mem B2i] error: %s\n", cudaGetErrorString(code));
    }
    /* B3i */
    code = cudaMemcpy(pG->B3i[i], pG_gpu->B3i+i*Nx1T, sizeof(Real)*Nx1T, cudaMemcpyDeviceToHost);
    if(code != cudaSuccess) {
      ath_error("[copy_to_host_mem B3i] error: %s\n", cudaGetErrorString(code));
    }
  }
}
Пример #12
0
static char *line_block_name(char *line) 
{
  char *sp, *cp;

/* We assume that (*line == '<') is true */
/* Skip leading white space and remember the start of block name */
  sp = cp = skipwhite(line+1);
  while (*cp != '\0' && *cp != '>')
    cp++;
  if (*cp != '>') ath_error("Blockname %s does not appear terminated\n",sp);
  str_term(cp);      /* patch the line and remove any trailing white space */

  return sp;         /* return pointer into the now patched input string */
}
Пример #13
0
void Userwork_in_loop(MeshS *pM)
{
  GridS *pGrid;
  int nl,nd;
  Real newtime;

  for (nl=0; nl<(pM->NLevels); nl++){
    for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
      if (pM->Domain[nl][nd].Grid != NULL){

        pGrid = pM->Domain[nl][nd].Grid;

        if (isnan(pGrid->dt)) ath_error("Time step is NaN!");

        if (idrive == 0) {  /* driven turbulence */
          /* Integration has already been done, but time not yet updated */
          newtime = pGrid->time + pGrid->dt;

#ifndef IMPULSIVE_DRIVING
          /* Drive on every time step */
          perturb(pGrid, pGrid->dt);
#endif /* IMPULSIVE_DRIVING */

          if (newtime >= (tdrive+dtdrive)) {
            /* If we start with large time steps so that tdrive would get way
             * behind newtime, this makes sure we don't keep generating after
             * dropping down to smaller time steps */
            while ((tdrive+dtdrive) <= newtime) tdrive += dtdrive;

#ifdef IMPULSIVE_DRIVING
              /* Only drive at intervals of dtdrive */
              perturb(pGrid, dtdrive);
#endif /* IMPULSIVE_DRIVING */

              /* Compute new spectrum after dtdrive.  Putting this after perturb()
               * means we won't be applying perturbations from a new power spectrum
               * just before writing outputs.  At the very beginning, we'll go a
               * little longer before regenerating, but the energy injection rate
               * was off on the very first timestep anyway.  When studying driven
               * turbulence, all we care about is the saturated state. */
              generate();
          }
        }
      }
    }
  }

  return;
}
Пример #14
0
/**==============================================================================
 * Copy grid from CPU host memory to prepared GPU grid (also host memory).
 * It will copy U, and B1i, B2i, B3i from host memeory to device
 */
void copy_to_gpu_mem(Grid_gpu *pG_gpu, Grid *pG) {

  cudaError_t code;
  int i, Nx2T, Nx1T;

  /* Calculate physical size of grid */
  if (pG->Nx2 > 1)
    Nx2T = pG->Nx2 + 2*nghost;
  else
    Nx2T = 1;

  if (pG->Nx1 > 1)
    Nx1T = pG->Nx1 + 2*nghost;
  else
    Nx1T = 1;

  /* Start copying rows of gas variables from host to device memory */
  for(i=0; i<Nx2T; i++) {
    code = cudaMemcpy(pG_gpu->U+i*Nx1T+nghost, pG->U[i], sizeof(Gas)*(Nx1T-nghost), cudaMemcpyHostToDevice);
    if(code != cudaSuccess) {
      ath_error("[copy_to_gpu_mem U] error: %s\n", cudaGetErrorString(code));
    }
    code = cudaMemcpy(pG_gpu->B1i+i*Nx1T+nghost, pG->B1i[i], sizeof(Real)*(Nx1T-nghost), cudaMemcpyHostToDevice);
    if(code != cudaSuccess) {
      ath_error("[copy_to_gpu_mem B1i] error: %s\n", cudaGetErrorString(code));
    }
    code = cudaMemcpy(pG_gpu->B2i+i*Nx1T+nghost, pG->B2i[i], sizeof(Real)*(Nx1T-nghost), cudaMemcpyHostToDevice);
    if(code != cudaSuccess) {
      ath_error("[copy_to_gpu_mem B2i] error: %s\n", cudaGetErrorString(code));
    }
    code = cudaMemcpy(pG_gpu->B3i+i*Nx1T+nghost, pG->B3i[i], sizeof(Real)*(Nx1T-nghost), cudaMemcpyHostToDevice);
    if(code != cudaSuccess) {
      ath_error("[copy_to_gpu_mem B3i] error: %s\n", cudaGetErrorString(code));
    }
  }
}
Пример #15
0
/*! \fn void integrate_init_2d(MeshS *pM)
 *  \brief Allocate temporary integration arrays 
*/
void integrate_init_2d(MeshS *pM)
{
  int nmax,size1=0,size2=0,size3=0,nl,nd;

/* Cycle over all Grids on this processor to find maximum Nx1, Nx2, Nx3 */
  for (nl=0; nl<(pM->NLevels); nl++){
    for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
      if (pM->Domain[nl][nd].Grid != NULL) {
        if (pM->Domain[nl][nd].Grid->Nx[0] > size1){
          size1 = pM->Domain[nl][nd].Grid->Nx[0];
        }
        if (pM->Domain[nl][nd].Grid->Nx[1] > size2){
          size2 = pM->Domain[nl][nd].Grid->Nx[1];
        }
        if (pM->Domain[nl][nd].Grid->Nx[2] > size3){
          size3 = pM->Domain[nl][nd].Grid->Nx[2];
        }
      }
    }
  }

  size1 = size1 + 2*nghost;
  size2 = size2 + 2*nghost;
  size3 = size3 + 2*nghost;
  nmax = MAX((MAX(size1,size2)),size3);

/*refer to material  integrate_2d_ctu.c*/
  if ((Bxc = (Real*)malloc(nmax*sizeof(Real))) == NULL) goto on_error;
  if ((Bxi = (Real*)malloc(nmax*sizeof(Real))) == NULL) goto on_error;


  if ((U1d= (Cons1DS*)malloc(nmax*sizeof(Cons1DS))) == NULL) goto on_error;
  if ((W  = (Prim1DS*)malloc(nmax*sizeof(Prim1DS))) == NULL) goto on_error;

  if ((x1Flux   =(Cons1DS**)calloc_2d_array(size2,size1,sizeof(Cons1DS)))==NULL)
    goto on_error;
  if ((x2Flux   =(Cons1DS**)calloc_2d_array(size2,size1,sizeof(Cons1DS)))==NULL)
    goto on_error;



  return;

  on_error:
    integrate_destruct();
    ath_error("[integrate_init]: malloc returned a NULL pointer\n");
}
Пример #16
0
void get_myGridIndex(DomainS *pD, const int myID,
                     int *pi, int *pj, int *pk)
{
  int i, j, k;
  for (k=0; k<(pD->NGrid[2]); k++){
    for (j=0; j<(pD->NGrid[1]); j++){
      for (i=0; i<(pD->NGrid[0]); i++){
        if (pD->GData[k][j][i].ID_Comm_world == myID) {
          *pi = i;  *pj = j;  *pk = k;
          return;
        }
      }
    }
  }

  ath_error("[get_myGridIndex]: Can't find ID=%i in GData\n", myID);
}
Пример #17
0
Real qsimp(Real (*func)(Real), const Real a, const Real b) 
{
  int j;
  Real s,st,ost,os;

  ost = os = -1.0e30;
  for (j=1; j<=JMAX; j++) {
    st = trapzd(func,a,b,j,ost);
    s = (4.0*st-ost)/3.0;  /* EQUIVALENT TO SIMPSON'S RULE */
    if (j > 5)  /* AVOID SPURIOUS EARLY CONVERGENCE. */
      if (fabs(s-os) < EPS*fabs(os) || (s == 0.0 && os == 0.0)) return s;
    os=s;
    ost=st;
  }

  ath_error("[qsimp]:  Too many steps!\n");
  return 0.0;
}
Пример #18
0
/*! \fn void integrate_init_1d(MeshS *pM)
 *  \brief Allocate temporary integration arrays */
void integrate_init_1d(MeshS *pM)
{
  int size1=0,nl,nd;

/* Cycle over all Grids on this processor to find maximum Nx1 */
  for (nl=0; nl<(pM->NLevels); nl++){
    for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
      if (pM->Domain[nl][nd].Grid != NULL) {
        if (pM->Domain[nl][nd].Grid->Nx[0] > size1){
          size1 = pM->Domain[nl][nd].Grid->Nx[0];
        }
      }
    }
  }

  size1 = size1 + 2*nghost;

  if ((Wl_x1Face=(Prim1DS*)malloc(size1*sizeof(Prim1DS))) ==NULL) goto on_error;
  if ((Wr_x1Face=(Prim1DS*)malloc(size1*sizeof(Prim1DS))) ==NULL) goto on_error;
  if ((x1Flux   =(Cons1DS*)malloc(size1*sizeof(Cons1DS))) ==NULL) goto on_error;

  if ((Bxc = (Real*)malloc(size1*sizeof(Real))) == NULL) goto on_error;
  if ((Bxi = (Real*)malloc(size1*sizeof(Real))) == NULL) goto on_error;

  if ((U1d= (Cons1DS*)malloc(size1*sizeof(Cons1DS))) == NULL) goto on_error;
  if ((Ul = (Cons1DS*)malloc(size1*sizeof(Cons1DS))) == NULL) goto on_error;
  if ((Ur = (Cons1DS*)malloc(size1*sizeof(Cons1DS))) == NULL) goto on_error;
  if ((W  = (Prim1DS*)malloc(size1*sizeof(Prim1DS))) == NULL) goto on_error;
  if ((Wl = (Prim1DS*)malloc(size1*sizeof(Prim1DS))) == NULL) goto on_error;
  if ((Wr = (Prim1DS*)malloc(size1*sizeof(Prim1DS))) == NULL) goto on_error;

  if ((Uhalf = (ConsS*)malloc(size1*sizeof(ConsS)))==NULL) goto on_error;

  return;

  on_error:
    integrate_destruct();
    ath_error("[integrate_init]: malloc returned a NULL pointer\n");
}
Пример #19
0
struct ath_2d_fft_plan *ath_2d_fft_quick_plan(DomainS *pD,
				ath_fft_data *data, ath_fft_direction dir)
{
  GridS *pGrid=(pD->Grid);
  if (pGrid->Nx[2] != 1) {
    ath_error("ath_2d_fft_quick_plan only works for Nx3=1.\n");
  }

  /* Get size of global FFT grid */
  int gnx1 = pD->Nx[0];
  int gnx2 = pD->Nx[1];

  /* Get extents of local FFT grid in global coordinates */
  /* These should be calculate from the origin of its Domain not root Domain */
  int gis = pGrid->Disp[0]-pD->Disp[0];
  int gie = pGrid->Disp[0]-pD->Disp[0] + pGrid->Nx[0] - 1;
  int gjs = pGrid->Disp[1]-pD->Disp[1];
  int gje = pGrid->Disp[1]-pD->Disp[1] + pGrid->Nx[1] - 1;

  /* Create the plan using a more generic function
   * If the data hasn't already been allocated, it will now */
  return ath_2d_fft_create_plan(pD, gnx2, gnx1, gjs, gje, gis, gie, data, 0, dir);
}
Пример #20
0
void fluxes(const Cons1DS Ul, const Cons1DS Ur, 
	    const Prim1DS Wl, const Prim1DS Wr, 
	    const Real Bxi, Cons1DS *pF)
{
  Real pc, fr, fl; 
  Real dc, dcl, dcr, Vxc;
  Real sl, sr;    /* Left and right going shock velocity */
  Real hdl, hdr;  /* Left and right going rarefaction head velocity */
  Real tll, tlr;  /* Left and right going rarefaction tail velocity */
  Real al = sqrt((double) Gamma*Wl.P/Wl.d); /* left sound speed */
  Real ar = sqrt((double) Gamma*Wr.P/Wr.d); /* right sound speed */
  Real tmp1, tmp2;
  Real e, V, E; 
 
  if(!(Ul.d > 0.0)||!(Ur.d > 0.0))
    ath_error("[exact flux]: Non-positive densities: dl = %e  dr = %e\n", 
	      Ul.d, Ur.d);

  pc = getPC(Wl, Wr); 
  
  /*----------------------------------------------------------------*/
  /* calculate Vxc */
  fr = PFunc(Wr, pc); 
  fl = PFunc(Wl, pc); 
  Vxc = 0.5*(Wl.Vx + Wr.Vx) + 0.5*(fr - fl); 

  /*-----------------------------------------------------------------*/
  /* calucate density to left of contact (dcl) */
  if (pc > Wl.P) {

    /* left shock wave */
    Real tmp = (Gamma - 1.0) / (Gamma + 1.0);
    dcl = Wl.d*(pc/Wl.P + tmp)/(tmp*pc/Wl.P + 1); 
  }
  else {

    /* left rarefaction wave */
    dcl = Wl.d*pow((double) (pc/Wl.P), (double) (1/Gamma)); 
  }

  if (dcl < 0.0)
     ath_error("[exact flux]: Solver finds negative density %5.4e\n", dcl);
  
  /*-----------------------------------------------------------------*/
  /* calculate density to the right of contact (dcr) */
  if (pc > Wr.P) {

    /* right shock wave */
    Real tmp = (Gamma - 1)/(Gamma + 1);
    dcr = Wr.d*(pc/Wr.P + tmp)/(tmp*pc/Wr.P + 1); 
  }
  else {

    /* right rarefaction wave */
    dcr = Wr.d*pow((double) (pc/Wr.P), (double) (1/Gamma)); 
  }

  if (dcr < 0.0)
    ath_error("[exact flux]: Solver finds negative density %5.4e\n", dcr);
 /*-----------------------------------------------------------------
  * Calculate the Interface Flux if the wave speeds are such that we aren't
  * actually in the intermediate state */
  
  if (pc > Wl.P) {
    /* left shock wave */
    
    /* left shock speed */
    sl = Wl.Vx - al*sqrt((double)(pc*(Gamma+1)/(2*Gamma*Wl.P) + 
				  (Gamma-1)/(2*Gamma))); 
    if (sl >= 0.0) {
      /* to left of shock */
     
      e = Wl.P/(Wl.d*(Gamma-1));
      V = Wl.Vx*Wl.Vx + Wl.Vy*Wl.Vy + Wl.Vz*Wl.Vz;
      E = Wl.d*(0.5*V + e); 
      
      pF->E = Wl.Vx*(E + Wl.P);
      pF->d  = Ul.Mx;
      pF->Mx = Ul.Mx*(Wl.Vx) + Wl.P;
      pF->My = Ul.My*(Wl.Vx);
      pF->Mz = Ul.Mz*(Wl.Vx);

      return; 
    }
  }
  else {
    /* left rarefaction */
    
    Real alc = al*pow((double)(pc/Wl.P), (double)(Gamma-1)/(2*Gamma));
    
    hdl = Wl.Vx - al; 
    tll = Vxc - alc; 
    
    if (hdl >= 0.0) {
      /* To left of rarefaction */
	
      e = Wl.P/(Wl.d*(Gamma-1));
      V = Wl.Vx*Wl.Vx + Wl.Vy*Wl.Vy + Wl.Vz*Wl.Vz;
      E = Wl.d*(0.5*V + e); 
      
      pF->E =  Wl.Vx*(E + Wl.P);
      pF->d  = Ul.Mx;
      pF->Mx = Ul.Mx*(Wl.Vx) + Wl.P;
      pF->My = Ul.My*(Wl.Vx);
      pF->Mz = Ul.Mz*(Wl.Vx);
      return;
      
    } 
    else if (tll >= 0.0) {
      /* Inside rarefaction fan */
       
      
      tmp1 = 2/(Gamma + 1); 
      tmp2 = (Gamma - 1)/(al*(Gamma+1)); 
      
      dc = Wl.d*pow((double)(tmp1 + tmp2*Wl.Vx), (double)(2/(Gamma-1))); 
      Vxc = tmp1*(al + Wl.Vx*(Gamma-1)/2);
      pc = Wl.P*pow((double)(tmp1+tmp2*Wl.Vx),(double)(2*Gamma/(Gamma-1))); 
      
      e = pc/(dc*(Gamma-1));
      V = Vxc*Vxc + Wl.Vy*Wl.Vy + Wl.Vz*Wl.Vz;
      E = dc*(0.5*V + e); 	
      
      pF->E = Vxc*(E + pc); 
      pF->d  = dc*Vxc;
      pF->Mx = dc*Vxc*Vxc + pc;
      pF->My = dc*Vxc*Wl.Vy;
      pF->Mz = dc*Vxc*Wl.Vz;
      return;
    } 
  }

  if (pc > Wr.P) {
    /* right shock wave */
    
    /* right shock speed */
    sr = Wr.Vx + ar*sqrt((double)(pc*(Gamma+1)/(2*Gamma*Wr.P) + 
				  (Gamma-1)/(2*Gamma))); 
    if (sr <= 0.0) {
      /* to right of shock */

      e = Wr.P/(Wr.d*(Gamma-1));
      V = Wr.Vx*Wr.Vx + Wr.Vy*Wr.Vy + Wr.Vz*Wr.Vz;
      E = Wr.d*(0.5*V + e);     
      
      pF->E = Wr.Vx*(E + Wr.P);
      pF->d  = Ur.Mx;
      pF->Mx = Ur.Mx*(Wr.Vx) + Wr.P;
      pF->My = Ur.My*(Wr.Vx);
      pF->Mz = Ur.Mz*(Wr.Vx);
      return; 
    }
  }
  else {
    /* right rarefaction */
    
    Real arc = ar*pow((double)(pc/Wr.P), (double)(Gamma-1)/(2*Gamma)); 
      
    hdr = Wr.Vx + ar; 
    tlr = Vxc + arc; 
    
    if (hdr <= 0.0) {
      /* To right of rarefaction */

      e = Wr.P/(Wr.d*(Gamma-1));
      V = Wr.Vx*Wr.Vx + Wr.Vy*Wr.Vy + Wr.Vz*Wr.Vz;
      E = Wr.d*(0.5*V + e); 	
      
      pF->E = Wr.Vx*(E + Wr.P);
      pF->d  = Ur.Mx;
      pF->Mx = Ur.Mx*(Wr.Vx) + Wr.P;
      pF->My = Ur.My*(Wr.Vx);
      pF->Mz = Ur.Mz*(Wr.Vx);
      return;
      
    } else if (tlr <= 0.0) {
      /* Inside rarefaction fan */
      
      tmp1 = 2/(Gamma + 1); 
      tmp2 = (Gamma - 1)/(ar*(Gamma+1)); 
      
      dc = Wr.d*pow((double)(tmp1 - tmp2*Wr.Vx), (double)(2/(Gamma-1))); 
      Vxc = tmp1*(-ar + Wr.Vx*(Gamma-1)/2);
      pc = Wr.P*pow((double)(tmp1-tmp2*Wr.Vx), (double)(2*Gamma/(Gamma-1))); 
      
      e = pc/(dc*(Gamma-1));
      V = Vxc*Vxc + Wr.Vy*Wr.Vy + Wr.Vz*Wr.Vz;
      E = dc*(0.5*V + e); 
      
      pF->E = Vxc*(E + pc);
      pF->d  = dc*Vxc;
      pF->Mx = dc*Vxc*Vxc + pc;
      pF->My = dc*Vxc*Wr.Vy;
      pF->Mz = dc*Vxc*Wr.Vz;
      return;
    }
  }
    
/* We are in the intermediate state */

/*---------------------------------------------------------------------
 * Calculate the Interface Flux */
  if (Vxc >= 0.0) {

    e = pc/(dcl*(Gamma-1));
    V = Vxc*Vxc + Wl.Vy*Wl.Vy + Wl.Vz*Wl.Vz;
    E = dcl*(0.5*V + e); 
    
    pF->E = Vxc*(E + pc); 
    pF->d  = dcl*Vxc;
    pF->Mx = dcl*Vxc*Vxc + pc;
    pF->My = dcl*Vxc*Wl.Vy;
    pF->Mz = dcl*Vxc*Wl.Vz;
  }
  else {

    e = pc/(dcr*(Gamma-1));
    V = Vxc*Vxc + Wr.Vy*Wr.Vy + Wr.Vz*Wr.Vz;
    E = dcr*(0.5*V + e); 
    
    pF->E = Vxc*(E + pc); 
    pF->d  = dcr*Vxc;
    pF->Mx = dcr*Vxc*Vxc + pc;
    pF->My = dcr*Vxc*Wr.Vy;
    pF->Mz = dcr*Vxc*Wr.Vz;
  }
  
  return;
}
Пример #21
0
/*! \fn static void flux_output_func(MeshS *pM, OutputS *pOut) 
 *  \brief  New output format which outputs y-integrated angular momentum fluxes
 *  Currently can only be used with 1 proc and 1 domain.
 */
static void flux_output_func(MeshS *pM, OutputS *pOut)
{
  GridS *pG=pM->Domain[0][0].Grid;
  int nx1,nx2,nx3, ind, i,j,k, ind_i,ind_k;
  Real lx1, lx2, lx3;
  PrimS W[7],Ws[7],We[7];
  Real x1[7],x2[7],x3[7],xs1[7],xs2[7],xs3[7],xe1[7],xe2[7],xe3[7];
  Real dmin, dmax;
  Real **Fluxx=NULL;
  Real **FluxH=NULL;
  Real **FluxNu=NULL;
  Real **Th=NULL;
  Real **outCoordsx1=NULL;
  Real **outCoordsx3=NULL;
  Real **vx=NULL;
  Real **vy=NULL;
  Real **sigvx=NULL;
  Real **osigx=NULL;
  Real **davg=NULL;
  
  
  FILE *pfile;
  char *fname;
	
  nx1 = pG->Nx[0]; nx3 = pG->Nx[2]; nx2 = pG->Nx[1];
  lx1 = pG->MaxX[0] - pG->MinX[0];
  lx2 = pG->MaxX[1] - pG->MinX[1];
  lx3 = pG->MaxX[2] - pG->MinX[2];
 printf("%d, %d, %d, %g, %g, %g\n",nx1,nx2,nx3,lx1,lx2,lx3);
#ifdef MPI_PARALLEL  
  printf("%d, %d, %d, %g, %g, %g \n", myID_Comm_world,nx1,nx3,lx1,lx2,lx3); 

  printf("IND %d: (%d,%d), (%d,%d)\n",myID_Comm_world,pG->is,pG->js,pG->ie,pG->je);

#endif

  Fluxx=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (Fluxx == NULL) return;
  FluxH=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (FluxH == NULL) return;
  FluxNu=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (FluxNu == NULL) return;
  Th=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (Th == NULL) return;
  outCoordsx1=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (outCoordsx1 == NULL) return;
  outCoordsx3=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (outCoordsx3 == NULL) return;
  vx=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (vx == NULL) return;
  vy=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (vy == NULL) return;
  sigvx=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (sigvx == NULL) return;
  osigx=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (osigx == NULL) return;
  davg=(Real **)calloc_2d_array(nx3,nx1,sizeof(Real));
  if (davg == NULL) return;
/* Open file and write header */  
  
  if((fname = ath_fname(NULL,pM->outfilename,NULL,NULL,num_digit,
            pOut->num,pOut->id,"tab")) == NULL){
          ath_error("[dump_tab]: Error constructing filename\n");
  }
  if((pfile = fopen(fname,"w")) == NULL){
  	ath_error("[dump_tab]: Unable to open ppm file %s\n",fname);
  }
  free(fname);
  
#ifdef MPI_PARALLEL
  if(myID_Comm_world == 0) 
#endif
  	fprintf(pfile,"#t=%12.8e	x,FH,Fx,Fnu,Th,vx,vy,davg,sigvx,omsigx \n", pOut->t);

/* Compute y-integrated fluxes explicitly.
 * For the derivatives use a central difference method.
 * For the integration use a composite trapezoid method.
 * Both of these make use of the ghost cells for the boundary values.
 * 1	FluxH = < d * vx1 *vx2 >
 * 2	Fluxx = < 0.5 * omega * d * x1 * vx1 >
 * 3	FluxNu = - < nu_iso * d/dx vx2 >
 * 4	Th = - < d * d/dy phi >
 * 5	vx = < vx1 >
 * 6	vy = < vx2 >
 * 7	davg = < d >
 * 8	sigvx = < d * vx1 >
 * 9	osigx = < 0.5 * sig * omega * x1 >
 *
 *         
 *		x	4   x
 *      1   0	2
 *		x	3	x
 *
 * The variables are stored up as arrays of primitives W[7].
 * W = ( W[k][j][i], W[k][j][i-1], W[k][j][i+1], W[k][j-1][i], 
 *		 W[k][j+1][i], W[k-1][j][i], W[k+1][j][i] )
 * This is needed for the integration and differentiation.
 *
 * The background shear is taken out of vy when doing computations.
*/

  for(k=pG->ks; k <=pG->ke; k++) {
  	for(i=pG->is; i<= pG->ie; i++) {
		ind_i=i-pG->is; ind_k=k-pG->ks; 
		for(ind=0; ind < 7; ind++) {
			if (ind==0) {
				cc_pos(pG,i,pG->js,k,&xs1[ind],&xs2[ind],&xs3[ind]);
				cc_pos(pG,i,pG->je,k,&xe1[ind],&xe2[ind],&xe3[ind]);
				Ws[ind] = Cons_to_Prim(&(pG->U[k][pG->js][i])); 
				We[ind] = Cons_to_Prim(&(pG->U[k][pG->je][i])); 
			}
			if (ind > 0 && ind < 3) {
				cc_pos(pG,i+2*ind-3,pG->js,k,&xs1[ind],&xs2[ind],&xs3[ind]);
				cc_pos(pG,i+2*ind-3,pG->je,k,&xe1[ind],&xe2[ind],&xe3[ind]);
				Ws[ind] = Cons_to_Prim(&(pG->U[k][pG->js][i+2*ind-3])); 
				We[ind] = Cons_to_Prim(&(pG->U[k][pG->je][i+2*ind-3]));
			}
			if (ind > 2 && ind < 5) {
				cc_pos(pG,i,pG->js+2*ind-7,k,&xs1[ind],&xs2[ind],&xs3[ind]);
				cc_pos(pG,i,pG->je+2*ind-7,k,&xe1[ind],&xe2[ind],&xe3[ind]);
				Ws[ind] = Cons_to_Prim(&(pG->U[k][pG->js+2*ind-7][i])); 
				We[ind] = Cons_to_Prim(&(pG->U[k][pG->je+2*ind-7][i]));
			}
			if (ind > 4 && ind < 7) {
				if (pG->MinX[2] == pG->MaxX[2]) {
					cc_pos(pG,i,pG->js,k,&xs1[ind],&xs2[ind],&xs3[ind]);
					cc_pos(pG,i,pG->je,k,&xe1[ind],&xe2[ind],&xe3[ind]);
					Ws[ind] = Cons_to_Prim(&(pG->U[k][pG->js][i])); 
					We[ind] = Cons_to_Prim(&(pG->U[k][pG->je][i]));
				}
				else {
					cc_pos(pG,i,pG->js,k+2*ind-11,&xs1[ind],&xs2[ind],&xs3[ind]);
					cc_pos(pG,i,pG->je,k+2*ind-11,&xe1[ind],&xe2[ind],&xe3[ind]);
					Ws[ind] = Cons_to_Prim(&(pG->U[k+2*ind-11][pG->js][i])); 
					We[ind] = Cons_to_Prim(&(pG->U[k+2*ind-11][pG->je][i]));
				}
			}
			Ws[ind].V2 = Ws[ind].V2 + qshear*Omega_0*xs1[ind];
			We[ind].V2 = We[ind].V2 + qshear*Omega_0*xe1[ind];
/* If using d' instead of d then put in
 * W[ind] = W[ind]->d - d0;
 */
		}
/* Set initial values for the integration */
		FluxH[ind_k][ind_i] = 0.5*( Ws[0].d * Ws[0].V1 * Ws[0].V2 + 
						    We[0].d * We[0].V1 * We[0].V2 );  	
		
		Fluxx[ind_k][ind_i] = 0.5*( Ws[0].d * Ws[0].V1 * xs1[0] +
							We[0].d * We[0].V1 * xe1[0] );
		
#ifdef VISCOSITY 
		FluxNu[ind_k][ind_i] = 0.5*( Ws[2].V2 - Ws[1].V2 +
							 We[2].V2 - We[1].V2 ); 
		
#else
		FluxNu[ind_k][ind_i] = 0;
#endif   	
  	
  		Th[ind_k][ind_i] = 0.5*( Ws[0].d * dx2PlanetPot(xs1[0],xs2[0],xs3[0]) +
  						 We[0].d * dx2PlanetPot(xe1[0],xe2[0],xe3[0]) );
		
		vx[ind_k][ind_i] = 0.5*( Ws[0].V1 + We[0].V1 );
		vy[ind_k][ind_i] = 0.5*( Ws[0].V2 + We[0].V2 );
		sigvx[ind_k][ind_i] = 0.5*( Ws[0].d * Ws[0].V1 + We[0].d * We[0].V1 );
		osigx[ind_k][ind_i] = 0.5*( Ws[0].d * xs1[0] + We[0].d * xe1[0] );
		davg[ind_k][ind_i] = 0.5*(Ws[0].d + We[0].d);
  	 	for(j=(pG->js)+1; j < pG->je; j++) {
  			for(ind=0; ind < 7; ind++) {
				if (ind==0) {
					cc_pos(pG,i,j,k,&x1[ind],&x2[ind],&x3[ind]);
					W[ind] = Cons_to_Prim(&(pG->U[k][j][i])); 
				}
				if (ind > 0 && ind < 3) {
					cc_pos(pG,i+2*ind-3,j,k,&x1[ind],&x2[ind],&x3[ind]);
					W[ind] = Cons_to_Prim(&(pG->U[k][j][i+2*ind-3])); 
				}
				if (ind > 2 && ind < 5) {
					cc_pos(pG,i,j+2*ind-7,k,&x1[ind],&x2[ind],&x3[ind]);
					W[ind] = Cons_to_Prim(&(pG->U[k][j+2*ind-7][i])); 
				}
				if (ind > 4 && ind < 7) {
					if (pG->MinX[2] == pG->MaxX[2]) {
						cc_pos(pG,i,j,k,&x1[ind],&x2[ind],&x3[ind]);
						W[ind] = Cons_to_Prim(&(pG->U[k][j][i])); 
					}
					else {
						cc_pos(pG,i,j,k+2*ind-11,&x1[ind],&x2[ind],&x3[ind]);
						W[ind] = Cons_to_Prim(&(pG->U[k+2*ind-11][j][i])); 
					}
				}
				W[ind].V2 = W[ind].V2 + qshear*Omega_0*x1[ind];
				
			}	 
			
			FluxH[ind_k][ind_i] += W[0].d * W[0].V1 * W[0].V2;
			Fluxx[ind_k][ind_i] += W[0].d * W[0].V1 * x1[0];
#ifdef VISCOSITY
			FluxNu[ind_k][ind_i] += W[0].d * (W[2].V2 - W[1].V1);
#endif
			Th[ind_k][ind_i] += W[0].d * dx2PlanetPot(x1[0],x2[0],x3[0]);
			vx[ind_k][ind_i] += W[0].V1;
			vy[ind_k][ind_i] += W[0].V2;
			sigvx[ind_k][ind_i] += W[0].d * W[0].V1;
			osigx[ind_k][ind_i] += W[0].d * x1[0];
			davg[ind_k][ind_i] += W[0].d;
			
  		}	
  		FluxH[ind_k][ind_i] *= (pG->dx2)/lx2;
  		Fluxx[ind_k][ind_i] *= .5*Omega_0*(pG->dx2)/lx2;
#ifdef	VISCOSITY
		FluxNu[ind_k][ind_i] *= -nu_iso*(pG->dx2)/(2*lx2*(pG->dx1));
#endif 
  		Th[ind_k][ind_i] *= -1.0*(pG->dx2)/lx2;				
  		vx[ind_k][ind_i] *= (pG->dx2)/lx2;
  		vy[ind_k][ind_i] *= (pG->dx2)/lx2;
  		sigvx[ind_k][ind_i] *= (pG->dx2)/lx2;
  		osigx[ind_k][ind_i] *= (0.5*Omega_0*(pG->dx2))/lx2;
  		davg[ind_k][ind_i] *= (pG->dx2)/lx2;
  	 	outCoordsx1[ind_k][ind_i]=x1[0]; outCoordsx3[ind_k][ind_i]=x3[0];
  	}
  }  

/* Quantities are ready to be written to output file
 * Format (Not outputting x3 at the moment: 
 * x1	(x3)	FluxH	Fluxx	Fluxnu	Th	vx	vy	davg	sigvx	osigx
*/
  
  
  for(k=pG->ks; k<=pG->ke; k++) {
  	for(i=pG->is; i<=pG->ie; i++) {
 		ind_k=k-pG->ks; ind_i=i-pG->is;
  		if (lx3==0) {
  			fprintf(pfile,"%12.8e %12.8e %12.8e %12.8e %12.8e %12.8e %12.8e %12.8e %12.8e %12.8e\n",
  					outCoordsx1[ind_k][ind_i],FluxH[ind_k][ind_i],
  					Fluxx[ind_k][ind_i],FluxNu[ind_k][ind_i],Th[ind_k][ind_i],
  					vx[ind_k][ind_i],vy[ind_k][ind_i],davg[ind_k][ind_i],sigvx[ind_k][ind_i],
  					osigx[ind_k][ind_i]);
  		}
  		else {
  			fprintf(pfile,"%12.8e	%12.8e	%12.8e	%12.8e	%12.8e	%12.8e %12.8e %12.8e %12.8e %12.8e %12.8e\n",
  					outCoordsx1[ind_k][ind_i],outCoordsx3[ind_k][ind_i],FluxH[ind_k][ind_i],
  					Fluxx[ind_k][ind_i],FluxNu[ind_k][ind_i],Th[ind_k][ind_i],
  					vx[ind_k][ind_i],vy[ind_k][ind_i],davg[ind_k][ind_i],sigvx[ind_k][ind_i],
  					osigx[ind_k][ind_i]);
  		}
  	}
  }
  
  fclose(pfile);
  free_2d_array(Fluxx); 
  free_2d_array(FluxH); 
  free_2d_array(FluxNu); 
  free_2d_array(Th); 
  free_2d_array(outCoordsx1);
  free_2d_array(outCoordsx3);
  free_2d_array(vx);
  free_2d_array(vy);
  free_2d_array(sigvx);
  free_2d_array(osigx);
  free_2d_array(davg);
  return;
}
Пример #22
0
/* problem:  */
void problem(DomainS *pDomain)
{
  GridS *pG = pDomain->Grid;
  int i,j,k,n,converged;
  int is,ie,il,iu,js,je,jl,ju,ks,ke,kl,ku;
  int nx1, nx2, nx3;
  Real x1, x2, x3;
  Real a,b,c,d,xmin,xmax,ymin,ymax;
  Real x,y,xslow,yslow,xfast,yfast;
  Real R0,R1,R2,rho,Mdot,K,Omega,Pgas,beta,vR,BR,vphi,Bphi;
  ConsS *Wind=NULL;
  Real *pU=NULL,*pUl=NULL,*pUr=NULL;
  Real lsf,rsf;

  is = pG->is;  ie = pG->ie;  nx1 = ie-is+1;
  js = pG->js;  je = pG->je;  nx2 = je-js+1;
  ks = pG->ks;  ke = pG->ke;  nx3 = ke-ks+1;

  il = is-nghost*(nx1>1);  iu = ie+nghost*(nx1>1);  nx1 = iu-il+1;
  jl = js-nghost*(nx2>1);  ju = je+nghost*(nx2>1);  nx2 = ju-jl+1;
  kl = ks-nghost*(nx3>1);  ku = ke+nghost*(nx3>1);  nx3 = ku-kl+1;

#ifndef CYLINDRICAL
  ath_error("[cylwindrotb]: This problem only works in cylindrical!\n");
#endif
#ifndef MHD
  ath_error("[cylwindrotb]: This problem only works in MHD!\n");
#endif

  if (nx1==1) {
    ath_error("[cylwindrotb]: Only R can be used in 1D!\n");
  }
  else if (nx2==1 && nx3>1) {
    ath_error("[cylwindrotb]: Only (R,phi) can be used in 2D!\n");
  }

  /* Allocate memory for wind solution */
  if ((Wind = (ConsS*)calloc_1d_array(nx1+1,sizeof(ConsS))) == NULL)
    ath_error("[cylwindrotb]: Error allocating memory\n");

  /* Allocate memory for grid solution */
  if ((RootSoln = (ConsS***)calloc_3d_array(nx3,nx2,nx1,sizeof(ConsS))) == NULL)
    ath_error("[cylwindrotb]: Error allocating memory\n");

  theta = par_getd("problem","theta");
  omega = par_getd("problem","omega");
  vz    = par_getd("problem","vz");

  /* This numerical solution was obtained from MATLAB.
   * Ideally, we replace this with a nonlinear solver... */
  xslow = 0.5243264128;
  yslow = 2.4985859152;
  xfast = 1.6383327831;
  yfast = 0.5373957134;
  E     = 7.8744739104;
  eta   = 2.3608500383;

  xmin = par_getd("domain1","x1min")/R_A;
  xmax = par_getd("domain1","x1max")/R_A;
  ymin = 0.45/rho_A;
  ymax = 2.6/rho_A;

  printf("theta = %f,\t omega = %f,\t eta = %f,\t E = %f\n", theta,omega,eta,E);
  printf("xslow = %f,\t yslow = %f,\t xfast = %f,\t yfast = %f\n", xslow,yslow,xfast,yfast);
  printf("xmin = %f,\t ymin = %f,\t xmax = %f,\t ymax = %f\n", xmin,ymin,xmax,ymax);


  /* Calculate the 1D wind solution at cell-interfaces */
  for (i=il; i<=iu+1; i++) {
    memset(&(Wind[i]),0.0,sizeof(ConsS));
    cc_pos(pG,i,js,ks,&x1,&x2,&x3);

    /* Want the solution at R-interfaces */
    R0 = x1 - 0.5*pG->dx1;
    x = R0/R_A;

    /* Look for a sign change interval */
    if (x < xslow) {
      sign_change(myfunc,yslow,10.0*ymax,x,&a,&b);
      sign_change(myfunc,b,10.0*ymax,x,&a,&b);
    } else if (x < 1.0) {
      sign_change(myfunc,1.0+TINY_NUMBER,yslow,x,&a,&b);
    } else if (x < xfast) {
      sign_change(myfunc,yfast,1.0-TINY_NUMBER,x,&a,&b);
      if (!sign_change(myfunc,b,1.0-TINY_NUMBER,x,&a,&b)) {
        a = yfast;
        b = 1.0-TINY_NUMBER;
      }
    } else {
      sign_change(myfunc,0.5*ymin,yfast,x,&a,&b);
    }

    /* Use bisection to find the root */
    converged = bisection(myfunc,a,b,x,&y);
    if(!converged) {
      ath_error("[cylwindrotb]:  Bisection did not converge!\n");
    }

    /* Construct the solution */
    rho = rho_A*y;
    Mdot = sqrt(R_A*SQR(rho_A)*GM*eta);
    Omega = sqrt((GM*omega)/pow(R_A,3));
    K = (GM*theta)/(Gamma*pow(rho_A,Gamma_1)*R_A);
    Pgas = K*pow(rho,Gamma);
    vR = Mdot/(R0*rho);
    beta = sqrt(1.0/rho_A);
    BR = beta*rho*vR;
    vphi = R0*Omega*(1.0/SQR(x)-y)/(1.0-y);
    Bphi = beta*rho*(vphi-R0*Omega);

    Wind[i].d   = rho;
    Wind[i].M1  = rho*vR;
    Wind[i].M2  = rho*vphi;
    Wind[i].M3  = rho*vz;
    Wind[i].B1c = BR;
    Wind[i].B2c = Bphi;
    Wind[i].B3c = 0.0;
    Wind[i].E   = Pgas/Gamma_1
      + 0.5*(SQR(Wind[i].B1c) + SQR(Wind[i].B2c) + SQR(Wind[i].B3c))
      + 0.5*(SQR(Wind[i].M1 ) + SQR(Wind[i].M2 ) + SQR(Wind[i].M3 ))/Wind[i].d;
  }

  /* Average the wind solution across the zone for cc variables */
  for (i=il; i<=iu; i++) {
    memset(&(pG->U[ks][js][i]),0.0,sizeof(ConsS));
    cc_pos(pG,i,js,ks,&x1,&x2,&x3);
    lsf = (x1 - 0.5*pG->dx1)/x1;
    rsf = (x1 + 0.5*pG->dx1)/x1;

    pU  = (Real*)&(pG->U[ks][js][i]);
    pUl = (Real*)&(Wind[i]);
    pUr = (Real*)&(Wind[i+1]);
    for (n=0; n<NWAVE; n++) {
      pU[n] = 0.5*(lsf*pUl[n] + rsf*pUr[n]);
    }

    pG->B1i[ks][js][i]   = Wind[i].B1c;
    pG->B2i[ks][js][i]   = 0.5*(lsf*Wind[i].B2c + rsf*Wind[i+1].B2c);
    pG->B3i[ks][js][i]   = 0.5*(lsf*Wind[i].B3c + rsf*Wind[i+1].B3c);
  }

  /* Copy 1D solution across the grid and save */
  for (k=kl; k<=ku; k++) {
    for (j=jl; j<=ju; j++) {
      for (i=il; i<=iu; i++) {
        pG->U[k][j][i] = pG->U[ks][js][i];
        pG->B1i[k][j][i] = pG->B1i[ks][js][i];
        pG->B2i[k][j][i] = pG->B2i[ks][js][i];
        pG->B3i[k][j][i] = pG->B3i[ks][js][i];
        RootSoln[k][j][i]  = pG->U[ks][js][i];
      }
    }
  }

  StaticGravPot = grav_pot;
  bvals_mhd_fun(pDomain,left_x1,do_nothing_bc);
  bvals_mhd_fun(pDomain,right_x1,do_nothing_bc);

  free_1d_array((void *)Wind);

  return;
}
Пример #23
0
void fluxes(const Cons1DS Ul, const Cons1DS Ur,
            const Prim1DS Wl, const Prim1DS Wr,
            const Real Bxi, Cons1DS *pF)
{
  Real zl, zr, zm, dm, Vxm, Mxm, tmp, dmin, dmax;
  Real sl, sr;    /* Left and right going shock velocity */
  Real hdl, hdr;  /* Left and right going rarefaction head velocity */
  Real tll, tlr;  /* Left and right going rarefaction tail velocity */
  char soln;      /* two bits: 0=shock, 1=raref */

  if(!(Ul.d > 0.0)||!(Ur.d > 0.0))
    ath_error("[exact flux]: Non-positive densities: dl = %e  dr = %e\n",
	      Ul.d, Ur.d);

/*--- Step 1. ------------------------------------------------------------------
 * Compute the density and momentum of the intermediate state
 */

  zl = sqrt((double)Wl.d);
  zr = sqrt((double)Wr.d);

  /* --- 1-shock and 2-shock --- */
  soln = 0;

  /* Start by finding density if shocks on both left and right.
   * This will only be the case if dm > Wl.d and dm > Wr.d */
  tmp = zl*zr*(Wl.Vx - Wr.Vx)/(2.0*Iso_csound*(zl + zr));
  zm = tmp + sqrt((double)(tmp*tmp + zl*zr));
  dm = zm*zm;

  /* Get velocity from 1-shock formula */
  Vxm = Wl.Vx - Iso_csound*(dm-Wl.d)/(zm*zl);

  /* If left or right density is greater than intermediate density,
   * then at least one side has rarefaction instead of shock */
  dmin = MIN(Wl.d, Wr.d);
  dmax = MAX(Wl.d, Wr.d);
  if (dm < dmax) {
    /* --- 1-rarefaction and 2-rarefaction --- */
    soln = 3;

    /* Try rarefactions on both left and right, since it's a quicker
     * calculation than 1-shock+2-raref or 1-raref+2-shock */
    dm = zl*zr*exp((Wl.Vx-Wr.Vx)/(2.0*Iso_csound));

    /* Get velocity from 1-rarefaction formula */
    Vxm = Wl.Vx - Iso_csound*log(dm/Wl.d);

    /* If left or right density is smaller than intermediate density,
     * then we must instead have a combination of shock and rarefaction */
    if (dm > dmin) {
      /* --- EITHER 1-rarefaction and 2-shock ---
       * --- OR     1-shock and 2-rarefaction --- */

      /* Solve iteratively equation for shock and rarefaction
       * If Wl.d > Wr.d ==> 1-rarefaction and 2-shock
       * If Wr.d > Wl.d ==> 1-shock and 2-rarefaction */
      if (Wl.d > Wr.d) soln = 2; else soln = 1;

      dm = rtsafe(&srder,dmin,dmax, 2.0*DBL_EPSILON, Wl.Vx, Wr.Vx, dmin, dmax);

      /* Don't be foolish enough to take ln of zero */
      if ((dm > dmin) && (dm <= dmax)) {
        if (Wl.d > Wr.d) {
          /* Get velocity from 1-rarefaction formula */
          Vxm = Wl.Vx - Iso_csound*log(dm/Wl.d);
        } else {
          /* Get velocity from 2-rarefaction formula */
          Vxm = Wr.Vx + Iso_csound*log(dm/Wr.d);
        }
      } else {
        /* --- DEFAULT 1-rarefaction and 2-rarefaction --- */
        soln = 3;

        /* In the event that the intermediate density fails to fall between
         * the left and right densities (should only happen when left and
         * right densities differ only slightly and intermediate density
         * calculated in any step has significant truncation and/or roundoff
         * errors), default to rarefactions on both left and right */
        dm = zl*zr*exp((Wl.Vx-Wr.Vx)/(2.0*Iso_csound));

        /* Get velocity from 1-rarefaction formula */
        Vxm = Wl.Vx - Iso_csound*log(dm/Wl.d);
      }
    }
  }

  if (dm < 0.0)
    ath_error("[exact flux]: Solver finds negative density %5.4e\n", dm);

/*--- Step 2. ------------------------------------------------------------------
 * Calculate the Interface Flux if the wave speeds are such that we aren't
 * actually in the intermediate state
 */

  if (soln & 2) { /* left rarefaction */
    /* The L-going rarefaction head/tail velocity */
    hdl = Wl.Vx - Iso_csound;
    tll = Vxm - Iso_csound;

    if (hdl >= 0.0) {
      /* To left of rarefaction */
      pF->d  = Ul.Mx;
      pF->Mx = Ul.Mx*(Wl.Vx) + Wl.d*Iso_csound2;
      pF->My = Ul.My*(Wl.Vx);
      pF->Mz = Ul.Mz*(Wl.Vx);
      return;
    } else if (tll >= 0.0) {
      /* Inside rarefaction fan */
      dm = Ul.d*exp(hdl/Iso_csound);
      Mxm = Ul.d*Iso_csound*exp(hdl/Iso_csound);
      Vxm = (dm == 0.0 ? 0.0 : Mxm / dm);

      pF->d  = Mxm;
      pF->Mx = Mxm*Vxm + dm*Iso_csound2;
      pF->My = Mxm*Wl.Vy;
      pF->Mz = Mxm*Wl.Vz;
      return;
    }
  } else { /* left shock */
    /* The L-going shock velocity */
    sl = Wl.Vx - Iso_csound*sqrt(dm)/zl;

    if(sl >= 0.0) {
      /* To left of shock */
      pF->d  = Ul.Mx;
      pF->Mx = Ul.Mx*(Wl.Vx) + Wl.d*Iso_csound2;
      pF->My = Ul.My*(Wl.Vx);
      pF->Mz = Ul.Mz*(Wl.Vx);
      return;
    }
  }

  if (soln & 1) { /* right rarefaction */
    /* The R-going rarefaction head/tail velocity */
    hdr = Wr.Vx + Iso_csound;
    tlr = Vxm + Iso_csound;

    if (hdr <= 0.0) {
      /* To right of rarefaction */
      pF->d  = Ur.Mx;
      pF->Mx = Ur.Mx*(Wr.Vx) + Wr.d*Iso_csound2;
      pF->My = Ur.My*(Wr.Vx);
      pF->Mz = Ur.Mz*(Wr.Vx);
      return;
    } else if (tlr <= 0.0) {
      /* Inside rarefaction fan */
      tmp = dm;
      dm = tmp*exp(-tlr/Iso_csound);
      Mxm = -tmp*Iso_csound*exp(-tlr/Iso_csound);
      Vxm = (dm == 0.0 ? 0.0 : Mxm / dm);

      pF->d  = Mxm;
      pF->Mx = Mxm*Vxm + dm*Iso_csound2;
      pF->My = Mxm*Wr.Vy;
      pF->Mz = Mxm*Wr.Vz;
      return;
    }
  } else { /* right shock */
    /* The R-going shock velocity */
    sr = Wr.Vx + Iso_csound*sqrt(dm)/zr;

    if(sr <= 0.0) {
      /* To right of shock */
      pF->d  = Ur.Mx;
      pF->Mx = Ur.Mx*(Wr.Vx) + Wr.d*Iso_csound2;
      pF->My = Ur.My*(Wr.Vx);
      pF->Mz = Ur.Mz*(Wr.Vx);
      return;
    }
  }

/* If we make it this far, then we're in the intermediate state */

/*--- Step 3. ------------------------------------------------------------------
 * Calculate the Interface Flux */

  if(Vxm >= 0.0){
    pF->d  = dm*Vxm;
    pF->Mx = dm*Vxm*Vxm + dm*Iso_csound2;
    pF->My = dm*Vxm*Wl.Vy;
    pF->Mz = dm*Vxm*Wl.Vz;
  }
  else{
    pF->d  = dm*Vxm;
    pF->Mx = dm*Vxm*Vxm + dm*Iso_csound2;
    pF->My = dm*Vxm*Wr.Vy;
    pF->Mz = dm*Vxm*Wr.Vz;
  }

  return;
}
Пример #24
0
static void initialize(Grid *pGrid, Domain *pD)
{
  int i, is=pGrid->is, ie = pGrid->ie;
  int j, js=pGrid->js, je = pGrid->je;
  int k, ks=pGrid->ks, ke = pGrid->ke;
  int nbuf, mpierr, nx1gh, nx2gh, nx3gh;
  float kwv, kpara, kperp;
  char donedrive = 0;

/* -----------------------------------------------------------
 * Variables within this block are stored globally, and used
 * within preprocessor macros.  Don't create variables with
 * these names within your function if you are going to use
 * OFST(), KCOMP(), or KWVM() within the function! */

  /* Get local grid size */
  nx1 = (ie-is+1);
  nx2 = (je-js+1);
  nx3 = (ke-ks+1);

  /* Get global grid size */
  gnx1 = pD->ide - pD->ids + 1;
  gnx2 = pD->jde - pD->jds + 1;
  gnx3 = pD->kde - pD->kds + 1;

  /* Get extents of local FFT grid in global coordinates */
  gis=is+pGrid->idisp;  gie=ie+pGrid->idisp;
  gjs=js+pGrid->jdisp;  gje=je+pGrid->jdisp;
  gks=ks+pGrid->kdisp;  gke=ke+pGrid->kdisp;
/* ----------------------------------------------------------- */

  /* Get size of arrays with ghost cells */
  nx1gh = nx1 + 2*nghost;
  nx2gh = nx2 + 2*nghost;
  nx3gh = nx3 + 2*nghost;

  /* Get input parameters */

  /* interval for generating new driving spectrum; also interval for
   * driving when IMPULSIVE_DRIVING is used */
  dtdrive = par_getd("problem","dtdrive");
#ifdef MHD
  /* magnetic field strength */
  beta = par_getd("problem","beta");
  /* beta = isothermal pressure/magnetic pressure */
  B0 = sqrt(2.0*Iso_csound2*rhobar/beta);
#endif /* MHD */
  /* energy injection rate */
  dedt = par_getd("problem","dedt");

  /* parameters for spectrum */
  ispect = par_geti("problem","ispect");
  if (ispect == 1) {
    expo = par_getd("problem","expo");
  } else if (ispect == 2) {
    kpeak = par_getd("problem","kpeak")*2.0*PI;
  } else {
    ath_error("Invalid value for ispect\n");
  }
  /* Cutoff wavenumbers of spectrum */
  klow = par_getd("problem","klow"); /* in integer units */
  khigh = par_getd("problem","khigh"); /* in integer units */
  dkx = 2.0*PI/(pGrid->dx1*gnx1); /* convert k from integer */

  /* Driven or decaying */
  idrive = par_geti("problem","idrive");
  if ((idrive < 0) || (idrive > 1)) ath_error("Invalid value for idrive\n");
  /* If restarting with decaying turbulence, no driving necessary. */
  if ((idrive == 1) && (pGrid->nstep > 0)) {
    donedrive = 1;
  }

  if (donedrive == 0) {
    /* Allocate memory for components of velocity perturbation */
    if ((dv1=(Real***)calloc_3d_array(nx3gh,nx2gh,nx1gh,sizeof(Real)))==NULL) {
      ath_error("[problem]: Error allocating memory for vel pert\n");
    }
    if ((dv2=(Real***)calloc_3d_array(nx3gh,nx2gh,nx1gh,sizeof(Real)))==NULL) {
      ath_error("[problem]: Error allocating memory for vel pert\n");
    }
    if ((dv3=(Real***)calloc_3d_array(nx3gh,nx2gh,nx1gh,sizeof(Real)))==NULL) {
      ath_error("[problem]: Error allocating memory for vel pert\n");
    }
  }

  /* Initialize the FFT plan */
  plan = ath_3d_fft_quick_plan(pGrid, pD, NULL, ATH_FFT_BACKWARD);

  /* Allocate memory for FFTs */
  if (donedrive == 0) {
    fv1 = ath_3d_fft_malloc(plan);
    fv2 = ath_3d_fft_malloc(plan);
    fv3 = ath_3d_fft_malloc(plan);
  }

  /* Enroll outputs */
  dump_history_enroll(hst_dEk,"<dE_K>");
  dump_history_enroll(hst_dEb,"<dE_B>");

  return;
}
Пример #25
0
static void perturb(Grid *pGrid, Real dt)
{
  int i, is=pGrid->is, ie = pGrid->ie;
  int j, js=pGrid->js, je = pGrid->je;
  int k, ks=pGrid->ks, ke = pGrid->ke;
  int ind, mpierr;
  Real dvol, aa, b, c, s, de, qa, v1, v2, v3;
  Real t0, t0ij, t0i, t1, t1ij, t1i;
  Real t2, t2ij, t2i, t3, t3ij, t3i;
  Real m[4], gm[4];

  /* Set the velocities in real space */
  dvol = 1.0/((Real)(gnx1*gnx2*gnx3));
  for (k=ks; k<=ke; k++) {
    for (j=js; j<=je; j++) {
      for (i=is; i<=ie; i++) {
        ind = OFST(i-is,j-js,k-ks);
        dv1[k][j][i] = fv1[ind][0]*dvol;
        dv2[k][j][i] = fv2[ind][0]*dvol;
        dv3[k][j][i] = fv3[ind][0]*dvol;
      }
    }
  }

  /* Calculate net momentum pertubation components t1, t2, t3 */
  t0 = 0.0;  t1 = 0.0;  t2 = 0.0;  t3 = 0.0;
  for (k=ks; k<=ke; k++) {
    t0ij = 0.0;  t1ij = 0.0;  t2ij = 0.0;  t3ij = 0.0;
    for (j=js; j<=je; j++) {
      t0i = 0.0;  t1i = 0.0;  t2i = 0.0;  t3i = 0.0;
      for (i=is; i<=ie; i++) {
        t0i += pGrid->U[k][j][i].d;

	/* The net momentum perturbation */
        t1i += pGrid->U[k][j][i].d * dv1[k][j][i];
        t2i += pGrid->U[k][j][i].d * dv2[k][j][i];
        t3i += pGrid->U[k][j][i].d * dv3[k][j][i];
      }
      t0ij += t0i;  t1ij += t1i;  t2ij += t2i;  t3ij += t3i;
    }
    t0 += t0ij;  t1 += t1ij;  t2 += t2ij;  t3 += t3ij;
  }

#ifdef MPI_PARALLEL
  /* Sum the perturbations over all processors */
  m[0] = t0;  m[1] = t1;  m[2] = t2;  m[3] = t3;
  mpierr = MPI_Allreduce(m, gm, 4, MPI_RL, MPI_SUM, MPI_COMM_WORLD);
  if (mpierr) ath_error("[normalize]: MPI_Allreduce error = %d\n", mpierr);
  t0 = gm[0];  t1 = gm[1];  t2 = gm[2];  t3 = gm[3];
#endif /* MPI_PARALLEL */

  /* Subtract the mean velocity perturbation so that the net momentum
   * perturbation is zero. */
  for (k=ks; k<=ke; k++) {
    for (j=js; j<=je; j++) {
      for (i=is; i<=ie; i++) {
        dv1[k][j][i] -= t1/t0;
        dv2[k][j][i] -= t2/t0;
        dv3[k][j][i] -= t3/t0;
      }
    }
  }

  /* Calculate unscaled energy of perturbations */
  t1 = 0.0;  t2 = 0.0;
  for (k=ks; k<=ke; k++) {
    t1ij = 0.0;  t2ij = 0.0;
    for (j=js; j<=je; j++) {
      t1i = 0.0;  t2i = 0.0;
      for (i=is; i<=ie; i++) {
        /* Calculate velocity pertubation at cell center from
         * perturbations at cell faces */
	v1 = dv1[k][j][i];
	v2 = dv2[k][j][i];
	v3 = dv3[k][j][i];

        t1i += (pGrid->U[k][j][i].d)*(SQR(v1) + SQR(v2) + SQR(v3));
	t2i +=  (pGrid->U[k][j][i].M1)*v1 + (pGrid->U[k][j][i].M2)*v2 +
                     (pGrid->U[k][j][i].M3)*v3;
      }
      t1ij += t1i;  t2ij += t2i;
    }
    t1 += t1ij;  t2 += t2ij;
  }

#ifdef MPI_PARALLEL
  /* Sum the perturbations over all processors */
  m[0] = t1;  m[1] = t2;
  mpierr = MPI_Allreduce(m, gm, 2, MPI_RL, MPI_SUM, MPI_COMM_WORLD);
  if (mpierr) ath_error("[normalize]: MPI_Allreduce error = %d\n", mpierr);
  t1 = gm[0];  t2 = gm[1];
#endif /* MPI_PARALLEL */

  /* Rescale to give the correct energy injection rate */
  dvol = pGrid->dx1*pGrid->dx2*pGrid->dx3;
  if (idrive == 0) {
    /* driven turbulence */
    de = dedt*dt;
  } else {
    /* decaying turbulence (all in one shot) */
    de = dedt;
  }
  aa = 0.5*t1;
  aa = MAX(aa,1.0e-20);
  b = t2;
  c = -de/dvol;
  if(b >= 0.0)
    s = (-2.0*c)/(b + sqrt(b*b - 4.0*aa*c));
  else
    s = (-b + sqrt(b*b - 4.0*aa*c))/(2.0*aa);

  if (isnan(s)) ath_error("[perturb]: s is NaN!\n");

  /* Apply momentum pertubations */
  for (k=ks; k<=ke; k++) {
    for (j=js; j<=je; j++) {
      for (i=is; i<=ie; i++) {
        qa = s*pGrid->U[k][j][i].d;
        pGrid->U[k][j][i].M1 += qa*dv1[k][j][i];
        pGrid->U[k][j][i].M2 += qa*dv2[k][j][i];
        pGrid->U[k][j][i].M3 += qa*dv3[k][j][i];
      }
    }
  }

  return;
}
Пример #26
0
void problem(DomainS *pDomain)
{
  GridS *pGrid=(pDomain->Grid);
  int i,il,iu,j,jl,ju,k,kl,ku;
  int shk_dir; /* Shock direction: {1,2,3} -> {x1,x2,x3} */
  Real x1,x2,x3;
  Prim1DS Wl, Wr;
  Cons1DS U1d, Ul, Ur;
  Real Bxl=0.0, Bxr=0.0;

/* Parse left state read from input file: dl,pl,ul,vl,wl,bxl,byl,bzl */

  Wl.d = par_getd("problem","dl");
#ifdef ADIABATIC
  Wl.P = par_getd("problem","pl");
#endif
  Wl.Vx = par_getd("problem","v1l");
  Wl.Vy = par_getd("problem","v2l");
  Wl.Vz = par_getd("problem","v3l");
#ifdef MHD
  Bxl = par_getd("problem","b1l");
  Wl.By = par_getd("problem","b2l");
  Wl.Bz = par_getd("problem","b3l");
#endif
#if (NSCALARS > 0)
  Wl.r[0] = par_getd("problem","r[0]l");
#endif

/* Parse right state read from input file: dr,pr,ur,vr,wr,bxr,byr,bzr */

  Wr.d = par_getd("problem","dr");
#ifdef ADIABATIC
  Wr.P = par_getd("problem","pr");
#endif
  Wr.Vx = par_getd("problem","v1r");
  Wr.Vy = par_getd("problem","v2r");
  Wr.Vz = par_getd("problem","v3r");
#ifdef MHD
  Bxr = par_getd("problem","b1r");
  Wr.By = par_getd("problem","b2r");
  Wr.Bz = par_getd("problem","b3r");
  if (Bxr != Bxl) ath_error(0,"[shkset1d] L/R values of Bx not the same\n");
#endif
#if (NSCALARS > 0)
  Wr.r[0] = par_getd("problem","r[0]r");
#endif

  Ul = Prim1D_to_Cons1D(&Wl, &Bxl);
  Ur = Prim1D_to_Cons1D(&Wr, &Bxr);

/* Parse shock direction */
  shk_dir = par_geti("problem","shk_dir");
  if (shk_dir != 1 && shk_dir != 2 && shk_dir != 3) {
    ath_error("[problem]: shk_dir = %d must be either 1,2 or 3\n",shk_dir);
  }

/* Set up the index bounds for initializing the grid */
  iu = pGrid->ie + nghost;
  il = pGrid->is - nghost;

  if (pGrid->Nx[1] > 1) {
    ju = pGrid->je + nghost;
    jl = pGrid->js - nghost;
  }
  else {
    ju = pGrid->je;
    jl = pGrid->js;
  }

  if (pGrid->Nx[2] > 1) {
    ku = pGrid->ke + nghost;
    kl = pGrid->ks - nghost;
  }
  else {
    ku = pGrid->ke;
    kl = pGrid->ks;
  }

/* Initialize the grid including the ghost cells.  Discontinuity is always
 * located at x=0, so xmin/xmax in input file must be set appropriately. */

  switch(shk_dir) {
/*--- shock in 1-direction ---------------------------------------------------*/
  case 1:  /* shock in 1-direction  */
    for (k=kl; k<=ku; k++) {
      for (j=jl; j<=ju; j++) {
        for (i=il; i<=iu; i++) {
          cc_pos(pGrid, i, j, k, &x1, &x2, &x3);

/* set primitive and conserved variables to be L or R state */
          if (x1 <= 0.0) {
            U1d = Ul;
          } else {
            U1d = Ur;
          }

/* Initialize conserved (and with SR the primitive) variables in Grid */
          pGrid->U[k][j][i].d  = U1d.d;
          pGrid->U[k][j][i].M1 = U1d.Mx;
          pGrid->U[k][j][i].M2 = U1d.My;
          pGrid->U[k][j][i].M3 = U1d.Mz;
#ifdef MHD
          pGrid->B1i[k][j][i] = Bxl;
          pGrid->B2i[k][j][i] = U1d.By;
          pGrid->B3i[k][j][i] = U1d.Bz;
          pGrid->U[k][j][i].B1c = Bxl;
          pGrid->U[k][j][i].B2c = U1d.By;
          pGrid->U[k][j][i].B3c = U1d.Bz;
#endif
#ifdef ADIABATIC
          pGrid->U[k][j][i].E = U1d.E;
#endif
#if (NSCALARS > 0)
          pGrid->U[k][j][i].s[0] = U1d.s[0];
#endif
        }
      }
    }
    break;

/*--- shock in 2-direction ---------------------------------------------------*/
  case 2:  /* shock in 2-direction  */
    for (k=kl; k<=ku; k++) {
      for (j=jl; j<=ju; j++) {
        for (i=il; i<=iu; i++) {
          cc_pos(pGrid, i, j, k, &x1, &x2, &x3);

/* set primitive variables to be L or R state */
          if (x2 <= 0.0) {
            U1d = Ul;
          } else {
            U1d = Ur;
          }

/* Initialize conserved (and with SR the primitive) variables in Grid */
          pGrid->U[k][j][i].d  = U1d.d;
          pGrid->U[k][j][i].M1 = U1d.Mz;
          pGrid->U[k][j][i].M2 = U1d.Mx;
          pGrid->U[k][j][i].M3 = U1d.My;
#ifdef MHD
          pGrid->B1i[k][j][i] = U1d.Bz;
          pGrid->B2i[k][j][i] = Bxl;
          pGrid->B3i[k][j][i] = U1d.By;
          pGrid->U[k][j][i].B1c = U1d.Bz;
          pGrid->U[k][j][i].B2c = Bxl;
          pGrid->U[k][j][i].B3c = U1d.By;
#endif
#ifdef ADIABATIC
          pGrid->U[k][j][i].E = U1d.E;
#endif
#if (NSCALARS > 0)
          pGrid->U[k][j][i].s[0] = U1d.s[0];
#endif
        }
      }
    }
    break;

/*--- shock in 3-direction ---------------------------------------------------*/
  case 3:  /* shock in 3-direction  */
    for (k=kl; k<=ku; k++) {
      for (j=jl; j<=ju; j++) {
        for (i=il; i<=iu; i++) {
          cc_pos(pGrid, i, j, k, &x1, &x2, &x3);

/* set primitive variables to be L or R state */
          if (x3 <= 0.0) {
            U1d = Ul;
          } else {
            U1d = Ur;
          }

/* Initialize conserved (and with SR the primitive) variables in Grid */
          pGrid->U[k][j][i].d  = U1d.d;
          pGrid->U[k][j][i].M1 = U1d.My;
          pGrid->U[k][j][i].M2 = U1d.Mz;
          pGrid->U[k][j][i].M3 = U1d.Mx;
#ifdef MHD
          pGrid->B1i[k][j][i] = U1d.By;
          pGrid->B2i[k][j][i] = U1d.Bz;
          pGrid->B3i[k][j][i] = Bxl;
          pGrid->U[k][j][i].B1c = U1d.By;
          pGrid->U[k][j][i].B2c = U1d.Bz;
          pGrid->U[k][j][i].B3c = Bxl;
#endif
#ifdef ADIABATIC
          pGrid->U[k][j][i].E = U1d.E;
#endif
#if (NSCALARS > 0)
          pGrid->U[k][j][i].s[0] = U1d.s[0];
#endif
        }
      }
    }
  break;
  default:
    ath_error("[shkset1d]: invalid shk_dir = %i\n",shk_dir);
  }

  return;
}
Пример #27
0
void Userwork_in_loop(MeshS *pM)
{


  DomainS *pDomain = (DomainS*)&(pM->Domain[0][0]);
  GridS *pGrid = pM->Domain[0][0].Grid;


int i, is=pGrid->is, ie = pGrid->ie;
  int j, js=pGrid->js, je = pGrid->je;
  int k, ks=pGrid->ks, ke = pGrid->ke;
  Real newtime;

  Real qt,tdep,s_period,AA;
  Real delta_x, delta_z, xxmax, yymax, xxmin, yymin;
  Real exp_x,exp_y,exp_z,exp_xyz;
  Real r1,r2,xp, yp,zp;
  Real vvz;
  Real x1,x2,x3;

  Real xcz,xcx;

  int n1,n2;

  n1=0;
  n2=0;


  s_period=30.0; //Driver period
  AA=350.0;       //Driver amplitude
  //AA=1;
  xcz=0.5e6;
  xcx=2.0e6;
  delta_z=0.004e6;
  delta_x=0.016e6;




  if (isnan(pGrid->dt)) ath_error("Time step is NaN!");


	qt=pGrid->time;

	tdep=sin(qt*2.0*PI/s_period);



	if (pM->Nx[2] == 1)
	{
		cc_pos(pGrid,ie,je,ke,&x1,&x2,&x3);
		xxmax=x1;
		yymax=x3;
		cc_pos(pGrid,is,js,ks,&x1,&x2,&x3);
		xxmax=xxmax-x1;
		yymax=yymax-x3;
		xxmin=x1;
		yymin=x3;
	}

        /*printf("%d %d %d \n",is,js,ks);
        printf("%d %d %d \n",ie,je,ke);
        printf("%d %d %d \n", pGrid->Nx[0],pGrid->Nx[1], pGrid->Nx[2]);*/
	if (pGrid->Nx[2] == 1) {
	  for (k=ks; k<=ke; k++) {
	    for (j=js; j<=je; j++) {
	      for (i=is; i<=ie; i++) {
		cc_pos(pGrid,i,j,k,&x1,&x2,&x3);

		xp=x1-xxmin;
		yp=x3-yymin;
		zp=x2;

		r2=(zp-xcz)*(zp-xcz);
                r1=(xp-xcx)*(xp-xcx);
		
                exp_y=exp(-r1/(delta_x*delta_x));
		exp_z=exp(-r2/(delta_z*delta_z));
		exp_xyz=sin(PI*xp*(n1+1)/xxmax)*exp_z;
		//exp_xyz=exp_y*exp_z;

		vvz=100*AA*exp_xyz*tdep;
                vvz=0;
                //if(j==12)
                //    printf("%d %d %d %f %f %f %f %f %f\n",i,j,k,xp,yp,zp,xcz,exp_y,exp_z);

//if(i>60 && i<68)
//if(i>is && i<ie)
//{

                //if(j==12)
                //    printf("%d %d %d %g %g %g \n",i,j,k,vvz,(pGrid->dt),(pGrid->dt)*vvz*(pGrid->U[k][j][i].d));


		pGrid->U[k][j][i].M2 += (pGrid->dt)*vvz*(pGrid->U[k][j][i].d);
		pGrid->U[k][j][i].E += (pGrid->dt)*vvz*vvz*(pGrid->U[k][j][i].d)/2.0;
//}
	      }
              //printf("\n");

	    }
	  }
        }

	//for 3D model
	if (pM->Nx[2] > 1)
	{
		cc_pos(pGrid,ie,je,ke,&x1,&x2,&x3);
		xxmax=x1;
		yymax=x2;
		cc_pos(pGrid,is,js,ks,&x1,&x2,&x3);
		xxmax=xxmax-x1;
		yymax=yymax-x2;
		xxmin=x1;
		yymin=x2;
	}



	if (pGrid->Nx[2] > 1) {
	  for (k=ks; k<=ke; k++) {
	    for (j=js; j<=je; j++) {
	      for (i=is; i<=ie; i++) {
		cc_pos(pGrid,i,j,k,&x1,&x2,&x3);

		xp=x1-xxmin;
		yp=x2-yymin;
		zp=x3;

		r2=(x3-xcz)*(x3-xcz);
		
		exp_z=exp(-r2/(delta_z*delta_z));
		exp_xyz=sin(PI*xp*(n1+1)/xxmax)*sin(PI*yp*(n2+1)/yymax)*exp_z;

		vvz=AA*exp_xyz*tdep;
                vvz=0;

		pGrid->U[k][j][i].M3 += (pGrid->dt)*vvz*(pGrid->U[k][j][i].d);
		pGrid->U[k][j][i].E += (pGrid->dt)*vvz*vvz*(pGrid->U[k][j][i].d)/2.0;
	      }

	    }
	  }
      }

	//newtime = pGrid->time + pGrid->dt;



  return;

}
Пример #28
0
/* --------------------------------------------------------------
 * Routine to compute photoionization rate from a plane radiation
 * source.
 * --------------------------------------------------------------
 */
void get_ph_rate_plane(Real initflux, int dir, Real ***ph_rate, DomainS *pDomain) {
  GridS *pGrid = pDomain->Grid;
  int lr, fixed;
  Real tau, n_H, kph, etau, cell_len;
  Real flux, flux_frac;
  int i, j, k, ii;
  int s, e;
#ifdef MPI_PARALLEL
  int NGrid_x1, NGrid_x2, NGrid_x3;
  int n, nGrid=0;
  int myrank, nextproc, prevproc, err;
  int planesize;
  Real *planeflux = NULL;
  Real max_flux_frac, max_flux_frac_glob;
  MPI_Status stat;
  int npg, ncg, arrsize;
  MPI_Comm Comm_Domain = pDomain->Comm_Domain;
#endif
#ifdef STATIC_MESH_REFINEMENT
  GridOvrlpS *pCO, *pPO;
#endif
  MeshS *pMesh = pGrid->Mesh;

  flux = 0;

  /* Set lr based on whether radiation is left or right
     propagating. lr = 1 is for radiation going left to right. Also
     set up the start and end indices based on the direction, and
     store the cell length. */
  lr = (dir < 0) ? 1 : -1;
  switch(dir) {
  case -1: case 1: {
    if (lr > 0) {
      s=pGrid->is; e=pGrid->ie;
    } else {
      s=pGrid->ie; e=pGrid->is;
    }
    cell_len = pGrid->dx1;
    break;
  }
  case -2: case 2: {
    if (lr > 0) {
      s=pGrid->js; e=pGrid->je;
    } else {
      s=pGrid->je; e=pGrid->js;
    }
    cell_len = pGrid->dx2;
    break;
  }
  case -3: case 3: {
    if (lr > 0) {
      s=pGrid->ks; e=pGrid->ke;
    } else {
      s=pGrid->ke; e=pGrid->ks;
    cell_len = pGrid->dx3;
    }
    break;
  }
  }

  fixed = (lr > 0) ? 0 : e - nghost;

#ifdef MPI_PARALLEL
  /* Figure out processor geometry: where am I, where are my neighbors
     upstream and downstream, how many processors are there in the
     direction of radiation propagation, how big is the interface with
     my neighbor? */
  NGrid_x1 = pDomain->NGrid[0];
  NGrid_x2 = pDomain->NGrid[1];
  NGrid_x3 = pDomain->NGrid[2];

  for (k=0; k<NGrid_x3; k++) {
    for (j=0; j<NGrid_x2; j++) {
      for (i=0; i<NGrid_x1; i++) {
	if (pDomain->GData[k][j][i].ID_Comm_world == myID_Comm_world) {
	  switch(dir) {
	  case -1: case 1: {
	    nGrid=NGrid_x1;
	    myrank = lr > 0 ? i : nGrid - i - 1;
	    planesize=pGrid->Nx[1]*pGrid->Nx[2];
	    if ((i-lr >= 0) && (i-lr <= NGrid_x1-1))
	      prevproc = pDomain->GData[k][j][i-lr].ID_Comm_world;
	    else
	      prevproc = -1;
	    if ((i+lr >= 0) && (i+lr <= NGrid_x1-1))
	      nextproc = pDomain->GData[k][j][i+lr].ID_Comm_world;
	    else
	      nextproc = -1;
	    break;
	  }
	  case -2: case 2: {
	    nGrid=NGrid_x2;
	    myrank = lr > 0 ? j : nGrid - j - 1;
	    planesize=pGrid->Nx[0]*pGrid->Nx[1];
	    if ((j-lr >= 0) && (j-lr <= NGrid_x2-1))
	      prevproc = pDomain->GData[k][j-lr][i].ID_Comm_world;
	    else
	      prevproc = -1;
	    if ((j+lr >= 0) && (j+lr <= NGrid_x2-1))
	      nextproc = pDomain->GData[k][j+lr][i].ID_Comm_world;
	    else
	      nextproc = -1;
	    break;
	  }
	  case -3: case 3: {
	    nGrid=NGrid_x3;
	    myrank = lr > 0 ? k : nGrid - k - 1;
	    planesize=pGrid->Nx[0]*pGrid->Nx[1];
	    if ((k-lr >= 0) && (k-lr <= NGrid_x3-1))
	      prevproc = pDomain->GData[k-lr][j][i].ID_Comm_world;
	    else
	      prevproc = -1;
	    if ((k+lr >= 0) && (k+lr <= NGrid_x2-1))
	      nextproc = pDomain->GData[k+lr][j][i].ID_Comm_world;
	    else
	      nextproc = -1;
	    break;
	  }
	  default:
	    ath_error("[get_ph_rate_plane]: dir must be +-1, 2, or 3\n");
	  }
	}
      }
      if (nGrid != 0) break;
    }
      if (nGrid != 0) break;
  }


  /* AT 9/26/12: Make sure that the grids at the upsetram edge have received their data from the coarse grid.  */
  /* Also ADD IN a non-MPI receive for SMR only - A.t. 9/14/12*/


  /* Allocate memory for flux at interface on first pass */
  if (!(planeflux=calloc(planesize, sizeof(Real))))
    ath_error("[get_ph_rate_plane]: calloc returned a null pointer!\n");

  /* Loop over processors in the direction of propagation */
  for (n=0; n<nGrid; n++) {

    /* Set to 0 flux fraction remaining to start */
    max_flux_frac = 0.0;

    /* Am I the rank before the current one? If so, pass the flux on
       to the next processor. */
    if (myrank == n-1) {
      err = MPI_Send(planeflux, planesize, MP_RL, nextproc, n,
		     MPI_COMM_WORLD);
      if (err) ath_error("[get_ph_rate_plane]: MPI_Send error = %d\n", err);
    } 
 
    /* Is it my turn to compute the transfer now? */
    if (myrank == n) {

      /* If I am not the first processor, get the flux from the
	 previous one */
      if (prevproc != -1) {
	err = MPI_Recv(planeflux, planesize, MP_RL, prevproc, n,
		       MPI_COMM_WORLD, &stat);
	if (err) ath_error("[get_ph_rate_plane]: MPI_Send error = %d\n", err);
      } 
#endif /* MPI_PARALLEL */

      /* Propagate the radiation */
      switch(dir) {
      case -1: case 1: {
	for (k=pGrid->ks; k<=pGrid->ke; k++) {
	  for (j=pGrid->js; j<=pGrid->je; j++) {
#ifdef MPI_PARALLEL
	    /* Get initial flux from passed information or boundary
	       conditions */
	    if (prevproc != -1) 
	      flux = planeflux[(k-pGrid->ks)*pGrid->Nx[1]+j-pGrid->js];
	    else
#endif /* MPI_PARALLEL */
	      if (pDomain->Level == 0){
		/* if (pMesh->time <= 9e4) { */
		flux = (pMesh->radplanelist)->flux_i*(5.*(erf((pMesh->time - 1.2e5)/8e4)+1)+0.1);
		  /* log1p(pMesh->time) / log1p(9e4); */
		/* } else  { */
		/*   flux = (pMesh->radplanelist)->flux_i; */
		/* } */
	      } else {
		flux = pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][fixed];
	      }
	    /* if (pDomain->Level >0 && flux > 1) */
	    /*   fprintf(stderr,"Level: %d Input: k: %d j: %d, i:%d Here: %e Mesh: %e\n",pDomain->Level, k-pGrid->ks, j-pGrid->js, fixed, flux, (pMesh->radplanelist)->flux_i); */

	    /* fprintf(stderr,"Input: k: %d j: %d, i:0 Here: %e Mesh: %e\n",k-pGrid->ks, j-pGrid->js, flux, (pMesh->radplanelist)->flux_i); */

	    for (i=s; i<=e; i+=lr) {
	      pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][i-s] = flux;
	      /* fprintf(stderr,"Setting  pGrid->EdgeFlux[%d][%d][%d - %d] to %f \n", k-pGrid->ks, j-pGrid->js, i, s, flux); */
	      n_H = pGrid->U[k][j][i].s[0] / m_H;

	      	      /* fprintf(stderr, "I am %d My flux at k: %d j: %d i: %d is %f \n", myID_Comm_world, k-pGrid->ks, j-pGrid->js, i-pGrid->is, pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][i-s]); */

/* 	      if (pGrid->Nx[0] != 64){ */
/* 		if ((j<pGrid->js+1) && (k<pGrid->ks+1) && (i<s+2)) { */
/* /\* 		  fprintf(stderr, "Fine -  Time: %e .... i: %d, j:%d, k:%d ..... nh: %e, flux:%e \n", pMesh->time, i-s, j-pGrid->js,k-pGrid->ks, n_H ,pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][i-s]); *\/ */
/* 		} */
/* 	      } else{ */
/* 		if ((j<pGrid->js+1) && (k<pGrid->ks+1) && (i<s+2)) { */
/* /\* 		  fprintf(stderr, "Coarse -  Time: %e .... i: %d, j:%d, k:%d ..... nh: %e, Flux: %e \n", pMesh->time, i-s, j-pGrid->js,k-pGrid->ks, n_H,pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][i-s]); *\/ */
/* 		} */
/* 	      } */
	      tau = sigma_ph * n_H * pGrid->dx1;
	      etau = exp(-tau);
	      kph = flux * (1.0-etau) / (n_H*cell_len);
	      ph_rate[k][j][i] += kph;
	      flux *= etau;
	      flux_frac = flux / (pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][fixed] +1e-12); /*Check if this should still be 0 or not*/
	      if (flux_frac < MINFLUXFRAC){
		/*AT 1/15/13: Should this really not be here??*/
		for (ii=i; ii<=e; ii+=lr) {
		  pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][ii-s+1] = 0.0;
		}
		break;
	      }
	    }
	    pGrid->EdgeFlux[k-pGrid->ks][j-pGrid->js][e-s+1] = flux_frac < MINFLUXFRAC ? 0.0 : flux; /*Account for flux at rightmost edge*/
#ifdef MPI_PARALLEL
	    /* Store final flux to pass to next processor, or 0 if we
	       ended the loop early because we were below the minimum
	       fraction. */
	    planeflux[(k-pGrid->ks)*pGrid->Nx[1]+j-pGrid->js] = flux_frac < MINFLUXFRAC ? 0.0 : flux;

	    /*	    fprintf("j:%d, k:%d, Planeflux %f \n", j, k, planeflux[(k-pGrid->ks)*pGrid->Nx[1]+j-pGrid->js]);
	     */
	    max_flux_frac = (flux_frac > max_flux_frac) ? flux_frac : max_flux_frac;
#endif /* MPI_PARALLEL */
	  }
	}
	break;
      }
      case -2: case 2: {
	for (k=pGrid->ks; k<=pGrid->ke; k++) {
	  for (i=pGrid->is; i<=pGrid->ie; i++) {
#ifdef MPI_PARALLEL
	    /* Get initial flux from passed information or boundary
	       conditions */
	    if (prevproc != -1) 
	      flux = planeflux[(k-pGrid->ks)*pGrid->Nx[0]+i-pGrid->is];
	    else
#endif /* MPI_PARALLEL */
	      flux = initflux;
	    for (j=s; j<=e; j+=lr) {
	      pGrid->EdgeFlux[k-pGrid->ks][j-s][i-pGrid->is] = flux;
	      n_H = pGrid->U[k][j][i].s[0] / m_H;
	      tau = sigma_ph * n_H * pGrid->dx1;
	      etau = exp(-tau);
	      kph = flux * (1.0-etau) / (n_H*cell_len);
	      ph_rate[k][j][i] += kph;
	      flux *= etau;
	      flux_frac = flux / initflux;
	      if (flux_frac < MINFLUXFRAC) break;
	    }
#ifdef MPI_PARALLEL
	    /* Store final flux to pass to next processor */
	    planeflux[(k-pGrid->ks)*pGrid->Nx[0]+i-pGrid->is] = 
	      flux_frac < MINFLUXFRAC ? 0.0 : flux;
	    max_flux_frac = (flux_frac > max_flux_frac) ?
	      flux_frac : max_flux_frac;
#endif /* MPI_PARALLEL */
	  }
	}
	break;
      }
      case -3: case 3: {
	for (j=pGrid->js; j<=pGrid->je; j++) {
	  for (i=pGrid->is; i<=pGrid->ie; i++) {
#ifdef MPI_PARALLEL
	    /* Get initial flux from passed information or boundary
	       conditions */
	    if (prevproc != -1) 
	      flux = planeflux[(j-pGrid->js)*pGrid->Nx[0]+i-pGrid->is];
	    else
#endif /* MPI_PARALLEL */
	      flux = initflux;
	    for (k=s; k<=e; k+=lr) {
	      pGrid->EdgeFlux[k-s][j-pGrid->js][i-pGrid->is] = flux;
	      n_H = pGrid->U[k][j][i].s[0] / m_H;
	      tau = sigma_ph * n_H * pGrid->dx1;
	      etau = exp(-tau);
	      kph = flux * (1.0-etau) / (n_H*cell_len);
	      ph_rate[k][j][i] += kph;
	      flux *= etau;
	      flux_frac = flux / initflux;
	      if (flux_frac < MINFLUXFRAC) break;
	    }
#ifdef MPI_PARALLEL
	    /* Store final flux to pass to next processor */
	    planeflux[(j-pGrid->js)*pGrid->Nx[0]+i-pGrid->is] = 
	      flux_frac < MINFLUXFRAC ? 0.0 : flux;
	    max_flux_frac = (flux_frac > max_flux_frac) ?
	      flux_frac : max_flux_frac;
#endif /* MPI_PARALLEL */
	  }
	}
	break;
      }
      }

#ifdef MPI_PARALLEL
    }

    /* If we're parallel, get the maximum flux fraction left and see
       if we should continue to the next set of processors. */
    err = MPI_Allreduce(&max_flux_frac, &max_flux_frac_glob, 1, MP_RL,
			MPI_MAX, Comm_Domain);
    if (err) ath_error("[get_ph_rate_plane]: MPI_Allreduce error = %d\n", err);
    if (max_flux_frac_glob < MINFLUXFRAC) break;
  }


  free(planeflux);
#endif /* MPI_PARALLEL */

  return;
}
Пример #29
0
void problem(DomainS *pDomain)
{
  GridS *pGrid=(pDomain->Grid);
  int i,il,iu,j,jl,ju,k,kl,ku;
  int is,ie,js,je,ks,ke,nx1,nx2,nx3;

  int shk_dir; /* Shock direction: {1,2,3} -> {x1,x2,x3} */
  Real ang_2, ang_3; /* Rotation angles about the y and z' axis */
  Real sin_a2, cos_a2, sin_a3, cos_a3;

  Real x1,x2,x3;
  Prim1DS Wl, Wr;
  Cons1DS U1d, Ul, Ur;
  Real Bxl=0.0, Bxr=0.0, Bxb=0.0;
/* speeds of shock, contact, head and foot of rarefaction for Sod test */
/* speeds of slow/fast shocks, Alfven wave and contact in RJ2a test */
  Real tlim;
  int err_test;
  Real r,xs,xc,xf,xh,vs,vc,vf,vh;
  Real xfp,xrp,xsp,xsm,xrm,xfm,vfp,vrp,vsp,vsm,vrm,vfm;
  Real d0,v0,Mx,My,Mz,E0,r0,Bx,By,Bz;
#if (NSCALARS > 0)
  int n;
#endif

  is = pGrid->is; ie = pGrid->ie;
  js = pGrid->js; je = pGrid->je;
  ks = pGrid->ks; ke = pGrid->ke;

  nx1 = (ie-is)+1 + 2*nghost;
  nx2 = (je-js)+1 + 2*nghost;
  nx3 = (ke-ks)+1 + 2*nghost;

printf("here1\n");


  if (pDomain->Level == 0){
    if ((RootSoln = (ConsS***)calloc_3d_array(nx3,nx2,nx1,sizeof(ConsS)))
      == NULL) ath_error("[problem]: Error alloc memory for RootSoln\n");
  }

/* Parse left state read from input file: dl,pl,ul,vl,wl,bxl,byl,bzl */

  Wl.d = par_getd("problem","dl");
#ifdef ADIABATIC
  Wl.P = par_getd("problem","pl");
#endif
  Wl.Vx = par_getd("problem","v1l");
  Wl.Vy = par_getd("problem","v2l");
  Wl.Vz = par_getd("problem","v3l");
#ifdef MHD
  Bxl = par_getd("problem","b1l");
  Wl.By = par_getd("problem","b2l");
  Wl.Bz = par_getd("problem","b3l");
#endif
#if (NSCALARS > 0)
  Wl.r[0] = par_getd("problem","r0l");
#endif

/* Parse right state read from input file: dr,pr,ur,vr,wr,bxr,byr,bzr */

  Wr.d = par_getd("problem","dr");
#ifdef ADIABATIC
  Wr.P = par_getd("problem","pr");
#endif
  Wr.Vx = par_getd("problem","v1r");
  Wr.Vy = par_getd("problem","v2r");
  Wr.Vz = par_getd("problem","v3r");
#ifdef MHD
  Bxr = par_getd("problem","b1r");
  Wr.By = par_getd("problem","b2r");
  Wr.Bz = par_getd("problem","b3r");
  if (Bxr != Bxl) ath_error(0,"[shkset1d] L/R values of Bx not the same\n");
#endif
#if (NSCALARS > 0)
  Wr.r[0] = par_getd("problem","r0r");
#endif


printf("here2\n");
#ifdef SAC_INTEGRATOR
 Ul = Prim1D_to_Cons1D(&Wl, &Bxl,&Bxb);
  Ur = Prim1D_to_Cons1D(&Wr, &Bxr,&Bxb);
#elif defined  SMAUG_INTEGRATOR
 Ul = Prim1D_to_Cons1D(&Wl, &Bxl,&Bxb);
  Ur = Prim1D_to_Cons1D(&Wr, &Bxr,&Bxb);
#else
  Ul = Prim1D_to_Cons1D(&Wl, &Bxl);
  Ur = Prim1D_to_Cons1D(&Wr, &Bxr);
#endif
printf("here3\n");
/* Parse shock direction */
  shk_dir = par_geti("problem","shk_dir");
  if (shk_dir != 1 && shk_dir != 2 && shk_dir != 3) {
    ath_error("[problem]: shk_dir = %d must be either 1,2 or 3\n",shk_dir);
  }

/* Set up the index bounds for initializing the grid */
  iu = pGrid->ie + nghost;
  il = pGrid->is - nghost;

  if (pGrid->Nx[1] > 1) {
    ju = pGrid->je + nghost;
    jl = pGrid->js - nghost;
  }
  else {
    ju = pGrid->je;
    jl = pGrid->js;
  }

  if (pGrid->Nx[2] > 1) {
    ku = pGrid->ke + nghost;
    kl = pGrid->ks - nghost;
  }
  else {
    ku = pGrid->ke;
    kl = pGrid->ks;
  }


printf("here4\n");
/* Initialize the grid including the ghost cells.  Discontinuity is always
 * located at x=0, so xmin/xmax in input file must be set appropriately. */

  switch(shk_dir) {
/*--- shock in 1-direction ---------------------------------------------------*/
  case 1:  /* shock in 1-direction  */
    ang_2 = 0.0;
    ang_3 = 0.0;

    for (k=kl; k<=ku; k++) {
      for (j=jl; j<=ju; j++) {
        for (i=il; i<=iu; i++) {
          cc_pos(pGrid, i, j, k, &x1, &x2, &x3);

/* set primitive and conserved variables to be L or R state */
          if (x1 <= 0.0) {
            U1d = Ul;
          } else {
            U1d = Ur;
          }

/* Initialize conserved (and with SR the primitive) variables in Grid */
          pGrid->U[k][j][i].d  = U1d.d;
          pGrid->U[k][j][i].M1 = U1d.Mx;
          pGrid->U[k][j][i].M2 = U1d.My;
          pGrid->U[k][j][i].M3 = U1d.Mz;
#ifdef MHD
          pGrid->B1i[k][j][i] = Bxl;
          pGrid->B2i[k][j][i] = U1d.By;
          pGrid->B3i[k][j][i] = U1d.Bz;
          pGrid->U[k][j][i].B1c = Bxl;
          pGrid->U[k][j][i].B2c = U1d.By;
          pGrid->U[k][j][i].B3c = U1d.Bz;
#endif
#ifdef ADIABATIC
          pGrid->U[k][j][i].E = U1d.E;
#endif
#if (NSCALARS > 0)
          pGrid->U[k][j][i].s[0] = U1d.s[0];
#endif
        }
      }
    }
    break;

/*--- shock in 2-direction ---------------------------------------------------*/
  case 2:  /* shock in 2-direction  */
    ang_2 = 0.0;
    ang_3 = PI/2.0;
    for (k=kl; k<=ku; k++) {
      for (j=jl; j<=ju; j++) {
        for (i=il; i<=iu; i++) {
          cc_pos(pGrid, i, j, k, &x1, &x2, &x3);

/* set primitive variables to be L or R state */
          if (x2 <= 0.0) {
            U1d = Ul;
          } else {
            U1d = Ur;
          }

/* Initialize conserved (and with SR the primitive) variables in Grid */
          pGrid->U[k][j][i].d  = U1d.d;
          pGrid->U[k][j][i].M1 = -U1d.My;
          pGrid->U[k][j][i].M2 = U1d.Mx;
          pGrid->U[k][j][i].M3 = U1d.Mz;
#ifdef MHD
          pGrid->B1i[k][j][i] = -U1d.By;
          pGrid->B2i[k][j][i] = Bxl;
          pGrid->B3i[k][j][i] = U1d.Bz;
          pGrid->U[k][j][i].B1c = -U1d.By;
          pGrid->U[k][j][i].B2c = Bxl;
          pGrid->U[k][j][i].B3c = U1d.Bz;
#endif
#ifdef ADIABATIC
          pGrid->U[k][j][i].E = U1d.E;
#endif
#if (NSCALARS > 0)
          pGrid->U[k][j][i].s[0] = U1d.s[0];
#endif
        }
      }
    }
    break;

/*--- shock in 3-direction ---------------------------------------------------*/
  case 3:  /* shock in 3-direction  */
    ang_2 = PI/2.0;
    ang_3 = 0.0;
    for (k=kl; k<=ku; k++) {
      for (j=jl; j<=ju; j++) {
        for (i=il; i<=iu; i++) {
          cc_pos(pGrid, i, j, k, &x1, &x2, &x3);

/* set primitive variables to be L or R state */
          if (x3 <= 0.0) {
            U1d = Ul;
          } else {
            U1d = Ur;
          }

/* Initialize conserved (and with SR the primitive) variables in Grid */
          pGrid->U[k][j][i].d  = U1d.d;
          pGrid->U[k][j][i].M1 = -U1d.Mz;
          pGrid->U[k][j][i].M2 = U1d.My;
          pGrid->U[k][j][i].M3 = U1d.Mx;
#ifdef MHD
          pGrid->B1i[k][j][i] = -U1d.Bz;
          pGrid->B2i[k][j][i] = U1d.By;
          pGrid->B3i[k][j][i] = Bxl;
          pGrid->U[k][j][i].B1c = -U1d.Bz;
          pGrid->U[k][j][i].B2c = U1d.By;
          pGrid->U[k][j][i].B3c = Bxl;
#endif
#ifdef ADIABATIC
          pGrid->U[k][j][i].E = U1d.E;
#endif
#if (NSCALARS > 0)
          pGrid->U[k][j][i].s[0] = U1d.s[0];
#endif
        }
      }
    }
  break;
  default:
    ath_error("[shkset1d]: invalid shk_dir = %i\n",shk_dir);
  }

/* Compute Analytic solution for Sod and RJ4a tests, if required */

  tlim = par_getd("time","tlim");
  err_test = par_getd_def("problem","error_test",0);
  if (err_test == 1) {

    sin_a3 = sin(ang_3);
    cos_a3 = cos(ang_3);
    sin_a2 = sin(ang_2);
    cos_a2 = cos(ang_2);

/* wave speeds for Sod test */
#ifdef HYDRO
    vs = 1.7522; xs = vs*tlim;
    vc = 0.92745; xc = vc*tlim;
    vf = -0.07027; xf = vf*tlim;
    vh = -1.1832; xh = vh*tlim;
#endif /* HYDRO */

/* wave speeds for RJ2a test */
#ifdef MHD
    vfp = 2.2638; xfp = vfp*tlim;
    vrp = (0.53432 + 1.0/sqrt(PI*1.309)); xrp = vrp*tlim;
    vsp = (0.53432 + 0.48144/1.309); xsp = vsp*tlim;
    vc = 0.57538; xc = vc*tlim;
    vsm = (0.60588 - 0.51594/1.4903); xsm = vsm*tlim;
    vrm = (0.60588 - 1.0/sqrt(PI*1.4903)); xrm = vrm*tlim;
    vfm = (1.2 - 2.3305/1.08); xfm = vfm*tlim;
#endif /* MHD */

    for (k=ks; k<=ke; k++) {
    for (j=js; j<=je; j++) {
      for (i=is; i<=ie; i++) {
        cc_pos(pGrid,i,j,k,&x1,&x2,&x3);
        r = cos_a2*(x1*cos_a3 + x2*sin_a3) + x3*sin_a2;

/* Sod solution */
#ifdef HYDRO
        My = Mz = 0.0;
        if (r > xs) {
          d0 = 0.125;
          Mx = 0.0;
          E0 = 0.25;
          r0 = 0.0;
        } else if (r > xc) {
          d0 = 0.26557;
          Mx = 0.92745*d0;
          E0 = 0.87204;
          r0 = 0.0;
        } else if (r > xf) {
          d0 = 0.42632;
          Mx = 0.92745*d0;
          E0 = 0.94118;
          r0 = 1.0;
        } else if (r > xh) {
          v0 = 0.92745*(r-xh)/(xf-xh);
          d0 = 0.42632*pow((1.0+0.20046*(0.92745-v0)),5);
          E0 = (0.30313*pow((1.0+0.20046*(0.92745-v0)),7))/0.4 + 0.5*d0*v0*v0;
          r0 = 1.0;
          Mx = v0*d0;
        } else {
          d0 = 1.0;
          Mx = 0.0;
          E0 = 2.5;
          r0 = 1.0;
        }
#endif /* HYDRO */
/* RJ2a solution (Dai & Woodward 1994 Tables Ia and Ib) */
#ifdef MHD
        Bx = 2.0/sqrt(4.0*PI);
        if (r > xfp) {
          d0 = 1.0;
          Mx = 0.0;
          My = 0.0;
          Mz = 0.0;
          By = 4.0/sqrt(4.0*PI);
          Bz = 2.0/sqrt(4.0*PI);
          E0 = 1.0/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 0.0;
        } else if (r > xrp) {
          d0 = 1.3090;
          Mx = 0.53432*d0;
          My = -0.094572*d0;
          Mz = -0.047286*d0;
          By = 5.3452/sqrt(4.0*PI);
          Bz = 2.6726/sqrt(4.0*PI);
          E0 = 1.5844/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 0.0;
        } else if (r > xsp) {
          d0 = 1.3090;
          Mx = 0.53432*d0;
          My = -0.18411*d0;
          Mz = 0.17554*d0;
          By = 5.7083/sqrt(4.0*PI);
          Bz = 1.7689/sqrt(4.0*PI);
          E0 = 1.5844/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 0.0;
        } else if (r > xc) {
          d0 = 1.4735;
          Mx = 0.57538*d0;
          My = 0.047601*d0;
          Mz = 0.24734*d0;
          By = 5.0074/sqrt(4.0*PI);
          Bz = 1.5517/sqrt(4.0*PI);
          E0 = 1.9317/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 0.0;
        } else if (r > xsm) {
          d0 = 1.6343;
          Mx = 0.57538*d0;
          My = 0.047601*d0;
          Mz = 0.24734*d0;
          By = 5.0074/sqrt(4.0*PI);
          Bz = 1.5517/sqrt(4.0*PI);
          E0 = 1.9317/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 1.0;
        } else if (r > xrm) {
          d0 = 1.4903;
          Mx = 0.60588*d0;
          My = 0.22157*d0;
          Mz = 0.30125*d0;
          By = 5.5713/sqrt(4.0*PI);
          Bz = 1.7264/sqrt(4.0*PI);
          E0 = 1.6558/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 1.0;
        } else if (r > xfm) {
          d0 = 1.4903;
          Mx = 0.60588*d0;
          My = 0.11235*d0;
          Mz = 0.55686*d0;
          By = 5.0987/sqrt(4.0*PI);
          Bz = 2.8326/sqrt(4.0*PI);
          E0 = 1.6558/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 1.0;
        } else {
          d0 = 1.08;
          Mx = 1.2*d0;
          My = 0.01*d0;
          Mz = 0.5*d0;
          By = 3.6/sqrt(4.0*PI);
          Bz = 2.0/sqrt(4.0*PI);
          E0 = 0.95/Gamma_1 + 0.5*((Mx*Mx+My*My+Mz*Mz)/d0 + (Bx*Bx+By*By+Bz*Bz));
          r0 = 1.0;
        }
#endif /* MHD */
 
        RootSoln[k][j][i].d = d0;

        RootSoln[k][j][i].M1 = Mx*cos_a2*cos_a3 - My*sin_a3 - Mz*sin_a2*cos_a3;
        RootSoln[k][j][i].M2 = Mx*cos_a2*sin_a3 + My*cos_a3 - Mz*sin_a2*sin_a3;
        RootSoln[k][j][i].M3 = Mx*sin_a2                    + Mz*cos_a2;

#ifdef MHD
        RootSoln[k][j][i].B1c = Bx*cos_a2*cos_a3 - By*sin_a3 - Bz*sin_a2*cos_a3;
        RootSoln[k][j][i].B2c = Bx*cos_a2*sin_a3 + By*cos_a3 - Bz*sin_a2*sin_a3;
        RootSoln[k][j][i].B3c = Bx*sin_a2                    + Bz*cos_a2;
#endif /* MHD */

#ifndef ISOTHERMAL
        RootSoln[k][j][i].E = E0;
#endif /* ISOTHERMAL */
#if (NSCALARS > 0)
        for (n=0; n<NSCALARS; n++) RootSoln[k][j][i].s[n] = r0*d0;
#endif

      }
    }}

  } /* end calculation of analytic (root) solution */

  return;
}
Пример #30
0
void init_mesh(MeshS *pM)
{
  int nblock,num_domains,nd,nl,level,maxlevel=0,nd_this_level;
  int nDim,nDim_test,dim;
  int *next_domainid;
  char block[80];
  int ncd,ir,irefine,l,m,n,roffset;
  int i,Nx[3],izones;
  div_t xdiv[3];  /* divisor with quot and rem members */
  Real root_xmin[3], root_xmax[3];  /* min/max of x in each dir on root grid */
  int Nproc_Comm_world=1,nproc=0,next_procID;
  SideS D1,D2;
  DomainS *pD, *pCD;
#ifdef MPI_PARALLEL
  int ierr,child_found,groupn,Nranks,Nranks0,max_rank,irank,*ranks;
  MPI_Group world_group;

/* Get total # of processes, in MPI_COMM_WORLD */
  ierr = MPI_Comm_size(MPI_COMM_WORLD, &Nproc_Comm_world);
#endif

/* Start by initializing some quantaties in Mesh structure */

  pM->time = 0.0;
  pM->nstep = 0;
  pM->outfilename = par_gets("job","problem_id");

/*--- Step 1: Figure out how many levels and domains there are. --------------*/
/* read levels of each domain block in input file and calculate max level */

  num_domains = par_geti("job","num_domains");
#ifndef STATIC_MESH_REFINEMENT
  if (num_domains > 1) 
    ath_error("[init_mesh]: num_domains=%d; for num_domains > 1 configure with --enable-smr\n",num_domains);
#endif

  for (nblock=1; nblock<=num_domains; nblock++){
    sprintf(block,"domain%d",nblock);
    if (par_exist(block,"level") == 0)
      ath_error("[init_mesh]: level does not exist in block %s\n",block);
    level = par_geti(block,"level");
    maxlevel = MAX(maxlevel,level);
  }

/* set number of levels in Mesh, and allocate DomainsPerLevel array */

  pM->NLevels = maxlevel + 1;  /* level counting starts at 0 */

  pM->DomainsPerLevel = (int*)calloc_1d_array(pM->NLevels,sizeof(int));
  if (pM->DomainsPerLevel == NULL)
    ath_error("[init_mesh]: malloc returned a NULL pointer\n");

/* Now figure out how many domains there are at each level */

  for (nl=0; nl<=maxlevel; nl++){
    nd_this_level=0;
    for (nblock=1; nblock<=num_domains; nblock++){
      sprintf(block,"domain%d",nblock);
      if (par_geti(block,"level") == nl) nd_this_level++; 
    }

/* Error if there are any levels with no domains.  Else set DomainsPerLevel */

    if (nd_this_level == 0) {
      ath_error("[init_mesh]: Level %d has zero domains\n",nl);
    } else {
      pM->DomainsPerLevel[nl] = nd_this_level;
    }
  }

/*--- Step 2: Set up root level.  --------------------------------------------*/
/* Find the <domain> block in the input file corresponding to the root level,
 * and set root level properties in Mesh structure  */

  if (pM->DomainsPerLevel[0] != 1)
    ath_error("[init_mesh]: Level 0 has %d domains\n",pM->DomainsPerLevel[0]);

  for (nblock=1; nblock<=num_domains; nblock++){
    sprintf(block,"domain%d",nblock);
    level = par_geti(block,"level");
    if (level == 0){
      root_xmin[0] = par_getd(block,"x1min");
      root_xmax[0] = par_getd(block,"x1max");
      root_xmin[1] = par_getd(block,"x2min");
      root_xmax[1] = par_getd(block,"x2max");
      root_xmin[2] = par_getd(block,"x3min");
      root_xmax[2] = par_getd(block,"x3max");
      Nx[0] = par_geti(block,"Nx1");
      Nx[1] = par_geti(block,"Nx2");
      Nx[2] = par_geti(block,"Nx3");

/* number of dimensions of root level, to test against all other inputs */
      nDim=0;
      for (i=0; i<3; i++) if (Nx[i]>1) nDim++;
      if (nDim==0) ath_error("[init_mesh] None of Nx1,Nx2,Nx3 > 1\n");

/* some error tests of root grid */

      for (i=0; i<3; i++) {
        if (Nx[i] < 1) {
          ath_error("[init_mesh]: Nx%d in %s must be >= 1\n",(i+1),block);
        }
        if(root_xmax[i] < root_xmin[i]) {
          ath_error("[init_mesh]: x%dmax < x%dmin in %s\n",(i+1),block);
        }
      }
      if (nDim==1 && Nx[0]==1) {
        ath_error("[init_mesh]:1D requires Nx1>1: in %s Nx1=1,Nx2=%d,Nx3=%d\n",
        block,Nx[1],Nx[2]);
      }
      if (nDim==2 && Nx[2]>1) {ath_error(
        "[init_mesh]:2D requires Nx1,Nx2>1: in %s Nx1=%d,Nx2=%d,Nx3=%d\n",
        block,Nx[0],Nx[1],Nx[2]);
      }

/* Now that everything is OK, set root grid properties in Mesh structure  */

      for (i=0; i<3; i++) {
        pM->Nx[i] = Nx[i];
        pM->RootMinX[i] = root_xmin[i];
        pM->RootMaxX[i] = root_xmax[i];
        pM->dx[i] = (root_xmax[i] - root_xmin[i])/(Real)(Nx[i]);
      }

/* Set BC flags on root domain */

      pM->BCFlag_ix1 = par_geti_def(block,"bc_ix1",0);
      pM->BCFlag_ix2 = par_geti_def(block,"bc_ix2",0);
      pM->BCFlag_ix3 = par_geti_def(block,"bc_ix3",0);
      pM->BCFlag_ox1 = par_geti_def(block,"bc_ox1",0);
      pM->BCFlag_ox2 = par_geti_def(block,"bc_ox2",0);
      pM->BCFlag_ox3 = par_geti_def(block,"bc_ox3",0);
    }
  }

/*--- Step 3: Allocate and initialize domain array. --------------------------*/
/* Allocate memory and set pointers for Domain array in Mesh.  Since the
 * number of domains nd depends on the level nl, this is a strange array
 * because it is not [nl]x[nd].  Rather it is nl pointers to nd[nl] Domains.
 * Compare to the calloc_2d_array() function in ath_array.c
 */
      
  if((pM->Domain = (DomainS**)calloc((maxlevel+1),sizeof(DomainS*))) == NULL){
    ath_error("[init_mesh] failed to allocate memory for %d Domain pointers\n",
     (maxlevel+1));
  }

  if((pM->Domain[0]=(DomainS*)calloc(num_domains,sizeof(DomainS))) == NULL){
    ath_error("[init_mesh] failed to allocate memory for Domains\n");
  }

  for(nl=1; nl<=maxlevel; nl++)
    pM->Domain[nl] = (DomainS*)((unsigned char *)pM->Domain[nl-1] +
      pM->DomainsPerLevel[nl-1]*sizeof(DomainS));

/* Loop over every <domain> block in the input file, and initialize each Domain
 * in the mesh hierarchy (the Domain array), including the root level Domain  */

  next_domainid = (int*)calloc_1d_array(pM->NLevels,sizeof(int));
  for(nl=0; nl<=maxlevel; nl++) next_domainid[nl] = 0;

  for (nblock=1; nblock<=num_domains; nblock++){
    sprintf(block,"domain%d",nblock);

/* choose nd coordinate in Domain array for this <domain> block according
 * to the order it appears in input */

    nl = par_geti(block,"level");
    if (next_domainid[nl] > (pM->DomainsPerLevel[nl])-1)
      ath_error("[init_mesh]: Exceeded available domain ids on level %d\n",nl);
    nd = next_domainid[nl];
    next_domainid[nl]++;
    irefine = 1;
    for (ir=1;ir<=nl;ir++) irefine *= 2;   /* C pow fn only takes doubles !! */

/* Initialize level, number, input <domain> block number, and total number of
 * cells in this Domain */

    pM->Domain[nl][nd].Level = nl;
    pM->Domain[nl][nd].DomNumber = nd;
    pM->Domain[nl][nd].InputBlock = nblock;

    pM->Domain[nl][nd].Nx[0] = par_geti(block,"Nx1");
    pM->Domain[nl][nd].Nx[1] = par_geti(block,"Nx2");
    pM->Domain[nl][nd].Nx[2] = par_geti(block,"Nx3");

/* error tests: dimensions of domain */

    nDim_test=0;
    for (i=0; i<3; i++) if (pM->Domain[nl][nd].Nx[i]>1) nDim_test++;
    if (nDim_test != nDim) {
      ath_error("[init_mesh]: in %s grid is %dD, but in root level it is %dD\n",
      block,nDim_test,nDim);
    }
    for (i=0; i<3; i++) {
      if (pM->Domain[nl][nd].Nx[i] < 1) {
        ath_error("[init_mesh]: %s/Nx%d = %d must be >= 1\n",
          block,(i+1),pM->Domain[nl][nd].Nx[i]);
      }
    }
    if (nDim==1 && pM->Domain[nl][nd].Nx[0]==1) {ath_error(
      "[init_mesh]: 1D requires Nx1>1 but in %s Nx1=1,Nx2=%d,Nx3=%d\n",
      block,pM->Domain[nl][nd].Nx[1],pM->Domain[nl][nd].Nx[2]);
    }
    if (nDim==2 && pM->Domain[nl][nd].Nx[2]>1) {ath_error(
      "[init_mesh]:2D requires Nx1,Nx2 > 1 but in %s Nx1=%d,Nx2=%d,Nx3=%d\n",
      block,pM->Domain[nl][nd].Nx[0],pM->Domain[nl][nd].Nx[1],
      pM->Domain[nl][nd].Nx[2]);
    }
    for (i=0; i<nDim; i++) {
      xdiv[i] = div(pM->Domain[nl][nd].Nx[i], irefine);
      if (xdiv[i].rem != 0){
        ath_error("[init_mesh]: %s/Nx%d = %d must be divisible by %d\n",
          block,(i+1),pM->Domain[nl][nd].Nx[i],irefine);
      }
    }

/* Set cell size based on level of domain, but only if Ncell > 1 */

    for (i=0; i<3; i++) {
      if (pM->Domain[nl][nd].Nx[i] > 1) {
        pM->Domain[nl][nd].dx[i] = pM->dx[i]/(Real)(irefine);
      } else {
        pM->Domain[nl][nd].dx[i] = pM->dx[i];
      }
    }

/* Set displacement of Domain from origin. By definition, root level has 0
 * displacement, so only read for levels other than root  */

    for (i=0; i<3; i++) pM->Domain[nl][nd].Disp[i] = 0;
    if (nl != 0) {  
      if (par_exist(block,"iDisp") == 0)
        ath_error("[init_mesh]: iDisp does not exist in block %s\n",block);
      pM->Domain[nl][nd].Disp[0] = par_geti(block,"iDisp");

/* jDisp=0 if problem is only 1D */
      if (pM->Nx[1] > 1) {
        if (par_exist(block,"jDisp") == 0)
          ath_error("[init_mesh]: jDisp does not exist in block %s\n",block);
        pM->Domain[nl][nd].Disp[1] = par_geti(block,"jDisp");
      }

/* kDisp=0 if problem is only 2D */
      if (pM->Nx[2] > 1) {
        if (par_exist(block,"kDisp") == 0)
          ath_error("[init_mesh]: kDisp does not exist in block %s\n",block);
        pM->Domain[nl][nd].Disp[2] = par_geti(block,"kDisp");
      }
    }

    for (i=0; i<nDim; i++) {
      xdiv[i] = div(pM->Domain[nl][nd].Disp[i], irefine);
      if (xdiv[i].rem != 0){
        ath_error("[init_mesh]: %s/Disp%d = %d must be divisible by %d\n",
          block,(i+1),pM->Domain[nl][nd].Disp[i],irefine);
      }
    }

/* Use cell size and displacement from origin to compute min/max of x1/x2/x3 on
 * this domain.  Ensure that if Domain touches root grid boundary, the min/max
 * of this Domain are set IDENTICAL to values in root grid  */

    for (i=0; i<3; i++){

      if (pM->Domain[nl][nd].Disp[i] == 0) {
        pM->Domain[nl][nd].MinX[i] = root_xmin[i];
      } else { 
        pM->Domain[nl][nd].MinX[i] = root_xmin[i] 
          + ((Real)(pM->Domain[nl][nd].Disp[i]))*pM->Domain[nl][nd].dx[i];
      }

      izones= (pM->Domain[nl][nd].Disp[i] + pM->Domain[nl][nd].Nx[i])/irefine;
      if(izones == pM->Nx[i]){
        pM->Domain[nl][nd].MaxX[i] = root_xmax[i];
      } else {
        pM->Domain[nl][nd].MaxX[i] = pM->Domain[nl][nd].MinX[i] 
          + ((Real)(pM->Domain[nl][nd].Nx[i]))*pM->Domain[nl][nd].dx[i];
      }

      pM->Domain[nl][nd].RootMinX[i] = root_xmin[i];
      pM->Domain[nl][nd].RootMaxX[i] = root_xmax[i];
    }

  }  /*---------- end loop over domain blocks in input file ------------------*/
    
/*--- Step 4: Check that domains on the same level are non-overlapping. ------*/
/* Compare the integer coordinates of the sides of Domains at the same level.
 * Print error if Domains overlap or touch. */

  for (nl=maxlevel; nl>0; nl--){     /* start at highest level, and skip root */
  for (nd=0; nd<(pM->DomainsPerLevel[nl])-1; nd++){
    for (i=0; i<3; i++) {
      D1.ijkl[i] = pM->Domain[nl][nd].Disp[i];
      D1.ijkr[i] = pM->Domain[nl][nd].Disp[i] + pM->Domain[nl][nd].Nx[i];
    }

    for (ncd=nd+1; ncd<(pM->DomainsPerLevel[nl]); ncd++) {
      for (i=0; i<3; i++) {
        D2.ijkl[i] = pM->Domain[nl][ncd].Disp[i];
        D2.ijkr[i] = pM->Domain[nl][ncd].Disp[i] + pM->Domain[nl][ncd].Nx[i];
      }

      if (D1.ijkl[0] <= D2.ijkr[0] && D1.ijkr[0] >= D2.ijkl[0] &&
          D1.ijkl[1] <= D2.ijkr[1] && D1.ijkr[1] >= D2.ijkl[1] &&
          D1.ijkl[2] <= D2.ijkr[2] && D1.ijkr[2] >= D2.ijkl[2]){
          ath_error("Domains %d and %d at same level overlap or touch\n",
          pM->Domain[nl][nd].InputBlock,pM->Domain[nl][ncd].InputBlock);
      }
    }
  }}

/*--- Step 5: Check for illegal geometry of child/parent Domains -------------*/

  for (nl=0; nl<maxlevel; nl++){
  for (nd=0; nd<pM->DomainsPerLevel[nl]; nd++){
    pD = (DomainS*)&(pM->Domain[nl][nd]);  /* set ptr to this Domain */

    for (i=0; i<3; i++) {
      D1.ijkl[i] = pD->Disp[i];
      D1.ijkr[i] = pD->Disp[i] + pD->Nx[i];
    }

    for (ncd=0; ncd<pM->DomainsPerLevel[nl+1]; ncd++){
      pCD = (DomainS*)&(pM->Domain[nl+1][ncd]);  /* set ptr to potential child*/

      for (i=0; i<3; i++) {
        D2.ijkl[i] = pCD->Disp[i]/2;
        D2.ijkr[i] = 1;
        if (pCD->Nx[i] > 1) D2.ijkr[i] = (pCD->Disp[i] + pCD->Nx[i])/2;
      }

      if (D1.ijkl[0] <= D2.ijkr[0] && D1.ijkr[0] >= D2.ijkl[0] &&
          D1.ijkl[1] <= D2.ijkr[1] && D1.ijkr[1] >= D2.ijkl[1] &&
          D1.ijkl[2] <= D2.ijkr[2] && D1.ijkr[2] >= D2.ijkl[2]){

/* check for child Domains that touch edge of parent (and are not at edges of
 * root), extends past edge of parent, or are < nghost/2 from edge of parent  */

        for (dim=0; dim<nDim; dim++){
          irefine = 1;
          for (i=1;i<=nl;i++) irefine *= 2; /* parent refinement lev */
          roffset = (pCD->Disp[dim] + pCD->Nx[dim])/(2*irefine) - pM->Nx[dim];

          if (((D2.ijkl[dim] == D1.ijkl[dim]) && (pD->Disp[dim] != 0)) ||
              ((D2.ijkr[dim] == D1.ijkr[dim]) && (roffset != 0))) {
            for (i=0; i<nDim; i++) {
              D1.ijkl[i] /= irefine;  /* report indices scaled to root */
              D1.ijkr[i] /= irefine;
              D2.ijkl[i] /= irefine; 
              D2.ijkr[i] /= irefine;
            }
            ath_error("[init_mesh] child Domain D%d[is,ie,js,je,ks,ke]=[%d %d %d %d %d %d] touches parent D%d[is,ie,js,je,ks,ke]=[%d %d %d %d %d %d]\n",
              pCD->InputBlock,D2.ijkl[0],D2.ijkr[0],D2.ijkl[1],D2.ijkr[1],
              D2.ijkl[2],D2.ijkr[2],pD->InputBlock,D1.ijkl[0],D1.ijkr[0],
              D1.ijkl[1],D1.ijkr[1],D1.ijkl[2],D1.ijkr[2]);
          }

          if ((D2.ijkl[dim] < D1.ijkl[dim]) ||
              (D2.ijkr[dim] > D1.ijkr[dim])) {
            for (i=0; i<nDim; i++) {
              D1.ijkl[i] /= irefine;  /* report indices scaled to root */
              D1.ijkr[i] /= irefine;
              D2.ijkl[i] /= irefine; 
              D2.ijkr[i] /= irefine;
            }
            ath_error("[init_mesh] child Domain D%d[is,ie,js,je,ks,ke]=[%d %d %d %d %d %d] extends past parent D%d[is,ie,js,je,ks,ke]=[%d %d %d %d %d %d]\n",
              pCD->InputBlock,D2.ijkl[0],D2.ijkr[0],D2.ijkl[1],D2.ijkr[1],
              D2.ijkl[2],D2.ijkr[2],pD->InputBlock,D1.ijkl[0],D1.ijkr[0],
              D1.ijkl[1],D1.ijkr[1],D1.ijkl[2],D1.ijkr[2]);
          }

          if (((2*(D2.ijkl[dim]-D1.ijkl[dim]) < nghost) &&
               (2*(D2.ijkl[dim]-D1.ijkl[dim]) > 0     )) ||
              ((2*(D1.ijkr[dim]-D2.ijkr[dim]) < nghost) &&
               (2*(D1.ijkr[dim]-D2.ijkr[dim]) > 0     ))) {
            for (i=0; i<nDim; i++) {
              D1.ijkl[i] /= irefine;  /* report indices scaled to root */
              D1.ijkr[i] /= irefine;
              D2.ijkl[i] /= irefine; 
              D2.ijkr[i] /= irefine;
            }
            ath_error("[init_mesh] child Domain D%d[is,ie,js,je,ks,ke]=[%d %d %d %d %d %d] closer than nghost/2 to parent D%d[is,ie,js,je,ks,ke]=[%d %d %d %d %d %d]\n",
              pCD->InputBlock,D2.ijkl[0],D2.ijkr[0],D2.ijkl[1],D2.ijkr[1],
              D2.ijkl[2],D2.ijkr[2],pD->InputBlock,D1.ijkl[0],D1.ijkr[0],
              D1.ijkl[1],D1.ijkr[1],D1.ijkl[2],D1.ijkr[2]);
          }

        }
      }
    }
  }}

/*--- Step 6: Divide each Domain into Grids, and allocate to processor(s)  ---*/
/* Get the number of Grids in each direction.  These are given either in the
 * <domain?> block in the input file, or by automatic decomposition given the
 * number of processor desired for this domain.   */

  next_procID = 0;  /* start assigning processors to Grids at ID=0 */

  for (nl=0; nl<=maxlevel; nl++){
    for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
      pD = (DomainS*)&(pM->Domain[nl][nd]);  /* set ptr to this Domain */
      sprintf(block,"domain%d",pD->InputBlock);

#ifndef MPI_PARALLEL
      for (i=0; i<3; i++) pD->NGrid[i] = 1;
#else
      nproc = par_geti_def(block,"AutoWithNProc",0);

/* Read layout of Grids from input file */

      if (nproc == 0){
        pD->NGrid[0] = par_geti_def(block,"NGrid_x1",1);
        pD->NGrid[1] = par_geti_def(block,"NGrid_x2",1);
        pD->NGrid[2] = par_geti_def(block,"NGrid_x3",1);
        if (pD->NGrid[0] == 0)
          ath_error("[init_mesh] Cannot enter NGrid_x1=0 in %s\n",block);
        if (pD->NGrid[1] == 0)
          ath_error("[init_mesh] Cannot enter NGrid_x2=0 in %s\n",block);
        if (pD->NGrid[2] == 0)
          ath_error("[init_mesh] Cannot enter NGrid_x3=0 in %s\n",block);
      }

/* Auto decompose Domain into Grids.  To use this option, set "AutoWithNProc"
 * to number of processors desired for this Domain  */

      else if (nproc > 0){
        if(dom_decomp(pD->Nx[0],pD->Nx[1],pD->Nx[2],nproc,
           &(pD->NGrid[0]),&(pD->NGrid[1]),&(pD->NGrid[2])))
           ath_error("[init_mesh]: Error in automatic Domain decomposition\n");

        /* Store the domain decomposition in the par database */
        par_seti(block,"NGrid_x1","%d",pD->NGrid[0],"x1 decomp");
        par_seti(block,"NGrid_x2","%d",pD->NGrid[1],"x2 decomp");
        par_seti(block,"NGrid_x3","%d",pD->NGrid[2],"x3 decomp");

      } else {
        ath_error("[init_mesh] invalid AutoWithNProc=%d in %s\n",nproc,block);
      }
#endif /* MPI_PARALLEL */

/* test for conflicts between number of grids and dimensionality */

      for (i=0; i<3; i++){
        if(pD->NGrid[i] > 1 && pD->Nx[i] <= 1)
          ath_error("[init_mesh]: %s/NGrid_x%d = %d and Nx%d = %d\n",block,
          (i+1),pD->NGrid[i],(i+1),pD->Nx[i]);
      }

/* check there are more processors than Grids needed by this Domain. */

      nproc = (pD->NGrid[0])*(pD->NGrid[1])*(pD->NGrid[2]);
      if(nproc > Nproc_Comm_world) ath_error(
        "[init_mesh]: %d Grids requested by block %s and only %d procs\n"
        ,nproc,block,Nproc_Comm_world); 

/* Build 3D array to store data on Grids in this Domain */

      if ((pD->GData = (GridsDataS***)calloc_3d_array(pD->NGrid[2],pD->NGrid[1],
        pD->NGrid[0],sizeof(GridsDataS))) == NULL) ath_error(
        "[init_mesh]: GData calloc returned a NULL pointer\n");

/* Divide the domain into blocks */

      for (i=0; i<3; i++) {
        xdiv[i] = div(pD->Nx[i], pD->NGrid[i]);
      }

/* Distribute cells in Domain to Grids.  Assign each Grid to a processor ID in
 * the MPI_COMM_WORLD communicator.  For single-processor jobs, there is only
 * one ID=0, and the GData array will have only one element. */

      for(n=0; n<(pD->NGrid[2]); n++){
      for(m=0; m<(pD->NGrid[1]); m++){
      for(l=0; l<(pD->NGrid[0]); l++){
        for (i=0; i<3; i++) pD->GData[n][m][l].Nx[i] = xdiv[i].quot;
        pD->GData[n][m][l].ID_Comm_world = next_procID++;
        if (next_procID > ((Nproc_Comm_world)-1)) next_procID=0;
      }}}

/* If the Domain is not evenly divisible put the extra cells on the first
 * Grids in each direction, maintaining the load balance as much as possible */

      for(n=0; n<(pD->NGrid[2]); n++){
        for(m=0; m<(pD->NGrid[1]); m++){
          for(l=0; l<xdiv[0].rem; l++){
            pD->GData[n][m][l].Nx[0]++;
          }
        }
      }
      xdiv[0].rem=0;

      for(n=0; n<(pD->NGrid[2]); n++){
        for(m=0; m<xdiv[1].rem; m++) {
          for(l=0; l<(pD->NGrid[0]); l++){
            pD->GData[n][m][l].Nx[1]++;
          }
        }
      }
      xdiv[1].rem=0;

      for(n=0; n<xdiv[2].rem; n++){
        for(m=0; m<(pD->NGrid[1]); m++){
          for(l=0; l<(pD->NGrid[0]); l++){
            pD->GData[n][m][l].Nx[2]++;
          }
        }
      }
      xdiv[2].rem=0;

/* Initialize displacements from origin for each Grid */

      for(n=0; n<(pD->NGrid[2]); n++){
        for(m=0; m<(pD->NGrid[1]); m++){
          pD->GData[n][m][0].Disp[0] = pD->Disp[0];
          for(l=1; l<(pD->NGrid[0]); l++){
            pD->GData[n][m][l].Disp[0] = pD->GData[n][m][l-1].Disp[0] + 
                                         pD->GData[n][m][l-1].Nx[0];
          }
        }
      }

      for(n=0; n<(pD->NGrid[2]); n++){
        for(l=0; l<(pD->NGrid[0]); l++){
          pD->GData[n][0][l].Disp[1] = pD->Disp[1];
          for(m=1; m<(pD->NGrid[1]); m++){
            pD->GData[n][m][l].Disp[1] = pD->GData[n][m-1][l].Disp[1] + 
                                         pD->GData[n][m-1][l].Nx[1];
          }
        }
      }

      for(m=0; m<(pD->NGrid[1]); m++){
        for(l=0; l<(pD->NGrid[0]); l++){
          pD->GData[0][m][l].Disp[2] = pD->Disp[2];
          for(n=1; n<(pD->NGrid[2]); n++){
            pD->GData[n][m][l].Disp[2] = pD->GData[n-1][m][l].Disp[2] + 
                                         pD->GData[n-1][m][l].Nx[2];
          }
        }
      }

    }  /* end loop over ndomains */
  }    /* end loop over nlevels */

/* check that total number of Grids was partitioned evenly over total number of
 * MPI processes available (equal to one for single processor jobs) */ 

  if (next_procID != 0)
    ath_error("[init_mesh]:total # of Grids != total # of MPI procs\n");

/*--- Step 7: Allocate a Grid for each Domain on this processor --------------*/

  for (nl=0; nl<=maxlevel; nl++){
    for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
      pD = (DomainS*)&(pM->Domain[nl][nd]);  /* set ptr to this Domain */
      sprintf(block,"domain%d",pD->InputBlock);
      pD->Grid = NULL;

/* Loop over GData array, and if there is a Grid assigned to this proc, 
 * allocate it */

      for(n=0; n<(pD->NGrid[2]); n++){
      for(m=0; m<(pD->NGrid[1]); m++){
      for(l=0; l<(pD->NGrid[0]); l++){
        if (pD->GData[n][m][l].ID_Comm_world == myID_Comm_world) {
          if ((pD->Grid = (GridS*)malloc(sizeof(GridS))) == NULL)
            ath_error("[init_mesh]: Failed to malloc a Grid for %s\n",block);
        }
      }}}
    }
  }

/*--- Step 8: Create an MPI Communicator for each Domain ---------------------*/

#ifdef MPI_PARALLEL
/* Allocate memory for ranks[] array */

  max_rank = 0;
  for (nl=0; nl<=maxlevel; nl++){
  for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
    pD = (DomainS*)&(pM->Domain[nl][nd]);  /* set ptr to this Domain */
    Nranks = (pD->NGrid[0])*(pD->NGrid[1])*(pD->NGrid[2]);
    max_rank = MAX(max_rank, Nranks);
  }}
  ranks = (int*)calloc_1d_array(max_rank,sizeof(int));

/* Extract handle of group defined by MPI_COMM_WORLD communicator */

  ierr = MPI_Comm_group(MPI_COMM_WORLD, &world_group);

  for (nl=0; nl<=maxlevel; nl++){
  for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
    pD = (DomainS*)&(pM->Domain[nl][nd]);  /* set ptr to this Domain */

/* Load integer array with ranks of processes in MPI_COMM_WORLD updating Grids
 * on this Domain.  The ranks of these processes in the new Comm_Domain
 * communicator created below are equal to the indices of this array */

    Nranks = (pD->NGrid[0])*(pD->NGrid[1])*(pD->NGrid[2]);
    groupn = 0;

    for(n=0; n<(pD->NGrid[2]); n++){
    for(m=0; m<(pD->NGrid[1]); m++){
    for(l=0; l<(pD->NGrid[0]); l++){
      ranks[groupn] = pD->GData[n][m][l].ID_Comm_world;
      pD->GData[n][m][l].ID_Comm_Domain = groupn;
      groupn++;
    }}}

/* Create a new group for this Domain; use it to create a new communicator */

    ierr = MPI_Group_incl(world_group,Nranks,ranks,&(pD->Group_Domain));
    ierr = MPI_Comm_create(MPI_COMM_WORLD,pD->Group_Domain,&(pD->Comm_Domain));

  }}

  free_1d_array(ranks);
#endif /* MPI_PARALLEL */

/*--- Step 9: Create MPI Communicators for Child and Parent Domains ----------*/

#if defined(MPI_PARALLEL) && defined(STATIC_MESH_REFINEMENT)
/* Initialize communicators to NULL, since not all Domains use them, and
 * allocate memory for ranks[] array */

  for (nl=0; nl<=maxlevel; nl++){
    for (nd=0; nd<(pM->DomainsPerLevel[nl]); nd++){
      pM->Domain[nl][nd].Comm_Parent = MPI_COMM_NULL;
      pM->Domain[nl][nd].Comm_Children = MPI_COMM_NULL;
    }
  }

  if (maxlevel > 0) {
    ranks = (int*)calloc_1d_array(Nproc_Comm_world,sizeof(int));
  }

/* For each Domain up to (maxlevel-1), initialize communicator with children */

  for (nl=0; nl<maxlevel; nl++){
  for (nd=0; nd<pM->DomainsPerLevel[nl]; nd++){
    pD = (DomainS*)&(pM->Domain[nl][nd]);  /* set ptr to this Domain */
    child_found = 0;

/* Load integer array with ranks of processes in MPI_COMM_WORLD updating Grids
 * on this Domain, in case a child Domain is found.  Set IDs in Comm_Children
 * communicator based on index in rank array, in case child found.  If no
 * child is found these ranks will never be used. */

    Nranks = (pD->NGrid[0])*(pD->NGrid[1])*(pD->NGrid[2]);
    groupn = 0;

    for(n=0; n<(pD->NGrid[2]); n++){
    for(m=0; m<(pD->NGrid[1]); m++){
    for(l=0; l<(pD->NGrid[0]); l++){
      ranks[groupn] = pD->GData[n][m][l].ID_Comm_world;
      pD->GData[n][m][l].ID_Comm_Children = groupn;
      groupn++;
    }}}

/* edges of this Domain */
    for (i=0; i<3; i++) {
      D1.ijkl[i] = pD->Disp[i];
      D1.ijkr[i] = pD->Disp[i] + pD->Nx[i];
    }

/* Loop over all Domains at next level, looking for children of this Domain */

    for (ncd=0; ncd<pM->DomainsPerLevel[nl+1]; ncd++){
      pCD = (DomainS*)&(pM->Domain[nl+1][ncd]);  /* set ptr to potential child*/

/* edges of potential child Domain */
      for (i=0; i<3; i++) {
        D2.ijkl[i] = pCD->Disp[i]/2;
        D2.ijkr[i] = 1;
        if (pCD->Nx[i] > 1) D2.ijkr[i] = (pCD->Disp[i] + pCD->Nx[i])/2;
      }

      if (D1.ijkl[0] < D2.ijkr[0] && D1.ijkr[0] > D2.ijkl[0] &&
          D1.ijkl[1] < D2.ijkr[1] && D1.ijkr[1] > D2.ijkl[1] &&
          D1.ijkl[2] < D2.ijkr[2] && D1.ijkr[2] > D2.ijkl[2]){
        child_found = 1;

/* Child found.  Add child processors to ranks array, but only if they are
 * different from processes currently there (including parent and any previously
 * found children).  Set IDs associated with Comm_Parent communicator, since on 
 * the child Domain this is the same as the Comm_Children communicator on the
 * parent Domain  */

        for(n=0; n<(pCD->NGrid[2]); n++){
        for(m=0; m<(pCD->NGrid[1]); m++){
        for(l=0; l<(pCD->NGrid[0]); l++){
          irank = -1;
          for (i=0; i<Nranks; i++) {
            if(pCD->GData[n][m][l].ID_Comm_world == ranks[i]) irank = i;
          }
          if (irank == -1) {
            ranks[groupn] = pCD->GData[n][m][l].ID_Comm_world;
            pCD->GData[n][m][l].ID_Comm_Parent = groupn;
            groupn++;
            Nranks++;
          } else {
            pCD->GData[n][m][l].ID_Comm_Parent = ranks[irank];
          }
        }}}
      }
    }

/* After looping over all potential child Domains, create a new communicator if
 * a child was found */

    if (child_found == 1) {
      ierr = MPI_Group_incl(world_group, Nranks, ranks, &(pD->Group_Children));
      ierr = MPI_Comm_create(MPI_COMM_WORLD,pD->Group_Children,
        &pD->Comm_Children);

/* Loop over children to set Comm_Parent communicators */

      for (ncd=0; ncd<pM->DomainsPerLevel[nl+1]; ncd++){
        pCD = (DomainS*)&(pM->Domain[nl+1][ncd]);  

        for (i=0; i<3; i++) {
          D2.ijkl[i] = pCD->Disp[i]/2;
          D2.ijkr[i] = 1;
          if (pCD->Nx[i] > 1) D2.ijkr[i] = (pCD->Disp[i] + pCD->Nx[i])/2;
        }

        if (D1.ijkl[0] < D2.ijkr[0] && D1.ijkr[0] > D2.ijkl[0] &&
            D1.ijkl[1] < D2.ijkr[1] && D1.ijkr[1] > D2.ijkl[1] &&
            D1.ijkl[2] < D2.ijkr[2] && D1.ijkr[2] > D2.ijkl[2]){
          pCD->Comm_Parent = pD->Comm_Children;
        }
      }
    }
  }}

#endif /* MPI_PARALLEL & STATIC_MESH_REFINEMENT  */

  free(next_domainid);
  return;
}