henry/SimCore
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ADD: new track message, Entity class and Position class

Browse Source
This commit is contained in:
Henry Winkel
2022-12-20 17:20:35 +01:00
parent 469ecfb099
commit 98ebb563a8
2114 changed files with 482360 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
libs/geographiclib/maxima/.gitignore vendored Normal file
View File

@@ -0,0 +1 @@
geod*.lsp

302
libs/geographiclib/maxima/auxlat.mac Normal file
View File

@@ -0,0 +1,302 @@
/*
Compute series expansions for the auxiliary latitudes.
Copyright (c) Charles Karney (2014-2020) <charles@karney.com> and
licensed under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
This maxima program compute the coefficients for trigonometric series
relating the six latitudes
phi geographic
beta parametric
theta geocentric
mu rectifying
chi conformal
xi authalic
All 30 inter-relations are found. The coefficients are expressed as
Taylor series in the third flattening n. This generates the series
given on the page
https://geographiclib.sourceforge.io/C++/doc/auxlat.html
Instructions:
* [optional] edit to set the desired value of maxpow (currently 8)
* start maxima and run
batch("auxlat.mac")$
* now tx[beta,phi], for example, gives the expansion of beta in terms of phi
* to format the results
writefile("auxlat.txt")$
dispall()$
closefile()$
Approx timings:
maxpow time(s)
6 13
8 41
10 114
12 293
14 708
16 1629
20 7311
25 43020
30 210660
*/
/*
revert
var2 = expr(var1) = series in eps
to
var1 = revertexpr(var2) = series in eps
Require that expr(var1) = var1 to order eps^0. This throws in a
trigreduce to convert to multiple angle trig functions.
*/
maxpow:8$
reverta(expr,var1,var2,eps,pow):=block([tauacc:1,sigacc:0,dsig],
dsig:ratdisrep(taylor(expr-var1,eps,0,pow)),
dsig:subst([var1=var2],dsig),
for n:1 thru pow do (tauacc:trigreduce(ratdisrep(taylor(
-dsig*tauacc/n,eps,0,pow))),
sigacc:sigacc+expand(diff(tauacc,var2,n-1))),
var2+sigacc)$
/* beta in terms of phi */
beta_phi:phi+sum((-n)^j/j*sin(2*j*phi),j,1,maxpow)$
/* Alt:
beta_phi:taylor(atan((1-n)/(1+n)*tan(phi)),n,0,maxpow)$
beta_phi:subst([atan(tan(phi))=phi,tan(phi)=sin(phi)/cos(phi)],
ratdisrep(beta_phi))$
beta_phi:trigreduce(ratsimp(beta_phi))$
*/
/* phi in terms of beta */
phi_beta:subst([n=-n,phi=beta],beta_phi)$
/* Alt:
beta_phi:reverta(beta_phi,phi,beta,n,maxpow)$
*/
/* theta in terms of beta */
theta_beta:subst([phi=beta],beta_phi)$
/* theta in terms of phi */
theta_phi:subst([beta=beta_phi],theta_beta)$
theta_phi:trigreduce(taylor(theta_phi,n,0,maxpow))$
/* phi in terms of theta */
phi_theta:subst([n=-n,phi=theta],theta_phi)$
/* chi in terms of phi */
atanexp(x,eps):=''(ratdisrep(taylor(atan(x+eps),eps,0,maxpow)))$
chi_phi:block([psiv,tanchi,chiv,qq,e],
/* Here qq = atanh(sin(phi)) = asinh(tan(phi)) */
psiv:qq-e*atanh(e*tanh(qq)),
psiv:subst([e=sqrt(4*n/(1+n)^2),qq=atanh(sin(phi))],
ratdisrep(taylor(psiv,e,0,2*maxpow)))
+asinh(sin(phi)/cos(phi))-atanh(sin(phi)),
tanchi:subst([abs(cos(phi))=cos(phi),sqrt(sin(phi)^2+cos(phi)^2)=1],
ratdisrep(taylor(sinh(psiv),n,0,maxpow)))+tan(phi)-sin(phi)/cos(phi),
chiv:atanexp(tan(phi),tanchi-tan(phi)),
chiv:subst([atan(tan(phi))=phi,
tan(phi)=sin(phi)/cos(phi)],
(chiv-phi)/cos(phi))*cos(phi)+phi,
chiv:ratdisrep(taylor(chiv,n,0,maxpow)),
expand(trigreduce(chiv)))$
/* phi in terms of chi */
phi_chi:reverta(chi_phi,phi,chi,n,maxpow)$
df[i]:=if i<0 then df[i+2]/(i+2) else i!!$
/* df[-1] = 1; df[-3] = -1 */
c(k,maxpow):=sum(n^(k+2*j)*(df[2*j-3]*df[2*j+2*k-3])/(df[2*j]*df[2*j+2*k]),
j,0,(maxpow-k)/2)$
/* mu in terms of beta */
mu_beta:expand(ratdisrep(
taylor(beta+sum(c(i,maxpow)/i*sin(2*i*beta),i,1,maxpow)/c(0,maxpow),
n,0,maxpow)))$
/* beta in terms of mu */
beta_mu:reverta(mu_beta,beta,mu,n,maxpow)$
/* xi in terms of phi */
asinexp(x,eps):=''(sqrt(1-x^2)*
sum(ratsimp(diff(asin(x),x,i)/i!/sqrt(1-x^2))*eps^i,i,0,maxpow))$
sinxi:(sin(phi)/2*(1/(1-e^2*sin(phi)^2) + atanh(e*sin(phi))/(e*sin(phi))))/
(1/2*(1/(1-e^2) + atanh(e)/e))$
sinxi:ratdisrep(taylor(sinxi,e,0,2*maxpow))$
sinxi:subst([e=2*sqrt(n)/(1+n)],sinxi)$
sinxi:expand(trigreduce(ratdisrep(taylor(sinxi,n,0,maxpow))))$
xi_phi:asinexp(sin(phi),sinxi-sin(phi))$
xi_phi:taylor(subst([sqrt(1-sin(phi)^2)=cos(phi),asin(sin(phi))=phi],
xi_phi),n,0,maxpow)$
xi_phi:expand(ratdisrep(coeff(xi_phi,n,0))+sum(
ratsimp(trigreduce(sin(phi)*ratsimp(
subst([sin(phi)=sqrt(1-cos(phi)^2)],
ratsimp(trigexpand(ratdisrep(coeff(xi_phi,n,i)))/sin(phi))))))*n^i,
i,1,maxpow))$
/* phi in terms of xi */
phi_xi:reverta(xi_phi,phi,xi,n,maxpow)$
/* complete the set by using what we have */
mu_phi:expand(trigreduce(taylor(subst([beta=beta_phi],mu_beta),n,0,maxpow)))$
phi_mu:expand(trigreduce(taylor(subst([beta=beta_mu],phi_beta),n,0,maxpow)))$
chi_mu:expand(trigreduce(taylor(subst([phi=phi_mu],chi_phi),n,0,maxpow)))$
mu_chi:expand(trigreduce(taylor(subst([phi=phi_chi],mu_phi),n,0,maxpow)))$
beta_chi:expand(trigreduce(taylor(subst([phi=phi_chi],beta_phi),n,0,maxpow)))$
chi_beta:expand(trigreduce(taylor(subst([phi=phi_beta],chi_phi),n,0,maxpow)))$
beta_theta:expand(trigreduce
(taylor(subst([phi=phi_theta],beta_phi),n,0,maxpow)))$
beta_xi:expand(trigreduce(taylor(subst([phi=phi_xi],beta_phi),n,0,maxpow)))$
chi_theta:expand(trigreduce
(taylor(subst([phi=phi_theta],chi_phi),n,0,maxpow)))$
chi_xi:expand(trigreduce(taylor(subst([phi=phi_xi],chi_phi),n,0,maxpow)))$
mu_theta:expand(trigreduce(taylor(subst([phi=phi_theta],mu_phi),n,0,maxpow)))$
mu_xi:expand(trigreduce(taylor(subst([phi=phi_xi],mu_phi),n,0,maxpow)))$
theta_chi:expand(trigreduce
(taylor(subst([phi=phi_chi],theta_phi),n,0,maxpow)))$
theta_mu:expand(trigreduce(taylor(subst([phi=phi_mu],theta_phi),n,0,maxpow)))$
theta_xi:expand(trigreduce(taylor(subst([phi=phi_xi],theta_phi),n,0,maxpow)))$
xi_beta:expand(trigreduce(taylor(subst([phi=phi_beta],xi_phi),n,0,maxpow)))$
xi_chi:expand(trigreduce(taylor(subst([phi=phi_chi],xi_phi),n,0,maxpow)))$
xi_mu:expand(trigreduce(taylor(subst([phi=phi_mu],xi_phi),n,0,maxpow)))$
xi_theta:expand(trigreduce(taylor(subst([phi=phi_theta],xi_phi),n,0,maxpow)))$
/* put series in canonical form */
norm(x):=block([z:subst([n=0],x)],
z+sum(coeff(expand(x),sin(2*i*z))*sin(2*i*z),i,1,maxpow))$
(
tx[beta,chi]:norm(beta_chi),
tx[beta,mu]:norm(beta_mu),
tx[beta,phi]:norm(beta_phi),
tx[beta,theta]:norm(beta_theta),
tx[beta,xi]:norm(beta_xi),
tx[chi,beta]:norm(chi_beta),
tx[chi,mu]:norm(chi_mu),
tx[chi,phi]:norm(chi_phi),
tx[chi,theta]:norm(chi_theta),
tx[chi,xi]:norm(chi_xi),
tx[mu,beta]:norm(mu_beta),
tx[mu,chi]:norm(mu_chi),
tx[mu,phi]:norm(mu_phi),
tx[mu,theta]:norm(mu_theta),
tx[mu,xi]:norm(mu_xi),
tx[phi,beta]:norm(phi_beta),
tx[phi,chi]:norm(phi_chi),
tx[phi,mu]:norm(phi_mu),
tx[phi,theta]:norm(phi_theta),
tx[phi,xi]:norm(phi_xi),
tx[theta,beta]:norm(theta_beta),
tx[theta,chi]:norm(theta_chi),
tx[theta,mu]:norm(theta_mu),
tx[theta,phi]:norm(theta_phi),
tx[theta,xi]:norm(theta_xi),
tx[xi,beta]:norm(xi_beta),
tx[xi,chi]:norm(xi_chi),
tx[xi,mu]:norm(xi_mu),
tx[xi,phi]:norm(xi_phi),
tx[xi,theta]:norm(xi_theta))$
ll1:[
[beta,phi],
[theta,phi],
[theta,beta],
[mu,phi],
[mu,beta],
[mu,theta]]$
ll2:[
[chi,phi],
[chi,beta],
[chi,theta],
[chi,mu],
[xi,phi],
[xi,beta],
[xi,theta],
[xi,mu],
[xi,chi]]$
kill(tt)$
tt[i,j]:=if i=j then [] else
block([v:tx[i,j],x:j,l:[]],
for i:1 thru maxpow do block([l1:[],c:coeff(v,sin(2*i*x))],
for j:i thru maxpow do l1:endcons(coeff(c,n,j),l1),
l:endcons(l1,l)),
l)$
texa(i,j,pow):=block([x:j,y:i,v:tt[i,j],s:"\\",sn:"\\sin "],
x:concat(s,x), y:concat(s,y),
print(concat(y, "-", x, "&=\\textstyle{}")),
for k:1 thru pow do block([t:v[k],sgn,nterm:0,str:""],
sgn:0,
for l:1 thru pow-k+1 do block([m:t[l]],
if m # 0 then (nterm:nterm+1,
if sgn = 0 then sgn:if m>0 then 1 else -1) ),
t:sgn*t,
if sgn # 0 then block([f:true],
str:concat(str,if sgn > 0 then "+" else "-"),
if nterm > 1 then str:concat(str,"\\bigl("),
for l:1 thru pow-k+1 do block([c:t[l]],
if c # 0 then (sgn:if c > 0 then 1 else -1, c:sgn*c,
if not f and nterm > 1 then
str:concat(str,if sgn > 0 then "+" else "-"),
f:false,
if c # 1 then if integerp(c) then str:concat(str,c) else
str:concat(str,"\\frac{",num(c),"}{",denom(c),"}"),
if l+k-1 > 1 then
str:concat(str,"n^{",l+k-1,"}")
else
str:concat(str,"n"))),
if nterm > 1 then str:concat(str,"\\bigr)"),
str:concat(str,sn,2*k,x)),
print(str)),
print(concat(if length(v)>pow and [pow+1][1] < 0 then "-"
else "+","\\ldots\\\\")),
'done)$
cf(i,j):= (
print(concat("<p>&",i,";&nbsp;&minus;&nbsp;&",j,";:<br><tt><small>")),
for x in tt[i,j] do block([str:"&nbsp;&nbsp;&nbsp;["],
for i:1 thru length(x) do
str:concat(str,string(x[i]),if i<length(x) then ", " else "]<br>"),
print(str)),
print("</small></tt>"),
'done)$
printfrac(x):=block([n:num(x),d:denom(x),sn,sd,m:2^31],
sn:string(n), sd:concat("/",string(d)),
if abs(n)>=m then sn:concat(sn,".0"),
if d = 1 then sd:"" else (if d>=m or abs(n)<m then sd:concat(sd,".0")),
concat(sn,sd))$
cc(i,j):= (
print(concat("double coeff_",i,"_",j,"[] = {")),
for x in tt[i,j] do block([str:" "],
for i:1 thru length(x) do
str:concat(str,printfrac(x[i]),
if i<length(x) then ", " else if length(x)>1 then "," else ""),
print(str)),
print("};"),
'done)$
disptex(ll,pow):=
block([linel:1000],
print("\\f["),
print("\\begin{align}"),
for xx in ll do (texa(xx[1],xx[2],pow),texa(xx[2],xx[1],pow)),
print("\\end{align}"),
print("\\f]"))$
disphtml(ll):=
block([linel:1000],
for xx in ll do (cf(xx[1],xx[2]),cf(xx[2],xx[1])))$
dispcpp(ll):=
block([linel:1000],
for xx in ll do (cc(xx[1],xx[2]),cc(xx[2],xx[1])))$
dispall():=(
print(""),
disptex(ll1,4),
print(""),
disptex(ll2,3),
print(""),
disphtml(append(ll1,ll2)),
print(""),
dispcpp(append(ll1,ll2)))$

281
libs/geographiclib/maxima/ellint.mac Normal file
View File

@@ -0,0 +1,281 @@
/*
Implementation of methods given in
B. C. Carlson
Computation of elliptic integrals
Numerical Algorithms 10, 13-26 (1995)
Copyright (c) Charles Karney (2009-2013) <charles@karney.com> and
licensed under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
*/
/* fpprec:120$ Should be set outside */
etol:0.1b0^fpprec$ /* For Carlson */
tolRF : (3 * etol)^(1/8b0)$
tolRD : (etol/5)^(1/8b0)$
tolRG0 : 2.7b0 * sqrt(etol)$
tolJAC:sqrt(etol)$ /* For Bulirsch */
pi:bfloat(%pi)$
atan2x(y,x) := -atan2(-y, x)$ /* fix atan2(0b0,-1b0) = -pi */
rf(x,y,z) := block([a0:(x+y+z)/3, q,x0:x,y0:y,z0:z,
an,ln,xx,yy,zz,e2,e3,mul:1b0],
q:max(abs(a0-x),abs(a0-y),abs(a0-z))/tolRF,
an:a0,
while q >= mul * abs(an) do (
ln:sqrt(x0)*sqrt(y0)+sqrt(y0)*sqrt(z0)+sqrt(z0)*sqrt(x0),
an:(an+ln)/4,
x0:(x0+ln)/4,
y0:(y0+ln)/4,
z0:(z0+ln)/4,
mul:mul*4),
xx:(a0-x)/(mul*an),
yy:(a0-y)/(mul*an),
zz:-xx-yy,
e2:xx*yy-zz^2,
e3:xx*yy*zz,
(e3 * (6930 * e3 + e2 * (15015 * e2 - 16380) + 17160) +
e2 * ((10010 - 5775 * e2) * e2 - 24024) + 240240) /
(240240 * sqrt(an)))$
rd(x,y,z) := block([a0:(x+y+3*z)/5, q,x0:x,y0:y,z0:z,
an,ln,xx,yy,zz,e2,e3,e4,e5,s:0b0,mul:1b0],
q:max(abs(a0-x),abs(a0-y),abs(a0-z))/tolRD,
an:a0,
while q >= mul*abs(an) do (
ln:sqrt(x0)*sqrt(y0)+sqrt(y0)*sqrt(z0)+sqrt(z0)*sqrt(x0),
s:s+1/(mul*sqrt(z0)*(z0+ln)),
an:(an+ln)/4,
x0:(x0+ln)/4,
y0:(y0+ln)/4,
z0:(z0+ln)/4,
mul:4*mul),
xx:(a0-x)/(mul*an),
yy:(a0-y)/(mul*an),
zz:-(xx+yy)/3,
e2:xx*yy-6*zz^2,
e3:(3*xx*yy-8*zz^2)*zz,
e4:3*(xx*yy-zz^2)*zz^2,
e5:xx*yy*zz^3,
((471240 - 540540 * e2) * e5 +
(612612 * e2 - 540540 * e3 - 556920) * e4 +
e3 * (306306 * e3 + e2 * (675675 * e2 - 706860) + 680680) +
e2 * ((417690 - 255255 * e2) * e2 - 875160) + 4084080) /
(4084080 * mul * an * sqrt(an)) + 3 * s)$
/* R_G(x,y,0) */
rg0(x,y) := block([x0:sqrt(max(x,y)),y0:sqrt(min(x,y)),xn,yn,
t,s:0b0,mul:0.25b0],
xn:x0,
yn:y0,
while abs(xn-yn) > tolRG0 * xn do (
t:(xn+yn)/2,
yn:sqrt(xn*yn),
xn:t,
mul : 2*mul,
s:s+mul*(xn-yn)^2),
((x0+y0)^2/4 - s)*pi/(2*(xn+yn)) )$
rg(x, y, z) := (
if z = 0b0 then (z:y, y:0b0),
(z * rf(x, y, z) - (x-z) * (y-z) * rd(x, y, z) / 3
+ sqrt(x * y / z)) / 2)$
rj(x, y, z, p) := block([A0:(x + y + z + 2*p)/5,An,delta:(p-x) * (p-y) * (p-z),
Q,x0:x,y0:y,z0:z,p0:p,mul:1b0,mul3:1b0,s:0b0,X,Y,Z,P,E2,E3,E4,E5],
An : A0,
Q : max(abs(A0-x), abs(A0-y), abs(A0-z), abs(A0-p)) / tolRD,
while Q >= mul * abs(An) do block([lam,d0,e0],
lam : sqrt(x0)*sqrt(y0) + sqrt(y0)*sqrt(z0) + sqrt(z0)*sqrt(x0),
d0 : (sqrt(p0)+sqrt(x0)) * (sqrt(p0)+sqrt(y0)) * (sqrt(p0)+sqrt(z0)),
e0 : delta/(mul3 * d0^2),
s : s + rc(1b0, 1b0 + e0)/(mul * d0),
An : (An + lam)/4,
x0 : (x0 + lam)/4,
y0 : (y0 + lam)/4,
z0 : (z0 + lam)/4,
p0 : (p0 + lam)/4,
mul : 4*mul,
mul3 : 64*mul3),
X : (A0 - x) / (mul * An),
Y : (A0 - y) / (mul * An),
Z : (A0 - z) / (mul * An),
P : -(X + Y + Z) / 2,
E2 : X*Y + X*Z + Y*Z - 3*P*P,
E3 : X*Y*Z + 2*P * (E2 + 2*P*P),
E4 : (2*X*Y*Z + P * (E2 + 3*P*P)) * P,
E5 : X*Y*Z*P*P,
((471240 - 540540 * E2) * E5 +
(612612 * E2 - 540540 * E3 - 556920) * E4 +
E3 * (306306 * E3 + E2 * (675675 * E2 - 706860) + 680680) +
E2 * ((417690 - 255255 * E2) * E2 - 875160) + 4084080) /
(4084080 * mul * An * sqrt(An)) + 6 * s)$
rd(x, y, z) := block([A0:(x + y + 3*z)/5,An,Q,x0:x,y0:y,z0:z,
mul:1b0,s:0b0,X,Y,Z,E2,E3,E4,E5],
An : A0,
Q : max(abs(A0-x), abs(A0-y), abs(A0-z)) / tolRD,
while Q >= mul * abs(An) do block([lam],
lam : sqrt(x0)*sqrt(y0) + sqrt(y0)*sqrt(z0) + sqrt(z0)*sqrt(x0),
s : s + 1/(mul * sqrt(z0) * (z0 + lam)),
An : (An + lam)/4,
x0 : (x0 + lam)/4,
y0 : (y0 + lam)/4,
z0 : (z0 + lam)/4,
mul : 4*mul),
X : (A0 - x) / (mul * An),
Y : (A0 - y) / (mul * An),
Z : -(X + Y) / 3,
E2 : X*Y - 6*Z*Z,
E3 : (3*X*Y - 8*Z*Z)*Z,
E4 : 3 * (X*Y - Z*Z) * Z*Z,
E5 : X*Y*Z*Z*Z,
((471240 - 540540 * E2) * E5 +
(612612 * E2 - 540540 * E3 - 556920) * E4 +
E3 * (306306 * E3 + E2 * (675675 * E2 - 706860) + 680680) +
E2 * ((417690 - 255255 * E2) * E2 - 875160) + 4084080) /
(4084080 * mul * An * sqrt(An)) + 3 * s)$
rc(x, y):=if x < y then atan(sqrt((y - x) / x)) / sqrt(y - x)
else ( if x = y and y > 0b0 then 1 / sqrt(y) else
atanh( if y > 0b0 then sqrt((x - y) / x)
else sqrt(x / (x - y)) ) / sqrt(x - y) )$
/* k^2 = m */
ec(k2):=2*rg0(1b0-k2,1b0)$
kc(k2):=rf(0b0,1b0-k2,1b0)$
dc(k2):=rd(0b0,1b0-k2,1b0)/3$
pic(k2,alpha2):=if alpha2 # 0b0 then
kc(k2)+alpha2*rj(0b0,1b0-k2,1b0,1b0-alpha2)/3
else kc(k2)$
gc(k2,alpha2):=if alpha2 # 0b0 then (if k2 # 1b0 then
kc(k2) + (alpha2-k2)*rj(0b0,1b0-k2,1b0,1b0-alpha2)/3
else rc(1b0,1b0-alpha2))
else ec(k2)$
hc(k2,alpha2):=if alpha2 # 0b0 then (if k2 # 1b0 then
kc(k2) - (1b0-alpha2)*rj(0b0,1b0-k2,1b0,1b0-alpha2)/3
else rc(1b0,1b0-alpha2))
else kc(k2) - dc(k2)$
/* Implementation of methods given in
Roland Bulirsch
Numerical Calculation of Elliptic Integrals and Elliptic Functions
Numericshe Mathematik 7, 78-90 (1965)
*/
sncndn(x,mc):=block([bo, a, b, c, d, l, sn, cn, dn, m, n],
local(m, n),
if mc # 0 then (
bo:is(mc < 0b0),
if bo then (
d:1-mc,
mc:-mc/d,
d:sqrt(d),
x:d*x),
dn:a:1,
for i:0 thru 12 do (
l:i,
m[i]:a,
n[i]:mc:sqrt(mc),
c:(a+mc)/2,
if abs(a-mc)<=tolJAC*a then return(false),
mc:a*mc,
a:c
),
x:c*x,
sn:sin(x),
cn:cos(x),
if sn#0b0 then (
a:cn/sn,
c:a*c,
for i:l step -1 thru 0 do (
b:m[i],
a:c*a,
c:dn*c,
dn:(n[i]+a)/(b+a),
a:c/b
),
a:1/sqrt(c*c+1b0),
sn:if sn<0b0 then -a else a,
cn:c*sn
),
if bo then (
a:dn,
dn:cn,
cn:a,
sn:sn/d
)
) else /* mc = 0 */ (
sn:tanh(x),
dn:cn:sech(x)
/* d:exp(x), a:1/d, b:a+d, cn:dn:2/b,
if x < 0.3b0 then (
d:x*x*x*x,
d:(d*(d*(d*(d+93024b0)+3047466240b0)+24135932620800b0)+
20274183401472000b0)/60822550204416000b0,
sn:cn*(x*x*x*d+sin(x))
) else
sn:(d-a)/b */
),
[sn,cn,dn]
)$
Delta(sn, k2):=sqrt(1 - k2 * sn*sn)$
/* Versions of incomplete functions in terms of Jacobi elliptic function
with u = am(phi) real and in [0,K(k2)] */
eirx(sn,cn,dn,k2,ec):=block([t,cn2:cn*cn,dn2:dn*dn,sn2:sn*sn,ei,kp2:1b0-k2],
ei : (if k2 <= 0b0 then
rf(cn2, dn2, 1b0) - k2 * sn2 * rd(cn2, dn2, 1b0) / 3 else
(if kp2 >= 0b0 then
kp2 * rf(cn2, dn2, 1b0) +
k2 * kp2 * sn2 * rd(cn2, 1b0, dn2) / 3 +
k2 * abs(cn) / dn else
- kp2 * sn2 * rd(dn2, 1b0, cn2) / 3 + dn / abs(cn) ) ),
ei : ei * abs(sn),
if cn < 0b0 then ei : 2 * ec - ei,
if sn < 0 then ei : -ei,
ei)$
dirx(sn, cn, dn, k2, dc):=block(
[di:abs(sn) * sn*sn * rd(cn*cn, dn*dn, 1b0) / 3],
if cn < 0b0 then di : 2 * dc - di,
if sn < 0b0 then di : -di,
di)$
hirx(sn, cn, dn, k2, alpha2, hc):=block(
[cn2 : cn*cn, dn2 : dn*dn, sn2 : sn*sn, hi, alphap2:1b0-alpha2],
hi : abs(sn) * (rf(cn2, dn2, 1b0) -
alphap2 * sn2 *
rj(cn2, dn2, 1b0, cn2 + alphap2 * sn2) / 3),
if cn < 0 then hi : 2 * hc - hi,
if sn < 0 then hi : -hi,
hi)$
deltae(sn, cn, dn, k2, ec):=(
if cn < 0 then (cn : -cn, sn : -sn),
eirx(sn, cn, dn, k2, ec) * (pi/2) / ec - atan2x(sn, cn))$
deltad(sn, cn, dn, k2, dc):=(
if cn < 0 then (cn : -cn, sn : -sn),
dirx(sn, cn, dn, k2, ec) * (pi/2) / dc - atan2x(sn, cn))$
deltah(sn, cn, dn, k2, alpha2, hc):=(
if cn < 0 then (cn : -cn, sn : -sn),
hirx(sn, cn, dn, k2, alpha2, hc) * (pi/2) / hc - atan2x(sn, cn))$
einv(x, k2, ec):=block(
[n : floor(x / (2 * ec) + 0.5b0), phi, eps : k2/(sqrt(1b0-k2) + 1b0)^2,
err:1b0],
x : x - 2 * ec * n,
phi : pi * x / (2 * ec),
phi : phi - eps * sin(2 * phi) / 2,
while abs(err) > tolJAC do block([sn:sin(phi), cn:cos(phi), dn],
dn : Delta(sn, k2),
err : (eirx(sn, cn, dn, k2, ec) - x)/dn,
phi : phi - err),
n * pi + phi)$
deltaeinv(stau, ctau, k2, ec) := block([tau],
if ctau < 0 then (ctau : -ctau, stau : -stau),
tau : atan2x(stau, ctau),
einv(tau * ec / (pi/2), k2, ec) - tau)$

138
libs/geographiclib/maxima/gearea.mac Normal file
View File

@@ -0,0 +1,138 @@
/*
Compute the series expansion for the great ellipse area.
Copyright (c) Charles Karney (2014) <charles@karney.com> and licensed
under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
Area of great ellipse quad
area from equator to phi
dA = dlambda*b^2*sin(phi)/2*
(1/(1-e^2*sin(phi)^2) + atanh(e*sin(phi))/(e*sin(phi)))
Total area = 2*pi*(a^2 + b^2*atanh(e)/e)
convert to beta using
sin(phi)^2 = sin(beta)^2/(1-e^2*cos(beta)^2)
dA = dlambda*sin(beta)/2*
( a^2*sqrt(1-e^2*cos(beta)^2)
+ b^2*atanh(e*sin(beta)/sqrt(1-e^2*cos(beta)^2))
/(e*sin(beta))) )
subst for great ellipse
sin(beta) = cos(gamma0)*sin(sigma)
dlambda = dsigma * sin(gamma0) / (1 - cos(gamma0)^2*sin(sigma)^2)
(1-e^2*cos(beta)^2) = (1-e^2)*(1+k^2*sin(sigma)^2)
k^2 = ep^2*cos(gamma0)^2
e*sin(beta) = sqrt(1-e^2)*k*sin(sigma)
dA = dsigma*sin(gamma0)*cos(gamma0)*sin(sigma)/2*e^2*a^2*sqrt(1+ep^2)*
( (1+k^2*sin(sigma)^2)
+ atanh(k*sin(sigma)/sqrt(1+k^2*sin(sigma)^2)) / (k*sin(sigma))) )
/ (ep^2 - k^2*sin(sigma)^2)
Spherical case radius c, c^2 = a^2/2 + b^2/2*atanh(e)/e
dA0 = dsigma*sin(gamma0)*cos(gamma0)*sin(sigma)/2*
( a^2 + b^2*atanh(e)/e)
/ (1 - cos(gamma0)^2*sin(sigma)^2)
= dsigma*sin(gamma0)*cos(gamma0)*sin(sigma)/2*e^2*a^2*sqrt(1+ep^2)
( sqrt(1+ep^2) + atanh(ep/sqrt(1+ep^2))/ep )
/ (ep^2 - k^2*sin(sigma)^2)
dA-dA0 = dsigma*sin(gamma0)*cos(gamma0)*sin(sigma)/2*e^2*a^2*sqrt(1+ep^2)*
-( ( sqrt(1+ep^2)
+ atanh(ep/sqrt(1+ep^2))/ep ) -
( sqrt(1+k^2*sin(sigma)^2)
+ atanh(k*sin(sigma)/sqrt(1+k^2*sin(sigma)^2)) / (k*sin(sigma)) ) ) /
/ (ep^2 - k^2*sin(sigma)^2)
atanh(y/sqrt(1+y^2)) = asinh(y)
dA-dA0 = dsigma*sin(gamma0)*cos(gamma0)*sin(sigma)/2*e^2*a^2*
- ( ( sqrt(1+ep^2) + asinh(ep)/ep ) -
( sqrt(1+k^2*sin(sigma)^2)
+ asinh(k*sin(sigma)) / (k*sin(sigma)) ) ) /
/ (ep^2 - k^2*sin(sigma)^2)
r(x) = sqrt(1+x) + asinh(sqrt(x))/sqrt(x)
dA-dA0 = e^2*a^2*dsigma*sin(gamma0)*cos(gamma0)*
- ( r(ep^2) - r(k^2*sin(sigma)^2)) /
( ep^2 - k^2*sin(sigma)^2 ) *
sin(sigma)/2*sqrt(1+ep^2)*
subst
ep^2=4*n/(1-n)^2 -- second eccentricity in terms of third flattening
ellipse semi axes = [a, a * sqrt(1-e^2*cos(gamma0)^2)]
third flattening for ellipsoid
eps = (1 - sqrt(1-e^2*cos(gamma0)^2)) / (1 + sqrt(1-e^2*cos(gamma0)^2))
e^2*cos(gamma0)^2 = 4*eps/(1+eps)^2 -- 1st ecc in terms of 3rd flattening
k2=((1+n)/(1-n))^2 * 4*eps/(1+eps)^2
Taylor expand in n and eps, integrate, trigreduce
*/
taylordepth:5$
jtaylor(expr,var1,var2,ord):=block([zz],expand(subst([zz=1],
ratdisrep(taylor(subst([var1=zz*var1,var2=zz*var2],expr),zz,0,ord)))))$
/* Great ellipse via r */
computeG4(maxpow):=block([int,r,intexp,area, x,ep2,k2],
maxpow:maxpow-1,
r : sqrt(1+x) + asinh(sqrt(x))/sqrt(x),
int:-(rf(ep2) - rf(k2*sin(sigma)^2)) / (ep2 - k2*sin(sigma)^2)
* sin(sigma)/2*sqrt(1+ep2),
int:subst([rf(ep2)=subst([x=ep2],r),
rf(k2*sin(sigma)^2)=subst([x=k2*sin(sigma)^2],r)],
int),
int:subst([abs(sin(sigma))=sin(sigma)],int),
int:subst([k2=((1+n)/(1-n))^2 * 4*eps/(1+eps)^2,ep2=4*n/(1-n)^2],int),
intexp:jtaylor(int,n,eps,maxpow),
area:trigreduce(integrate(intexp,sigma)),
area:expand(area-subst(sigma=%pi/2,area)),
for i:0 thru maxpow do G4[i]:coeff(area,cos((2*i+1)*sigma)),
if expand(area-sum(G4[i]*cos((2*i+1)*sigma),i,0,maxpow)) # 0
then error("left over terms in G4"),
'done)$
codeG4(maxpow):=block([tab1:" ",nn:maxpow,c],
c:0,
for m:0 thru nn-1 do block(
[q:jtaylor(G4[m],n,eps,nn-1), linel:1200],
for j:m thru nn-1 do (
print(concat(tab1,"G4x(",c,"+1) = ",
string(horner(coeff(q,eps,j))),";")),
c:c+1)
),
'done)$
dispG4(ord):=(ord:ord-1,for i:0 thru ord do
block([tt:jtaylor(G4[i],n,eps,ord),
ttt,t4,linel:1200],
for j:i thru ord do (
ttt:coeff(tt,eps,j),
if ttt # 0 then block([a:taylor(ttt+n^(ord+1),n,0,ord+1),paren,s],
paren : is(length(a) > 2),
s:if j = i then concat("G4[",i,"] = ") else " ",
if subst([n=1],part(a,1)) > 0 then s:concat(s,"+ ")
else (s:concat(s,"- "), a:-a),
if paren then s:concat(s,"("),
for k:1 thru length(a)-1 do block([term:part(a,k),nn],
nn:subst([n=1],term),
term:term/nn,
if nn > 0 and k > 1 then s:concat(s," + ")
else if nn < 0 then (s:concat(s," - "), nn:-nn),
if lopow(term,n) = 0 then s:concat(s,string(nn))
else (
if nn # 1 then s:concat(s,string(nn)," * "),
s:concat(s,string(term))
)),
if paren then s:concat(s,")"),
if j>0 then s:concat(s," * ", string(eps^j)),
print(concat(s,if j = ord then ";" else ""))))))$
maxpow:6$
(computeG4(maxpow),
print(""),
codeG4(maxpow),
print(""),
dispG4(maxpow))$

609
libs/geographiclib/maxima/geod.mac Normal file
View File

@@ -0,0 +1,609 @@
/*
Compute the series expansions for the ellipsoidal geodesic problem.
Copyright (c) Charles Karney (2009-2015) <charles@karney.com> and
licensed under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
References:
Charles F. F. Karney,
Algorithms for geodesics, J. Geodesy 87, 43-55 (2013),
https://doi.org/10.1007/s00190-012-0578-z
Addenda: https://geographiclib.sourceforge.io/geod-addenda.html
There are 4 sections in this file
(1) Functions to compute the expansions
(2) Functions to print C++ code
(3) Functions to display the results
(4) Calls to the above.
Edit the section at the end, to modify what is done. As distributed
this code computes the 8th order series. This takes about 10 secs. If
you want to compute accurate geodesics using geodesic.mac, then you need
alse to uncomment the last line of this file so that the series get
saved as geodNN.lsp.
To run the code, start Maxima and enter
load("geod.mac")$
*/
/* EXPANSIONS FOR INTEGRALS */
taylordepth:5$
ataylor(expr,var,ord):=expand(ratdisrep(taylor(expr,var,0,ord)))$
jtaylor(expr,var1,var2,ord):=block([zz],expand(subst([zz=1],
ratdisrep(taylor(subst([var1=zz*var1,var2=zz*var2],expr),zz,0,ord)))))$
/*
Express
I1 = integrate( sqrt(1+k2*sin(sigma1)^2), sigma1, 0, sigma )
as a series
A1 * ( sigma + sum(C1[l] * sin(2*l*sigma), l, 1, maxpow) )
valid for k2 small. It is convenient to write k2 = 4 * eps / (1 - eps)^2
and to expand (1 - eps) * I1 retaining terms up to order eps^maxpow
in A1 and C1[l]. This leads to a series where half the terms drop out.
*/
computeI1(maxpow):=block([sintegrand,sintegrandexp,s,sigma,tau1,k2,eps],
sintegrand:sqrt(1+k2*sin(sigma)^2),
/* Multiplicative factor 1/(1-eps) */
sintegrandexp:ataylor(
(1-eps)*subst([k2=4*eps/(1-eps)^2],sintegrand),
eps,maxpow),
s:trigreduce(integrate(sintegrandexp,sigma)),
s:s-subst(sigma=0,s),
A1:expand(subst(sigma=2*%pi,s)/(2*%pi)),
tau1:ataylor(s/A1,eps,maxpow),
for i:1 thru maxpow do C1[i]:coeff(tau1,sin(2*i*sigma)),
if expand(tau1-sigma-sum(C1[i]*sin(2*i*sigma),i,1,maxpow)) # 0
then error("left over terms in B1"),
A1:A1/(1-eps),
'done)$
/*
Write
tau1 = sigma + sum(C1[l] * sin(2*l*sigma), l, 1, maxpow)
and revert this to obtain
sigma = tau1 + sum(C1p[l] * sin(2*tau1), l, 1, maxpow)
retaining terms up to order eps^maxpow in tp[l].
Write
tau = sigma + B1(sigma)
sigma = tau + B1p(tau)
B1(sigma) = sum(C1[l] * sin(2*l*sigma), l, 1, inf)
B1p(tau) = sum(C1p[l] * sin(2*tau), l, 1, inf)
Then the Lagrange Inversion Theorem
J. L. Lagrange, Nouvelle methode pour resoudre les equations
litterales par le moyen des series, Mem. de l'Acad. Roy. des Sciences
de Berlin 24, 251-326 (1768, publ. 1770), Sec. 16,
https://books.google.com/books?id=YywPAAAAIAAJ&pg=PA25
gives
B1p(tau) = sum( (-1)^n/n! * diff( B1(tau)^n, tau, n-1 ),
n, 1, inf)
Call this after computeI1(maxpow)$
*/
revertI1(maxpow):=block([tau,eps,tauacc:1,sigacc:0],
for n:1 thru maxpow do (
tauacc:trigreduce(ataylor(
-sum(C1[j]*sin(2*j*tau),j,1,maxpow-n+1)*tauacc/n,
eps,maxpow)),
sigacc:sigacc+expand(diff(tauacc,tau,n-1))),
for i:1 thru maxpow do C1p[i]:coeff(sigacc,sin(2*i*tau)),
if expand(sigacc-sum(C1p[i]*sin(2*i*tau),i,1,maxpow)) # 0
then error("left over terms in B1p"),
'done)$
/*
Express
I2 = integrate( 1/sqrt(1+k2*sin(sigma1)^2), sigma1, 0, sigma )
as a series
A2 * ( sigma + sum(C2[l] * sin(2*l*sigma), l, 1, maxpow) )
valid for k2 small. It is convenient to write k2 = 4 * eps / (1 - eps)^2
and to expand 1/(1 - eps) * I2 retaining terms up to order eps^maxpow
in A2 and C2[l]. This leads to a series where half the terms drop out.
*/
computeI2(maxpow):=block([sintegrand,sintegrandexp,s,sigma,tau1,k2,eps],
sintegrand:1/sqrt(1+k2*sin(sigma)^2),
/* Multiplicative factor 1/(1+eps) */
sintegrandexp:ataylor(
(1+eps)*subst([k2=4*eps/(1-eps)^2],sintegrand),
eps,maxpow),
s:trigreduce(integrate(sintegrandexp,sigma)),
s:s-subst(sigma=0,s),
A2:expand(subst(sigma=2*%pi,s)/(2*%pi)),
tau1:ataylor(s/A2,eps,maxpow),
for i:1 thru maxpow do C2[i]:coeff(tau1,sin(2*i*sigma)),
if expand(tau1-sigma-sum(C2[i]*sin(2*i*sigma),i,1,maxpow)) # 0
then error("left over terms in B2"),
A2:A2/(1+eps),
'done)$
/*
Express
I3 = integrate( (2-f)/(1+(1-f)*sqrt(1+k2*sin(sigma1)^2)), sigma1, 0, sigma )
as a series
A3 * ( sigma + sum(C3[l] * sin(2*l*sigma), l, 1, maxpow-1) )
valid for f and k2 small. It is convenient to write k2 = 4 * eps / (1 -
eps)^2 and f = 2*n/(1+n) and expand in eps and n. This procedure leads
to a series where the coefficients of eps^j are terminating series in n.
*/
computeI3(maxpow):=block([int,intexp,dlam,eta,del,eps,nu,f,z,n],
maxpow:maxpow-1,
int:subst([k2=4*eps/(1-eps)^2],
(2-f)/(1+(1-f)*sqrt(1+k2*sin(sigma)^2))),
int:subst([f=2*n/(1+n)],int),
intexp:jtaylor(int,n,eps,maxpow),
dlam:trigreduce(integrate(intexp,sigma)),
dlam:dlam-subst(sigma=0,dlam),
A3:expand(subst(sigma=2*%pi,dlam)/(2*%pi)),
eta:jtaylor(dlam/A3,n,eps,maxpow),
A3:jtaylor(A3,n,eps,maxpow),
for i:1 thru maxpow do C3[i]:coeff(eta,sin(2*i*sigma)),
if expand(eta-sigma-sum(C3[i]*sin(2*i*sigma),i,1,maxpow)) # 0
then error("left over terms in B3"),
'done)$
/*
Express
I4 = -integrate( (t(ep2) - t(k2*sin(sigma1)^2)) / (ep2 - k2*sin(sigma1)^2)
* sin(sigma1)/2, sigma1, pi/2, sigma )
where
t(x) = sqrt(1+1/x)*asinh(sqrt(x)) + x
as a series
sum(C4[l] * cos((2*l+1)*sigma), l, 0, maxpow-1) )
valid for ep2 and k2 small. It is convenient to write k2 = 4 * eps /
(1 - eps)^2 and ep2 = 4 * n / (1 - n)^2 and to expand in eps and n.
This procedure leads to a series which converges even for very
eccentric ellipsoids.
*/
computeI4(maxpow):=block([int,t,intexp,area, x,ep2,k2],
maxpow:maxpow-1,
t : sqrt(1+1/x) * asinh(sqrt(x)) + x,
int:-(tf(ep2) - tf(k2*sin(sigma)^2)) / (ep2 - k2*sin(sigma)^2)
* sin(sigma)/2,
int:subst([tf(ep2)=subst([x=ep2],t),
tf(k2*sin(sigma)^2)=subst([x=k2*sin(sigma)^2],t)],
int),
int:subst([abs(sin(sigma))=sin(sigma)],int),
int:subst([k2=4*eps/(1-eps)^2,ep2=4*n/(1-n)^2],int),
int:subst([abs(eps-1)=1-eps,abs(n-1)=1-n],int),
intexp:jtaylor(int,n,eps,maxpow),
area:trigreduce(integrate(intexp,sigma)),
area:expand(area-subst(sigma=%pi/2,area)),
for i:0 thru maxpow do C4[i]:coeff(area,cos((2*i+1)*sigma)),
if expand(area-sum(C4[i]*cos((2*i+1)*sigma),i,0,maxpow)) # 0
then error("left over terms in I4"),
'done)$
/* Call all of the above */
computeall():=(
computeI1(maxpow), revertI1(maxpow),
computeI2(maxpow), computeI3(maxpow), computeI4(maxpow))$
/* FORMAT FOR C++ */
/* If nA1, nC1, nC1p, nA2, nA3, nC3 are compile-time constants
indicating the required order, the compiler will include only the needed
code. */
codeA1(maxpow):=block([tab2:" ",tab3:" "],
print(" // The scale factor A1-1 = mean value of (d/dsigma)I1 - 1
Math::real Geodesic::A1m1f(real eps) {
real
eps2 = Math::sq(eps),
t;
switch (nA1_/2) {"),
for n:0 thru entier(maxpow/2) do block([
q:horner(ataylor(subst([eps=sqrt(eps2)],A1*(1-eps)-1),eps2,n)),
linel:1200],
print(concat(tab2,"case ",string(n),":")),
print(concat(tab3,"t = ",string(q),";")),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nA1_ >= ",string(0),
" && nA1_ <= ",string(maxpow),", \"Bad value of nA1_\");")),
print(concat(tab3,"t = 0;")),
print(" }
return (t + eps) / (1 - eps);
}"),
'done)$
codeC1(maxpow):=block([tab2:" ",tab3:" "],
print(" // The coefficients C1[l] in the Fourier expansion of B1
void Geodesic::C1f(real eps, real c[]) {
real
eps2 = Math::sq(eps),
d = eps;
switch (nC1_) {"),
for n:0 thru maxpow do (
print(concat(tab2,"case ",string(n),":")),
for m:1 thru n do block([q:d*horner(
subst([eps=sqrt(eps2)],ataylor(C1[m],eps,n)/eps^m)),
linel:1200],
if m>1 then print(concat(tab3,"d *= eps;")),
print(concat(tab3,"c[",string(m),"] = ",string(q),";"))),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nC1_ >= ",string(0),
" && nC1_ <= ",string(maxpow),", \"Bad value of nC1_\");")),
print(" }
}"),
'done)$
codeC1p(maxpow):=block([tab2:" ",tab3:" "],
print(" // The coefficients C1p[l] in the Fourier expansion of B1p
void Geodesic::C1pf(real eps, real c[]) {
real
eps2 = Math::sq(eps),
d = eps;
switch (nC1p_) {"),
for n:0 thru maxpow do (
print(concat(tab2,"case ",string(n),":")),
for m:1 thru n do block([q:d*horner(
subst([eps=sqrt(eps2)],ataylor(C1p[m],eps,n)/eps^m)),
linel:1200],
if m>1 then print(concat(tab3,"d *= eps;")),
print(concat(tab3,"c[",string(m),"] = ",string(q),";"))),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nC1p_ >= ",string(0),
" && nC1p_ <= ",string(maxpow),", \"Bad value of nC1p_\");")),
print(" }
}"),
'done)$
codeA2(maxpow):=block([tab2:" ",tab3:" "],
print(" // The scale factor A2-1 = mean value of (d/dsigma)I2 - 1
Math::real Geodesic::A2m1f(real eps) {
real
eps2 = Math::sq(eps),
t;
switch (nA2_/2) {"),
for n:0 thru entier(maxpow/2) do block([
q:horner(ataylor(subst([eps=sqrt(eps2)],A2*(1+eps)-1),eps2,n)),
linel:1200],
print(concat(tab2,"case ",string(n),":")),
print(concat(tab3,"t = ",string(q),";")),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nA2_ >= ",string(0),
" && nA2_ <= ",string(maxpow),", \"Bad value of nA2_\");")),
print(concat(tab3,"t = 0;")),
print(" }
return (t - eps) / (1 + eps);
}"),
'done)$
codeC2(maxpow):=block([tab2:" ",tab3:" "],
print(" // The coefficients C2[l] in the Fourier expansion of B2
void Geodesic::C2f(real eps, real c[]) {
real
eps2 = Math::sq(eps),
d = eps;
switch (nC2_) {"),
for n:0 thru maxpow do (
print(concat(tab2,"case ",string(n),":")),
for m:1 thru n do block([q:d*horner(
subst([eps=sqrt(eps2)],ataylor(C2[m],eps,n)/eps^m)),
linel:1200],
if m>1 then print(concat(tab3,"d *= eps;")),
print(concat(tab3,"c[",string(m),"] = ",string(q),";"))),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nC2_ >= ",string(0),
" && nC2_ <= ",string(maxpow),", \"Bad value of nC2_\");")),
print(" }
}"),
'done)$
codeA3(maxpow):=block([tab2:" ",tab3:" "],
print(" // The scale factor A3 = mean value of (d/dsigma)I3
void Geodesic::A3coeff() {
switch (nA3_) {"),
for nn:0 thru maxpow do block(
[q:if nn=0 then 0 else
jtaylor(subst([n=_n],A3),_n,eps,nn-1),
linel:1200],
print(concat(tab2,"case ",string(nn),":")),
for i : 0 thru nn-1 do
print(concat(tab3,"_A3x[",i,"] = ",
string(horner(coeff(q,eps,i))),";")),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nA3_ >= ",string(0),
" && nA3_ <= ",string(maxpow),", \"Bad value of nA3_\");")),
print(" }
}"),
'done)$
codeC3(maxpow):=block([tab2:" ",tab3:" "],
print(" // The coefficients C3[l] in the Fourier expansion of B3
void Geodesic::C3coeff() {
switch (nC3_) {"),
for nn:0 thru maxpow do block([c],
print(concat(tab2,"case ",string(nn),":")),
c:0,
for m:1 thru nn-1 do block(
[q:if nn = 0 then 0 else
jtaylor(subst([n=_n],C3[m]),_n,eps,nn-1),
linel:1200],
for j:m thru nn-1 do (
print(concat(tab3,"_C3x[",c,"] = ",
string(horner(coeff(q,eps,j))),";")),
c:c+1)
),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nC3_ >= ",string(0),
" && nC3_ <= ",string(maxpow),", \"Bad value of nC3_\");")),
print(" }
}"),
'done)$
codeC4(maxpow):=block([tab2:" ",tab3:" "],
print(" // The coefficients C4[l] in the Fourier expansion of I4
void Geodesic::C4coeff() {
switch (nC4_) {"),
for nn:0 thru maxpow do block([c],
print(concat(tab2,"case ",string(nn),":")),
c:0,
for m:0 thru nn-1 do block(
[q:jtaylor(subst([n=_n],C4[m]),_n,eps,nn-1),
linel:1200],
for j:m thru nn-1 do (
print(concat(tab3,"_C4x[",c,"] = ",
string(horner(coeff(q,eps,j))),";")),
c:c+1)
),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"static_assert(nC4_ >= ",string(0),
" && nC4_ <= ",string(maxpow),", \"Bad value of nC4_\");")),
print(" }
}"),
'done)$
printcode():=(
print(""),
print(concat(" // Generated by Maxima on ",timedate())),
print(""),
codeA1(maxpow),
print(""),
codeC1(maxpow),
print(""),
codeC1p(maxpow),
print(""),
codeA2(maxpow),
print(""),
codeC2(maxpow),
print(""),
codeA3(maxpow),
print(""),
codeC3(maxpow),
print(""),
codeC4(maxpow))$
/* FORMAT FOR DISPLAY */
dispA1(ord):=block(
[tt:ataylor(A1*(1-eps),eps,ord),ttt,linel:1200],
for j:2 step 2 thru ord do (ttt:coeff(tt,eps,j),
print(concat(if j = 2 then "A1 = (1 " else " ",
if ttt>0 then "+ " else "- ",
string(abs(ttt)), " * ", string(eps^j),
if j=ord or j = ord-1 then ") / (1 - eps);" else ""))))$
dispC1(ord):=for i:1 thru ord do
block([tt:ataylor(C1[i],eps,ord),ttt,linel:1200],
print(),
for j:i step 2 thru ord do (ttt:coeff(tt,eps,j), print(concat(
if j = i then concat("C1[",string(i),"] = ") else " ",
if ttt>0 then "+ " else "- ",
string(abs(ttt)), " * ", string(eps^j),
if j=ord or j=ord-1 then ";" else ""))))$
dispC1p(ord):=for i:1 thru ord do
block([tt:ataylor(C1p[i],eps,ord),ttt,linel:1200],
print(),
for j:i step 2 thru ord do (ttt:coeff(tt,eps,j), print(concat(
if j = i then concat("C1p[",string(i),"] = ") else " ",
if ttt>0 then "+ " else "- ",
string(abs(ttt)), " * ", string(eps^j),
if j=ord or j=ord-1 then ";" else ""))))$
dispA2(ord):=block(
[tt:ataylor(A2*(1+eps),eps,ord),ttt,linel:1200],
for j:2 step 2 thru ord do (ttt:coeff(tt,eps,j),
print(concat(if j = 2 then "A2 = (1 " else " ",
if ttt>0 then "+ " else "- ",
string(abs(ttt)), " * ", string(eps^j),
if j=ord or j = ord-1 then ") / (1 + eps);" else ""))))$
dispC2(ord):=for i:1 thru ord do
block([tt:ataylor(C2[i],eps,ord),ttt,linel:1200],
print(),
for j:i step 2 thru ord do (ttt:coeff(tt,eps,j), print(concat(
if j = i then concat("C2[",string(i),"] = ") else " ",
if ttt>0 then "+ " else "- ",
string(abs(ttt)), " * ", string(eps^j),
if j=ord or j=ord-1 then ";" else ""))))$
dispA3(ord):=(ord:ord-1,block(
[tt:jtaylor(A3,n,eps,ord),ttt,t4,linel:1200,s],
for j:1 thru ord do (ttt:expand(coeff(tt,eps,j)),
if ttt # 0 then block([a:taylor(ttt+n^(ord+1),n,0,ord+1),paren,s],
paren : is(length(a) > 2),
s:if j=1 then "A3 = 1" else " ",
if subst([n=1],part(a,1)) > 0 then s:concat(s," + ")
else (s:concat(s," - "), a:-a),
if paren then s:concat(s,"("),
for k:1 thru length(a)-1 do block([term:part(a,k),nn],
nn:subst([n=1],term),
term:term/nn,
if nn > 0 and k > 1 then s:concat(s," + ")
else if nn < 0 then (s:concat(s," - "), nn:-nn),
if lopow(term,n) = 0 then s:concat(s,string(nn))
else (
if nn # 1 then s:concat(s,string(nn)," * "),
s:concat(s,string(term))
)),
if paren then s:concat(s,")"),
s:concat(s," * ", string(eps^j)),
print(concat(s,if j = ord then ";" else ""))))))$
dispC3(ord):=(ord:ord-1,for i:1 thru ord do
block([tt:jtaylor(C3[i],eps,n,ord),
ttt,t4,linel:1200],
for j:i thru ord do (
ttt:coeff(tt,eps,j),
if ttt # 0 then block([a:taylor(ttt+n^(ord+1),n,0,ord+1),paren,s],
paren : is(length(a) > 2),
s:if j = i then concat("C3[",i,"] = ") else " ",
if subst([n=1],part(a,1)) > 0 then s:concat(s,"+ ")
else (s:concat(s,"- "), a:-a),
if paren then s:concat(s,"("),
for k:1 thru length(a)-1 do block([term:part(a,k),nn],
nn:subst([n=1],term),
term:term/nn,
if nn > 0 and k > 1 then s:concat(s," + ")
else if nn < 0 then (s:concat(s," - "), nn:-nn),
if lopow(term,n) = 0 then s:concat(s,string(nn))
else (
if nn # 1 then s:concat(s,string(nn)," * "),
s:concat(s,string(term))
)),
if paren then s:concat(s,")"),
s:concat(s," * ", string(eps^j)),
print(concat(s,if j = ord then ";" else ""))))))$
dispC4(ord):=(ord:ord-1,for i:0 thru ord do
block([tt:jtaylor(C4[i],n,eps,ord),
ttt,t4,linel:1200],
for j:i thru ord do (
ttt:coeff(tt,eps,j),
if ttt # 0 then block([a:taylor(ttt+n^(ord+1),n,0,ord+1),paren,s],
paren : is(length(a) > 2),
s:if j = i then concat("C4[",i,"] = ") else " ",
if subst([n=1],part(a,1)) > 0 then s:concat(s,"+ ")
else (s:concat(s,"- "), a:-a),
if paren then s:concat(s,"("),
for k:1 thru length(a)-1 do block([term:part(a,k),nn],
nn:subst([n=1],term),
term:term/nn,
if nn > 0 and k > 1 then s:concat(s," + ")
else if nn < 0 then (s:concat(s," - "), nn:-nn),
if lopow(term,n) = 0 then s:concat(s,string(nn))
else (
if nn # 1 then s:concat(s,string(nn)," * "),
s:concat(s,string(term))
)),
if paren then s:concat(s,")"),
if j>0 then s:concat(s," * ", string(eps^j)),
print(concat(s,if j = ord then ";" else ""))))))$
dispseries():=(
print(""),
print(concat("// Generated by Maxima on ",timedate())),
print(""),
dispA1(maxpow),
print(""),
dispC1(maxpow),
print(""),
dispC1p(maxpow),
print(""),
dispA2(maxpow),
print(""),
dispC2(maxpow),
print(""),
dispA3(maxpow),
print(""),
dispC3(maxpow),
print(""),
dispC4(maxpow),
print(""))$
/* CALL THE FUNCTIONS */
/* Timings for computeall(n)
n time(s)
8 8
10 19
12 43
20 571
30 6671 (111m)
For computeI4(n)
n time(s)
8 1.5
16 29
24 215
30 702 = 11.7 m
32 1040 = 17.3 m
40 3851
48 11521
64 69960 = 19.4 h
*/
maxpow:8$
computeall()$
/* printcode()$ */
dispseries()$
load("polyprint.mac")$
printgeod():= block([macro:if simplenum then "GEOGRAPHICLIB_GEODESIC_ORDER"
else "GEOGRAPHICLIB_GEODESICEXACT_ORDER"],
value1('(A1*(1-eps)-1),'eps,2,0),
array1('C1,'eps,2,0),
array1('C1p,'eps,2,0),
value1('(A2*(1+eps)-1),'eps,2,0),
array1('C2,eps,2,0),
value2('A3,'n,'eps,1),
array2('C3,'n,'eps,1),
array2('C4,'n,'eps,1))$
printgeod()$
/* Save the values needed for geodesic.mac This is commented out
here to avoid accidentally overwriting files in a user's directory. */
/* (file:concat("geod",maxpow,".lsp"), save(file, values, arrays))$ */

1209
libs/geographiclib/maxima/geodesic.mac Normal file
View File

File diff suppressed because it is too large Load Diff

146
libs/geographiclib/maxima/polyprint.mac Normal file
View File

@@ -0,0 +1,146 @@
/* Print out the coefficients for the geodesic series in a format that
allows Math::polyval to be used. */
taylordepth:5$
simplenum:true$
count:0$
jtaylor(expr,var1,var2,ord):=expand(subst([zz=1],
ratdisrep(taylor(subst([var1=zz*var1,var2=zz*var2],expr),zz,0,ord))))$
h(x):=if x=0 then 0 else block([n:0],while not(oddp(x)) do (x:x/2,n:n+1),n);
decorhex(x):=if x=0 then "0" else if abs(x)<10^12 then string(x)
else concat(if x<0 then "-" else "",
"0x",block([obase:16,s],
s:sdowncase(string(abs(x))),
if substring(s,1,2) = "0" then s:substring(s,2),
s))$
formatnum(x):=block([n,neg:is(x<0),s1,s2,ll],x:abs(x),n:h(x),
ll:if x<2^31 then "" else "LL",
s1:concat(if neg then "-" else "", decorhex(x), ll),
s2:concat(if neg then "-(" else "", decorhex(x/2^n), ll, "<<", n,
if neg then ")" else ""),
if slength(s2) < slength(s1) then s2 else s1)$
formatnumx(x):=if simplenum then
concat(string(x),if abs(x) < 2^31 then "" else "LL") else
if abs(x)<2^63 then (if abs(x) < 2^24
/* test used to be: abs(x)/2^h(abs(x)) < 2^24; but Visual Studio
complains about truncation of __int64 to real even if trailing bits
are zero */
then formatnum(x)
else concat(s:if x<0 then "-" else "","real(",formatnum(abs(x)),")"))
else
block([sb:if x<0 then "-reale(" else "reale(",se:")"], x:abs(x),
se:concat(formatnum(x-floor(x/2^52)*2^52),se),x:floor(x/2^52),
while x > 0 do (
se:concat(formatnum(x-floor(x/2^52)*2^52),",",se),x:floor(x/2^52)),
concat(sb,se))$
printterm(x,line):=block([lx:slength(x)+1,lline:slength(line)],
count:count+1,
x:concat(x,if simplenum then ", " else ","),
if lline=0 then line:concat(" ",x)
else (if lx+lline<80 then line:concat(line,x)
else (print(line),line:concat(" ",x))),
line)$
flushline(line):=(if slength(line)>0 then (print(line),line:""),line)$
polyprint(p, var, title):=block([linel:90,d,line:"",h],
p:ratsimp(p),
d:abs(denom(p)),
p:expand(d*p),
h:hipow(p,var),
print(concat(" // ", title, ", polynomial in ", var, " of order ",h)),
for k:h step -1 thru 0 do
line:printterm(formatnumx(coeff(p,var,k)),line),
line:printterm(formatnumx(d),line),
flushline(line),
done)$
value1(val,var,pow,dord):=block([tab2:" ",linel:90,div],
print(concat(tab2,"// Generated by Maxima on ",timedate())),
div:if pow = 1 then "" else concat("/",pow),
for nn:0 step pow thru maxpow do block([c],
if nn = 0 then
print(concat("#if ", macro, div, " == ",nn/pow))
else
print(concat("#elif ", macro, div, " == ",nn/pow)),
count:0,
print(concat(tab2,"static const real coeff[] = {")),
block(
[q:ratdisrep(taylor(ev(val),var,0,nn-dord)),line:""],
if pow = 2 then (
q:subst(var=sqrt(concat(var,2)),expand(q)),
polyprint(q,concat(var,2),string(val)))
else (polyprint(q,var,string(val))),
line:flushline(line)),
print(concat(tab2,"}; // count = ",count))),
print("#else
#error", concat("\"Bad value for ", macro, "\""), "
#endif
"),
'done)$
array1(array,var,pow,dord):=block([tab2:" ",linel:90],
print(concat(tab2,"// Generated by Maxima on ",timedate())),
for nn:0 thru maxpow do block([c],
if nn = 0 then
print(concat("#if ", macro, " == ",nn))
else
print(concat("#elif ", macro, " == ",nn)),
count:0,
print(concat(tab2,"static const real coeff[] = {")),
for m:0 thru nn do if part(arrayapply(array,[m]),0) # array then block(
[q:ratdisrep(taylor(arrayapply(array,[m]),var,0,nn-dord)),line:""],
if pow = 2 then (
q:subst(var=sqrt(concat(var,2)),expand(q/var^(m-dord))),
polyprint(q,concat(var,2),concat(array, "[", m, "]/",var,"^",m-dord)))
else (
q:expand(q/var^(m-dord)),
polyprint(q,var,concat(array, "[", m, "]/",var,"^",m-dord))),
line:flushline(line)),
print(concat(tab2,"}; // count = ",count))),
print("#else
#error", concat("\"Bad value for ", macro, "\""), "
#endif
"),
'done)$
value2(val,var1,var2,dord):=block([tab2:" ",linel:90],
print(concat(tab2,"// Generated by Maxima on ",timedate())),
for nn:0 thru maxpow do block([c],
if nn = 0 then
print(concat("#if ", macro, " == ",nn))
else
print(concat("#elif ", macro, " == ",nn)),
count:0,
print(concat(tab2,"static const real coeff[] = {")),
block(
[q:jtaylor(ev(val),n,eps,nn-dord),line:""],
for j:nn-dord step -1 thru 0 do block(
[p:coeff(q,var2,j)],
polyprint(p,var1,concat(val, ", coeff of eps^",j))),
line:flushline(line)),
print(concat(tab2,"}; // count = ",count))),
print("#else
#error", concat("\"Bad value for ", macro, "\""), "
#endif
"),
'done)$
array2(array,var1,var2,dord):=block([tab2:" ",linel:90],
print(concat(tab2,"// Generated by Maxima on ",timedate())),
for nn:0 thru maxpow do block([c],
if nn = 0 then
print(concat("#if ", macro, " == ",nn))
else
print(concat("#elif ", macro, " == ",nn)),
count:0,
print(concat(tab2,"static const real coeff[] = {")),
for m:0 thru nn-1 do if part(arrayapply(array,[m]),0) # array then block(
[q:jtaylor(arrayapply(array,[m]),n,eps,nn-dord),line:""],
for j:nn-dord step -1 thru m do block(
[p:coeff(q,var2,j)],
polyprint(p,var1,concat(array, "[", m ,"], coeff of eps^",j))),
line:flushline(line)),
print(concat(tab2,"}; // count = ",count))),
print("#else
#error", concat("\"Bad value for ", macro, "\""), "
#endif
"),
'done)$

202
libs/geographiclib/maxima/rhumbarea.mac Normal file
View File

@@ -0,0 +1,202 @@
/*
Compute the series expansion for the rhumb area.
Copyright (c) Charles Karney (2014) <charles@karney.com> and licensed
under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
Instructions: edit the value of maxpow near the end of this file. Then
load the file into maxima.
Area of rhumb quad
dA = c^2 sin(xi) * dlambda
c = authalic radius
xi = authalic latitude
Express sin(xi) in terms of chi and expand for small n
this can be written in terms of powers of sin(chi)
Subst sin(chi) = tanh(psi) = tanh(m*lambda)
Integrate over lambda to give
A = c^2 * S(chi)/m
S(chi) = log(sec(chi)) + sum(R[i]*cos(2*i*chi),i,0,maxpow)
R[0] = + 1/3 * n
- 16/45 * n^2
+ 131/945 * n^3
+ 691/56700 * n^4
R[1] = - 1/3 * n
+ 22/45 * n^2
- 356/945 * n^3
+ 1772/14175 * n^4;
R[2] = - 2/15 * n^2
+ 106/315 * n^3
- 1747/4725 * n^4;
R[3] = - 31/315 * n^3
+ 104/315 * n^4;
R[4] = - 41/420 * n^4;
i=0 term is just the integration const so can be dropped. However
including this terms gives S(0) = 0.
Evaluate A between limits lam1 and lam2 gives
A = c^2 * (lam2 - lam1) *
(S(chi2) - S(chi1)) / (atanh(sin(chi2)) - atanh(sin(chi1)))
In limit chi2 -> chi, chi1 -> chi
diff(atanh(sin(chi)),chi) = sec(chi)
diff(log(sec(chi)),chi) = tan(chi)
c^2 * (lam2 - lam1) * [
(1-R[1]) * sin(chi)
- (R[1]+2*R[2]) * sin(3*chi)
- (2*R[2]+3*R[3]) * sin(5*chi)
- (3*R[3]+4*R[4]) * sin(7*chi)
...
]
which is expansion of c^2 * (lam2 - lam1) * sin(xi) in terms of sin(chi)
Note:
limit chi->0 = 0
limit chi->pi/2 = c^2 * (lam2-lam1)
Express in terms of psi
A = c^2 * (lam2 - lam1) *
(S(chi(psi2)) - S(chi(psi2))) / (psi2 - psi1)
sum(R[i]*cos(2*i*chi),i,0,maxpow) = sum(sin(chi),cos(chi))
S(chi(psi)) = log(cosh(psi)) + sum(tanh(psi),sech(psi))
(S(chi(psi2)) - S(chi(psi2))) / (psi2 - psi1)
= Dlog(cosh(psi1),cosh(psi2)) * Dcosh(psi1,psi2)
+ Dsum(chi1,chi2) * Dgd(psi1,psi2)
*/
reverta(expr,var1,var2,eps,pow):=block([tauacc:1,sigacc:0,dsig],
dsig:ratdisrep(taylor(expr-var1,eps,0,pow)),
dsig:subst([var1=var2],dsig),
for n:1 thru pow do (tauacc:trigreduce(ratdisrep(taylor(
-dsig*tauacc/n,eps,0,pow))),
sigacc:sigacc+expand(diff(tauacc,var2,n-1))),
var2+sigacc)$
/* chi in terms of phi -- from auxlat.mac*/
chi_phi(maxpow):=block([psiv,tanchi,chiv,qq,e,atanexp,x,eps],
/* Here qq = atanh(sin(phi)) = asinh(tan(phi)) */
psiv:qq-e*atanh(e*tanh(qq)),
psiv:subst([e=sqrt(4*n/(1+n)^2),qq=atanh(sin(phi))],
ratdisrep(taylor(psiv,e,0,2*maxpow)))
+asinh(sin(phi)/cos(phi))-atanh(sin(phi)),
tanchi:subst([abs(cos(phi))=cos(phi),sqrt(sin(phi)^2+cos(phi)^2)=1],
ratdisrep(taylor(sinh(psiv),n,0,maxpow)))+tan(phi)-sin(phi)/cos(phi),
atanexp:ratdisrep(taylor(atan(x+eps),eps,0,maxpow)),
chiv:subst([x=tan(phi),eps=tanchi-tan(phi)],atanexp),
chiv:subst([atan(tan(phi))=phi,
tan(phi)=sin(phi)/cos(phi)],
(chiv-phi)/cos(phi))*cos(phi)+phi,
chiv:ratdisrep(taylor(chiv,n,0,maxpow)),
expand(trigreduce(chiv)))$
/* phi in terms of chi -- from auxlat.mac */
phi_chi(maxpow):=reverta(chi_phi(maxpow),phi,chi,n,maxpow)$
/* xi in terms of phi */
xi_phi(maxpow):=block([sinxi,asinexp,x,eps,v],
sinxi:(sin(phi)/2*(1/(1-e^2*sin(phi)^2) + atanh(e*sin(phi))/(e*sin(phi))))/
(1/2*(1/(1-e^2) + atanh(e)/e)),
sinxi:ratdisrep(taylor(sinxi,e,0,2*maxpow)),
sinxi:subst([e=2*sqrt(n)/(1+n)],sinxi),
sinxi:expand(trigreduce(ratdisrep(taylor(sinxi,n,0,maxpow)))),
asinexp:sqrt(1-x^2)*
sum(ratsimp(diff(asin(x),x,i)/i!/sqrt(1-x^2))*eps^i,i,0,maxpow),
v:subst([x=sin(phi),eps=sinxi-sin(phi)],asinexp),
v:taylor(subst([sqrt(1-sin(phi)^2)=cos(phi),asin(sin(phi))=phi],
v),n,0,maxpow),
v:expand(ratdisrep(coeff(v,n,0))+sum(
ratsimp(trigreduce(sin(phi)*ratsimp(
subst([sin(phi)=sqrt(1-cos(phi)^2)],
ratsimp(trigexpand(ratdisrep(coeff(v,n,i)))/sin(phi))))))
*n^i,
i,1,maxpow)))$
xi_chi(maxpow):=
expand(trigreduce(taylor(subst([phi=phi_chi(maxpow)],xi_phi(maxpow)),
n,0,maxpow)))$
computeR(maxpow):=block([xichi,xxn,inttanh,yy,m,yyi,yyj,s],
local(inttanh),
xichi:xi_chi(maxpow),
xxn:expand(subst([cos(chi)=sqrt(1-sin(chi)^2)],
trigexpand(taylor(sin(xichi),n,0,maxpow)))),
/* integrals of tanh(x)^l. Use tanh(x)^2 + sech(x)^2 = 1. */
inttanh[0](x):=x, /* Not needed -- only odd l occurs in this problem */
inttanh[1](x):=log(cosh(x)),
inttanh[l](x):=inttanh[l-2](x) - tanh(x)^(l-1)/(l-1),
yy:subst([sin(chi)=tanh(m*lambda)],xxn),
/*
psi = atanh(sin(chi)) = m*lambda
sin(chi)=tanh(m*lambda)
sech(m*lambda) = sqrt(1-tanh(m*lambda))^2 = cos(chi)
cosh(m*lambda) = sec(chi)
m=(atanh(sin(chi2))-atanh(sin(chi1)))/(lam2-lam1)
*/
yyi:block([v:yy/m,ii],
local(ii),
for j:2*maxpow+1 step -2 thru 1 do
v:subst([tanh(m*lambda)^j=ii[j](m*lambda)],v),
for j:2*maxpow+1 step -2 thru 1 do
v:subst([ii[j](m*lambda)=inttanh[j](m*lambda)],v),
expand(v)),
yyj:expand(m*trigreduce(
subst([tanh(m*lambda)=sin(chi),cosh(m*lambda)=sec(chi)],yyi)))/
( (atanh(sin(chi2))-atanh(sin(chi1)))/(lam2-lam1) ),
s:( (atanh(sin(chi2))-atanh(sin(chi1)))/(lam2-lam1) )*yyj-log(sec(chi)),
for i:1 thru maxpow do R[i]:coeff(s,cos(2*i*chi)),
R[0]:s-expand(sum(R[i]*cos(2*i*chi),i,1,maxpow)),
if expand(s-sum(R[i]*cos(2*i*chi),i,0,maxpow)) # 0 then
error("Left over terms in R"),
if expand(trigreduce(expand(
diff(sum(R[i]*cos(2*i*chi),i,0,maxpow),chi)*cos(chi)+sin(chi))))-
expand(trigreduce(expand(xxn))) # 0 then
error("Derivative error in R"),
'done)$
ataylor(expr,var,ord):=expand(ratdisrep(taylor(expr,var,0,ord)))$
dispR(ord):=for i:1 thru ord do
block([tt:ataylor(R[i],n,ord),ttt,linel:1200],
print(),
for j:max(i,1) step 1 thru ord do (ttt:coeff(tt,n,j), print(concat(
if j = max(i,1) then concat("R[",string(i),"] = ") else " ",
if ttt<0 then "- " else "+ ",
string(abs(ttt)), " * ", string(n^j),
if j=ord then ";" else ""))))$
codeR(minpow,maxpow):=block([tab2:" ",tab3:" "],
print(" // The coefficients R[l] in the Fourier expansion of rhumb area
real nx = n;
switch (maxpow_) {"),
for k:minpow thru maxpow do (
print(concat(tab2,"case ",string(k),":")),
for m:1 thru k do block([q:nx*horner(
ataylor(R[m],n,k)/n^m),
linel:1200],
if m>1 then print(concat(tab3,"nx *= n;")),
print(concat(tab3,"c[",string(m),"] = ",string(q),";"))),
print(concat(tab3,"break;"))),
print(concat(tab2,"default:")),
print(concat(tab3,"GEOGRAPHICLIB_STATIC_ASSERT(maxpow_ >= ",string(minpow),
" && maxpow_ <= ",string(maxpow),", \"Bad value of maxpow_\");")),
print(" }"),
'done)$
maxpow:8$
computeR(maxpow)$
dispR(maxpow)$
/* codeR(4,maxpow)$ */
load("polyprint.mac")$
printrhumb():=block([macro:GEOGRAPHICLIB_RHUMBAREA_ORDER],
array1('R,'n,1,0))$
printrhumb()$

399
libs/geographiclib/maxima/tm.mac Normal file
View File

@@ -0,0 +1,399 @@
/*
Arbitrary precision Transverse Mercator Projection
Copyright (c) Charles Karney (2009-2017) <charles@karney.com> and
licensed under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
Reference:
Charles F. F. Karney,
Transverse Mercator with an accuracy of a few nanometers,
J. Geodesy 85(8), 475-485 (Aug. 2011).
DOI 10.1007/s00190-011-0445-3
preprint https://arxiv.org/abs/1002.1417
resource page https://geographiclib.sourceforge.io/tm.html
The parameters for the transformation are set by
setparams(a,f,k0)$
sets the equatorial radius, inverse flattening, and central scale
factor. The default is
setparams(6378137b0, 1/298.257223563b0, 0.9996b0)$
appropriate for UTM applications.
tm(lat,lon);
takes lat and lon args (in degrees) and returns
[x, y, convergence, scale]
[x, y] do not include false eastings/northings but do include the
scale factor k0. convergence is in degrees.
ll(x,y);
takes x and y args (in meters) and returns
[lat, lon, convergence, scale].
Example:
$ maxima
Maxima 5.15.0 http://maxima.sourceforge.net
Using Lisp CLISP 2.43 (2007-11-18)
Distributed under the GNU Public License. See the file COPYING.
Dedicated to the memory of William Schelter.
The function bug_report() provides bug reporting information.
(%i1) load("tm.mac")$
(%i2) tm(10b0,20b0);
(%o2) [2.235209504622466691587930831718465965864199221939781808953597771095103\
6690000464b6, 1.17529734503138466792126931904154130080533935727351398258511134\
68541970512119385b6, 3.6194756227592979778565787394402350354250845160819430786\
093514889500602612857052b0, 1.062074627142564335518604915718789933200854739344\
8664109599248189291146283796933b0]
(%i3) ll(%[1],%[2]);
(%o3) [1.0b1, 2.0b1, 3.6194756227592979778565787394402350354250845160819430786\
093514889500602612857053b0, 1.062074627142564335518604915718789933200854739344\
8664109599248189291146283796933b0]
(%i4) float(%o2);
(%o4) [2235209.504622467, 1175297.345031385, 3.619475622759298,
1.062074627142564]
(%i5) float(%o3);
(%o5) [10.0, 20.0, 3.619475622759298, 1.062074627142564]
This implements GeographicLib::TransverseMercatorExact (i.e., Lee, 1976)
using bfloats. However fewer changes from Lee 1976 have been made since
we rely more heavily on the high precision to deal with problem cases.
To change the precision, change fpprec below and reload.
*/
fpprec:80$
load("ellint.mac")$ /* Load elliptic functions */
tol:0.1b0^fpprec$
tol1:0.1b0*sqrt(tol)$ /* For Newton's method */
tol2:sqrt(0.01*tol*tol1)$ /* Also for Newton's method but more conservative */
ahypover:log(10b0^fpprec)+2$
pi:bfloat(%pi)$
degree:pi/180$
ratprint:false$
debugprint:false$
setparams(a1,f1,k1):=(a:bfloat(a1),f:bfloat(f1),k0:bfloat(k1),
e2:f*(2-f),
e:sqrt(e2),
kcu:kc(e2),
kcv:kc(1-e2),
ecu:ec(e2),
ecv:ec(1-e2),
n:f/(2-f),
'done)$
setparams(6378137b0, 1/298.257223563b0, 0.9996b0)$ /* WGS 84 */
/* setparams(6378388b0, 1/297b0, 0.9996b0)$ International */
/* setparams(1/ec(0.01b0), 1/(30*sqrt(11b0)+100), 1b0)$ testing, eps = 0.1*/
/*
Interpret x_y(y) as x <- y, i.e., "transform quantity y to quantity x"
Let
phi = geodetic latitude
psi = isometric latitude ( + i * lambda )
sigma = TM coords
thom = Thompson coords
*/
/* sqrt(x^2 + y^2) -- Real only */
hypot(x,y):=sqrt(x^2 + y^2)$
/* log(1 + x) -- Real only */
log1p(x) := block([y : 1b0+x],
if y = 1b0 then x else x*log(y)/(y - 1))$
/* Real only */
/* Some versions of Maxima have a buggy atanh
atnh(x) := block([y : abs(x)],
y : log1p(2 * y/(1 - y))/2,
if x < 0 then -y else y)$ */
atnh(x) := atanh(x)$
/* exp(x)-1 -- Real only */
expm1(x) := block([y : exp(bfloat(x)),z],
z : y - 1b0,
if abs(x) > 1b0 then z else if z = 0b0 then x else x * z/log(y))$
/* Real only */
/* Some versions of Maxima have a buggy sinh */
snh(x) := block([u : expm1(x)],
(u / (u + 1)) * (u + 2) /2);
/* Real only */
psi_phi(phi):=block([s:sin(phi)],
asinh(s/max(cos(phi),0.1b0*tol)) - e * atnh(e * s))$
/* Real only */
phi_psi(psi):=block([q:psi,t,dq],
for i do (
t:tanh(q),
dq : -(q - e * atnh(e * t) - psi) * (1 - e2 * t^2) / (1 - e2),
q : q + dq,
if debugprint then print(float(q), float(dq)),
if abs(dq) < tol1 then return(false)),
atan(snh(q)))$
psi_thom_comb(w):=block([jacr:sncndn(bfloat(realpart(w)),1-e2),
jaci:sncndn(bfloat(imagpart(w)),e2),d,d1,d2],
d:(1-e2)*(jaci[2]^2 + e2 * (jacr[1] * jaci[1])^2)^2,
d1:sqrt(jacr[2]^2 + (1-e2) * (jacr[1] * jaci[1])^2),
d2:sqrt(e2 * jacr[2]^2 + (1-e2) * jaci[2]^2),
[
(if d1 > 0b0 then asinh(jacr[1]*jaci[3]/ d1) else signnum(snu) * ahypover)
- (if d2 > 0b0 then e * asinh(e * jacr[1] / d2) else signnum(snu) * ahypover)
+ %i * (if d1 > 0b0 and d2 > 0b0 then
atan2(jacr[3]*jaci[1],jacr[2]*jaci[2])
- e * atan2(e*jacr[2]*jaci[1],jacr[3]*jaci[2]) else 0),
jacr[2]*jacr[3]*jaci[3]*(jaci[2]^2-e2*(jacr[1]*jaci[1])^2)/d
-%i * jacr[1]*jaci[1]*jaci[2]*((jacr[3]*jaci[3])^2+e2*jacr[2]^2)/d]
)$
psi_thom(w):=block([tt:psi_thom_comb(w)],tt[1])$
inv_diff_psi_thom(w):=block([tt:psi_thom_comb(w)],tt[2])$
w0a(psi):=block([lam:bfloat(imagpart(psi)),psia:bfloat(realpart(psi))],
rectform(kcu/(pi/2)*( atan2(snh(psia),cos(lam))
+%i*asinh(sin(lam)/sqrt(cos(lam)^2 + snh(psia)^2)))))$
w0c(psi):=block([m,a,dlam],
dlam:bfloat(imagpart(psi))-pi/2*(1-e),
psi:bfloat(realpart(psi)),
m:sqrt(psi^2+dlam^2)*3/(1-e2)/e,
a:if m = 0b0 then 0 else atan2(dlam-psi, psi+dlam) - 0.75b0*pi,
m:m^(1/3), a:a/3,
m*cos(a)+%i*(m*sin(a)+kcv))$
w0d(psi):=block([psir:-realpart(psi)/e+1b0,lam:(pi/2-imagpart(psi))/e,uu,vv],
uu:asinh(sin(lam)/sqrt(cos(lam)^2+snh(psir)^2))*(1+e2/2),
vv:atan2(cos(lam), snh(psir)) *(1+e2/2),
(-uu+kcu) + %i * (-vv+kcv))$
w0m(psi):=if realpart(psi)<-e/2*pi/2 and
imagpart(psi)>pi/2*(1-2*e) and
realpart(psi) < imagpart(psi)-(pi/2*(1-e)) then w0d(psi) else
if realpart(psi)<e*pi/2 and imagpart(psi)>pi/2*(1-2*e)
then w0c(psi) else w0a(psi)$
w0(psi):=w0m(psi)$
thom_psi(psi):=block([w:w0(psi),dw,v,vv],
if not(abs(psi-pi/2*(1-e)*%i) < e * tol^0.6b0) then
for i do (
if i > 100 then error("too many iterations"),
vv:psi_thom_comb(w),
v:vv[1],
dw:-rectform((v-psi)*vv[2]),
w:w+dw,
dw:abs(dw),
if debugprint then print(float(w),float(dw)),
/* error is approx dw^2/2 */
if dw < tol2 then return(false)
),
w
)$
sigma_thom_comb(w):=block([u:bfloat(realpart(w)),v:bfloat(imagpart(w)),
jacr,jaci,phi,iu,iv,den,den1,er,ei,dnr,dni],
jacr:sncndn(u,1-e2),jaci:sncndn(v,e2),
er:eirx(jacr[1],jacr[2],jacr[3],e2,ecu),
ei:eirx(jaci[1],jaci[2],jaci[3],1-e2,ecv),
den:e2*jacr[2]^2+(1-e2)*jaci[2]^2,
den1:(1-e2)*(jaci[2]^2 + e2 * (jacr[1] * jaci[1])^2)^2,
dnr:jacr[3]*jaci[2]*jaci[3],
dni:-e2*jacr[1]*jacr[2]*jaci[1],
[ er - e2*jacr[1]*jacr[2]*jacr[3]/den
+ %i*(v - ei + (1-e2)*jaci[1]*jaci[2]*jaci[3]/den),
(dnr^2-dni^2)/den1 + %i * 2*dnr*dni/den1])$
sigma_thom(w):=block([tt:sigma_thom_comb(w)],tt[1])$
inv_diff_sigma_thom(w):=block([tt:sigma_thom_comb(w)],tt[2])$
wx0a(sigma):=rectform(sigma*kcu/ecu)$
wx0b(sigma):=block([m,aa],
sigma:rectform(sigma-%i*(kcv-ecv)),
m:abs(sigma)*3/(1-e2),
aa:atan2(imagpart(sigma),realpart(sigma)),
if aa<-pi/2 then aa:aa+2*pi,
aa:aa-pi,
rectform(m^(1/3)*(cos(aa/3b0)+%i*sin(aa/3b0))+%i*kcv))$
wx0c(sigma):=rectform(1/(sigma-(ecu+%i*(kcv-ecv))) + kcu+%i*kcv)$
wx0m(sigma):=block([eta:bfloat(imagpart(sigma)),
xi:bfloat(realpart(sigma))],
if eta > 1.25b0 * (kcv-ecv) or (xi < -0.25*ecu and xi < eta-(kcv-ecv)) then
wx0c(sigma) else
if (eta > 0.75b0 * (kcv-ecv) and xi < 0.25b0 * ecu) or
eta > kcv-ecv or xi < 0 then wx0b(sigma) else wx0a(sigma))$
wx0(sigma):=wx0m(sigma)$
thom_sigma(sigma):=block([w:wx0(sigma),dw,v,vv],
for i do (
if i > 100 then error("too many iterations"),
vv:sigma_thom_comb(w),
v:vv[1],
dw:-rectform((v-sigma)*vv[2]),
w:w+dw,
dw:abs(dw),
if debugprint then print(float(w),float(dw)),
/* error is approx dw^2/2 */
if dw < tol2 then return(false)
),
w
)$
/* Lee/Thompson's method forward */
tm(phi,lam):=block([psi,thom,jacr,jaci,sigma,gam,scale,c],
phi:phi*degree,
lam:lam*degree,
psi:psi_phi(phi),
thom:thom_psi(psi+%i*lam),
jacr:sncndn(bfloat(realpart(thom)),1-e2),
jaci:sncndn(bfloat(imagpart(thom)),e2),
sigma:sigma_thom(thom),
c:cos(phi),
if c > tol1 then (
gam:atan2((1-e2)*jacr[1]*jaci[1]*jaci[2],
jacr[2]*jacr[3]*jaci[3]),
scale:sqrt(1-e2 + e2 * c^2)/c*
sqrt(((1-e2)*jaci[1]^2 + (jacr[2]*jaci[3])^2)/
(e2*jacr[2]^2 + (1-e2)*jaci[2]^2)))
else (gam : lam, scale : 1b0),
[imagpart(sigma)*k0*a,realpart(sigma)*k0*a,gam/degree,k0*scale])$
/* Lee/Thompson's method reverse */
ll(x,y):=block([sigma,thom,jacr,jaci,psi,lam,phi,gam,scale,c],
sigma:y/(a*k0)+%i*x/(a*k0),
thom:thom_sigma(sigma),
jacr:sncndn(bfloat(realpart(thom)),1-e2),
jaci:sncndn(bfloat(imagpart(thom)),e2),
psi:psi_thom(thom),
lam:bfloat(imagpart(psi)),
psi:bfloat(realpart(psi)),
phi:phi_psi(psi),
c:cos(phi),
if c > tol1 then (
gam:atan2((1-e2)*jacr[1]*jaci[1]*jaci[2],
jacr[2]*jacr[3]*jaci[3]),
scale:sqrt(1-e2 + e2 * c^2)/c*
sqrt(((1-e2)*jaci[1]^2 + (jacr[2]*jaci[3])^2)/
(e2*jacr[2]^2 + (1-e2)*jaci[2]^2)))
else (gam : lam, scale : 1b0),
[phi/degree,lam/degree,gam/degree,k0*scale])$
/* Return lat/lon/x/y for a point specified in Thompson coords */
/* Pick u in [0, kcu] and v in [0, kcv] */
lltm(u,v):=block([jacr,jaci,psi,lam,phi,c,gam,scale,sigma,x,y],
u:bfloat(u), v:bfloat(v),
jacr:sncndn(u,1-e2),
jaci:sncndn(v,e2),
psi:psi_thom(u+%i*v),
sigma:sigma_thom(u+%i*v),
x:imagpart(sigma)*k0*a,y:realpart(sigma)*k0*a,
lam:bfloat(imagpart(psi)),
psi:bfloat(realpart(psi)),
phi:phi_psi(psi),
c:cos(phi),
if c > tol1 then (
gam:atan2((1-e2)*jacr[1]*jaci[1]*jaci[2],
jacr[2]*jacr[3]*jaci[3]),
scale:sqrt(1-e2 + e2 * c^2)/c*
sqrt(((1-e2)*jaci[1]^2 + (jacr[2]*jaci[3])^2)/
(e2*jacr[2]^2 + (1-e2)*jaci[2]^2)))
else (gam : lam, scale : 1b0),
[phi/degree,lam/degree,x,y,gam/degree,k0*scale])$
/* Gauss-Krueger series to order n^i forward
Uses the array functions
a1_a[i](n), zeta_a[i](z,n), zeta_d[i](z,n), zetap_a[i](s,n), zetap_d[i](s,n),
defined in tmseries.mac.
*/
tms(phi,lam,i):=block([psi,xip,etap,z,sigma,sp,gam,k,b1],
phi:phi*degree,
lam:lam*degree,
psi:psi_phi(phi),
xip:atan2(snh(psi), cos(lam)),
etap:asinh(sin(lam)/hypot(snh(psi),cos(lam))),
k:sqrt(1 - e2*sin(phi)^2)/(cos(phi)*hypot(snh(psi),cos(lam))),
gam:atan(tan(xip)*tanh(etap)),
z:xip+%i*etap,
b1:a1_a[i](n),
sigma:rectform(b1*zeta_a[i](z,n)),
sp:rectform(zeta_d[i](z,n)),
gam : gam - atan2(imagpart(sp),realpart(sp)),
k : k * b1 * cabs(sp),
[imagpart(sigma)*k0*a,realpart(sigma)*k0*a,gam/degree,k*k0])$
/* Gauss-Krueger series to order n^i reverse */
lls(x,y,i):=block([sigma,b1,s,z,zp,xip,etap,s,c,r,gam,k,lam,psi,phi],
sigma:y/(a*k0)+%i*x/(a*k0),
b1:a1_a[i](n),
s:rectform(sigma/b1),
z:rectform(zetap_a[i](s,n)),
zp:rectform(zetap_d[i](s,n)),
gam : atan2(imagpart(zp), realpart(zp)),
k : b1 / cabs(zp),
xip:realpart(z),
etap:imagpart(z),
s:snh(etap),
c:cos(xip),
r:hypot(s, c),
lam:atan2(s, c),
psi : asinh(sin(xip)/r),
phi :phi_psi(psi),
k : k * sqrt(1 - e2*sin(phi)^2) * r/cos(phi),
gam : gam + atan(tan(xip) * tanh(etap)),
[phi/degree,lam/degree,gam/degree,k*k0])$
/* Approx geodesic distance valid for small displacements */
dist(phi0,lam0,phi,lam):=block([dphi,dlam,nn,hlon,hlat],
dphi:(phi-phi0)*degree,
dlam:(lam-lam0)*degree,
phi0:phi0*degree,
lam0:lam0*degree,
nn : 1/sqrt(1 - e2 * sin(phi0)^2),
hlon : cos(phi0) * nn,
hlat : (1 - e2) * nn^3,
a * hypot(dphi*hlat, dlam*hlon))$
/* Compute truncation errors for all truncation levels */
check(phi,lam):=block([vv,x,y,gam,k,vf,vb,errf,errr,err2,errlist],
phi:min(90-0.01b0,phi),
lam:min(90-0.01b0,lam),
vv:tm(phi,lam),
errlist:[],
x:vv[1], y:vv[2], gam:vv[3], k:vv[4],
for i:1 thru maxpow do (
vf:tms(phi,lam,i),
errf:hypot(vf[1]-x,vf[2]-y)/k,
errfg:abs(vf[3]-gam),
errfk:abs((vf[4]-k)/k),
vb:lls(x,y,i),
errr:dist(phi,lam,vb[1],vb[2]),
errrg:abs(vb[3]-gam),
errrk:abs((vb[4]-k)/k),
errlist:append(errlist,
[max(errf, errr), max(errfg, errrg), max(errfk, errrk)])),
errlist)$
/* Max of output of check over a set of points */
checka(lst):=block([errlist:[],errx],
for i:1 thru 3*maxpow do errlist:cons(0b0,errlist),
for vv in lst do (
errx:check(vv[1],vv[2]),
for i:1 thru 3*maxpow do errlist[i]:max(errlist[i],errx[i])),
errlist)$

220
libs/geographiclib/maxima/tmseries.mac Normal file
View File

@@ -0,0 +1,220 @@
/*
Compute series approximations for Transverse Mercator Projection
Copyright (c) Charles Karney (2009-2010) <charles@karney.com> and
licensed under the MIT/X11 License. For more information, see
https://geographiclib.sourceforge.io/
Reference:
Charles F. F. Karney,
Transverse Mercator with an accuracy of a few nanometers,
J. Geodesy 85(8), 475-485 (Aug. 2011).
DOI 10.1007/s00190-011-0445-3
preprint https://arxiv.org/abs/1002.1417
resource page https://geographiclib.sourceforge.io/tm.html
Compute coefficient for forward and inverse trigonometric series for
conversion from conformal latitude to rectifying latitude. This prints
out assignments which with minor editing are suitable for insertion into
C++ code. (N.B. n^3 in the output means n*n*n; 3/5 means 0.6.)
To run, start maxima and enter
writefile("tmseries.out")$
load("tmseries.mac")$
closefile()$
With maxpow = 6, the output (after about 5 secs) is
A=a/(n+1)*(1+n^2/4+n^4/64+n^6/256);
alpha[1]=n/2-2*n^2/3+5*n^3/16+41*n^4/180-127*n^5/288+7891*n^6/37800;
alpha[2]=13*n^2/48-3*n^3/5+557*n^4/1440+281*n^5/630-1983433*n^6/1935360;
alpha[3]=61*n^3/240-103*n^4/140+15061*n^5/26880+167603*n^6/181440;
alpha[4]=49561*n^4/161280-179*n^5/168+6601661*n^6/7257600;
alpha[5]=34729*n^5/80640-3418889*n^6/1995840;
alpha[6]=+212378941*n^6/319334400;
beta[1]=n/2-2*n^2/3+37*n^3/96-n^4/360-81*n^5/512+96199*n^6/604800;
beta[2]=n^2/48+n^3/15-437*n^4/1440+46*n^5/105-1118711*n^6/3870720;
beta[3]=17*n^3/480-37*n^4/840-209*n^5/4480+5569*n^6/90720;
beta[4]=4397*n^4/161280-11*n^5/504-830251*n^6/7257600;
beta[5]=4583*n^5/161280-108847*n^6/3991680;
beta[6]=+20648693*n^6/638668800;
Notation of output matches that of
L. Krueger,
Konforme Abbildung des Erdellipsoids in der Ebene
Royal Prussian Geodetic Institute, New Series 52, 172 pp. (1912).
with gamma replaced by alpha.
Alter maxpow to generate more or less terms for the series
approximations to the forward and reverse projections. This has been
tested out to maxpow = 30; but this takes a long time (see below).
*/
/* Timing:
maxpow time
4 2s
6 5s
8 11s
10 24s
12 52s
20 813s = 14m
30 13535s = 226m
*/
maxpow:8$ /* Max power for forward and reverse projections */
/* Notation
e = eccentricity
e2 = e^2 = f*(2-f)
n = third flattening = f/(2-f)
phi = (complex) geodetic latitude
zetap = Gauss-Schreiber TM = complex conformal latitude
psi = Mercator = complex isometric latitude
zeta = scaled UTM projection = complex rectifying latitude
*/
taylordepth:6$
triginverses:'all$
/*
revert
var2 = expr(var1) = series in eps
to
var1 = revertexpr(var2) = series in eps
Require that expr(var1) = var1 to order eps^0. This throws in a
trigreduce to convert to multiple angle trig functions.
*/
reverta(expr,var1,var2,eps,pow):=block([tauacc:1,sigacc:0,dsig],
dsig:ratdisrep(taylor(expr-var1,eps,0,pow)),
dsig:subst([var1=var2],dsig),
for n:1 thru pow do (tauacc:trigreduce(ratdisrep(taylor(
-dsig*tauacc/n,eps,0,pow))),
sigacc:sigacc+expand(diff(tauacc,var2,n-1))),
var2+sigacc)$
/* Expansion for atan(x+eps) for small eps. Equivalent to
taylor(atan(x + eps), eps, 0, maxpow) but tidied up a bit.
*/
atanexp(x,eps):=''(ratdisrep(taylor(atan(x+eps),eps,0,maxpow)))$
/* Convert from n to e^2 */
e2:4*n/(1+n)^2$
/* zetap in terms of phi. The expansion of
atan(sinh( asinh(tan(phi)) + e * atanh(e * sin(phi)) ))
*/
zetap_phi:block([psiv,tanzetap,zetapv,qq,e],
/* Here qq = atanh(sin(phi)) = asinh(tan(phi)) */
psiv:qq-e*atanh(e*tanh(qq)),
psiv:subst([e=sqrt(e2),qq=atanh(sin(phi))],
ratdisrep(taylor(psiv,e,0,2*maxpow)))
+asinh(sin(phi)/cos(phi))-atanh(sin(phi)),
tanzetap:subst([abs(cos(phi))=cos(phi),sqrt(sin(phi)^2+cos(phi)^2)=1],
ratdisrep(taylor(sinh(psiv),n,0,maxpow)))+tan(phi)-sin(phi)/cos(phi),
zetapv:atanexp(tan(phi),tanzetap-tan(phi)),
zetapv:subst([cos(phi)=sqrt(1-sin(phi)^2),
tan(phi)=sin(phi)/sqrt(1-sin(phi)^2)],
(zetapv-phi)/cos(phi))*cos(phi)+phi,
zetapv:ratdisrep(taylor(zetapv,n,0,maxpow)),
expand(trigreduce(zetapv)))$
/* phi in terms of zetap */
phi_zetap:reverta(zetap_phi,phi,zetap,n,maxpow)$
/* Mean radius of meridian */
a1:expand(integrate(
ratdisrep(taylor((1+n)*(1-e2)/(1-e2*sin(phi)^2)^(3/2),
n,0,maxpow)),
phi, 0, %pi/2)/(%pi/2))/(1+n)$
/* zeta in terms of phi. The expansion of
zeta = pi/(2*a1) * int( (1-e^2)/(1-e^2*sin(phi)^2)^(3/2) )
*/
zeta_phi:block([zetav],
zetav:integrate(trigreduce(ratdisrep(taylor(
(1-e2)/(1-e2*sin(phi)^2)^(3/2)/a1,
n,0,maxpow))),phi),
expand(zetav))$
/* phi in terms of zeta */
phi_zeta:reverta(zeta_phi,phi,zeta,n,maxpow)$
/* zeta in terms of zetap */
/* This is slow. The next version speeds it up a little.
zeta_zetap:expand(trigreduce(ratdisrep(
taylor(subst([phi=phi_zetap],zeta_phi),n,0,maxpow))))$
*/
zeta_zetap:block([phiv:phi_zetap,zetav:expand(zeta_phi),acc:0],
for i:0 thru maxpow do (
phiv:ratdisrep(taylor(phiv,n,0,maxpow-i)),
acc:acc + expand(n^i * trigreduce(ratdisrep(taylor(
subst([phi=phiv],coeff(zetav,n,i)),n,0,maxpow-i))))),
acc)$
/* zetap in terms of zeta */
/* This is slow. The next version speeds it up a little.
zetap_zeta:expand(trigreduce(ratdisrep(
taylor(subst([phi=phi_zeta],zetap_phi),n,0,maxpow))))$
*/
zetap_zeta:block([phiv:phi_zeta,zetapv:expand(zetap_phi),acc:0],
for i:0 thru maxpow do (
phiv:ratdisrep(taylor(phiv,n,0,maxpow-i)),
acc:acc + expand(n^i * trigreduce(ratdisrep(taylor(
subst([phi=phiv],coeff(zetapv,n,i)),n,0,maxpow-i))))),
acc)$
printa1():=block([],
print(concat("A=",string(a/(n+1)),"*(",
string(taylor(a1*(1+n),n,0,maxpow)),");")),
0)$
printtxf():=block([alpha:zeta_zetap,t],
for i:1 thru maxpow do (t:coeff(alpha,sin(2*i*zetap)),
print(concat("alpha[",i,"]=",string(taylor(t,n,0,maxpow)),";")),
alpha:alpha-expand(t*sin(2*i*zetap))),
/* should return zero */
alpha:alpha-zetap)$
printtxr():=block([beta:zetap_zeta,t],
for i:1 thru maxpow do (t:coeff(beta,sin(2*i*zeta)),
print(concat("beta[",i,"]=",string(taylor(-t,n,0,maxpow)),";")),
beta:beta-expand(t*sin(2*i*zeta))),
/* should return zero */
beta:beta-zeta)$
printseries():=[printa1(),printtxf(),printtxr()]$
/* Define array functions which are be read by tm.mac */
defarrayfuns():=block([aa:a1*(1+n),alpha:zeta_zetap,beta:zetap_zeta,t],
for i:1 thru maxpow do (
define(a1_a[i](n),ratdisrep(taylor(aa,n,0,i))/(1+n)),
t:expand(ratdisrep(taylor(alpha,n,0,i))),
define(zeta_a[i](zp,n),
zp+sum(coeff(t,sin(2*k*zetap))*sin(2*k*zp),k,1,i)),
t:diff(t,zetap),
define(zeta_d[i](zp,n),
1+sum(coeff(t,cos(2*k*zetap))*cos(2*k*zp),k,1,i)),
t:expand(ratdisrep(taylor(beta,n,0,i))),
define(zetap_a[i](z,n),
z+sum(coeff(t,sin(2*k*zeta))*sin(2*k*z),k,1,i)),
t:diff(t,zeta),
define(zetap_d[i](z,n),
1+sum(coeff(t,cos(2*k*zeta))*cos(2*k*z),k,1,i))))$
printseries()$
(b1:a1,
for i:1 thru maxpow do (alp[i]:coeff(zeta_zetap,sin(2*i*zetap)),
bet[i]:coeff(expand(-zetap_zeta),sin(2*i*zeta))))$
load("polyprint.mac")$
printtm():=block([macro:GEOGRAPHICLIB_TRANSVERSEMERCATOR_ORDER],
value1('(b1*(1+n)),'n,2,0),
array1('alp,'n,1,0),
array1('bet,'n,1,0))$
printtm()$
/*
defarrayfuns()$
save("tmseries.lsp",maxpow,arrays)$
*/