Appendix (T080194-01)

coupled two-mass oscillator derivation

following J.C. Snowdon, Vibration and Shock in Damped Mechanical Systems, John Wiley & Sons, cr 1968, section 4.2, pp. 80-83.

derivation

The derivation below corrects Snowdon's equations. Snowdon's formulation for the amplitude of the transfer function from ground to primary mass motion is correct, but his real and imaginary terms are incorrect.

eqn1[t_]:=(Subscript[M, 1]) (Subscript[x, 2])''[t]-(Subscript[k, 1]) (Subscript[G, 1])[ω]((Subscript[x, 1])[t]-(Subscript[x, 2])[t])+(Subscript[k, 2]) (Subscript[G, 2])[ω]((Subscript[x, 2])[t]-(Subscript[x, 3])[t]);

eqn3=LaplaceTransform[eqn1[t],t,s]/.{(Subscript[x, 1])'[0]-> 0,(Subscript[x, 1])[0]-> 0,LaplaceTransform[(Subscript[x, 1])[t],t,s]-> (OverBar[(Subscript[x, 1])])[s],(Subscript[x, 2])'[0]-> 0,(Subscript[x, 2])[0]-> 0,LaplaceTransform[(Subscript[x, 2])[t],t,s]-> (OverBar[(Subscript[x, 2])])[s],(Subscript[x, 3])'[0]-> 0,(Subscript[x, 3])[0]-> 0,LaplaceTransform[(Subscript[x, 3])[t],t,s]-> (OverBar[(Subscript[x, 3])])[s]}

eqn2[t_]:=(Subscript[M, 2]) (Subscript[x, 3])''[t]-(Subscript[k, 2]) (Subscript[G, 2])[ω]((Subscript[x, 2])[t]-(Subscript[x, 3])[t]);

eqn4=LaplaceTransform[eqn2[t],t,s]/.{(Subscript[x, 1])'[0]-> 0,(Subscript[x, 1])[0]-> ζ,LaplaceTransform[(Subscript[x, 1])[t],t,s]-> (OverBar[(Subscript[x, 1])])[s],(Subscript[x, 2])'[0]-> 0,(Subscript[x, 2])[0]-> 0,LaplaceTransform[(Subscript[x, 2])[t],t,s]-> (OverBar[(Subscript[x, 2])])[s],(Subscript[x, 3])'[0]-> 0,(Subscript[x, 3])[0]-> 0,LaplaceTransform[(Subscript[x, 3])[t],t,s]-> (OverBar[(Subscript[x, 3])])[s]}

soln=Solve[{eqn3==0,eqn4==0},{(OverBar[(Subscript[x, 2])])[s],(OverBar[(Subscript[x, 3])])[s]}]

T[ω_]:=Simplify[(OverBar[(Subscript[x, 2])])[s]/(OverBar[(Subscript[x, 1])])[s]/.soln/.s->I ω]

Snowdon's equation 4.7:

T[ω]

Using the following substitutions/defintions
μ=((Subscript[M, 1])/((Subscript[M, 1])+(Subscript[M, 2])));
n=((Subscript[ω, a])/(Subscript[ω, 0]));
(Subscript[ω, 0])=(Sqrt[(((Subscript[k, 1]) (Subscript[Y, 1])[(Subscript[ω, 00])])/((Subscript[M, 1])+(Subscript[M, 2])))]);
(Subscript[ω, a])=(Sqrt[(((Subscript[k, 2]) (Subscript[Y, 2])[(Subscript[ω, 00])])/(Subscript[M, 2]))]);
Ω=(ω/(Subscript[ω, 0]));
and thefollowing notation for the complex modulus:

(Subscript[G, 1])[ω_]:=(Subscript[Y, 1])(1+I (Subscript[δ, 1]));
(Subscript[G, 2])[ω_]:=(Subscript[Y, 2])(1+I (Subscript[δ, 2]));

The expression for the transfer function is as follows:

T[ω]

Transfer function,: Real Numerator Term

(Subscript[R, N])=FullSimplify[Re[Expand[T[ω][[1,{1,2,3,4}]]]],{(Subscript[k, 1]),(Subscript[k, 2]),(Subscript[Y, 1]),(Subscript[Y, 2]),(Subscript[δ, 1]),(Subscript[δ, 2]),μ,w0,wa,Ω,ω,(Subscript[M, 1]),(Subscript[M, 2])}∈Reals]

c=-n^2/((Subscript[k, 1]) (Subscript[k, 2]) (Subscript[Y, 1]) (Subscript[Y, 2]))

Simplify[c (Subscript[R, N])]

Simplify[Expand[c (Subscript[R, N])]//.ω^2 n^2 (Subscript[M, 2])/((Subscript[k, 2]) (Subscript[Y, 2]))->Ω^2 ((Subscript[Y, a])/(Subscript[Y, 2]))]

This is the same as Snowdon's Equation 4.13 for (Subscript[I, N])

Transfer function,: Imaginary Numerator Term

(Subscript[I, N])=FullSimplify[Im[Expand[T[ω][[1,{1,2,3,4}]]]],{(Subscript[k, 1]),(Subscript[k, 2]),(Subscript[Y, 1]),(Subscript[Y, 2]),(Subscript[δ, 1]),(Subscript[δ, 2]),μ,w0,wa,Ω,ω,(Subscript[M, 1]),(Subscript[M, 2])}∈Reals]

Simplify[c (Subscript[I, N])]

Simplify[Expand[c (Subscript[I, N])]//.ω^2 n^2 (Subscript[M, 2])/((Subscript[k, 2]) (Subscript[Y, 2]))->Ω^2 ((Subscript[Y, a])/(Subscript[Y, 2]))]

This is the negative of Snowdon's Equation 4.12 for (Subscript[R, N])

Transfer function,: Real Denominator Term

(Subscript[R, D])=FullSimplify[Re[1/T[ω][[1,5]]],{(Subscript[k, 1]),(Subscript[k, 2]),(Subscript[Y, 1]),(Subscript[Y, 2]),(Subscript[δ, 1]),(Subscript[δ, 2]),μ,w0,wa,Ω,ω,(Subscript[M, 1]),(Subscript[M, 2])}∈Reals]

Simplify[c (Subscript[R, D])]

FullSimplify[Expand[Expand[c (Subscript[R, D])//.{ω^2 ((Subscript[M, 1])+(Subscript[M, 2]))->((Subscript[k, 1]) (Subscript[Y, 1])) Ω^2 ((Subscript[Y, 0])/(Subscript[Y, 1])),ω^2 n^2 (Subscript[M, 2])/((Subscript[k, 2]) (Subscript[Y, 2]))->Ω^2 ((Subscript[Y, a])/(Subscript[Y, 2]))}]]//.{ω^2 ((Subscript[M, 1])+(Subscript[M, 2]))->((Subscript[k, 1]) (Subscript[Y, 1])) Ω^2 ((Subscript[Y, 0])/(Subscript[Y, 1])),ω^2 n^2 (Subscript[M, 2])/((Subscript[k, 2]) (Subscript[Y, 2]))->Ω^2 ((Subscript[Y, a])/(Subscript[Y, 2]))}]

This is the Snowdon's Equation 4.15 for (Subscript[I, D])

Transfer function,: Imaginary Denominator Term

(Subscript[I, D])=FullSimplify[Im[1/T[ω][[1,5]]],{(Subscript[k, 1]),(Subscript[k, 2]),(Subscript[Y, 1]),(Subscript[Y, 2]),(Subscript[δ, 1]),(Subscript[δ, 2]),μ,w0,wa,Ω,ω,(Subscript[M, 1]),(Subscript[M, 2])}∈Reals]

Collect[Expand[c (Subscript[I, D])]//.{ω^2 (Subscript[M, 1])/((Subscript[k, 1]) (Subscript[Y, 1]))+ω^2 (Subscript[M, 2])/((Subscript[k, 1]) (Subscript[Y, 1]))->Ω^2 ((Subscript[Y, 0])/(Subscript[Y, 1])),ω^2 n^2 (Subscript[M, 2])/((Subscript[k, 2]) (Subscript[Y, 2]))->Ω^2 ((Subscript[Y, a])/(Subscript[Y, 2])),n^2ω^4 (Subscript[M, 1]) (Subscript[M, 2]) /((Subscript[k, 1]) (Subscript[k, 2]) (Subscript[Y, 1]) (Subscript[Y, 2]))-> μ  Ω^4 ((Subscript[Y, 0])/(Subscript[Y, 1]))((Subscript[Y, a])/(Subscript[Y, 2]))},n]/.{ω^2 (Subscript[M, 1])/((Subscript[k, 1]) (Subscript[Y, 1]))+ω^2 (Subscript[M, 2])/((Subscript[k, 1]) (Subscript[Y, 1]))->Ω^2 ((Subscript[Y, 0])/(Subscript[Y, 1]))}

This is the negative of Snowdon's Equation 4.14 for (Subscript[R, D])

coupled two-mass oscillator formulation

Same formulation as above but restated without subscripts.

general transmissibility equation

n=wa/w0;
M1=40;
M2=eps M1;
mu=M1/(M1+M2);

d1[w_]:= 10^-7;
d2[w_]:= d;
Y1[w_]:= w0^2(M1+M2);
Y2[w_]:= wa^2 M2;

Variables:
d = loss factor
eps = damping mass to primary mass ratio, M2/M1 == 10^-4
wa = natural frequency of the damping element by itself, rad/sec  (10 kHz <= wa <= 60 kHz)
w0 = natural frequency of the primary mass without the damping element added, rad/sec  (6 kHz <= w0 <= 100 kHz)

IN[w_]:=(w/w0)^2 (Y2[wa]/Y2[w])-n^2 (1-d1[w] d2[w]);
RN[w_]:=-(w/w0)^2 (Y2[wa]/Y2[w]) d1[w]+n^2 (d1[w]+d2[w]);
ID[w_]:= -mu (w/w0)^4 (Y1[w0]/Y1[w]) (Y2[wa]/Y2[w])+(w/w0)^2 (n^2 (Y1[w0]/Y1[w])+(Y2[wa]/Y2[w]))-n^2 (1-d1[w] d2[w]);
RD[w_]:= -(w/w0)^2 (n^2 (Y1[w0]/Y1[w]) d2[w]+(Y2[wa]/Y2[w]) d1[w])+n^2 (d1[w]+d2[w]);
T[w_]:=(RN[w]+I IN[w])/(RD[w]+I ID[w]);

application

case 0: no damping element

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0,eps->0}, {ω,1 10^4,3 10^4}]

case 1: wa < w0, low damping

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0,eps->10^-4},{ω,1000,100000},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

Abs[T[w0]]/.{w0->2 10^4,wa->10^4,d->.02,eps->10^-4} //N

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0.02,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

case 2: wa < w0, moderate damping

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0.01,eps->10^-4},{ω,1000,100000},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0.01,eps->10^-4},{ω,9950,10050},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0.01,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

case 3: wa < w0, high damping

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0.1,eps->10^-4},{ω,1000,100000},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->10^4,d->0.1,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

case 4: wa ~ w0, low damping

19950/20000 //N

plt1=LogLogPlot[Abs[T[Ω w0]] /. {w0 -> 2 10^4, wa -> 1.995 10^4, d -> 10^-3, eps -> 10^-4}, {Ω, .9, 1.1}, PlotRange -> All, PlotPoints -> 10000, MaxRecursion -> 15,PlotStyle->{Red},Frame->True,FrameLabel->{"Normalized Excitation Frequency, Ω (Hz)","Transfer Function Amplitude, T"}]

FindMaximum[Abs[T[ω]] /. {w0 -> 2 10^4, wa -> 1.995 10^4, d -> 10^-3, eps -> 10^-4}, {ω, 1.99 10^4, 2.1 10^4}, AccuracyGoal -> 10, PrecisionGoal -> 10]

FindMaximum[Abs[T[ω]] /. {w0 -> 2 10^4, wa -> 1.995 10^4, d -> 10^-3, eps -> 10^-4}, {ω, 2.0 10^4, 2.1 10^4}, AccuracyGoal -> 10, PrecisionGoal -> 10]

case 5: wa ~ w0, moderate damping

plt2=LogLogPlot[Abs[T[Ω w0]]/.{w0->2 10^4,wa->1.995 10^4,d->0.01,eps->10^-4},{Ω, .9, 1.1},PlotRange->All,PlotPoints->10000,MaxRecursion->15,PlotStyle->{Cyan}]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->1.995 10^4,d->.01,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

case 6: wa ~ w0, high damping

plt3=LogLogPlot[Abs[T[Ω w0]]/.{w0->2 10^4,wa->1.995 10^4,d->0.1,eps->10^-4},{Ω, .9, 1.1},PlotRange->All,PlotPoints->10000,MaxRecursion->15,PlotStyle->{Black}]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->1.995 10^4,d->.1,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

compare cases 4,5,6: wa ~ w0, low, mod, high damping

Show[plt1,plt2,plt3]

case 7: wa > w0, low damping

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->3 10^4,d->10^-3,eps->10^-4},{ω,10000,35000},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->3 10^4,d->10^-3,eps->10^-4}, {ω,1.99 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

case 8: wa > w0, moderate damping

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->3 10^4,d->0.01,eps->10^-4},{ω,10000,35000},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->3 10^4,d->.01,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

case 9: wa > w0, high damping

LogLogPlot[Abs[T[ω]]/.{w0->2 10^4,wa->3 10^4,d->0.1,eps->10^-4},{ω,10000,35000},PlotRange->All,PlotPoints->10000,MaxRecursion->15]

FindMaximum[Abs[T[ω]]/.{w0->2 10^4,wa->3 10^4,d->.1,eps->10^-4}, {ω,1.9 10^4,2.1 10^4},AccuracyGoal->10,PrecisionGoal->10]

dynamic absorber formulation with negligible test mass damping

transmissibility equation

mode shape (coupling) factor, φ, is not included below

G2[w] = Y2[w] (1 + d2[w]) is the complex modulus for the absorber
w = frequency
Y2 = elastic modulus for the absorber
d2 = loss factor for the absorber
Ω = normalized frequency, w/w0
w0 = undamped natural frequency of the simple (SDOF) system, wo^2 = Y1/(M1+M2)
n = normalized absorber frequency, wa/w0
wa = undamped natural frequency of the absorber, wa^2 = Y2/M2
μ = M1/(M1+M2)

RN[w_]:=-(w/w0)^2 (Y2[wa]/Y2[w])+(wa/w0)^2 ;
IN[w_]:=(wa/w0)^2  d2[w];
RD[w_]:= μ (w/w0)^4 (Y2[wa]/Y2[w])-(w/w0)^2 ((wa/w0)^2 +(Y2[wa]/Y2[w]))+(wa/w0)^2 ;
ID[w_]:=(1 -(w/w0)^2) (wa/w0)^2  d2[w];
T[w_]:=(RN[w]+I IN[w])/(RD[w]+I ID[w]);

T[w]

Assume that the absorber elastic modulus and damping factor do not vary with frequency

Y2[w_]:=Y
d2[w_]:=d

Simplify[Abs[T[w]]]

func=T[w]//.{w->w0 Ω, wa->w0 n}

func/.{(wa/w0)^2-> n^2}

Clear[v]

v[w]=(RN[w]^2+IN[w]^2)/(RD[w]^2+ID[w]^2)

here is Snowdon's eqn 4.27 for the transfer function squared, T^2 with α = Y2[wa]/Y2[w] = 1:

Clear[V,μ]
V[Ω_]:=Simplify[v[w]//.{w->w0 Ω, wa/w0->n,μ->1/(1+r)}]
V[Ω]

Clear[n];
V[Ω_]:=(d^2 n^4+(Ω^2-n^2)^2)/(d^2 n^4 (Ω^2-1)^2+(Ω^2-Ω^4/(1+r)+n^2 (Ω^2-1))^2);
V[Ω]

solution for the peak of the transfer function amplitude

Let's examine the variation of the terms of the transfer function amplitude with frequency

Vnum[Ω_]:=V[Ω][[1]]
Vnum[Ω]

Vdenom[Ω_]:=1/V[Ω][[2]]
Vdenom[Ω]

The following shows that the frequency at which the overall transfer function peak is maximized is dominated by the denominator:

evalRule={r->10^-4,d->0.1,n->1.1};
LogLogPlot[{Sqrt[V[Ω]] /.evalRule,Vnum[Ω]/.evalRule,Vdenom[Ω]/.evalRule},{Ω,.1,10},PlotStyle->{Black,Red,Green}]
LogLogPlot[{Sqrt[V[Ω]] /.evalRule,Vnum[Ω]/.evalRule,Vdenom[Ω]/.evalRule},{Ω,.99,1.01},PlotStyle->{Black,Red,Green}]

Here we see that the derivative of the denominator is well described by a line, and we find the first order coeff around Ω = 1

DVdenomDΩ=D[Vdenom[Ω],Ω];
Plot[{DVdenomDΩ/.evalRule},{Ω,0.999,1.001}]

eqDS=Simplify[Normal[Series[DVdenomDΩ/.{Ω->1+ϵ},{ϵ,0,1}]]]

Root[eqDS,ϵ,1]

freqOfPeak=FullSimplify[1+Normal[Series[Root[eqDS,ϵ,1],{r,0,1}]]]

FullSimplify[V[freqOfPeak]]

Sqrt[V[freqOfPeak]]/.{n->0.75,d->0.1,r->.0001}

Sqrt[V[freqOfPeak]]/.{n->0.75,d->0.1,r->.001}

Sqrt[V[freqOfPeak]]/.{n->0.75,d->0.1,r->.00001}

Consider likely piezoelectric and viscoelasic dampers
to cover the frequency range with a suppreesion to 10^5
piezoelectric (0.1 loss factor) requires 10, 16, 25, 40, and 60 kHz dampers 
viscoelastic (1.0 loss factor) requires 20 and 40 kHz dampers

d1=10^-7;
Qp[Ω_]:=1/(1/Sqrt[V[Ω]]+d1);

plt1=LogLogPlot[Qp[freqOfPeak]/.{d->0.05,r->.0001},{n,0.1,10},PlotStyle->{Green,Thickness[0.005]},GridLines->Automatic,Frame->True,PlotRange->All,FrameLabel->{"Damper to Modal Frequency Ratiom, n","Peak Response, Q"}];
plt2=LogLogPlot[Qp[freqOfPeak]/.{d->.1,r->.0001},{n,0.1,10},PlotStyle->{Blue,Thickness[0.005]},PlotRange->All];
plt3=LogLogPlot[Qp[freqOfPeak]/.{d->.2,r->.0001},{n,0.1,10},PlotStyle->{Cyan,Thickness[0.005]},PlotRange->All];
plt4=LogLogPlot[Qp[freqOfPeak]/.{d->.5,r->.0001},{n,0.1,10},PlotStyle->{Red,Thickness[0.005]},PlotRange->All];
plt5=LogLogPlot[Qp[freqOfPeak]/.{d->1,r->.0001},{n,0.1,10},PlotStyle->{Magenta,Thickness[0.005]},PlotRange->All];
Show[plt1,plt2,plt3,plt4,plt5,PlotRange->All]

NSolve[Qp[freqOfPeak]==10^5/.{d->1.,r->.0001},n]

ScientificForm[Qp[freqOfPeak]/.{d->0.1,r->.0001,n->1.6}]

ScientificForm[Qp[freqOfPeak]/.{d->0.1,r->.0001,n->0.6}]

6000/.6

10000 1.6

16000 1.6

25000 1.6

40000 1.6

100000/1.6

60000 .6

ScientificForm[Sqrt[V[freqOfPeak]]/.{d->1,r->.0001,n->0.291}]

6000/.291

ScientificForm[Sqrt[V[freqOfPeak]]/.{d->1,r->.0001,n->2.4}]

20000 2.4

100000/2.4

40000 .291

plots to explore limits of validity of approximate solution

evalRule1={r->.0001,d->0.1,n->1.1};
evalRule2={r->.0001,d->0.01,n->2};
evalRule3={r->.0001,d->0.01,n->1.1};
evalRule4={r->.001,d->0.01,n->1.1};
evalRule5={r->.0001,d->0.1,n->1};
evalRule6={r->.001,d->0.01,n->0.999};
evalRule7={r->.001,d->0.01,n->1};
evalRule8={r->.0001,d->0.01,n->.999};
evalRule9={r->.001,d->0.01,n->.95};
evalRule10={r->.001,d->0.01,n->.5};

plot definition

fmin=.98;
fmax=1.02;
plt1a=LogPlot[Sqrt[V[Ω]]/.evalRule1,{Ω,fmin,fmax},PlotStyle->{Black},PlotPoints->1000,MaxRecursion->15,PlotRange->{{0.98,1.02},{1,10^7}},Frame->True,FrameLabel->{"Eacitation Frequency to Primary Mass Frequency Ratio, Ω","Transfer Function Amplitude"}];
plt2a=LogPlot[Sqrt[V[Ω]]/.evalRule2,{Ω,fmin,fmax},PlotStyle->{Blue},PlotPoints->1000,MaxRecursion->15,PlotRange->All];
plt3a=LogPlot[Sqrt[V[Ω]]/.evalRule3,{Ω,fmin,fmax},PlotStyle->{Cyan},PlotPoints->1000,MaxRecursion->15,PlotRange->All];
plt4a=LogPlot[Sqrt[V[Ω]]/.evalRule4,{Ω,fmin,fmax},PlotStyle->{Magenta},PlotPoints->1000,MaxRecursion->15,PlotRange->All];
plt5a=LogPlot[Sqrt[V[Ω]]/.evalRule5,{Ω,fmin,fmax},PlotStyle->{Green},PlotPoints->1000,MaxRecursion->15,PlotRange->All];
plt6a=LogPlot[Sqrt[V[Ω]]/.evalRule6,{Ω,fmin,fmax},PlotStyle->{Red},PlotPoints->1000,MaxRecursion->15,PlotRange->All];plt7a=LogPlot[Sqrt[V[Ω]]/.evalRule7,{Ω,fmin,fmax},PlotStyle->{Purple},PlotPoints->1000,MaxRecursion->15,PlotRange->All];plt8a=LogPlot[Sqrt[V[Ω]]/.evalRule8,{Ω,fmin,fmax},PlotStyle->{Orange},PlotPoints->1000,MaxRecursion->15,PlotRange->All];plt9a=LogPlot[Sqrt[V[Ω]]/.evalRule9,{Ω,fmin,fmax},PlotStyle->{Pink},PlotPoints->1000,MaxRecursion->15,PlotRange->All];plt10a=LogPlot[Sqrt[V[Ω]]/.evalRule10,{Ω,fmin,fmax},PlotStyle->{Brown},PlotPoints->1000,MaxRecursion->15,PlotRange->All];plt1b=ListLogPlot[{{freqOfPeak/.evalRule1},{Sqrt[V[freqOfPeak]]/.evalRule1}}\[Transpose],PlotStyle->{Black,PointSize[0.02]}];
plt2b=ListLogPlot[{{freqOfPeak/.evalRule2},{Sqrt[V[freqOfPeak]]/.evalRule2}}\[Transpose],PlotStyle->{Blue,PointSize[0.02]}];
plt3b=ListLogPlot[{{freqOfPeak/.evalRule3},{Sqrt[V[freqOfPeak]]/.evalRule3}}\[Transpose],PlotStyle->{Cyan,PointSize[0.02]}];
plt4b=ListLogPlot[{{freqOfPeak/.evalRule4},{Sqrt[V[freqOfPeak]]/.evalRule4}}\[Transpose],PlotStyle->{Magenta,PointSize[0.02]}];
plt5b=ListLogPlot[{{freqOfPeak/.evalRule5},{Sqrt[V[freqOfPeak]]/.evalRule5}}\[Transpose],PlotStyle->{Green,PointSize[0.02]}];
plt6b=ListLogPlot[{{freqOfPeak/.evalRule6},{Sqrt[V[freqOfPeak]]/.evalRule6}}\[Transpose],PlotStyle->{Red,PointSize[0.02]}];
plt7b=ListLogPlot[{{freqOfPeak/.evalRule7},{Sqrt[V[freqOfPeak]]/.evalRule7}}\[Transpose],PlotStyle->{Purple,PointSize[0.02]}];
plt8b=ListLogPlot[{{freqOfPeak/.evalRule8},{Sqrt[V[freqOfPeak]]/.evalRule8}}\[Transpose],PlotStyle->{Orange,PointSize[0.02]}];
plt9b=ListLogPlot[{{freqOfPeak/.evalRule9},{Sqrt[V[freqOfPeak]]/.evalRule9}}\[Transpose],PlotStyle->{Pink,PointSize[0.02]}];
plt10b=ListLogPlot[{{freqOfPeak/.evalRule10},{Sqrt[V[freqOfPeak]]/.evalRule10}}\[Transpose],PlotStyle->{Brown,PointSize[0.02]}];

plots

Show[plt1a,plt2a,plt3a,plt4a,plt5a,plt6a,plt7a,plt8a,plt9a,plt10a,plt1b,plt2b,plt3b,plt4b,plt5b,plt6b,plt7b,plt8b,plt9b,plt10b]

Show[plt1a,plt2a,plt3a,plt4a,plt5a,plt6a,plt7a,plt8a,plt9a,plt10a,plt1b,plt2b,plt3b,plt4b,plt5b,plt6b,plt7b,plt8b,plt9b,plt10b,PlotRange->{{.995,1.005},Automatic}]

3D plots of the peak response

ni=50;
nj=100;
n0=1/10;
dn=1/20;
d0=1/50;
dd=1/500;
in=Table[n0+i dn,{i,1,ni}];
jd=Table[d0+j dd,{j,1,nj}];
Qp=Table[0,{ni},{nj}];
Do[Qp[[i,j]]=Sqrt[V[freqOfPeak]]/.Flatten[{d->jd[[j]],n->in[[i]],r->0.0001}],{i,1,ni},{j,1,nj}]

ListContourPlot[Log[10,Qp],ColorFunction->"SouthwestColors",PlotRange->All,ContourLabels->Automatic,FrameLabel->{"Absorber Loss Factor, (Subscript[δ, 2]) [0.02 to 0.22]","Absorber Frequency to Test Mass Frequency Ratio, n [0.15 to 2.6]"}]

ListPlot3D[Log[10,Qp],ColorFunction->"SouthwestColors",PlotRange->All,AxesLabel->{"Absorber Loss Factor, (Subscript[δ, 2]) [0.02 to 0.22]","Absorber Frequency to Test Mass Frequency Ratio, n [0.15 to 2.6]","Log10(Q)"}]

ni=50;
nj=91;
n0=1/10;
dn=1/20;
r0=.0001;
dr=.00001;
in=Table[n0+i dn,{i,1,ni}];
jr=Table[r0+(j-1) dr,{j,1,nj}];
Qp=Table[0,{ni},{nj}];
Do[Qp[[i,j]]=Sqrt[V[freqOfPeak]]/.Flatten[{r->jr[[j]],n->in[[i]],d->0.1}],{i,1,ni},{j,1,nj}]

ListContourPlot[Log[10,Qp],ColorFunction->"SouthwestColors",PlotRange->All,ContourLabels->Automatic,FrameLabel->{"Absorber Mass to Test Mass ratio, r [0.0001 to 0.001]","Absorber Frequency to Test Mass Frequency Ratio, n [0.15 to 2.6]"}]

ListPlot3D[Log[10,Qp],ColorFunction->"SouthwestColors",PlotRange->All,AxesLabel->{"Absorber Mass to Test Mass ratio, r [0.0001 to 0.001]","Absorber Frequency to Test Mass Frequency Ratio, n [0.15 to 2.6]","Log10(Q)"}]

solution for restricted & specific case: 1/μ-1 = 10^-4, d1 = 0, d2 ~ 0.1 (single peak in transfer function)

define the actual loss in the test mass to use in limiting the transfer function magnitude:

d1=10^-7;

Tsqd1[Ω_]:=V[Ω]/.{μ->1/(1+10^-4),d->1/10}

Tsqd1[Ω]

soln=Maximize[Tsqd1[Ω],Ω];

Dimensions[soln]

soln[[1,1]]

soln[[1,2]]

soln[[2,1]]

plt1=LogLogPlot[1/((1/Sqrt[soln[[1,2]]]/.n->nn)+d1),{nn,0.1,10},PlotStyle->{Black}];

Tsqd05[Ω_]:=V[Ω]/.{μ->1/(1+10^-4),d->1/20}
soln05=Maximize[Tsqd05[Ω],Ω];
plt2=LogLogPlot[1/((1/Sqrt[soln05[[1,2]]]/.n->nn)+d1),{nn,0.1,10},PlotStyle->{Cyan}];

Tsqd2[Ω_]:=V[Ω]/.{μ->1/(1+10^-4),d->2/10}
soln2=Maximize[Tsqd2[Ω],Ω];
plt3=LogLogPlot[1/((1/Sqrt[soln2[[1,2]]]/.n->nn)+d1),{nn,0.1,10},PlotStyle->{Red}];

Show[plt1,plt2,plt3,PlotRange->All,Frame->True,FrameLabel->{"Normalized Absorber Frequency, n","Qpeak"}]