I'm having a problem with color shades on multi curves drawn with the Mathematica 7.0 code below. All the curves with both their endpoints inside the unit cylinder (green circle on the picture below) are okay. But the curves which are going outside have a free ending that should gently fade away. The code should do this for any alpha angle, all values of omega < 1, and any value to the NCourbes parameter.

Here's the working code :

alpha = 45Pi/180;

omega = 0.2;

r[x_,y_,z_] := Sqrt[x^2 + y^2 + z^2]

Mu0[t_,x_,y_,z_] := {Cos[t-r[x,y,z]]Sin[alpha], Sin[t-r[x,y,z]]Sin[alpha], Cos[alpha]}

Mu1[t_,x_,y_,z_] := {-Sin[t-r[x,y,z]]Sin[alpha], Cos[t-r[x,y,z]]Sin[alpha], 0}

Mu2[t_,x_,y_,z_] := {-Cos[t-r[x,y,z]]Sin[alpha], -Sin[t-r[x,y,z]]Sin[alpha], 0}

Bdipolaire[t_,x_,y_,z_] := 3(Mu0[t,x,y,z].{x,y,z}){x,y,z}/r[x,y,z]^5 - Mu0[t,x,y,z]/r[x,y,z]^3

Binduction[t_,x_,y_,z_] := 3(Mu1[t,x,y,z].{x,y,z}){x,y,z}/r[x,y,z]^4 - Mu1[t,x,y,z]/r[x,y,z]^2

Bradiation[t_,x_,y_,z_] := 1 (Mu2[t,x,y,z].{x,y,z}){x,y,z}/r[x,y,z]^3 - Mu2[t,x,y,z]/r[x,y,z]

Btotal[t_,x_,y_,z_] := Bdipolaire[t,x,y,z] + Binduction[t,x,y,z] + Bradiation[t,x,y,z]

NormeB[t_,x_,y_,z_] := Sqrt[Btotal[t,x,y,z].Btotal[t,x,y,z]]

Bx[t_,x_,y_,z_] := {1,0,0}.Btotal[t,x,y,z]
By[t_,x_,y_,z_] := {0,1,0}.Btotal[t,x,y,z]
Bz[t_,x_,y_,z_] := {0,0,1}.Btotal[t,x,y,z]

NCourbes = 26;

phi[n_] := n 2Pi/NCourbes

CourbeMagnetique[n_] := NDSolve[{
    x'[s] == Bx[omega,x[s],y[s],z[s]]/NormeB[omega,x[s],y[s],z[s]],
    y'[s] == By[omega,x[s],y[s],z[s]]/NormeB[omega,x[s],y[s],z[s]],
    z'[s] == Bz[omega,x[s],y[s],z[s]]/NormeB[omega,x[s],y[s],z[s]],
    x[0] == Cos[phi[n]],
    y[0] == Sin[phi[n]],
    z[0] == 0
},{x,y,z},{s,-20,20},Method->Automatic,MaxSteps->10000000, StoppingTest->(Sqrt[x[s]^2+y[s]^2+z[s]^2]<omega||Sqrt[x[s]^2+y[s]^2+z[s]^2] >5)]

Do[CourbeMagnetique[n], {n,1,NCourbes}]

Smin[n_] := (x/.CourbeMagnetique[n])[[1]][[1]][[1]][[1]]
Smax[n_] := (x/.CourbeMagnetique[n])[[1]][[1]][[1]][[2]]

Couleur1 = RGBColor[0,0,1];
Couleur2 = RGBColor[0.70,0.60,0.40];
Couleur3 = RGBColor[1,0,0];

GrapheMagnetique[n_] := ParametricPlot3D[Evaluate[{x[s],y[s],z[s]}/.CourbeMagnetique[n]],{s,Smin[n],Smax[n]},PlotStyle->{Directive[AbsoluteThickness[1]]}, ColorFunction->(Blend[{Couleur1,Couleur2,Couleur3},#4]&)]

CercleLumiere = ParametricPlot3D[{Cos[p],Sin[p],0},{p,0,2Pi}, PlotStyle->{Directive[Thick,RGBColor[0.40,0.70,0.40]]}];

Pulsar = Graphics3D[Sphere[{0,0,0},omega]];

Graphique = Show[Table[GrapheMagnetique[n],{n,1,NCourbes}], CercleLumiere,Pulsar,PlotRange->All]

Here's a picture showing what the code above is doing : my picture

As you can see, there are several curves going outside the cylinder, and their free ending (in blue or red) is ugly. How to make them gently fade away to white ?

I guess that a condition like $x^2 + y^2 > 1$ should be added somewhere, but I can't see what exactly.

Take note that I'm working with Mathematica 7.0.

EDIT : I simplified a bit the code above.

EDIT 2 : From wxffles's solution below, I'm now getting this sweetness :

my picture

  • $\begingroup$ Please post a MINIMAL example instead of dumping all your code here ... There are a lot of nuisances unrelated to your current problem in there $\endgroup$ – Dr. belisarius Aug 4 '15 at 20:04
  • $\begingroup$ Sorry. I didn't had the impression that the code is that long. I'll simplify it. $\endgroup$ – Cham Aug 4 '15 at 20:11
  • $\begingroup$ You need only one function definition and one ParametricPlot3D to show the problem: just two expressions.The rest is meaningless for solving your issue. $\endgroup$ – Dr. belisarius Aug 4 '15 at 20:28
  • $\begingroup$ I don't think so. I need to show various field lines ; some with their endpoints closed on the central sphere, and some going outside with a free end. For the rest of the code, I don't see what could be simplified. $\endgroup$ – Cham Aug 4 '15 at 20:32

You could just make a function which decides your end colour:

colour1[n_] := 
 With[{end = {x[s], y[s], z[s]} /. First@CourbeMagnetique[n] /. s :> Smin[n]},
  If[Norm@end < 1, RGBColor[0, 0, 1], RGBColor[1, 1, 1]]]

colour3[n_] := 
 With[{end = {x[s], y[s], z[s]} /. First@CourbeMagnetique[n] /. s :> Smax[n]},
  If[Norm@end < 1, RGBColor[1, 0, 0], RGBColor[1, 1, 1]]]

And change your ColorFunction to match:

Blend[{colour1[n], Couleur2, colour3[n]}, #4] &
| improve this answer | |
  • $\begingroup$ hmm, it doesn't work. I'm getting several error messages like this one : "Blend::arg:{Couleur1[1],RGBColor[0,0,1],Couleur3[1]} is not a valid list of color or gray-level directives, or pairs of a real number and a directive.". Are you sure that these commands are compatible with Mathematica 7.0 ? $\endgroup$ – Cham Aug 5 '15 at 0:10
  • $\begingroup$ No, it's working !! I just made a stupid typo in the code ! 8-) Wow, this is fantastic ! Thanks a lot wxffles ! $\endgroup$ – Cham Aug 5 '15 at 0:21

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.