|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 3072 (0xc00)
Types: TextFile
Names: »marctx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦80900d603⟧ »giprocfile«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦80900d603⟧ »giprocfile«
└─⟦this⟧
; m_arctx * page 1 23 11 77, 14.23;
; m_arc
if listing.yes
char 10 12 10
m_arc = set 1
m_arc = algol
external long procedure m_arc
_____________________________
_ (a, f, mode, B);
value a, f, mode, B;
long a, B;
integer mode;
real f;
comment
The procedure performs computation of
length of meridian at latitude B - mode = 1
latitude when length of meridian is given - mode = 2
Formulas from Kønig/Weise I.97, I.97a
m_arc (return) long
mode = 1 - length of meridian arc in units of '-6 m
mode = 2 - geodetic latitude as geotype variable
a (call) long
semi-diameter in units of '-6
f (call) real
flattening
mode (call) integer
B (call) long
mode = 1 - geodetic latitude as geotype variable
mode = 2 - length of meridian arc in units of '-6 m;
begin
real n1, n2, n3, n4, n5, argm, wr;
array m(0:5);
integer q;
long w, ab, save_B;
boolean neg;
n1:=f/(2 - f);
n2:=n1*n1;
n3:=n2*n1;
n4:=n3*n1;
n5:=n4*n1;
w:=a*f;
ab:=a - w;
ab:=a + ab;
wr:=n2/4 + n4/64;
w:=ab*wr;
ab:=ab + w;
neg:=B < 0;
if neg then B:=-B;
\f
comment m_arctx * page 2 23 11 77, 14.23
0 1 2 3 4 5 6 7 8 9 ;
w := -3.673 205 1035'-6*ab;
ab := ab <* *1 *>
_ + ((ab + 4)//5)*3 <* *1.6 *>
_ - ((ab + 99)//100)*3 <* *1.57 *>
_ + (ab + 1249)//1250 <* *1.0008 *>
_ + w;
case mode of
begin
begin
m(1) := -3*n1/2 + 9*n3/16 - 3*n5/32;
m(2) := 15*n2/16 - 15*n4/32;
m(3) := -35*n3/48 + 105*n5/256;
m(4) := 315*n4/512;
m(5) := -693*n5/1280;
argm:=2*B*rg;
w:=clenshaw(m, 5, argm, 2)/rg;
B:=B + w;
w:=0;
for q:=1 step 1 until 47 do
begin
if B extract 1 = 1 then w:=w + ab;
w:=(w + 1) shift (-1);
B:=B shift (-1);
end;
end;
begin
m(1) := 3*n1/2 - 27*n3/32 + 269*n5/512;
m(2) := 21*n2/16 - 55*n4/32;
m(3) := 151*n3/96 - 417*n5/128;
m(4) := 1097*n4/512;
m(5) := 8011*n5/2560;
w:=0;
save_B:=B;
for q:=1 step 1 until 47 do
begin
B:=B - ab;
if B >= 0 then
w:=w + 1
else
B:=save_B;
w:=w shift 1;
B:=save_B:= B shift 1;
end;
argm:=2*w*rg;
B:=clenshaw(m, 5, argm, 2)/rg;
w:=w + B;
end;
end;
\f
comment m_arctx * page 3 23 11 77, 14.23
0 1 2 3 4 5 6 7 8 9 ;
marc:=if neg then -w else w;
end;
end
if warning.yes
(mode 0.yes
message m_arc not ok
lookup m_arc)
▶EOF◀