|
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: 8448 (0x2100)
Types: TextFile
Names: »nlloctx«
└─⟦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⟧
; nll_oc_tx * page 1 15 03 78, 11.14;
; nll_oc
; ******
if listing.yes
char nl ff nl
nll_oc = set 1
nll_oc = algol
external integer procedure nll_oc
_________________________________
_ (OC_a, unk, cca, obs_count, epu, epu_lng, sol);
value unk, obs_count, epu_lng, sol;
array OC_a;
integer unk, obs_count, epu_lng;
integer array cca;
zone epu;
boolean sol;
comment
nll_oc (return, integer proc)
service proc for orientation unknowns. the procedure has
a value equal to the array field value for the unknowns
in the array OC_a in the sol case. the value in the -, sol
case is irrelevant.
OC_a (array, return)
work array of length at least 1 : (unk+1)*(unk+2)//2.
the array needs no initialization and should not be a
fielded array. the content becomes the upper triangular
CHOLESKY matrix, and when sol is true also the solutions,
fielded by the value of nll_oc.
unk (call, integer)
the number of unknowns
cca (call, integer array)
the abs addr of the first elements in each col of obs-eq incl.
the rhs. the last is not used in the -, sol case, but then
cca(0) = first oc coeff in obs-eq coeff,
cca(unk+2) = first coord col addr in the array pointed by cca
_ the cols must be consecutive
cca(unk+3) = coord_pr_stat
cca(unk+4) = eq_pr_stat
obs_count (call, integer)
the number of obs_eq (mostly observations*eq_pr_stat)
epu (call and return, zone)
a zone buffer opened to the epu and after an outrec_6 of the
full buffer length. the zone is left in the same state. the
zone should have not less than 4*24 bytes.
epu_lng (call, integer)
the zone buffer length in bytes
sol (call, boolean)
true when the orientation unknowns are computed and false
when their cholesky reduction is done
\f
comment nll_oc_tx * page 2 15 03 78, 11.14
0 1 2 3 4 5 6 7 8 9 ;
comment
_
ext. used
__________
abs_addr
Prog: Knud Poder, 19 FEB 1978
GI_nr: 78010
;
begin
integer t, t1, unk1, row, col,
_ coef_pnt, coef_step, status_addr,
_ coord_pr_stat, eq_pr_stat,
_ cca_disp, cca_step,
_ z_mla_obs_count, mls_m1, z_mls_m1,
_ epu_op, chl_30, stp_1;
real status;
integer array cwa(1:unk+1), coord_pnt(1:3);
integer array field word;
_
comment proc value;
___________________
nll_oc := (unk + 1)*unk*2;
_
comment init of variables;
__________________________
unk1 := if sol then (unk + 1) else unk;
epu_lng := epu_lng - 24;
word := 0;
_
comment epu-instr;
__________________
zmla_obs_count := 1 shift 23 + 2 shift 12 + obs_count;
mls_m1 := 0 shift 23 + 3 shift 12 - 1;
z_mls_m1 := 1 shift 23 + 3 shift 12 - 1;
chl_30 := 0 shift 23 + 8 shift 12 + 30;
stp_1 := 4095 shift 12 + 1;
_
comment abs_addresses;
______________________
status_addr := abs_addr(status);
cwa(1) := abs_addr(OC_a) + 4;
for t := 1 step 1 until unk do
cwa(t+1) := cwa(t) + 4*t;
_
comment reduction of oc-normals;
________________________________
_
comment clear orientation normals;
__________________________________
for t := ((unk1 + 1)*unk1)//2 step - 1 until 1 do
OC_a(t) := 0.0;
\f
comment nll_oc_tx * page 3 15 03 78, 11.14
0 1 2 3 4 5 6 7 8 9 ;
_
comment orientation normals;
____________________________
for t := 1 step 1 until unk1 do
begin
for t1 := 1 step 1 until t do
begin
epu.word(1) := zmla_obs_count;
epu.word(2) := cca(t);
epu.word(3) := cca(t1);
epu.word(4) := mls_m1 + t1;
epu.word(5) := cwa(t);
epu.word(6) := cwa(t1);
epu.word(7) := chl_30;
epu.word(8) := status_addr;
epu.word(9) := 0;
word := word + 18;
_
comment test epu action;
________________________
if word > epu_lng then
begin
epu.word(1) := stp_1;
changerec_6(epu, word + 6);
outrec_6(epu, epu_lng + 24);
word := 0;
end;
end t1-loop;
end t-loop;
_
comment start epu;
__________________
if word <> 0 then
begin
epu.word(1) := stp_1;
changerec_6(epu, word + 6);
outrec_6(epu, epu_lng + 24);
word := 0;
end;
_
comment back-sol of normals;
____________________________
if sol then
begin
row := ((unk1 + 1)*unk1)//2;
col := row - unk;
_
comment pseudo-enp;
___________________
OC_a(row+1) :=
status := 0;
for t := row - 1 step -1 until col do
status := status + OC_a(t)**2;
OC_a(row+1) := sqrt(status);
_
comment mean error;
___________________
if obs_count - unk > 0 then
OC_a(row) := OC_a(row)/sqrt(obs_count - unk);
_
comment back-sol;
_________________
for t := unk - 1 step -1 until 0 do
begin
row := row - 1;
col := col - 1;
OC_a(row) := OC_a(row)/OC_a(col);
for t1 := 1 step 1 until t do
begin
col := col - 1;
OC_a(row-t1) := OC_a(row-t1) - OC_a(row)*OC_a(col);
end t1-loop;
end t-loop;
end sol-clause
else
\f
<* nll_oc_tx * page 4 15 03 78, 11.14
0 1 2 3 4 5 6 7 8 9 *>
<*reduce oc-normal coeff*>
__________________________
begin
coef_pnt := cca(0);
coord_pnt(1) := cca(unk+2);
coord_pr_stat := cca(unk+3);
eq_pr_stat := cca(unk+4);
for col := 2 step 1 until coord_pr_stat do
coord_pnt(col) := coord_pnt(col-1) + 4*obs_count;
cca_disp := 0;
cca_step := 4*eq_pr_stat;
coef_step := 4*unk;
obs_count := obs_count//eq_pr_stat;
epu_op := 1 shift 23 + 2 shift 12 <*z_mla*>
_ + eq_pr_stat;
_
comment clear oc part of coef_zn;
_________________________________
epu.word(1) := 1 shift 23 + 4 shift 12 <*clear and store*>
_ + coord_pr_stat*unk*obs_count;
epu.word(2) :=
epu.word(3) := coef_pnt;
word := word + 6;
_
comment loop over objects;
__________________________
for t := 1 step 1 until obs_count do
begin
_
comment loop over coord cols;
_____________________________
for col := 1 step 1 until coord_pr_stat do
begin
_
comment col of oc-oc coeff;
___________________________
for t1 := 1 step 1 until unk do
begin
epu.word(1) := epu_op;
epu.word(2) := coord_pnt(col) + cca_disp;
epu.word(3) := cca(t1) + cca_disp;
epu.word(4) := mls_m1 + t1;
epu.word(5) := coef_pnt;
epu.word(6) := cwa(t1);
epu.word(7) := chl_30;
epu.word(8) := status_addr;
epu.word(9) := 0;
word := word + 18;
\f
comment nll_oc_tx * page 5 15 03 78, 11.14
0 1 2 3 4 5 6 7 8 9 ;
_
comment test epu action;
________________________
if word > epu_lng then
begin
epu.word(1) := stp_1;
changerec_6(epu, word + 6);
outrec_6(epu, epu_lng + 24);
word := 0;
end;
end t1-loop;
_
comment move obs-eq coef-pointer;
_________________________________
coef_pnt := coef_pnt + coef_step;
end col-loop;
_
comment move oc-array pointer;
______________________________
cca_disp := cca_disp + cca_step;
end t-loop;
_
comment start epu;
__________________
if word <> 0 then
begin
epu.word(1) := stp_1;
changerec_6(epu, word + 6);
outrec_6(epu, epu_lng + 24);
word := 0;
end;
end no sol clause;
end nll_oc;
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message nll_oc not ok
lookup nll_oc)
end
▶EOF◀