|
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: 9216 (0x2400)
Types: TextFile
Names: »nllphtx«
└─⟦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_ph_tx * page 1 2 11 79, 15.47;
; nll_ph
; ******
if listing.yes
char nl ff nl
nll_ph = set 1
nll_ph = algol
external integer procedure nll_ph
_________________________________
_ (OC_a, unk, cca, obs_count, sol);
value unk, obs_count, sol;
array OC_a;
integer unk, obs_count;
integer array cca;
boolean sol;
comment
nll_ph (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_ph.
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)
sol (call, boolean)
true when the orientation unknowns are computed and false
when their cholesky reduction is done
_
ext. used
__________
abs_addr
to_epu
Prog: Knud Poder, 8 OCT 1979
GI_nr: 79013;
\f
comment nll_ph_tx * page 2 2 11 79, 15.47
0 1 2 3 4 5 6 7 8 9 ;
begin
zone epu(((unk+2)*(unk+1)*9+9)//4, 1,
_ nll_block);
integer t, t1, t2, unk1, row, col, rep,
_ 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, epu_lng, epu_max;
real enp_sum;
array status(0:unk+1);
integer array cwa(1:unk+1), coord_pnt(1:3);
integer array field word;
boolean neg_dia;
_
comment proc value;
___________________
nll_ph := (unk + 1)*unk*2;
_
comment init of variables;
__________________________
unk1 := if sol then (unk + 1) else unk;
epu_lng := (((unk + 2)*(unk + 1)*9 + 9)//4)*4;
epu_max := epu_lng - 24;
open(epu, 14, <:ympe:>, 55 shift 17);
outrec_6(epu, epu_lng);
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;
_
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;
________________________________
rep := -1;
\f
comment nll_ph_tx * page 3 2 11 79, 15.47
0 1 2 3 4 5 6 7 8 9 ;
repeat
begin
rep := rep + 1;
_
comment clear orientation normals;
__________________________________
for t := ((unk1 + 1)*unk1)//2 step - 1 until 1 do
OC_a(t) := 0.0;
_
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 + t shift 2;
epu.word(9) := 0;
word := word + 18;
end t1-loop;
end t-loop;
to_epu(epu, word, epu_lng, false);
_
comment check dia_results;
__________________________
neg_dia := false;
for t := 1 step 1 until unk do
neg_dia := neg_dia or
_ (status(t) shift (-24)) extract 24 = 2;
if neg_dia then
begin
t2 := 0;
write(out, nl, 2, <:nllph error, rep:>,
_ <<dd>, rep, nl, 1);
for t := 1 step 1 until unk do
begin
write(out, nl, 1, <<__-dddd>,
_ (status(t) shift (-24)) extract 24);
for t1 := 1 step 1 until t do
begin
t2 := t2 + 1;
write(out, nl, if t1 mod 4 = 1 then 1 else 0,
<<__-d.ddd'-ddd>, OC_a(t2));
end t1-loop;
end t-loop;
end neg_dia output;
end rep-loop;
until rep = 5 or -, neg_dia;
\f
comment nll_ph_tx * page 4 2 11 79, 15.47
0 1 2 3 4 5 6 7 8 9 ;
_
comment back-sol of normals;
____________________________
if sol then
begin
row := ((unk1 + 1)*unk1)//2;
col := row - unk;
_
comment pseudo-enp;
___________________
OC_a(row+1) :=
enp_sum := 0;
for t := row - 1 step -1 until col do
enp_sum := enp_sum + OC_a(t)**2;
OC_a(row+1) := sqrt(enp_sum);
_
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
<*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;
\f
comment nll_ph_tx * page 5 2 11 79, 15.47
0 1 2 3 4 5 6 7 8 9 ;
_
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;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
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
to_epu(epu, word, epu_lng, false);
end no sol clause;
\f
comment nll_ph_tx * page 6 2 11 79, 15.47
0 1 2 3 4 5 6 7 8 9 ;
_
comment disconnect epu;
_______________________
changerec_6(epu, 0);
close(epu, true);
end nll_ph;
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message nll_ph not ok
lookup nll_ph)
end
finis
▶EOF◀