Adding a fading color only to 3D curves going outside a cylinder

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

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 x2+y2>1x^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 :

=================

  

 

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
– Dr. belisarius
Aug 4 ’15 at 20:04

  

 

Sorry. I didn’t had the impression that the code is that long. I’ll simplify it.
– Cham
Aug 4 ’15 at 20:11

  

 

You need only one function definition and one ParametricPlot3D to show the problem: just two expressions.The rest is meaningless for solving your issue.
– Dr. belisarius
Aug 4 ’15 at 20:28

  

 

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.
– Cham
Aug 4 ’15 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] &      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 ? – Cham Aug 5 '15 at 0:10      No, it's working !! I just made a stupid typo in the code ! 😎 Wow, this is fantastic ! Thanks a lot wxffles ! – Cham Aug 5 '15 at 0:21