Giving Meaning to the Circular Membrane Problem with Mathematica

Mathematica  code as it appeared in Mathematica in Education, 
Volume 1, No. 3, Spring 1992.

Martha L. Abell and Jim P. Braselton
Department of Mathematics and Computer Science
Georgia Sourthern University
jbrsltn@uscn.bitnet
jbrsltn%uscn.bitnet@uga.cc.uga.edu

Figure 4

start = {2.44, 5.5, 8.7, 12};

table = Table[FindRoot[BesselJ[0,r]==0,
	{r,start[[i]]}], {i,1,4}];

a[n_] := a[n] = (2/(BesselJ[1,table[[n,1,2]]])^2) *
	NIntegrate[r (1 - r^2) * 
		BesselJ[0,table[[n,1,2]] r], {r,0,1}]

uj[r_,t_,j_]:= a[j] * BesselJ[0,table[[j,1,2]] r] *
	Cos[2 table[[j,1,2]] t]

uapprox[r_,t_] = Sum[uj[r,t,j],{j,1,4}];

Do[Plot[uapprox[r,t],{r,-1,1},PlotRange->{-1.5,1}],
	{t,0,1,1/15}];

cross[t_] := Plot[uapprox[r,t],{r,-1,1},
	PlotRange -> {-1.5,1},
	Ticks -> {{-1,1},{-1,1}},
	DisplayFunction -> Identity]

Clear[graphs]
graphs = Partition[Table[cross[t],{t,0,1,1/15}],5];
Show[GraphicsArray[graphs]]

Figure 5

uapprox2[u_,t_] = Sum[uj[u,t,j],{j,1,4}];

ParametricPlot3D[{u Cos[v], u Sin[v], uapprox2[u,0]},
	{u,0,1},{v,0,2Pi}]

Do[ParametricPlot3D[{u Cos[v], u Sin[v], uapprox2[u,t]},
	{u,0,1},{v,0,2Pi}],
{t,0,1,0.1}]

sincostab=Table[{Sin[w],Cos[w]},{w,0,2Pi,2Pi/14}]//N;

solidrev[f_,{a_,b_,m_:Automatic},t_,axis_,ll_:Automatic]:=
	Block[{n,ll,xaxis,yaxis,un,list1,s,w,list2,q,list4,poly},
	
	xaxis=0;
	yaxis=1;
	uu=axis;
	
	If[m===Automatic,n=10,n=m]; (*Chooses default for m*)
	
	list1=Table[{x,f[x,t]},{x,a,b,(b-a)/n}] //N;
	
	list2=If[uu==0,
	(*Corresponds to points for revolution about x-axis*)
		s[{x_,y_}]:=Table[{x ,y sincostab[[i,2]],
							y sincostab[[i,1]]},{i,1,15}
							];
			Map[s, list1],
	(*Corresponds to points for revolution about y-axis*)
		w[{x_,y_}]:=Table[{x sincostab[[i,1]],x sincostab[[i,2]],y},
						{i,1,15}
							];
			Map[w, list1]
			];
			
	un[k_]:=Partition[k,2,1];
	(*Partitions list2 into sublists 2 elements long*)
	list3=Map[un,list2];  
	
	q[i_,j_]:=Join[list3[[i,j]],Reverse[list3[[i+1,j]]]];
	
	(*Creates ordered quadruples which will be displayed as
	either polygons or connected line segments*)
	list4=Flatten[Table[q[i,j],{j,1,Length[list3[[1]]]},
			{i,1,Length[list3]-1}],1];
	
	poly=If[ll===Automatic,Map[Line,list4],Map[Polygon,list4]];
	
	Show[Graphics3D[poly],
		ColorOutput->GrayLevel,
		DisplayFunction->Identity]
	];

Clear[uapprox]
uapprox[r_,t_]:= Sum[uj[r,t,j],{j,1,4}]

Do[solidrev[uapprox,{0,1},t,yaxis,solid],{t,0,1,.1}]

drum[t_]:=solidrev[uapprox,{0,1},t,yaxis,solid]
drumgraphs = Partition[Table[drum[t],{t,0,1,1/15}],4];

Show[GraphicsArray[drumgraphs],ColorOutput->GrayLevel]