1
$\begingroup$

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"]

Picture one

Picture two

$\endgroup$
  • $\begingroup$ "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. $\endgroup$ – Henrik Schumacher Apr 13 at 11:01
  • 1
    $\begingroup$ 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. $\endgroup$ – Michael E2 Apr 13 at 13:41
  • 1
    $\begingroup$ 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] $\endgroup$ – Michael E2 Apr 13 at 13:55
  • $\begingroup$ @guangya I tried to interpret your question. Please check I have done so accurately. You can fix any mistakes I made. $\endgroup$ – Michael E2 Apr 13 at 14:22
  • 1
    $\begingroup$ @Kuba I suspect what MichaelE2 suggested could become an answer if this is reopened. $\endgroup$ – Daniel Lichtblau Apr 13 at 14:59

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.