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$ Commented Aug 4, 2015 at 20:04
  • $\begingroup$ Sorry. I didn't had the impression that the code is that long. I'll simplify it. $\endgroup$
    – Cham
    Commented Aug 4, 2015 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$ Commented Aug 4, 2015 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
    Commented Aug 4, 2015 at 20:32

1 Answer 1


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] &
  • $\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
    Commented Aug 5, 2015 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
    Commented Aug 5, 2015 at 0:21

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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