|
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: 21504 (0x5400)
Types: TextFile
Names: »sethlmtx«
└─⟦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⟧
; set_hlm_tr n-dim * page 1 23 01 79, 15.32;
; set_hlm_2
; ********
set_hlm = set 1
if listing.yes
char 10 12 10
set_hlm = set 1
set_hlm = algol
external integer procedure set_hlm
___________________________________
_ (N, x);
array N, x;
comment
N (call and return, array)
contains the object system, i.e. the system to which
the source systems in x can be transformed. the first 4
bytes are not used by the procedure and may thus contain
invar/outvar parameters. the content of N is as follows:
byte type name content
1-4 - - not used
5-6 i fix no. of givENPoints
7-8 i new no. of new points
9-10 i grp no of source groups
11-12 i dim no. of axes
13-16 l C_f(0) station nmb in GI. format
17-20 l C_f(1) northing coordinate
21-24 l C_f(2) easting coordinate
25-28 l C_f(3) error info (not instld)
29-44 l next set of coord etc
.......
.......
13+16*stats r reg_lab reg_lab of the coord system
-> 48+16*stats (stats=all=fix+new)
(continued)
;
\f
comment set_hlm_tr n-dim * page 2 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
comment
x (call and return)
contains all source systems which should be transformed
to the object system in N. the first 4 bytes are not
used by the proc, and is available for invar/outvar.
the content is as follows:
byte type name content
1-4 - - not used
5-8 l ident source identification
9-10 i obs_count no of points in source
11-12 i cond conditions:
_ 0 -> no conditions
_ 1 -> iso-scale
_ 2 -> orthogon. axes
_ 3 -> konf. transf = iso+orth
13-16 r P_t weight of coord
17-20 r m aposteori mean error
21-24 r enp norm of reduced rhs
25-52 r trp transformation params
25-26 i dim_f dimension of coord sys
27-28 - - not used
29-32 l n0 northing of translat
33-36 l e0 easting of translat
37-52 r trp rot (row-wize)
53-54 i index index of 1. point in x
_ (e.g. 7. point in N
_ has index 7)
55-58 i index index of 2.point
........
........
53+2*obsct r x_f x_coord of 1. point
-> 58+2*obsct
........
........
53+6*obsct r y_f y_coord of first pnt
........
........
53+10*obsct r w_f weight red of 1.point coord
........
........
52+14*obsct is the last byte of 1.group.
next group begins with 53+14*obscount.
a group has a length of 48+14*obscount as the length/sum
bytes only are used once.
ext used
________
nll_trans
hlm_u_tr
Prog.: Knud Poder NOV 1978
;
\f
comment set_hlm_tr n-dim * page 3 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
begin
integer field fix_f, new_f, dim_f;
integer ALL, FIX, NEW, dim, NEQ_lng;
fix_f := 6;
new_f := fix_f + 2;
dim_f := new_f + 4;
FIX := N.fix_f;
NEW := N.new_f;
dim := N.dim_f;
comment
write(out, nl, 1, <:FIX,NEW,dim:>, <<-dddddd>, FIX, NEW, dim);
ALL := FIX + NEW;
NEQ_lng := (NEW*dim + 2)*(NEW*dim + 1);
begin
array NEQ(1:NEQ_lng);
long array SING(1:1+(NEW*dim)//48);
integer t, t1, t2, RED, OBS, GG, G, g, P_base,
_ dim_1, new, GRP, exp_lim, max_lim,
_ obs_count, unk, unk_1, UNK, UNK_1,
_ iso_mask, uni_mask, ort_mask;
real M, m, m3, enp, ENP;
long w;
long field ident_f;
integer field obs_count_f, grp, grp_base, cond;
real array field c_x, rhs, x_f, y_f, P_f, trp, reg_lab;
boolean tpd, solve, SOLVE, cond_appl;
integer array field index;
real field Pt_f, enp_f, ENP_f, m_f, M_f;
long array field C_f, C_base, trl;
_
comment init params;
____________________
P_base := abs_addr(x) + 4;
dim_1 := dim + 1;
explim := 30;
maxlim := 0;
grp := new_f + 2;;
GRP := N.grp;
C_base := 12 - 4*dim_1;;
tpd := false add (8 shift 6 add 6);
cond_appl := false;
\f
comment set_hlm_tr n-dim * page 4 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
_
comment loop without and with conditions;
_________________________________________
for GG := 0 step 1 until 1 do
begin
_
comment loop over all sources;
______________________________
ENP := 0;
repeat
begin
_
comment clear normals;
______________________
for t := 1 step 1 until NEQ_lng do
NEQ(t) := 0;
_
comment init grp_base;
______________________
grp_base := 4;
OBS := - dim*NEW;
RED := 0;
\f
_
comment loop over source;
__________________________
for grp := 1 step 1 until GRP do
begin
_
comment fields and params in x-source;
_______________________________________
ident_f := grp_base + 4;
obs_count_f := ident_f + 2;
cond := obs_count_f + 2;
Pt_f := cond + 4;
m_f := Pt_f + 4;
enp_f := m_f + 4;
trl :=
trp := enp_f;
index := trp + 4*(dim + 1)*dim + 4;
obs_count := x.obs_count_f;
cond := x.cond;
cond_appl := cond_appl or cond <> 0;
ort_mask := cond shift (-12);
iso_mask := cond extract 6;
uni_mask := (cond shift (-6)) extract 6;
cond := 0;
x_f := index - 2*obs_count;
P_f := x_f + 4*dim_1*obs_count;
m := '50;
enp := 0;
m3 := 3;
g := 0;
comment * page ;
_
comment count conditions;
_________________________
if GG = 1 then
begin
t := ort_mask;
while t <> 0 do
begin
if t extract 1 = 1 then cond := cond + 1;
t := t shift (-1);
end;
t := uni_mask;
while t <> 0 do
begin
if t extract 1 = 1 then cond := cond + 1;
t := t shift (-1);
end;
t := iso_mask;
while t <> 0 do
begin
if t extract 1 = 1 then cond := cond + 1;
t := t shift (-1);
end;
comment test af iso-uni konflikt mangler;
end
else
begin
cond :=
ort_mask :=
iso_mask :=
uni_mask := 0;
end;
comment write(out,nl,1,<:obscount, cond:>, obscount,cond);
\f
comment set_hlm_tr n-dim * page 6 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
_
comment group block;
____________________
begin
array coef(1:dim*dim*obs_count
_ + (dim_1*dim+1)*cond),
_ w_neq(0:dim_1*dim_1 + 2*cond + 1);
integer array cca(-1:dim1+1+cond+2*obs_count),
_ cond_pair1, cond_pair2(0:cond);
real m_crit, P_t, red_fct, max_w,
_ sum, c1, c2, last_enp;
integer t, t1, t2, t3, col, col1, col2,
_ i, u, obs, red;
long array N_tr(1:dim);
real array field cond_pnt, c_p;
boolean headline;
_
comment set cond_pairs;
_______________________
t1 := 0;
comment ortho-conditions;
t := ort_mask;
col1 :=
col2 := 1;
while t <> 0 do
begin
col2 := col2 + 1;
if col2 > dim then
begin
col1 := col1 + 1;
col2 := col1 + 1;
end;
if t extract 1 = 1 then
begin
t1 := t1 + 1;
cond_pair1(t1) := col1;
cond_pair2(t1) := col2;
end;
t := t shift (-1);
end;
comment uni-conditions;
t := uni_mask;
col1 := 0;
while t <> 0 do
begin
col1 := col1 + 1;
if t extract 1 = 1 then
begin
t1 := t1 + 1;
cond_pair1(t1) := col1;
cond_pair2(t1) := 0;
end;
t := t shift (-1);
end;
\f
comment set_hlm_tr n-dim * page 7 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
comment iso-conditions;
t := iso_mask;
col1 :=
col2 := 1;
while t <> 0 do
begin
col2 := col2 + 1;
if col2 > dim then
begin
col1 := col1 + 1;
col2 := col1 + 1;
end;
if t extract 1 = 1 then
begin
t1 := t1 + 1;
cond_pair1(t1) := col1;
cond_pair2(t1) := -col2;
end;
t := t shift (-1);
end;
_
comment fields in coef;
_______________________
c_x := 0;
cond_pnt := 4*dim*obs_count;
rhs := cond_pnt + 4*cond*(dim_1*dim+1);
_
comment absaddr of columns of coeff;
____________________________________
cca(-1) := 2*NEQ_lng;
cca( 0) := abs_addr(NEQ);
cca( 1) := P_base + P_f;
cca( 2) := abs_addr(coef) + 4;
for t := 3 step 1 until dim_1 + 1 do
cca( t) := cca(t-1) + 4*obs_count;
for t := dim_1 + 2 step 1 until dim_1 + 1 + cond do
cca( t) := cca(t-1) + 4*(dim*dim_1 + 1);
\f
comment set_hlm_tr n-dim * page 8 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
_
comment count new and set x-ref;
________________________________
new := 0;
for t := 1 step 1 until obs_count do
begin
t2 := dim_1 + cond + 1 + t;
cca(t2) :=
i := x.index(t) - FIX - 1;
if i >= 0 then
begin
cca(t2+obs_count) := new;
new := new + 1;
for t1 := t - 1 step -1 until 1 do
if x.index(t) = x.index(t1) then
begin
cca(t2+obs_count) := cca(t2+obs_count+t1-t);
new := new - 1;
t1 := 0;
end t1-loop;
end i >= 0
else
cca(t2+obs_count) := -1;
end t-loop;
if fp_mode(1) then
for t := -1 step 1 until
_ dim1 + 1 + cond + 2*obs_count do
write(out, nl, 1, <<-ddddddd>, t, cca(t));
_
comment obs-eq loop;
____________________
Pt := 1/(x.Pt_f);
last_enp := '-3;
repeat
begin
_
comment solve-control;
______________________
solve := enp < 3.0
_ and -,( abs(last_enp - enp)< 0.4 and g>= 10);
last_enp := enp;
<*
headline := -, solve or g = 10;
*>
headline := true;
obs := dim*obs_count + cond - dim*dim1;
red := 0;
g := g + 1;
if fp_mode(8) then
write(out, nl, 2, <:pass:>, <<ddd>, g);
m_crit := m* ( if g>1 then m3 else '4);
_
comment clear coef-array;
_________________________
for t := dim*dim*obs_count + (dim_1*dim+1)*cond
_ step -1 until 1 do coef(t) := 0;
\f
comment set_hlm_tr n-dim * page 9 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
_
comment obs_eq;
_______________
for t := 1 step 1 until obs_count do
begin
C_f := C_base + 4*(dim_1+1)*x.index(t);
x.P_f(t) := Pt;
coef.rhs(t) := '-6*(N.C_f(1) - hlm_u_tr(
_ x.x_f(t+i*obs_count), i,
_ x.trp, N_tr(u), u));
red_fct := abs coef.rhs(t);
for col := 2 step 1 until dim do
begin
max_w :=
coef.rhs(t+(col-1)*obs_count) :=
_ '-6*(N.C_f(col) - N_tr(col));
if abs max_w > red_fct then
red_fct := abs max_w;
end;
_
comment blunder action;
_______________________
if Pt*red_fct > m_crit then
begin
red_fct := Pt*red_fct/m_crit;
red_fct := if red_fct < 100 then
_ exp(-red_fct/2) else '-120;
x.P_f(t) := red_fct*Pt;
red := red + dim;
_
comment output of blunders;
__________________________
<*
if -, solve or g = 10 then
begin
*>
if headline then
begin
headline := false;
write(out, nl, 3, <<-dddddddddddd>, x.ident_f, nl, 1);
end;
write(out, nl, 1);
write_stn(out, N.C_f(0));
write(out, sp, 3);
for col := 1 step 1 until dim do
write(out, nl, if col mod 4 = 0 then 1 else 0,
<<__-ddd_ddd.ddd>, coef.rhs(t + (col-1)*obs_count));
write(out, nl, 1, sp, 14, <<-d.ddd'-dd>, red_fct);
<*
end output;
*>
end blunder action;
_
comment normalize obs_eq coef;
______________________________
for col := 1 step 1 until dim do
begin
t1 := t + col*obs_count;
t2 := t1 - obs_count;
coef.c_x(t2) := x.P_f(t)*x.x_f(t1);
coef.rhs(t2) := x.P_f(t)*coef.rhs(t2);
end col-loop;
end t-loop;
\f
comment set_hlm_tr n-dim * page 10 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
_
comment condition equations;
____________________________
c_p := cond_pnt + 4;
for t := 1 step 1 until cond do
begin
col1 := cond_pair1(t);
col2 := cond_pair2(t);
sum := 0;
case 2 - sign(col2) of
begin
comment case 1, ortho-condition;
________________________________
begin
t2 := dim_1*(dim - 1);
for t1 := 0 step dim_1 until t2 do
begin
c1 :=
coef.c_p(col1+t1) := x.trp(2+col2+t1);
c2 :=
coef.c_p(col2+t1) := x.trp(2+col1+t1);
sum := c1*c2 + sum;
end t1-loop;
coef.c_p(dim_1*dim) := sum;
end case 1;
comment case 2, uni-condition;
______________________________
begin
t2 := (col1-1)*dim_1 + dim;
t3 := 2 + col_1;
for t1 := (col1-1)*dim_1+1 step 1 until t2 do
begin
c1 :=
coef.c_p(t1) := x.trp(t3);
t3 := t3 + dim_1;
sum := c1**2 + sum;
end;
coef.c_p(dim_1*dim) := (sum - 1.0)/2;
end case 2;
comment case 3, iso-condition;
______________________________
begin
t2 := dim_1*(dim - 1);
col2 := - col2;
for t1 := 0 step dim_1 until t2 do
begin
c1 :=
coef.c_p(col1+t1) := x.trp(2+col1+t1);
c2 :=
coef.c_p(col2+t1) := -x.trp(2+col2+t1);
sum := c1**2 - c2**2 + sum;
end t1-loop;
coef.c_p(dim_1*dim) := sum/2;
end case 3;
end cases;
_
comment update c_p;
___________________
c_p := c_p + 4*(dim_1*dim + 1);
end t-loop;
\f
comment set_hlm_tr n-dim * page 11 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
comment
if fpmode(11) then
for t := 1 step 1 until dim*dim*obs_count
+ (dim_1*dim+1)*cond do
write(out, nl, if t mod 5 = 1 then 1 else 0,
<<___-d.dd'-dd>, coef(t));
_
comment solve and update source constants;
__________________________________________
m := nll_trans(w_neq, dim, cond,
_ if solve then 0 else new,
_ cca, obs_count, solve);
_
comment update transf. params;
______________________________
if solve then
begin
t2 := 2 + (dim - 1)*dim1;
for t := 2 step dim_1 until t2 do
begin
w := '6*w_neq(t-1);
x.trl(t) := x.trl(t) + w;
for t1 := 1 step 1 until dim do
x.trp(t+t1) := x.trp(t+t1) + w_neq(t+t1-1);
end;
\f
comment set_hlm_tr n-dim * page 12 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
if obs - red > 0 then
x.m_f :=
m := w_neq(dim*dim1+cond+1)/sqrt(obs-red)
else
x.m_f :=
m := '50;
x.enp_f :=
enp := w_neq(0);
if fp_mode(8) then
begin
write(out, nl, 2, <:m___=_:>, <<-dd.dd>, m,
_ nl, 1, <:enp_=_:>, enp, nl, 1);
t2 := 2 + (dim - 1)*dim1;
for t := 2 step dim_1 until t2 do
begin
write_geo_c(out, x.trl(t), tpd);
write_geo_c_r(out, w_neq(t-1), tpd);
write(out, nl, 1);
end t-loop;
for t := 2 step dim_1 until t2 do
begin
for t1 := 1 step 1 until dim do
write(out, <<__-d.ddddd ddddd'-dd>,
x.trp(t+t1), w_neq(t+t1-1), nl, 1);
end t-loop;
end output;
end update transf. params
else
begin
OBS := OBS + obs;
RED := RED + red;
end;
end
until -, solve;
end group-block;
_
comment reset group pointer;
____________________________
grp_base := index + (2 + 4*dim_1)*obs_count;
end grp-loop;
_
comment solve common normals;
_____________________________
if NEW > 0 then
begin
max_lim := 0;
M := nll_epu(NEQ, NEW*dim + 1,
_ exp_lim, max_lim, SING, ENP);
if OBS > RED and M > 0 then
M := sqrt(M/(OBS - RED))
else
begin
write(out, nl, 1, if M <= 0 then
<:ej positiv varians:> else <:ej overbestemt:>, nl, 1);
M := '5;
end;
if fp_mode(8) then
write(out, nl, 2, <<___-d.dd>, <:M____=:>, M, nl, 1,
<:ENP__=:>, ENP, nl, 1,
<:max_l_=:> , <<-dddd>, max_lim, nl, 1);
\f
comment set_hlm_tr n-dim * page 13 23 01 79, 15.32
0 1 2 3 4 5 6 7 8 9 ;
_
comment output of sol;
______________________
t1 := (NEW*dim + 1)*NEW*dim//2;
for t := FIX + 1 step 1 until ALL do
begin
C_f := C_base + 4*(dim_1 + 1)*t;
if fp_mode(8) then
begin
write(out, nl, 1);
write_stn(out, N.C_f(0));
end;
for t2 := 1 step 1 until dim do
begin
w := '6*NEQ(t1+(t-FIX-1)*dim+t2);
N.C_f(t2) := N.C_f(t2) + w;
if fp_mode(8) then
begin
write(out, sp, if t2 = 1 then 4 else 15);
write_geo_c(out, N.C_f(t2), tpd);
write_geo_c(out, w, tpd);
write(out, nl, 1);
end;
end t2-loop;
if fp_mode(8) then
write(out, nl, 1);
end;
if fp_mode(8) then
write(out, nl, 3);
end sol of NEW;
end
until ENP > 3.0 or NEW = 0;
if -, cond_appl then GG := 1;
end GG-loop;
end inner block;
end;
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message set_hlm not ok
lookup set_hlm)
end
finis
▶EOF◀