How can I improve ContourPlot to get smooth curve?

Question

I am working on the ContourPlot to creat contour line of a InterpolatingFunction recently. This is my data. This is my simple code:

Get["C:\\Users\\Administrator\\Desktop\\data.mx"]

hx = Derivative[1, 0][mdfun];
hxxx = Derivative[3, 0][mdfun];
scaledA[d_, B_, k_, e_, hx_, h_, hxxx_] := (3*d*(1 + B*k)*hx)/((k + h + B*k*h)^3*e) + 3*1/e*hxxx + 3*1/e*hx;
A = scaledA[-1, 1, 0.1, 0.05, hx[x, 11.35], mdfun[x, 11.35], hxxx[x, 11.35]];
scaledϕ[A_, z_, h_, B_, k_, hx_, e_, m_] := A*(z^3/6 - (h*z^2)/2) -
m ((1 +B*k)*k*hx*z^2)/((k + h + B k h)^2*e);

sl = ContourPlot[scaledϕ[A, y, mdfun[x, 11.35], 1, 0.1, hx[x, 11.35], 0.05, -5],
{x, 0, 2*Sqrt[2] π}, {y, 0, mdfun[x, 11.35]}, 
RegionFunction -> Function[{x, y, z}, 0 <= y <= mdfun[x, 11.35]],
ImageSize -> 600, Contours -> 20, PlotPoints -> 100,
ContourShading -> None,
ContourStyle -> Directive[Black, Thin], Frame -> False]

I got a graph with zigzag curve.

I have tried to increase PlotPoints up to 100, MaxRecursion up to 6 (which has turned off my machine :) ), and PrecisionGoal up to 10 (which is less than the PrecisionGoal(40) of my InterpolatingFunction) that run away rather easy :P, and also PerformanceGoal->"Quality". However, by anyway, I can not get an acceptable plot. Is there any way to improve the quality of ContourPlot? Is there any possible to use filter?

Answer 1

A slice of the function

Plot[scaledϕ[A, .2, mdfun[x, 11.35], 1, 0.1, hx[x, 11.35], 0.05, -5], {x, 0, 3}]

suggests that the irregular contours and long running time are due to the fine structure of mdfun. Averaging over the fine structure before generating the ContourPlot may give smoother contours, if details of the fine structure are not needed in the plot.

Addendum: Smoothed Contours

The small, rapid oscillations apparent in the plot above can be traced to hxxx, the third derivative of mdfun with respect to x. This oscillation can be eliminated, and the computational speed improved as well, by creating 1-D interpolation functions and then applying LowpassFilter to hxxx:

im = 199;
mddta1d = Table[x = i N[2*Sqrt[2] π]/im; {x, N[mdfun[x, 11.35]]}, {i, 0, im}];
mdfunh = Interpolation[mddta1d, InterpolationOrder -> 7, Method -> "Hermite", 
  PeriodicInterpolation -> True];
hxh = Derivative[1][mdfunh];
mdfunhhxxx = Derivative[3][mdfunh];

im and the Interpolation options are chosen to match those in mdfun. Increasing im or the InterpolationOrder actually make things worse, and using "Spline" instead of "Hermite" has little effect on the third derivative, plotted below directly from the interpolation points of mdfunhhxxx.

ListPlot[mdfunhhxxx["ValuesOnGrid"], PlotRange -> All]

A blowup of this curve would show oscillation among adjacent points of about 0.013 for the first and last 70 points. The central section is extremely noisy. Smoothing of the two wings of the plot is achieved by

hxxxtab = LowpassFilter[mdfunhhxxx["ValuesOnGrid"], 2]; 
hxxxtab[[1]] = 0; hxxxtab[[2]] = 0; hxxxtab[[im + 1]] = 0; 
hxxxtab1d = Table[x = i N[2*Sqrt[2] π]/im; {x, hxxxtab[[i + 1]]}, {i, 0, im}];
hxxxh = Interpolation[hxxxtab1d, InterpolationOrder -> 7, Method -> "Hermite",
  PeriodicInterpolation -> True];

Note that this process changes somewhat the values of the third derivative for the central 6o or so points but does not convert them into a smooth curve. Inserting mdfunh, hxh, and hxxxh into the equations given in the Question (and setting Contours -> 40) yields the desired result.

One should, of course, be cautious in interpreting the central portion of the curve, in light of the very noisy hxxx values there.