|
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: 12288 (0x3000)
Types: TextFile
Names: »rcoordobstx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦787c125fb⟧ »adjprocfile«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦787c125fb⟧ »adjprocfile«
└─⟦this⟧
; r_coord_obs_tx * page 1 14 09 78, 14.40;
; r_coord_obs
; ***********
if listing.yes
char 10 12 10
r_coord_obs = set 1
r_coord_obs = algol
external long procedure r_coord_obs
___________________________________
_ (in, reg_lab, obs_rec);
zone in;
array reg_lab, obs_rec;
comment
r_coord_obs (return, long)
Inputs a record of coordinates ot sam-heights and stores
the ecord in the array obs_rec. The values of r_coord_obs
id obs_kind shift 36 + obstype shift 24 + obs_count shift 12,
however in case of no data a value of 0 is returned, and a
useless call (wrong reg_lab) the value -1 is returned.
incomplete data lines are reported and skipped.
reg_lab (call, array)
an ordinary register label as defined in read_reg_lab.
obs_rec (return, array)
an array holding the data input i a format as follows:
byte type internal name content
2 int lng record-length in bytes
4 int - checksum
5 sh int obs_kind 13 = coord_obs
_ 15 = sam_heights
6 sh int obs_type kind 13 :
_ 1 = 1 coord (height)
_ 2 = 2 coord (geo or recta)
_ 3 = 3 (cartesian)
_ kind 15 :
_ 1 = all zero by default
_ 2 = obs value input
7 sh int obs_count number of stations
8 _ not used
9 sh int (weight) 1 (set by proc)
10 sh int h_state irrelev for obskind 13,
_ 0 = no mean height
_ 1 = mean height input
11 sh int c_tpd typedec of obs
12 sh int h_tpd typedec of mean height
16 long ident identific of rec.
20 long stmw reg_lab(6) =systemword
24 long Hm mean hght for samheights
28 long zl reg_lab(7) = zone etc.
32 real mc mean error sq in m**2
the last fields are of type long, and only the number of
fields needed to hold the coord are used
32+ 4*t station(t) station no. t
32+ 4*obs_count+4*t N_obs(t) 1. coord no. t
32+ 8*obs_count+4*t E_obs(t) 2. coord no. t
32+12*obs_count+4*t H_obs(t) 3. coord no. t
heights input as sam-heights are stored in N_obs;
\f
comment r_coord_obs_tx * page 2 14 09 78, 14.40
0 1 2 3 4 5 6 7 8 9 ;
comment
the length and sum are as for invar/outvar
_
ext. used:
__________
read_hak
read_ident
read_stn
read_geo
m_i_l
nl
sp
_
Prog: Knud Poder, JULY 1978, SEP 1978, MAY 1979, AUG 1979
;
begin
long ST, Hm, ident, Ep;
long array NEH(1:240);
integer obs_kind, obs_type, obs_count,
_ exp_tpd, max_dec, nr_type, h_state,
_ lng, cps, q, r, t, save_udt, impl_obs;
real mc;
boolean c_tpd, h_tpd, tpd, cw_cstm, error,
_ sam_h, sam_coord, sam, c_obs;
integer field lng_f;
long array field station, N_obs, E_obs, H_obs;
boolean field obs_kind_f, obs_type_f, obs_count_f,
_ tpd_f, h_tpd_f, h_state_f, P_f;
real field mc_f;
long field ident_f, stmw_f, Hm_f, zl_f, Ep_f;
\f
_
comment init op;
________________
save_udt := udt;
r_coord_obs := 0;
ident := read_hak(in, tpd);
comment ON TEST: :
write(out, nl, 4, <:ident__:>, ident, sp, 3,
_ <:tpd:>, tpd extract 12,
_ if tpd then <:__true:> else <:__false:>);
comment * page ;
if ident > 0 then
begin
_
comment decode reg_lab;
_______________________
obs_kind := reglab(2) extract 12;
c_obs := obs_kind = 13;
sam_h := obs_kind = 15;
sam_coord := obs_kind = 16;
sam := sam_h or sam_coord;
if c_obs then
<*coord_obs*>
begin
error := false;
t := reg_lab(6) extract 12;
cw_cstm := t <> 5 and -, (t = 8 and long reg_lab(7) < 0);
cps :=
obs_type := if t = 9 then 1
_ else if t<>8 and abs long reg_lab(7)<>3 then 2
_ else 3;
Ep := long reg_lab(9);
exp_tpd := if t <> 2 then 8 else 1;
udt := if t <> 2 then 109 <*m*> else 115 <*s*>;
end
else if sam_h then
<*sam heights*>
begin
error := false;
obs_type := 6; <*modified to 5 if implicit obs*>
cps := 1;
exp_tpd := 8;
udt := 109 <*m*>;
impl_obs := 0;
end
else if sam_coord then
<*sam coord*>
begin
error := false;
obs_type := 2*(reg_lab(5) extract 24);
_ <*reduced by 1 if implicit obs*>
cps := 1;
exp_tpd := if reg_lab(6) extract 12 <> 2 then 8
_ else 1;
udt := if exp_tpd = 8 then 109 <*m*>
_ else 115 <*s*>;
impl_obs := 0;
end
else
<*others*>
begin
error := true;
r_coord_obs := -1;
write(out, nl, 1, <:***skipped obs_kind ;:>);
write_reg_lab(out, reg_lab);
end;
\f
comment r_coord_obs_tx * page 4 14 09 78, 14.40
0 1 2 3 4 5 6 7 8 9 ;
_
comment input and store actions;
________________________________
if -, error then
begin
_
comment mean error;
___________________
<*input unit sx or m if stated else cm assumed*>
mc := read_ident(in, tpd);
if mtr then mc := ('-6*mc)**2
else
begin
for t := tpd extract 12 step -1 until 1 do
mc := mc/10;
if t_char <> 115 <*s*> then
<*store in m**2*>
mc := (mc/100)**2
else
<*store in radians**2*>
mc := (mc/rho)**2;
end -, mtr;
_
comment input mean height;
__________________________
if (if sam then m_i_l(in, true)
_ else false) then
begin
H_m := read_geo(in, h_tpd);
h_state := 1;
end
else
begin
H_m := 0;
h_tpd := false add (8 shift 6 + 3);
h_state := 1;
end;
_
comment fixed field in obs_rec;
______________________________
station := 36;
_
comment clear head of obs_rec;
______________________________
for t := 0 step -1 until -7 do
obs_rec.station(t) := 0;
\f
comment r_coord_obs_tx * page 5 14 09 78, 14.40
0 1 2 3 4 5 6 7 8 9 ;
_
comment input loop;
___________________
max_dec :=
obs_count := 0;
for ST := read_stn(in, nr_type)
_ while ST <> 200 00 0000 shift 19 and ST > 0 do
begin
comment ON TEST: :
write_stn(out, ST + 0*write(out, nl, 1, <:stat_:>));
q := obs_count*cps;
obs_count := obs_count + 1;
obs_rec.station(obs_count) := ST;
error := false;
for t := 1 step 1 until cps do
begin
q := q + 1;
if m_i_l(in, true) then
NEH(q) := read_geo(in, c_tpd)
else if sam then
begin
NEH(q) := 0;
c_tpd := false add (exp_tpd shift 6);
impl_obs := impl_obs + 1;
end
else
begin
error := true;
write(out, nl, 1);
write_stn(out, ST);
write(out, <:__koordinat no._:>, t, <:__mangler:>);
c_tpd := false add (exp_tpd shift 6);
end;
if (c_tpd shift (-6)) extract 6 <> exp_tpd then
begin
error := true;
write(out, nl, 1);
write_stn(out, ST);
write(out, <:__koordinat no. :>, t, sp, 4);
write_geo_c(out, NEH(q), c_tpd);
write(out, <:__inkonsistent:>);
c_tpd := false;
end;
if max_dec < c_tpd extract 6 then
max_dec := c_tpd extract 6;
end t-loop;
if error then obs_count := obs_count - 1;
end ST- loop;
comment ON TEST: :
write_stn(out, ST + write(out, nl, 1, <:slut_:>));
_
comment restore udt;
____________________
udt := save_udt;
\f
comment r_coord_obs_tx * page 6 14 09 78, 14.40
0 1 2 3 4 5 6 7 8 9 ;
_
comment check for implicit sam obs;
___________________________________
if
(if sam then impl_obs = obs_count else false)
then
begin
obs_type := obs_type - 1;
cps := 0;
end;
_
comment fields in obs_rec;
__________________________
lng_f := 2;
obs_kind_f := 5;
obs_type_f := 6;
obs_count_f := 7;
P_f := 9;
h_state_f := 10;
tpd_f := 11;
h_tpd_f := 12;
ident_f := 16;
stmw_f := 20;
Hm_f := 24;
zl_f := 28;
mc_f := 32;
Ep_f := 36;
N_obs := station + 4*obs_count;
E_obs := N_obs + 4*obs_count;
H_obs := E_obs + 4*obs_count;
_
comment rec-head;
_________________
lng :=
obs_rec.lng_f := station + 4*(1 + cps)*obs_count;
obs_rec.obs_kind_f := false add obs_kind;
obs_rec.obs_type_f := false add obs_type;
obs_rec.obs_count_f := false add obs_count;
obs_rec.P_f := false add 1;
obs_rec.h_state_f := false add h_state;
obs_rec.tpd_f := false add (exp_tpd shift 6)
_ add max_dec;
obs_rec.h_tpd_f := h_tpd;
obs_rec.ident_f := ident;
obs_rec.stmw_f := long reg_lab(6);
obs_rec.Hm_f := Hm;
obs_rec.zl_f := long reg_lab(7);
obs_rec.mc_f := mc;
obs_rec.Ep_f := Ep;
\f
comment r_coord_obs_tx * page 7 14 09 78, 14.40
0 1 2 3 4 5 6 7 8 9 ;
_
comment move obs-subrec;
________________________
q := 0;
for r := 1 step 1 until obs_count do
begin
for t := 1 step 1 until cps do
begin
q := q + 1;
case t of
begin
obs_rec.N_obs(r) := NEH(q);
obs_rec.E_obs(r) := if cw_cstm then (NEH(q) - Ep)
_ else (- (NEH(q) - Ep));
obs_rec.H_obs(t) := NEH(q);
end;
end t-loop;
end r-loop;
_
comment checksum;
_________________
t := 3 + obs_rec.lng_f;
for lng_f := lng_f + 4 step 2 until lng do
t := t + obs_rec.lng_f;
lng_f := 4;
obs_rec.lng_f := -t;
r_coord_obs := (((((long <::> add obs_kind) shift 12)
_ add obs_type) shift 12)
_ add obs_count) shift 12;
end -, error;
end ident <> 0;
end r_coord_obs;
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message r_coord_obs not ok
lookup r_coord_obs)
end
finis
▶EOF◀