Cardinal Points - Generic Problem

This Matrix Method notebook is a generic one set up to find the cardinal points for 3 identical thick biconvex lenses, each separated by an air space. To use this notebook for your own purposes, change the values for the indices of refraction, the radii of curvature, and the thickness and spacing of the lenses. You will also add or remove matrices to match your particular problem.

We will need 11 matrices : 6 refracting surfaces, with 5 translations in between.

First Matrix, (Subscript[M, 1]): Refraction Matrix
(Subscript[n, 1])=1.00, (Subscript[n, 2])=1.50, (Subscript[R, 1])=+20.0 cm

Second Matrix, (Subscript[M, 2]): Translation Matrix
 (Subscript[L, 1])=+1.00 cm

Third Matrix, (Subscript[M, 3]): Refraction Matrix
(Subscript[n, 2])=1.50, (Subscript[n, 3])=1.00, (Subscript[R, 2])=-20.0 cm

Fourth Matrix, (Subscript[M, 4]): Translation Matrix
 (Subscript[L, 2])=+1.00 cm

Fifth Matrix, (Subscript[M, 5]): Refraction Matrix
(Subscript[n, 3])=1.00, (Subscript[n, 4])=1.50, (Subscript[R, 3])=+20.0 cm

Sixth Matrix, (Subscript[M, 6]): Translation Matrix
 (Subscript[L, 3])=+1.00 cm

Seventh Matrix, (Subscript[M, 7]): Refraction Matrix
(Subscript[n, 4])=1.50, (Subscript[n, 5])=1.00, (Subscript[R, 4])=-20.0 cm

Eighth Matrix, (Subscript[M, 8]): Translation Matrix
 (Subscript[L, 4])=+1.00 cm

Ninth Matrix, (Subscript[M, 9]): Refraction Matrix
(Subscript[n, 5])=1.00, (Subscript[n, 6])=1.50, (Subscript[R, 5])=+20.0 cm

Tenth Matrix, (Subscript[M, 10]): Translation Matrix
 (Subscript[L, 5])=+1.00 cm

Eleventh Matrix, (Subscript[M, 11]): Refraction Matrix
(Subscript[n, 6])=1.50, (Subscript[n, 7])=1.00, (Subscript[R, 6])=-20.0 cm

n1=1.00;n2=1.50;n3=1.00;n4=1.50;n5=1.00;n6=1.50;n7=1.00;

R1=20.0;R2=-20.0;R3=20.0;R4=-20.0;R5=20.0;R6=-20.0;

L1=1.0;L2=1.0;L3=1.0;L4=1.0;L5=1.0;

M1=(({{1, 0}, {(1/R1)((n1/n2)-1), (n1/n2)}}));M2=(({{1, L1}, {0, 1}}));M3=(({{1, 0}, {(1/R2)((n2/n3)-1), (n2/n3)}}));M4=(({{1, L2}, {0, 1}}));

M5=(({{1, 0}, {(1/R3)((n3/n4)-1), (n3/n4)}}));M6=(({{1, L3}, {0, 1}}));M7=(({{1, 0}, {(1/R4)((n4/n5)-1), (n4/n5)}}));M8=(({{1, L4}, {0, 1}}));

M9=(({{1, 0}, {(1/R5)((n5/n6)-1), (n5/n6)}}));M10=(({{1, L5}, {0, 1}}));M11=(({{1, 0}, {(1/R6)((n6/n7)-1), (n6/n7)}}));

Calculate the system matrix, M, by multiplying the 11 matrices together in reverse order.
M=(Subscript[M, 11])•(Subscript[M, 10])•(Subscript[M, 9])•(Subscript[M, 8])•(Subscript[M, 7])•(Subscript[M, 6])•(Subscript[M, 5])•(Subscript[M, 4])•(Subscript[M, 3])•(Subscript[M, 2])•(Subscript[M, 1])
(remember to use . (period) when multiplying matrices instead of * (asterisk))

TraditionalForm[{MatrixForm[M11],MatrixForm[M10],MatrixForm[M9],MatrixForm[M8],MatrixForm[M7],MatrixForm[M6],MatrixForm[M5],MatrixForm[M4],MatrixForm[M3],MatrixForm[M2],MatrixForm[M1]}]//Rationalize

TraditionalForm[Simplify[MatrixForm[M=M11.M10.M9.M8.M7.M6.M5.M4.M3.M2.M1]]]

For convenience, let's assign A, B, C,& D to each matrix element.
(C & D are protected symbols in Mathematica, so we'll have to use lower case letters).
Also, find the ratio of the input and output indices of refraction by calculating the determinate of the matrix M.

a=M[[1,1]];b=M[[1,2]];c=M[[2,1]];d=M[[2,2]];nR=Det[M]

Find the location of the first and second focal points (relative to the input/output planes).

TraditionalForm[{p=(d/c),q=-(a/c)}]

Find the location of the first and second principal points (relative to the input/output planes).

TraditionalForm[{r=((d-nR)/c),s=((1-a)/c)}]

Find the location of the first and second nodal points (relative to the input/output planes).

TraditionalForm[{v=((d-1)/c),w=((nR-a)/c)}]

Find the location of the first and second focal points (relative to the principle planes).

TraditionalForm[{f1=(nR/c),f2=-(1/c)}]

Manipulate[
op=ip+L1+L2+L3+L4+L5;
Show[
ListPlot[
{{p+ip,0},{q+op,0}},
PlotRange->{{xl,xr},{-1,1}},
PlotStyle->Directive[PointSize[0.010],RGBColor[0,0.4,0]],
Axes->{True,False},
ImageSize->800,
AspectRatio->.5,
Epilog->{
Rotate[Text[Style["F1",{FontSize->12,FontFamily->"Times"}],{p+ip,0.07}],0°],
Rotate[Text[Style["F2",{FontSize->12,FontFamily->"Times"}],{q+op,0.07}],0°],
Rotate[Text[Style["PP1",{FontSize->12,FontFamily->"Times"}],{r+ip,0.82}],0°],
Rotate[Text[Style["PP2",{FontSize->12,FontFamily->"Times"}],{s+op,-0.82}],0°],
Rotate[Text[Style["N1",{FontSize->12,FontFamily->"Times"}],{v+ip,0.06}],0°],
Rotate[Text[Style["N2",{FontSize->12,FontFamily->"Times"}],{w+op,-0.07}],0°],
Rotate[Text[Style["IP",{FontSize->12,FontFamily->"Times"}],{ip,-0.82}],0°],
Rotate[Text[Style["OP",{FontSize->12,FontFamily->"Times"}],{op,-0.82}],0°]
}
],
ListLinePlot[
{{r+ip,-0.75},{r+ip,0.00}},
PlotStyle->Directive[RGBColor[0,0,1.0],AbsoluteThickness[2]]
],
ListLinePlot[
{{r+ip,0.12},{r+ip,0.75}},
PlotStyle->Directive[RGBColor[0,0,1.0],AbsoluteThickness[2]]
],
ListLinePlot[
{{s+op,-0.75},{s+op,-0.12}},
PlotStyle->Directive[RGBColor[0,0,1.0],AbsoluteThickness[2]]
],
ListLinePlot[
{{s+op,0.00},{s+op,0.75}},
PlotStyle->Directive[RGBColor[0,0,1.0],AbsoluteThickness[2]]
],
ListPlot[
{{v+ip,0},{w+op,0}},
PlotStyle->Directive[PointSize[0.010],Red]
],
ListLinePlot[
{{ip,-0.75},{ip,0.75}},
PlotStyle->Directive[RGBColor[1.0,0.4,0],AbsoluteThickness[2],Dotted]
],
ListLinePlot[
{{op,-0.75},{op,0.75}},
PlotStyle->Directive[RGBColor[1.0,0.4,0],AbsoluteThickness[2],Dotted]
]
],
{{ip,0,"Input Plane"},-200,200,0.1,Appearance->"Labeled"},{{xl,-100,"x-left"},-200,xr-1,0.1,Appearance->"Labeled"},
{{xr,100,"x-right"},xl+1,200,0.1,Appearance->"Labeled"}
]