void allocate_test ( ) {
printf("Allocating age arrays\n");
// Allocate working and output arrays
mn_test = alloc3d(NZ,NXMEM,NYMEM);
mn_htest = alloc3d(NZ,NXMEM,NYMEM);
}
void allocate_sf6 ( ) {
mn_sf6 = alloc3d(NZ,NXMEM,NYMEM);
sf6_init = alloc3d(NZ,NXMEM,NYMEM);
sf6_sat = alloc2d(NXMEM,NYMEM);
sf6_sol = alloc3d(NZ,NXMEM,NYMEM);
mn_sf6sat = alloc2d(NXMEM,NYMEM);
sf6_atmconc = alloc2d(NXMEM,NYMEM);
mn_psf6 = alloc3d(NZ,NXMEM,NYMEM);
psf6 = alloc3d(NZ,NXMEM,NYMEM);
}
void das_getHE(dasystem* das)
{
observations* obs = das->obs;
model* m = das->m;
ENSOBSTYPE* Hx = NULL;
int i, e;
das->s_mode = S_MODE_HE_f;
if (obs->nobs == 0)
return;
if (das->nmem <= 0)
das_getnmem(das);
enkf_printf(" ensemble size = %d\n", das->nmem);
assert(das->nmem > 0);
distribute_iterations(0, das->nmem - 1, nprocesses, rank, " ");
/*
* ensemble observation array to be filled
*/
assert(das->S == NULL);
das->S = alloc2d(das->nmem, obs->nobs, sizeof(ENSOBSTYPE));
if (das->mode == MODE_ENOI)
Hx = calloc(obs->nobs, sizeof(ENSOBSTYPE));
for (i = 0; i < obs->nobstypes; ++i) {
obstype* ot = &obs->obstypes[i];
float*** vvv = NULL;
float** vv = NULL;
H_fn H = NULL;
int mvid;
int ni, nj, nk;
int nobs;
int* obsids;
char fname[MAXSTRLEN];
enkf_printf(" %s ", ot->name);
fflush(stdout);
mvid = model_getvarid(m, obs->obstypes[i].varname);
if (mvid < 0)
enkf_quit("variable \"%s\" required for observation type \"%s\" is not defined", obs->obstypes[i].varname, ot->name);
if (ot->issurface) {
model_getvardims(m, mvid, &ni, &nj, NULL);
vv = alloc2d(nj, ni, sizeof(float));
} else {
model_getvardims(m, mvid, &ni, &nj, &nk);
vvv = alloc3d(nk, nj, ni, sizeof(float));
}
/*
* set H
*/
H = getH(ot->name, ot->hfunction);
if (ot->isasync) {
int t1 = get_tshift(ot->date_min, ot->async_tstep);
int t2 = get_tshift(ot->date_max, ot->async_tstep);
int t;
for (t = t1; t <= t2; ++t) {
enkf_printf("|");
obs_find_bytypeandtime(obs, i, t, &nobs, &obsids);
if (nobs == 0)
continue;
if (das->mode == MODE_ENKF || !enkf_fstatsonly) {
for (e = my_first_iteration; e <= my_last_iteration; ++e) {
int success = model_getmemberfname_async(m, das->ensdir, ot->varname, ot->name, e + 1, t, fname);
H(das, nobs, obsids, fname, e + 1, t, ot->varname, ot->varname2, (ot->issurface) ? (void*) vv : (void*) vvv, das->S[e]);
enkf_printf((success) ? "a" : "s");
fflush(stdout);
}
}
if (das->mode == MODE_ENOI) {
if (enkf_obstype == OBSTYPE_VALUE) {
int success = model_getbgfname_async(m, das->bgdir, ot->varname, ot->name, t, fname);
H(das, nobs, obsids, fname, -1, t, ot->varname, ot->varname2, (ot->issurface) ? (void*) vv : (void*) vvv, Hx);
enkf_printf((success) ? "A" : "S");
fflush(stdout);
} else if (enkf_obstype == OBSTYPE_INNOVATION) {
Hx[0] = 0;
enkf_printf("-");
fflush(stdout);
}
}
free(obsids);
}
} else {
obs_find_bytype(obs, i, &nobs, &obsids);
if (nobs == 0)
goto next;
if (das->mode == MODE_ENKF || !enkf_fstatsonly) {
for (e = my_first_iteration; e <= my_last_iteration; ++e) {
model_getmemberfname(m, das->ensdir, ot->varname, e + 1, fname);
H(das, nobs, obsids, fname, e + 1, MAXINT, ot->varname, ot->varname2, (ot->issurface) ? (void*) vv : (void*) vvv, das->S[e]);
enkf_printf(".");
fflush(stdout);
}
}
if (das->mode == MODE_ENOI) {
if (enkf_obstype == OBSTYPE_VALUE) {
model_getbgfname(m, das->bgdir, ot->varname, fname);
H(das, nobs, obsids, fname, -1, MAXINT, ot->varname, ot->varname2, (ot->issurface) ? (void*) vv : (void*) vvv, Hx);
enkf_printf("+");
fflush(stdout);
} else if (enkf_obstype == OBSTYPE_INNOVATION) {
Hx[0] = 0;
enkf_printf("-");
fflush(stdout);
}
}
free(obsids);
}
next:
if (ot->issurface)
free2d(vv);
else
free3d(vvv);
enkf_printf("\n");
} /* for i (over obstypes) */
#if defined(MPI)
if (das->mode == MODE_ENKF || !enkf_fstatsonly) {
#if !defined(HE_VIAFILE)
/*
* communicate HE via MPI
*/
int ierror, count;
/*
* Blocking communications can create a bottleneck in instances with
* large number of observations (e.g., 2e6 obs., 144 members, 48
* processes), but asynchronous send/receive seem to work well
*/
if (rank > 0) {
MPI_Request request;
/*
* send ensemble observations to master
*/
count = (my_last_iteration - my_first_iteration + 1) * obs->nobs;
ierror = MPI_Isend(das->S[my_first_iteration], count, MPIENSOBSTYPE, 0, rank, MPI_COMM_WORLD, &request);
assert(ierror == MPI_SUCCESS);
} else {
int r;
MPI_Request* requests = malloc((nprocesses - 1) * sizeof(MPI_Request));
/*
* collect ensemble observations from slaves
*/
for (r = 1; r < nprocesses; ++r) {
count = (last_iteration[r] - first_iteration[r] + 1) * obs->nobs;
ierror = MPI_Irecv(das->S[first_iteration[r]], count, MPIENSOBSTYPE, r, r, MPI_COMM_WORLD, &requests[r - 1]);
assert(ierror == MPI_SUCCESS);
}
ierror = MPI_Waitall(nprocesses - 1, requests, MPI_STATUS_IGNORE);
assert(ierror == MPI_SUCCESS);
free(requests);
}
/*
* now send the full set of ensemble observations to slaves
*/
count = das->nmem * obs->nobs;
ierror = MPI_Bcast(das->S[0], count, MPIENSOBSTYPE, 0, MPI_COMM_WORLD);
assert(ierror == MPI_SUCCESS);
#else
/*
* communicate HE via file
*/
{
int ncid;
int varid;
size_t start[2], count[2];
if (rank == 0) {
int dimids[2];
ncw_create(FNAME_HE, NC_CLOBBER | NC_64BIT_OFFSET, &ncid);
ncw_def_dim(FNAME_HE, ncid, "m", das->nmem, &dimids[0]);
ncw_def_dim(FNAME_HE, ncid, "p", obs->nobs, &dimids[1]);
ncw_def_var(FNAME_HE, ncid, "HE", NC_FLOAT, 2, dimids, &varid);
ncw_close(FNAME_HE, ncid);
}
MPI_Barrier(MPI_COMM_WORLD);
ncw_open(FNAME_HE, NC_WRITE, &ncid);
ncw_inq_varid(FNAME_HE, ncid, "HE", &varid);
start[0] = my_first_iteration;
start[1] = 0;
count[0] = my_last_iteration - my_first_iteration + 1;
count[1] = obs->nobs;
ncw_put_vara_float(FNAME_HE, ncid, varid, start, count, das->S[my_first_iteration]);
ncw_close(FNAME_HE, ncid);
MPI_Barrier(MPI_COMM_WORLD);
ncw_open(FNAME_HE, NC_NOWRITE, &ncid);
ncw_inq_varid(FNAME_HE, ncid, "HE", &varid);
ncw_get_var_float(FNAME_HE, ncid, varid, das->S[0]);
ncw_close(FNAME_HE, ncid);
}
#endif
}
#endif
if (das->mode == MODE_ENOI) {
/*
* subtract ensemble mean; add background
*/
if (!enkf_fstatsonly) {
double* ensmean = calloc(obs->nobs, sizeof(double));
for (e = 0; e < das->nmem; ++e) {
ENSOBSTYPE* Se = das->S[e];
for (i = 0; i < obs->nobs; ++i)
ensmean[i] += Se[i];
}
for (i = 0; i < obs->nobs; ++i)
ensmean[i] /= (double) das->nmem;
for (e = 0; e < das->nmem; ++e) {
ENSOBSTYPE* Se = das->S[e];
for (i = 0; i < obs->nobs; ++i)
Se[i] += Hx[i] - ensmean[i];
}
free(ensmean);
} else {
for (e = 0; e < das->nmem; ++e) {
ENSOBSTYPE* Se = das->S[e];
for (i = 0; i < obs->nobs; ++i)
Se[i] = Hx[i];
}
}
}
if (das->mode == MODE_ENOI)
free(Hx);
}
void das_getHE(dasystem* das)
{
observations* obs = das->obs;
model* m = das->m;
ENSOBSTYPE* Hx = NULL;
int i, e;
das->s_mode = S_MODE_HE_f;
if (obs->nobs == 0)
return;
if (das->nmem <= 0)
das_setnmem(das);
enkf_printf(" ensemble size = %d\n", das->nmem);
assert(das->nmem > 0);
distribute_iterations(0, das->nmem - 1, nprocesses, rank, " ");
/*
* ensemble observation array to be filled
*/
assert(das->S == NULL);
das->S = alloc2d(das->nmem, obs->nobs, sizeof(ENSOBSTYPE));
if (das->mode == MODE_ENOI)
Hx = calloc(obs->nobs, sizeof(ENSOBSTYPE));
for (i = 0; i < obs->nobstypes; ++i) {
obstype* ot = &obs->obstypes[i];
float*** vvv = NULL;
float** vv = NULL;
H_fn H = NULL;
int mvid;
int ni, nj, nk;
int nobs;
int* obsids;
char fname[MAXSTRLEN];
enkf_printf(" %s ", ot->name);
fflush(stdout);
mvid = model_getvarid(m, obs->obstypes[i].varnames[0], 1);
if (ot->issurface) {
model_getvardims(m, mvid, &ni, &nj, NULL);
vv = alloc2d(nj, ni, sizeof(float));
} else {
model_getvardims(m, mvid, &ni, &nj, &nk);
vvv = alloc3d(nk, nj, ni, sizeof(float));
}
/*
* set H
*/
H = getH(ot->name, ot->hfunction);
if (ot->isasync) {
int t1 = get_tshift(ot->date_min, ot->async_tstep);
int t2 = get_tshift(ot->date_max, ot->async_tstep);
int t;
for (t = t1; t <= t2; ++t) {
enkf_printf("|");
obs_find_bytypeandtime(obs, i, t, &nobs, &obsids);
if (nobs == 0)
continue;
/*
* for EnOI it is essential sometimes (e.g. in some bias
* correction cases) that the background is interpolated first
*/
if (das->mode == MODE_ENOI) {
if (enkf_obstype == OBSTYPE_VALUE) {
int success = model_getbgfname_async(m, das->bgdir, ot->varnames[0], ot->name, t, fname);
H(das, nobs, obsids, fname, -1, t, (ot->issurface) ? (void*) vv : (void*) vvv, Hx);
enkf_printf((success) ? "A" : "S");
fflush(stdout);
} else if (enkf_obstype == OBSTYPE_INNOVATION) {
Hx[0] = 0;
enkf_printf("-");
fflush(stdout);
}
}
if (das->mode == MODE_ENKF || !enkf_fstatsonly) {
for (e = my_first_iteration; e <= my_last_iteration; ++e) {
int success = model_getmemberfname_async(m, das->ensdir, ot->varnames[0], ot->name, e + 1, t, fname);
H(das, nobs, obsids, fname, e + 1, t, (ot->issurface) ? (void*) vv : (void*) vvv, das->S[e]);
enkf_printf((success) ? "a" : "s");
fflush(stdout);
}
}
free(obsids);
}
} else {
obs_find_bytype(obs, i, &nobs, &obsids);
if (nobs == 0)
goto next;
/*
* for EnOI it is essential sometimes (e.g. in some bias correction
* cases) that the background is interpolated first
*/
if (das->mode == MODE_ENOI) {
if (enkf_obstype == OBSTYPE_VALUE) {
model_getbgfname(m, das->bgdir, ot->varnames[0], fname);
H(das, nobs, obsids, fname, -1, INT_MAX, (ot->issurface) ? (void*) vv : (void*) vvv, Hx);
enkf_printf("+");
fflush(stdout);
} else if (enkf_obstype == OBSTYPE_INNOVATION) {
Hx[0] = 0;
enkf_printf("-");
fflush(stdout);
}
}
if (das->mode == MODE_ENKF || !enkf_fstatsonly) {
for (e = my_first_iteration; e <= my_last_iteration; ++e) {
model_getmemberfname(m, das->ensdir, ot->varnames[0], e + 1, fname);
H(das, nobs, obsids, fname, e + 1, INT_MAX, (ot->issurface) ? (void*) vv : (void*) vvv, das->S[e]);
enkf_printf(".");
fflush(stdout);
}
}
free(obsids);
}
next:
if (ot->issurface)
free(vv);
else
free(vvv);
enkf_printf("\n");
} /* for i (over obstypes) */
#if defined(MPI)
if (das->mode == MODE_ENKF || !enkf_fstatsonly) {
#if !defined(HE_VIAFILE)
/*
* communicate HE via MPI
*/
int ierror, sendcount, *recvcounts, *displs;
recvcounts = malloc(nprocesses * sizeof(int));
displs = malloc(nprocesses * sizeof(int));
sendcount = my_number_of_iterations * obs->nobs;
for (i = 0; i < nprocesses; ++i) {
recvcounts[i] = number_of_iterations[i] * obs->nobs;
displs[i] = first_iteration[i] * obs->nobs;
}
ierror = MPI_Allgatherv(das->S[my_first_iteration], sendcount, MPIENSOBSTYPE, das->S[0], recvcounts, displs, MPIENSOBSTYPE, MPI_COMM_WORLD);
assert(ierror == MPI_SUCCESS);
free(recvcounts);
free(displs);
#else
/*
* communicate HE via file
*/
{
int ncid;
int varid;
size_t start[2], count[2];
if (rank == 0) {
int dimids[2];
ncw_create(FNAME_HE, NC_CLOBBER | NETCDF_FORMAT, &ncid);
ncw_def_dim(FNAME_HE, ncid, "m", das->nmem, &dimids[0]);
ncw_def_dim(FNAME_HE, ncid, "p", obs->nobs, &dimids[1]);
ncw_def_var(FNAME_HE, ncid, "HE", NC_FLOAT, 2, dimids, &varid);
ncw_close(FNAME_HE, ncid);
}
MPI_Barrier(MPI_COMM_WORLD);
ncw_open(FNAME_HE, NC_WRITE, &ncid);
ncw_inq_varid(FNAME_HE, ncid, "HE", &varid);
start[0] = my_first_iteration;
start[1] = 0;
count[0] = my_last_iteration - my_first_iteration + 1;
count[1] = obs->nobs;
ncw_put_vara_float(FNAME_HE, ncid, varid, start, count, das->S[my_first_iteration]);
ncw_close(FNAME_HE, ncid);
MPI_Barrier(MPI_COMM_WORLD);
ncw_open(FNAME_HE, NC_NOWRITE, &ncid);
ncw_inq_varid(FNAME_HE, ncid, "HE", &varid);
ncw_get_var_float(FNAME_HE, ncid, varid, das->S[0]);
ncw_close(FNAME_HE, ncid);
}
#endif
}
#endif
if (das->mode == MODE_ENOI) {
/*
* subtract ensemble mean; add background
*/
if (!enkf_fstatsonly) {
double* ensmean = calloc(obs->nobs, sizeof(double));
for (e = 0; e < das->nmem; ++e) {
ENSOBSTYPE* Se = das->S[e];
for (i = 0; i < obs->nobs; ++i)
ensmean[i] += Se[i];
}
for (i = 0; i < obs->nobs; ++i)
ensmean[i] /= (double) das->nmem;
for (e = 0; e < das->nmem; ++e) {
ENSOBSTYPE* Se = das->S[e];
for (i = 0; i < obs->nobs; ++i)
Se[i] += Hx[i] - ensmean[i];
}
free(ensmean);
} else {
for (e = 0; e < das->nmem; ++e) {
ENSOBSTYPE* Se = das->S[e];
for (i = 0; i < obs->nobs; ++i)
Se[i] = Hx[i];
}
}
}
if (das->mode == MODE_ENOI)
free(Hx);
}
void tracer(int itts)
{
/* This subroutine time steps the tracer concentration. */
/* A positive definite scheme is used. */
double minslope; /* The maximum concentration slope per */
/* grid point consistent with mono- */
/* tonicity, in conc. (nondim.). */
double ***hvol; /* The cell volume of an h-element */
double slope[NXMEM+NYMEM][NTR]; /* The concentration slope per grid */
/* point in units of concentration (nondim.). */
double fluxtr[NXMEM+NYMEM][NTR];/* The flux of tracer across a */
/* boundary, in m3 * conc. (nondim.). */
double ***uhr; /* The remaining zonal and meridional */
double ***vhr; /* thickness fluxes, in m3.*/
double uhh[NXMEM]; /* uhh and vhh are the reduced fluxes */
double vhh[NYMEM]; /* during the current iteration, in m3.d */
double hup, hlos; /* hup is the upwind volume, hlos is the */
/* part of that volume that might be lost */
/* due to advection out the other side of */
/* the grid box, both in m3. */
double ts2;
double landvolfill; /* An arbitrary? nonzero cell volume, m3. */
double ***ear;
double ***ebr;
double ***wdh;
double bet[NXMEM]; /* bet and gam are variables used by the */
double gam[NZ][NXMEM]; /* tridiagonal solver. */
double hnew0[NXMEM]; /* The original topmost layer thickness, */
#if defined AGE2 || defined AGE3
// extern double hnew[NZ][NXMEM][NYMEM];
extern double ***hnew;
#else
double ***hnew;
#endif
double hlst1, Ihnew;
double hlst[NYMEM];
// double MLMIN = EPSILON; /* min depth for ML */
double MLMIN = 4.25;
double BLMIN = 0.20;
#ifdef ENTRAIN
double nts = dt/DT; /* number of timesteps (#day*86400/3600seconds) */
#endif
int i, j, k, m, ii, pstage;
int itt;
double fract1;
double fract2;
# ifdef WRTTS
double wrts;
# endif
hvol = alloc3d(NZ,NXMEM,NYMEM);
if(hvol == NULL) {
fprintf(stderr,"not enough memory for hvol!\n");
}
uhr = alloc3d(NZ,NXMEM,NYMEM);
if(uhr == NULL) {
fprintf(stderr,"not enough memory for uhr!\n");
}
vhr = alloc3d(NZ,NXMEM,NYMEM);
if(vhr == NULL) {
fprintf(stderr,"not enough memory for vhr!\n");
}
ear = alloc3d(NZ,NXMEM,NYMEM);
if(ear == NULL) {
fprintf(stderr,"not enough memory for ear!\n");
}
ebr = alloc3d(NZ,NXMEM,NYMEM);
if(ebr == NULL) {
fprintf(stderr,"not enough memory for ebr!\n");
}
wdh = alloc3d(NZ,NXMEM,NYMEM);
if(wdh == NULL) {
fprintf(stderr,"not enough memory for wdh!\n");
}
#if !defined AGE2 && !defined AGE3
hnew = alloc3d(NZ,NXMEM,NYMEM);
if(hnew == NULL) {
fprintf(stderr,"not enough memory for hnew!\n");
}
#endif
landvolfill = EPSILON*1000000.0; /* This is arbitrary. */
/* zonal re-entrance */
#pragma omp parallel
{
#pragma omp for private(j,k)
for (j=0;j<=NYMEM-1;j++) {
for (k=0;k<NZ;k++) {
uhtm[k][nx+1][j] = uhtm[k][2][j];
uhtm[k][nx+2][j] = uhtm[k][3][j];
uhtm[k][0][j] = uhtm[k][nx-1][j];
uhtm[k][1][j] = uhtm[k][nx][j];
vhtm[k][nx+1][j] = vhtm[k][2][j];
vhtm[k][nx+2][j] = vhtm[k][3][j];
vhtm[k][0][j] = vhtm[k][nx-1][j];
vhtm[k][1][j] = vhtm[k][nx][j];
}
for (k=0;k<NZ+1;k++) {
wd[k][nx+1][j] = wd[k][2][j];
wd[k][nx+2][j] = wd[k][3][j];
wd[k][0][j] = wd[k][nx-1][j];
wd[k][1][j] = wd[k][nx][j];
}
}
/* meridional re-entrance */
#pragma omp for private(i,k,ii)
for (i=2;i<=nx;i++) {
ii = 363 - i;
for (k=0;k<NZ;k++) {
uhtm[k][ii][ny+1] = (-1)*uhtm[k][i][ny];
uhtm[k][ii][ny+2] = (-1)*uhtm[k][i][ny-1];
vhtm[k][ii][ny+1] = (-1)*vhtm[k][i][ny];
vhtm[k][ii][ny+2] = (-1)*vhtm[k][i][ny-1];
}
for (k=0;k<NZ+1;k++) {
wd[k][ii][ny+1] = wd[k][i][ny];
wd[k][ii][ny+2] = wd[k][i][ny-1];
}
}
#pragma omp for private(i,j,k)
for (k=0;k<NZ;k++) {
/* Put the thickness fluxes into uhr and vhr. */
for (j=0;j<=ny+2;j++) {
for (i=0;i<=nx+2;i++) {
uhr[k][i][j] = uhtm[k][i][j]*dt;
vhr[k][i][j] = vhtm[k][i][j]*dt;
if (h[k][i][j] < EPSILON) {
h[k][i][j] = 1.0*EPSILON;
}
/* This line calculates the cell volume */
hvol[k][i][j] = DXDYh(i,j)*h[k][i][j];
hnew[k][i][j] = h[k][i][j];
}
}
}
/* calculate the diapycnal velocities at the interfaces */
/* if we read in the ea, eb and eaml variables */
/* Otherwise we read in wd directly */
#ifdef ENTRAIN
#pragma omp for private(i,j)
for (i=X0;i<=nx+1;i++)
for (j=Y0;j<=ny;j++)
wd[0][i][j] = nts*eaml[i][j];
#pragma omp for private(i,j,k)
for (k=1;k<NZ;k++) {
for (i=X0;i<=nx+1;i++)
for (j=Y0;j<=ny;j++)
wd[k][i][j] = nts*(ea[k][i][j] - eb[k-1][i][j]);
}
#endif
} // omp
#define STANDARD_ADVECTION
//#undef STANDARD_ADVECTION
#ifdef STANDARD_ADVECTION
/*
pstage=1;
print_tr(pstage);
*/
/* beginning of itt loop */
for (itt = 0; itt < NUM_ADV_ITER; itt++) {
/* big loop over k */
//ompfail
#pragma omp parallel
{
#pragma omp for private(i,j,k,m,minslope,slope,uhh,vhh,fluxtr,hup,hlos,ts2,hlst,hlst1,Ihnew)
for (k=0;k<NZ;k++)
{
/* To insure positive definiteness of the thickness at each */
/* iteration, the mass fluxes out of each layer are checked each */
/* time. This may not be very efficient, but it should be reliable. */
/* ============================================================ */
/* first advect zonally */
/* ============================================================ */
#ifndef ADV1D
for (j=Y1;j<=ny;j++) {
/* Calculate the i-direction profiles (slopes) of each tracer that */
/* is being advected. */
//#pragma omp for private(i,m,minslope)
for (i=X0;i<=nx+1;i++) {
for (m=0;m<NTR;m++) {
minslope = 4.0*((fabs(tr[m][k][i+1][j]-tr[m][k][i][j]) <
fabs(tr[m][k][i][j]-tr[m][k][i-1][j])) ?
(tr[m][k][i+1][j]-tr[m][k][i][j]) :
(tr[m][k][i][j]-tr[m][k][i-1][j]));
slope[i][m] = umask[i][j]*umask[i-1][j] *
(((tr[m][k][i+1][j]-tr[m][k][i][j]) *
(tr[m][k][i][j]-tr[m][k][i-1][j]) < 0.0) ? 0.0 :
((fabs(tr[m][k][i+1][j]-tr[m][k][i-1][j])<fabs(minslope)) ?
0.5*(tr[m][k][i+1][j]-tr[m][k][i-1][j]) : 0.5*minslope));
}
}
//#pragma omp barrier
/* Calculate the i-direction fluxes of each tracer, using as much */
/* the minimum of the remaining mass flux (uhr) and the half the mass */
/* in the cell plus whatever part of its half of the mass flux that */
/* the flux through the other side does not require. */
//#pragma omp for private(i,m,hup,hlos,ts2)
for (i=X0;i<=nx;i++) {
if (uhr[k][i][j] == 0.0) {
uhh[i] = 0.0;
for (m=0;m<NTR;m++) fluxtr[i][m] = 0.0;
}
else if (uhr[k][i][j] < 0.0) {
if (k==0 || k==1 ) {
hup = (hvol[k][i+1][j]-DXDYh(i+1,j)*MLMIN);
} else {
hup = (hvol[k][i+1][j]-DXDYh(i+1,j)*EPSILON);
}
hlos = D_MAX(0.0,uhr[k][i+1][j]);
if (((hup + uhr[k][i][j] - hlos) < 0.0) &&
((0.5*hup + uhr[k][i][j]) < 0.0)) {
uhh[i] = D_MIN(-0.5*hup,-hup+hlos);
}
else uhh[i] = uhr[k][i][j];
ts2 = 0.5*(1.0 + uhh[i]/hvol[k][i+1][j]);
for (m=0;m<NTR;m++) {
fluxtr[i][m] = uhh[i]*(tr[m][k][i+1][j] - slope[i+1][m]*ts2);
}
}
else {
if (k==0 || k==1 ) {
hup = (hvol[k][i][j]-DXDYh(i,j)*MLMIN);
} else {
hup = (hvol[k][i][j]-DXDYh(i,j)*EPSILON);
}
hlos = D_MAX(0.0,-uhr[k][i-1][j]);
if (((hup - uhr[k][i][j] - hlos) < 0.0) &&
((0.5*hup - uhr[k][i][j]) < 0.0)) {
uhh[i] = D_MAX(0.5*hup,hup-hlos);
}
else uhh[i] = uhr[k][i][j];
ts2 = 0.5*(1.0 - uhh[i]/hvol[k][i][j]);
for (m=0;m<NTR;m++) {
fluxtr[i][m] = uhh[i]*(tr[m][k][i][j] + slope[i][m]*ts2);
}
}
}
//#pragma omp barrier
/* Calculate new tracer concentration in each cell after accounting */
/* for the i-direction fluxes. */
uhr[k][X0][j] -= uhh[X0];
// #pragma omp barrier
//#pragma omp for private(i,m,hlst1,Ihnew)
for (i=X1;i<=nx;i++) {
if ((uhh[i] != 0.0) || (uhh[i-1] != 0.0))
{
uhr[k][i][j] -= uhh[i];
hlst1 = hvol[k][i][j];
hvol[k][i][j] -= (uhh[i] - uhh[i-1]);
Ihnew = 1.0 / hvol[k][i][j];
for (m=0;m<NTR;m++) {
tr[m][k][i][j] *= hlst1;
tr[m][k][i][j] = (tr[m][k][i][j] -
(fluxtr[i][m]-fluxtr[i-1][m])) * Ihnew;
}
}
}
// #pragma omp barrier
} /* j loop */
#endif
/* ============================================================ */
/* now advect meridionally */
/* ============================================================ */
#ifndef ADV1D
for (i=X1;i<=nx;i++) {
/* Calculate the j-direction profiles (slopes) of each tracer that */
/* is being advected. */
//#pragma omp for private(j,m,minslope)
for (j=Y0;j<=ny+1;j++) {
for (m=0;m<NTR;m++) {
minslope = 4.0*((fabs(tr[m][k][i][j+1]-tr[m][k][i][j]) <
fabs(tr[m][k][i][j]-tr[m][k][i][j-1])) ?
(tr[m][k][i][j+1]-tr[m][k][i][j]) :
(tr[m][k][i][j]-tr[m][k][i][j-1]));
slope[j][m] = vmask[i][j] * vmask[i][j-1] *
(((tr[m][k][i][j+1]-tr[m][k][i][j]) *
(tr[m][k][i][j]-tr[m][k][i][j-1]) < 0.0) ? 0.0 :
((fabs(tr[m][k][i][j+1]-tr[m][k][i][j-1])<fabs(minslope)) ?
0.5*(tr[m][k][i][j+1]-tr[m][k][i][j-1]) : 0.5*minslope));
}
}
// #pragma omp barrier
/* Calculate the j-direction fluxes of each tracer, using as much */
/* the minimum of the remaining mass flux (vhr) and the half the mass */
/* in the cell plus whatever part of its half of the mass flux that */
/* the flux through the other side does not require. */
//#pragma omp for private(j,m,hup,hlos,ts2)
for (j=Y0;j<=ny;j++) {
if (vhr[k][i][j] == 0.0) {
vhh[j] = 0.0;
for (m=0;m<NTR;m++) fluxtr[j][m] = 0.0;
}
else if (vhr[k][i][j] < 0.0) {
if (k==0 || k==1 ) {
hup = (hvol[k][i][j+1]-DXDYh(i,j+1)*MLMIN);
} else {
hup = (hvol[k][i][j+1]-DXDYh(i,j+1)*EPSILON);
}
hlos = D_MAX(0.0,vhr[k][i][j+1]);
if (((hup + vhr[k][i][j] - hlos) < 0.0) &&
((0.5*hup + vhr[k][i][j]) < 0.0)) {
vhh[j] = D_MIN(-0.5*hup,-hup+hlos);
}
else vhh[j] = vhr[k][i][j];
ts2 = 0.5*(1.0 + vhh[j]/(hvol[k][i][j+1]));
for (m=0;m<NTR;m++) {
fluxtr[j][m] = vhh[j]*(tr[m][k][i][j+1] - slope[j+1][m]*ts2);
}
}
else {
if (k==0 || k==1 ) {
hup = (hvol[k][i][j]-DXDYh(i,j)*MLMIN);
} else {
hup = (hvol[k][i][j]-DXDYh(i,j)*EPSILON);
}
hlos = D_MAX(0.0,-vhr[k][i][j-1]);
if (((hup - vhr[k][i][j] - hlos) < 0.0)
&& ((0.5*hup - vhr[k][i][j]) < 0.0)) {
vhh[j] = D_MAX(0.5*hup,hup-hlos);
}
else vhh[j] = vhr[k][i][j];
ts2 = 0.5*(1.0 - vhh[j] / (hvol[k][i][j]));
for (m=0;m<NTR;m++) {
fluxtr[j][m] = vhh[j]*(tr[m][k][i][j] + slope[j][m]*ts2);
}
}
}
// #pragma omp barrier
/* Calculate new tracer concentration in each cell after accounting */
/* for the j-direction fluxes. */
vhr[k][i][Y0] -= vhh[Y0];
// #pragma omp barrier
//#pragma omp for private(j,m,Ihnew)
for (j=Y1;j<=ny;j++) {
if ((vhh[j] != 0.0) || (vhh[j-1] != 0.0)) {
hlst[j] = hvol[k][i][j];
hvol[k][i][j] -= (vhh[j] - vhh[j-1]);
Ihnew = 1.0 / hvol[k][i][j];
vhr[k][i][j] -= vhh[j];
for (m=0;m<NTR;m++) {
tr[m][k][i][j] *= hlst[j];
tr[m][k][i][j] = (tr[m][k][i][j] -
fluxtr[j][m] + fluxtr[j-1][m]) * Ihnew;
}
}
}
// #pragma omp barrier
} /* i loop */
#endif
} /* end of big loop over k */
/* calculate new thickness field - to be used for vertical */
/* tracer advection from updated volumes (vol + fluxes) */
#pragma omp for private(i,j,k)
for (k=0; k<=NZ-1; k++) {
for (i=X1; i<=nx; i++) {
for (j=Y1; j<=ny; j++) {
hnew[k][i][j] = hvol[k][i][j]/DXDYh(i,j);
if (hnew[k][i][j] < EPSILON) {
hnew[k][i][j] = EPSILON;
}
}
}
}
/* ============================================================ */
/* now advect vertically */
/* ============================================================ */
#pragma omp for private(i,j,hup,hlos)
for (j=Y1; j<=ny; j++) {
for (i=X1; i<=nx; i++) {
/* work from top to bottom - by interfaces - interface k is the */
/* interface between layer k and layer k-1. net flux at this */
/* interface is wd[[k][i][j]= ea[k][i][j] and eb[k-1][i][j] */
/* k=0 */
if (wd[0][i][j] == 0.0) {
wdh[0][i][j] = 0.0;
}
else if (wd[0][i][j] < 0.0) {
hup = hnew[0][i][j] - MLMIN;
hlos = D_MAX(0.0, wd[1][i][j]);
if (((hup + wd[0][i][j] - hlos) < 0.0) &&
((0.5*hup + wd[0][i][j]) < 0.0)) {
wdh[0][i][j] = D_MIN(-0.5*hup,-hup+hlos);
}
else wdh[0][i][j] = wd[0][i][j];
}
else {
wdh[0][i][j] = wd[0][i][j];
}
}
}
#pragma omp for private(i,j,hup,hlos)
for (j=Y1; j<=ny; j++) {
for (i=X1; i<=nx; i++) {
/* k=1 */
if (wd[1][i][j] == 0.0) {
wdh[1][i][j] = 0.0;
}
else if (wd[1][i][j] > 0.0) {
hup = hnew[0][i][j] - MLMIN;
hlos = D_MAX(0.0, -wd[0][i][j]);
if (((hup - wd[1][i][j] - hlos) < 0.0) &&
((0.5*hup - wd[1][i][j]) < 0.0)) {
wdh[1][i][j] = D_MAX(0.5*hup,hup-hlos);
}
else wdh[1][i][j] = wd[1][i][j];
}
else {
hup = hnew[1][i][j] - MLMIN;
hlos = D_MAX(0.0,wd[2][i][j]);
if (((hup + wd[1][i][j] - hlos) < 0.0) &&
((0.5*hup + wd[1][i][j]) < 0.0)) {
wdh[1][i][j] = D_MIN(-0.5*hup,-hup+hlos);
}
else wdh[1][i][j] = wd[1][i][j];
}
}
}
#pragma omp for private(i,j,hup,hlos)
for (j=Y1; j<=ny; j++) {
for (i=X1; i<=nx; i++) {
/* k=2 */
if (wd[2][i][j] == 0.0) {
wdh[2][i][j] = 0.0;
}
else if (wd[2][i][j] > 0.0) {
hup = hnew[1][i][j] - MLMIN;
hlos = D_MAX(0.0, -wd[1][i][j]);
if (((hup - wd[2][i][j] - hlos) < 0.0) &&
((0.5*hup - wd[2][i][j]) < 0.0)) {
wdh[2][i][j] = D_MAX(0.5*hup,hup-hlos);
}
else wdh[2][i][j] = wd[2][i][j];
}
else {
hup = hnew[2][i][j] - EPSILON;
hlos = D_MAX(0.0,wd[3][i][j]);
if (((hup + wd[2][i][j] - hlos) < 0.0) &&
((0.5*hup + wd[2][i][j]) < 0.0)) {
wdh[2][i][j] = D_MIN(-0.5*hup,-hup+hlos);
}
else wdh[2][i][j] = wd[2][i][j];
}
}
}
/* k=3 --> NZ-1 */
#pragma omp for private(i,j,k,hup,hlos)
for (k=3; k<=NZ-1; k++) {
for (j=Y1; j<=ny; j++) {
for (i=X1; i<=nx; i++) {
if (wd[k][i][j] == 0.0) {
wdh[k][i][j] = 0.0;
}
else if (wd[k][i][j] > 0.0) {
hup = hnew[k-1][i][j] - EPSILON;
hlos = D_MAX(0.0, -wd[k-1][i][j]);
if (((hup - wd[k][i][j] - hlos) < 0.0) &&
((0.5*hup - wd[k][i][j]) < 0.0)) {
wdh[k][i][j] = D_MAX(0.5*hup,hup-hlos);
}
else wdh[k][i][j] = wd[k][i][j];
}
else {
hup = hnew[k][i][j] - EPSILON;
if (k != NZ-1) {
hlos = D_MAX(0.0,wd[k+1][i][j]);
} else {
hlos = 0.0;
}
if (((hup + wd[k][i][j] - hlos) < 0.0) &&
((0.5*hup + wd[k][i][j]) < 0.0)) {
wdh[k][i][j] = D_MIN(-0.5*hup,-hup+hlos);
}
else wdh[k][i][j] = wd[k][i][j];
}
} /* k */
} /* j */
} /* i */
#pragma omp for private(i,j)
for (i=X1; i<=nx; i++)
for (j=Y1; j<=ny; j++) {
ear[0][i][j] = wdh[0][i][j];
/* added by Curtis - bottom ebr wasn't set anywhere else */
ebr[NZ-1][i][j] = 0;
}
#pragma omp for private(i,j,k)
for (k=1;k<=NZ-1;k++) {
for (i=X1; i<=nx; i++) {
for (j=Y1; j<=ny; j++) {
ear[k][i][j] = 0.5 * (fabs(wdh[k][i][j]) + wdh[k][i][j]);
ebr[k-1][i][j] = 0.5 * (fabs(wdh[k][i][j]) - wdh[k][i][j]);
}
}
}
#pragma omp for private(i,j,k,m,hnew0,bet,gam)
for (j=Y1; j<=ny; j++) {
for (i=X1; i<=nx; i++) {
hnew0[i] = hnew[0][i][j];
bet[i]=1.0/(hnew[0][i][j] + ebr[0][i][j] + wdh[0][i][j]);
for (m=0;m<NTR;m++)
tr[m][0][i][j] = bet[i]*(hnew0[i]*tr[m][0][i][j]);
}
for (k=1;k<=NZ-1;k++) {
for (i=X1;i<=nx;i++) {
gam[k][i] = ebr[k-1][i][j] * bet[i];
bet[i]=1.0/(hnew[k][i][j] + ebr[k][i][j] +
(1.0-gam[k][i])*ear[k][i][j]);
for (m=0;m<NTR;m++)
tr[m][k][i][j] = bet[i] * (hnew[k][i][j]*tr[m][k][i][j] +
ear[k][i][j]*(tr[m][k-1][i][j]) );
}
}
for (m=0;m<NTR;m++)
for (k=NZ-2;k>=0;k--) {
for (i=X1;i<=nx;i++) {
tr[m][k][i][j] += gam[k+1][i]*tr[m][k+1][i][j];
}
}
} /*j*/
/* update hvol with diapycnal fluxes */
#pragma omp for private(i,j,k)
for (k=0;k<NZ-1;k++) {
for (i=X1; i<=nx; i++)
for (j=Y1; j<=ny; j++)
hnew[k][i][j] += (wdh[k][i][j] - wdh[k+1][i][j]);
}
#pragma omp for private(i,j)
for (i=X1; i<=nx; i++)
for (j=Y1; j<=ny; j++)
hnew[NZ-1][i][j] += wdh[NZ-1][i][j];
#pragma omp for private(i,j,k)
for (k=0;k<=NZ-1;k++)
for (i=X1; i<=nx; i++)
for (j=Y1; j<=ny; j++) {
if (hnew[k][i][j] < EPSILON) hnew[k][i][j] = EPSILON;
hvol[k][i][j] = DXDYh(i,j)*hnew[k][i][j];
if ( wd[k][i][j] > 0.0 && ( wdh[k][i][j] > wd[k][i][j] ))
printf("case 1 wdh[k]\n");
else if ( wd[k][i][j] < 0.0 && ( wdh[k][i][j] < wd[k][i][j] ))
printf("case 2 wdh[k]\n");
wd[k][i][j] -= wdh[k][i][j];
}
#else /* STANDARD_ADVECTION */
/* big loop over k */
// printf("phos(%d,%d,%d)=%g,uhtm=%g\n",0,190,26,tr[mPHOSPHATE][0][190][26],
// uhtm[0][190][26]);
// exit(1);
//yanxu: note these are null cycles, so I comment them out
//yanxu for (k=0;k<NZ;k++) {
// first advect zonally
//yanxu for (j=Y1;j<=ny;j++) {
//yanxu for (i=X0;i<=nx+1;i++) {
//yanxu for (m=0;m<NTR;m++) {
// fluxtr[i][m] = uhtm[i]*(tr[m][k][i][j]);
//yanxu }
//yanxu }
//yanxu }
// now advect meridionally
// null cycles again, yanxu
//yanxu for (i=X1;i<=nx;i++) {
//yanxu }
//yanxu } /* end of big loop over k */
/* calculate new thickness field - to be used for vertical */
/* tracer advection from updated volumes (vol + fluxes) */
#pragma omp for private(i,j,k)
for (k=0; k<=NZ-1; k++)
for (i=X1; i<=nx; i++)
for (j=Y1; j<=ny; j++) {
hnew[k][i][j] = hvol[k][i][j]/DXDYh(i,j);
if (hnew[k][i][j] < EPSILON) hnew[k][i][j] = EPSILON;
}
// now advect vertically
//yanxu: null cycles
//yanxu for (j=Y1; j<=ny; j++) {
//yanxu for (i=X1; i<=nx; i++) {
//yanxu
//yanxu }
//yanxu }
#endif /* STANDARD_ADVECTION */
/* zonal re-entrance */
#pragma omp for private(j,k,m)
for (j=0;j<NYMEM;j++) {
for (k=0;k<NZ;k++) {
uhr[k][nx+1][j] = uhr[k][2][j];
uhr[k][nx+2][j] = uhr[k][3][j];
uhr[k][0][j] = uhr[k][nx-1][j];
uhr[k][1][j] = uhr[k][nx][j];
vhr[k][nx+1][j] = vhr[k][2][j];
vhr[k][nx+2][j] = vhr[k][3][j];
vhr[k][0][j] = vhr[k][nx-1][j];
vhr[k][1][j] = vhr[k][nx][j];
hvol[k][nx+1][j] = hvol[k][2][j];
hvol[k][nx+2][j] = hvol[k][3][j];
hvol[k][0][j] = hvol[k][nx-1][j];
hvol[k][1][j] = hvol[k][nx][j];
for (m=0;m<NTR;m++) {
tr[m][k][nx+1][j] = tr[m][k][2][j];
tr[m][k][nx+2][j] = tr[m][k][3][j];
tr[m][k][0][j] = tr[m][k][nx-1][j];
tr[m][k][1][j] = tr[m][k][nx][j];
}
}
}
/* meridional re-entrance */
/* meridional re-entrance */
#pragma omp for private(i,k,ii,m)
for (i=2;i<=nx;i++) {
ii = 363 - i;
for (k=0;k<NZ;k++) {
uhr[k][ii][ny+1] = (-1)*uhr[k][i][ny];
uhr[k][ii][ny+2] = (-1)*uhr[k][i][ny-1];
vhr[k][ii][ny+1] = (-1)*vhr[k][i][ny];
vhr[k][ii][ny+2] = (-1)*vhr[k][i][ny-1];
hvol[k][ii][ny+1] = hvol[k][i][ny];
hvol[k][ii][ny+2] = hvol[k][i][ny-1];
for (m=0;m<NTR;m++) {
tr[m][k][ii][ny+1] = tr[m][k][i][ny];
tr[m][k][ii][ny+2] = tr[m][k][i][ny-1];
}
}
}
} // omp
#ifdef STANDARD_ADVECTION
# ifdef WRTTS
printf("itt = %i\n",itt);
wrts = (double)(itts)+(double)(itt)/11.+0.0001;
write_ts(wrts);
# endif // WRTTS
//****************************************************************************************
} /* end of temp itt iteration loop */
//****************************************************************************************
#endif
fract1 = (double)(NTSTEP-itts) / (double)NTSTEP;
fract2 = 1.0 - fract1;
//#pragma omp parallel for private(i,j,k) schedule(dynamic)
for (k=0;k<=NZ-1;k++) {
for (i=X1; i<=nx; i++) {
for (j=Y1; j<=ny; j++) {
# ifdef USE_CALC_H
h[k][i][j] = hnew[k][i][j];
if (h[k][i][j] < 0.0)
printf("tracadv l 796 - h[%d][%d][%d] = %g\n", k,i,j,
h[k][i][j]);
# else
h[k][i][j] = fract1*hstart[k][i][j] + fract2*hend[k][i][j];
//BX h[k][i][j] = hend[k][i][j];
# endif
#ifdef HTEST
htest[k][i][j] = hnew[k][i][j];
printf("htest(%d,%d,%d)=%g,hend=%g\n",
k,i,j,
// htest[k][i][j] = h[k][i][j];
#endif
}
}
}
//HF
// zonal re-entrance
//#pragma omp parallel for private(j,k) schedule(dynamic)
for (k=0;k<NZ;k++) {
for (j=0;j<=NYMEM-1;j++) {
h[k][nx+1][j] = h[k][2][j];
h[k][nx+2][j] = h[k][3][j];
h[k][0][j] = h[k][nx-1][j];
h[k][1][j] = h[k][nx][j];
}
}
// meridional re-entrance
//#pragma omp parallel for private(i,k,ii) schedule(dynamic)
for (i=2;i<=nx;i++) {
ii = 363 - i;
for (k=0;k<NZ;k++) {
h[k][ii][ny+1] = h[k][i][ny];
h[k][ii][ny+2] = h[k][i][ny-1];
}
}
//HF-e
# ifdef WRTTS
printf("End of tracadv\n");
wrts = (double)(itts)+(double)(itt)/11.+0.0005;
write_ts(wrts);
# endif // WRTTS
#ifdef DIFFUSE_TRACER
if ((KD>0.0) || (KDML>0.0)) {
diffuse_tracer();
}
#endif
pstage=4;
print_tr(pstage);
if ((KHTR>0.0)) {
tracer_hordiff();
}
pstage=5;
print_tr(pstage);
free3d(hvol, NZ);
free3d(uhr, NZ);
free3d(vhr, NZ);
free3d(ear, NZ);
free3d(ebr, NZ);
free3d(wdh, NZ);
#if !defined AGE2 && !defined AGE3
free3d(hnew, NZ);
#endif
}