# Colors in contours

When I want to draw a wide range of pictures,the value z=1 or z=-1 corresponds to plate patterns,I want it corresponds to one colour.This problem arises only when the scope of painting is large.

Picture two is I want,but the range is too small.

For example xp values range from 0 to 10,yp values range from 6 to 10.The Program will cost your 40 minutes if your computer has 20 kernels.

Interpretation by @Michael E2:

I have a function $$z = G(A,\omega)$$ which normally takes two indicator values $$z = \pm 1$$. The function is computed with a floating-point routine, so it does not compute these values exactly; also there are other values such along the left edge of the first image below. I want to make an image of the plate pattern formed by the indicator values. I expect to get an image mainly colored by two colors corresponding to $$z = \pm 1$$. The first image is over the full range of {xp, yp}, but the image is a mess. The second one shows the kind of pattern I desire, but the image is not over the full range.

On my machine (2.8 GHz 4-core Intel i7 Mac), evaluating G[A0, ω0] takes a little over a second on average. The OP reports (I think) for a 20-core machine, a table of values over

{xp, 0., 10., 0.05}, {yp, 6., 10., 0.05}


takes 40 min. If you change dx = dy = 0.05 to larger values, you can reduce the time and examine a test case. For example,

{xp, 0., 10., 0.5}, {yp, 6., 10., 0.5}


takes less than 60 seconds on my machine.

Is there a way to get uniform coloring of the regions?

t = 1; nk = 1; J = 1; Kx = -π/3; Kx1 = 2 π/3;
Ky = -π/Sqrt[3]; Ky1 = π/Sqrt[3]; sp1 = 0.01; d = 30;

G[A0_, ω0_] := (
ω = ω0;
T = 2 Pi/ω;
ClearAll[H, Hk, F];
A = A0;
H[k_] := H[k] = ({
{0,
J BesselJ[k,
A] (Exp[-I kx] Exp[I k (-π/2)] +
Exp[I kx] Exp[I k π/2]),
J BesselJ[k,
A] (Exp[-I (kx/2 + Sqrt[3] ky/2)] Exp[I k (-π/6)] +
Exp[I (kx/2 + Sqrt[3] ky/2)] Exp[I k 5 π/6])},
{J BesselJ[
k, -A] (Exp[I kx] Exp[I k (-π/2)] +
Exp[-I kx] Exp[I k π/2]), 0,
J BesselJ[k,
A] (Exp[-I (-kx/2 + Sqrt[3] ky/2)] Exp[I k (π/6)] +
Exp[-I (kx/2 - Sqrt[3] ky/2)] Exp[I k (-5 π/6)])},
{J BesselJ[
k, -A] (Exp[I (kx/2 + Sqrt[3] ky/2)] Exp[I k (-π/6)] +
Exp[-I (kx/2 + Sqrt[3] ky/2)] Exp[I k 5 π/6]),
J BesselJ[
k, -A] (Exp[I (-kx/2 + Sqrt[3] ky/2)] Exp[I k (π/6)] +
Exp[I (kx/2 - Sqrt[3] ky/2)] Exp[I k (-5 π/6)]), 0}
});

Hk = Table[
H[j - i] + IdentityMatrix[3] If[i == j, i ω, 0], {i, -nk,
nk}, {j, -nk, nk}];
Hk = ArrayFlatten[Hk];
F[x_, y_] := (
SA = Eigensystem[N[Hk /. kx -> x /. ky -> y]];
SA = Table[{Chop[SA[[1]][[i]]], SA[[2]][[i]]}, {i, (2 nk + 1) 3}];
SA = Sort[SA, #1[[1]] < #2[[1]] &];
SA1 = SA[[1 ;; (3 nk + 1)]][[All, 2]]);
s1 = Table[
F[x, y], {x, Kx + sp1, Kx1 + sp1, (Kx1 - Kx)/d}, {y, Ky + sp1,
Ky1 + sp1, (Ky1 - Ky)/d}];
s2 = Total[
Table[Im[
Log[Diagonal[(Conjugate[s1[[i, j]]].Transpose[
s1[[i + 1, j]]]) (Conjugate[s1[[i + 1, j]]].Transpose[
s1[[i + 1, j + 1]]]) (Conjugate[
s1[[i + 1, j + 1]]].Transpose[
s1[[i, j + 1]]]) (Conjugate[s1[[i, j + 1]]].Transpose[
s1[[i, j]]])]]], {i, d}, {j, d}], 2]/(2 Pi);
-Total[s2])
SetSharedVariable[ik];
ik = 0;
dp = Monitor[
ParallelTable[{ik++; xp, yp, G[xp, yp]}, {xp, 2., 3., 0.05}, {yp,
9, 10, 0.05}], ik];
ListContourPlot[Flatten[dp, 1], Contours -> 100,
PlotTheme -> "Detailed"]


• "The Program will cost your 40 minutes if your computer has 20 kernels." I second what Kuba says. Most of us have only 2 or 4 cores, so what's the point? You may try to apply Clip and Rescale before plotting. – Henrik Schumacher Apr 13 at 11:01
• You can reduce the time by reducing the sampling considerably (to produce test cases, before committing to a high-resolution final plot). What it shows is the almost 95% of the z differ from -1 by rounding error, the differences being what cause the random-looking contour lines. The other values (in my test case) differ from two other integers, -5 and 1, also by rounding error. Perhaps try Round[G[xp, yp]] in your table. – Michael E2 Apr 13 at 13:41
• If your table runs over {xp, 0, 10, dx}, {yp, 6, 10, dy}, then this plot may be useful: dx = 0.05; dy = 0.05; Show[ArrayPlot[dp[[All, All, 3]] // Rescale // Transpose, ColorFunction -> (Blend["M10DefaultDensityGradient", #1] &), DataRange -> {{0 + dx/2, 10 - dx/2}, {6 + dy/2, 10 - dy/2}}, DataReversed -> {True, False}], FrameTicks -> Automatic] – Michael E2 Apr 13 at 13:55
• @guangya I tried to interpret your question. Please check I have done so accurately. You can fix any mistakes I made. – Michael E2 Apr 13 at 14:22
• @Kuba I suspect what MichaelE2 suggested could become an answer if this is reopened. – Daniel Lichtblau Apr 13 at 14:59