|
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: 4608 (0x1200)
Types: TextFile
Names: »writegeottx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦bf33d74f6⟧ »iogeofile«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦bf33d74f6⟧ »iogeofile«
└─⟦this⟧
; write_geo_t_tx * page 1 13 09 77, 10.45;
; write_geo_t
; ***********
if listing.yes
char 10 12 10
write_geo_t = set 1 disc
write_geo_t = algol
external integer procedure write_geo_t
______________________________________
_ (kind, z, obs, typedec);
value kind, obs, typedec;
integer kind;
zone z;
long obs;
boolean typedec;
comment
write geo (return) integer
number of characters output
kind (call) integer
kind=1 => output of angles in the interval 0, 2pi
kind=2 => output of angles in the interval -pi, pi
distances are output in the same way indep. of kind
z (call and return) zone for char output
obs (call) long
angle or distance treated according to typedec
typedec (call) boolean
contains type shift 6 + number of decimals
nr type termination
1 degr min sec sexagesimal sx
2 degr min sexagesimal nt
3 degr nonagesimal dg
4 hours min sec tm
5 degr min sec centesimal cc
6 degr min centesimal eu
7 degr centesimal (grads) gr
8 meters (>=1000 km) m_
9 meters (>=1 km and <1000 km) m_
10 meters (< 1 km) m_;
begin
integer type, dec, char, dbfp, chlng, spmask, multmask,
_ signchar, zerochar, t;
long rounding; boolean neg; integer array chstr(1:20);
type := (typedec shift (-6)) extract 6; dec := typedec extract 6;
if type<1 or 10<type then begin type := 8; dec := 6; end;
t := case type of (6, 8, 10 , 7, 6, 8, 10, 6, 6, 6);
if dec>t then dec := t;
\f
comment write_geo_t_tx * page 2 13 09 77, 10.45
0 1 2 3 4 5 6 7 8 9 ;
neg := obs<0 and (type>=8 or kind=2);
if neg then begin obs := -obs; signchar := 45; end else signchar := 32;
dbfp := case type of (7, 5, 3, 6, 7, 5, 3, 8, 6, 3); chlng := dbfp+dec;
spmask := multmask := case type of (
(1 shift 19)+(1 shift 17), (1 shift 19), 0,
(1 shift 20)+(1 shift 18),
(1 shift 19)+(1 shift 17), (1 shift 19), 0,
(1 shift 20)+(1 shift 17), (1 shift 19), 0);
if type>4 then multmask := 0;
rounding := case type of (108 593 741, 6 515 624 461,
390 937 467 654, 1 628 906 115, 35 184 372,
3 518 437 209, 351 843 720 888, obs, obs, obs);
for t := if type<8 then dec else (t-dec) step -1 until 1 do
begin
if t=1 then rounding := rounding+5; rounding := rounding//10;
end;
if type<8 then
begin comment angle action;
obs := obs+rounding; obs := obs shift (-1);
if type<=3 then obs := obs-obs//10
else if type=4 then obs := obs//2+obs//10;
char := chstr(1) := (obs shift (-45)) extract 2;
obs := (obs-((extend char) shift 45)) shift (-2);
multmask := multmask shift 1;
for t := 2 step 1 until chlng do
begin
multmask := multmask shift 1;
obs := obs*(if multmask>=0 then 10 else 6);
char := chstr(t) := (obs shift (-43)) extract 4;
obs := obs-((extend char) shift 43);
end;
end angle action
else
begin comment distance action;
obs := rounding;
for t := chlng step -1 until 1 do
begin
chstr(t) := obs mod 10; obs := obs//10;
end;
end distances;
\f
comment write_geo_t_tx * page 3 13 09 77, 10.45
0 1 2 3 4 5 6 7 8 9 ;
zerochar := 32; dec := 4;
for t := 1 step 1 until chlng do
begin comment writechar into zone;
if t=dbfp+1 then begin outchar(z, 46); dec := dec+1; end;
spmask := spmask shift 1;
if spmask<0 then begin outchar(z, 32); dec := dec+1; end;
char := chstr(t);
if signchar<>0 then
begin comment test for output of sign;
if char>0 or t=dbfp then
begin
outchar(z, signchar); signchar := 0; zerochar := 48;
end;
end test for sign output;
outchar(z, char+zerochar);
end output of digits;
write(z, case type of (<:_sx:>, <:_nt:>, <:_dg:>,
<:_tm:>, <:_cc:>, <:_eu:>, <:_gr:>, <:_m_:>, <:_m_:>, <:_m_:>));
write_geo_t := chlng+dec;
end write geo t;
end
if warning.yes
(mode 0.yes
message write_geo_t not ok
lookup write_geo_t)
▶EOF◀