|
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: 19200 (0x4b00)
Types: TextFile
Names: »nlltranstx«
└─⟦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_trans_tx * page 1 23 01 79, 15.39;
; nll_trans
; ******
if listing.yes
char nl ff nl
nll_trans = set 1
nll_trans = algol
external integer procedure nll_trans
___________________________________
_ (w_neq, dim, cond, new, cca, obs_count, sol);
value dim, cond, new, obs_count, sol;
array w_neq;
integer dim, cond, new, obs_count;
integer array cca;
boolean sol;
comment
nll_trans (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 neq in the sol case. the value in the -, sol
case is irrelevant.
neq (array, return)
work array of length at least 1 : (unk+1)*(unk+2)//2+1.
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_trans.
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_trans_tx * page 2 23 01 79, 15.39
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, t2, t3, unk, row, col,
_ dim_1, save_col, coef_max,
_ t_coef, t_cond, t_rhs,
_ t_frst, t_last, ccf, cxf,
_ neq_addr, neq_step, neq_disp,
_ neq_tail, neq_max,
_ NEQ_addr, NEQ_disp,
_ zero_addr,
_ coef_pnt, coef_step, status_addr,
_ epu_lng, epu_max,
_ cca_disp, cca_step, cca_max,
_ zmla, epu_op_1, epu_op_2,
_ add_1, str_1, zmls, zmls_1, mls, mla,
_ zmla_obs_count, mls_m1, z_mls_m1,
_ zadd_1, chl_30, chl_op;
real status, zero;
array neq(1:(dim+cond+2)*(dim+cond+1)//2
_ + (dim+1)*(dim-1)*cond
_ + 2*dim*new*(dim*(dim+1)+cond));
integer array cwa(1:dim+cond+new*dim+3),
_ col_addr, col_index(dim+cond+3:
_ new*dim+dim+cond+3),
_ cxa(1:dim+1);
boolean rhs, not_transp;
zone epu(512, 1, nll_block);
integer array field word, cat_f, x_ref;
_
comment unknowns and conditions;
________________________________
dim_1 :=
t_coef := dim + 1;
unk := dim*dim_1;
t_cond := t_coef + cond;
t_rhs := t_cond + 1;
epu_lng := 4*512; comment gris;
epu_max := epu_lng - 48;
_
comment connect epu;
____________________
open(epu, 14, <:ympe:>, 55 shift 17);
outrec_6(epu, epu_lng);
word := 0;
\f
comment nll_trans_tx * page 3 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment epu-instr;
__________________
zadd_1 := 1 shift 23 + 0 shift 12 + 1;
add_1 := 0 shift 23 + 0 shift 12 + 1;
mla := 0 shift 23 + 2 shift 12 + 0;
zmla := 1 shift 23 + 2 shift 12 + 0;
zmla_obs_count := 1 shift 23 + 2 shift 12 + obs_count;
mls := 0 shift 23 + 3 shift 12 + 0;
zmls := 1 shift 23 + 3 shift 12 + 0;
zmls_1 := 1 shift 23 + 3 shift 12 + 1;
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;
str_1 := 0 shift 23 + 4 shift 12 + 1;
_
comment abs_addresses;
______________________
zero_addr := abs_addr(zero);
zero := 0.0;
cwa(t_rhs) := abs_addr(w_neq) + 4;
status_addr := cwa(t_rhs) + 4*(unk + cond);
cwa(1) := abs_addr(neq) + 4;
t1 := t_rhs - 2;
for t := 1 step 1 until t1 do
begin
cwa(t+1) := cwa(t) + 4*t;
if t > t_coef then
cwa(t+1) := cwa(t+1) + 4*dim_1*(dim - 1);
end;
comment
if fp_mode(3) then
for t := 1 step 1 until t_rhs do
write(out, nl, 1, <<ddddddd>, t, cwa(t));
_
comment reduction of normals;
_____________________________
_
comment clear orientation normals;
__________________________________
for t := (dim_1 + cond + 1)*(dim_1 + cond)//2
_ + dim_1*(dim - 1)*cond
_ + 2*dim*new*(unk + cond) step -1 until 1 do
_ neq(t) := 0.0;
for t := unk + dim_1 + 2*cond + 1 step -1 until 0 do
_ w_neq(t) := 0;
\f
comment nll_trans_tx * page 4 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment coef matrix;
____________________
for t := 1 step 1 until t_coef 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;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
end t-loop;
\f
comment nll_trans_tx * page 5 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment init pointers;
______________________
cca_step := 4*obs_count;
cca_disp := - cca_step;
coef_step := 4*(dim + 1);
coef_max := coef_step*(dim - 1);
_
comment cond and rhs col;
_________________________
for coef_pnt := 0 step coef_step until coef_max do
begin
cca_disp := cca_disp + cca_step;
for t := t_coef + 1 step 1 until t_rhs do
begin
rhs := t = t_rhs;
for t1 := 1 step 1 until t_coef do
begin
if rhs then
begin
epu.word(1) := zmla_obs_count;
epu.word(2) := cca(t) + cca_disp;
epu.word(3) := cca(t1);
end
else
begin
epu.word(1) := zadd_1;
epu.word(2) := cca(t) + coef_pnt + (t1-1) shift 2;
epu.word(3) := zero_addr;
end;
epu.word(4) := mls_m1 + t1;
epu.word(5) := cwa(t) + coef_pnt;
epu.word(6) := cwa(t1);
epu.word(7) := chl_30;
epu.word(8) :=
epu.word(9) := 0;
word := word + 18;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
end t-loop;
end gp-loop;
\f
comment nll_trans_tx * page 6 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment epu-op for auto-red;
____________________________
epu_op_1 := zmla + unk;
epu_op_2 := mls_m1;
chl_op := chl_30;
_
comment cond and rhs auto-red;
______________________________
for t := t_coef + 1 step 1 until t_rhs do
begin
rhs := t = t_rhs;
for t1 := t_coef + 1 step 1 until t do
begin
if t1 = t_rhs then
begin
epu.word(1) := zmla + dim*obs_count;
epu.word(2) := cca(t);
epu.word(3) := cca(t1);
word := word + 6;
epu_op_1 := mls + unk;
epu_op_2 := mla - 1;
chl_op := chl_30 + 70;
end
else if rhs then
begin
epu.word(1) := zadd_1;
epu.word(2) := cca(t1) + unk shift 2;
epu.word(3) := zero_addr;
word := word + 6;
epu_op_1 := mla + unk;
epu_op_2 := mls_m1;
end;
epu.word(1) := epu_op_1;
epu.word(2) := cwa(t);
epu.word(3) := cwa(t1);
epu.word(4) := epu_op_2 + t1 - t_coef;
epu.word(5) := cwa(t) + unk shift 2;
epu.word(6) := cwa(t1) + unk shift 2;
epu.word(7) := chl_op;
epu.word(8) := status_addr + t shift 2;
epu.word(9) := 0;
word := word + 18;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
end t-loop;
chl_op := chl_30;
\f
comment nll_trans_tx * page 7 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment start epu;
__________________
if word <> 0 then
to_epu(epu, word, epu_lng, false);
<*
if fp_mode(3) then
begin
write(out, nl, 3, <:normallign:>, nl, 1);
t1 := hlm_array(dim, cond);
for t := 1 step 1 until t1 do
write(out, nl, if t mod 5 = 1 then 1 else 0,
<<__-d.dd'-ddd>, neq(t));
end;
*>
comment w_neq skal kun være unk + dim1 +2*cond + 1;
comment
for t := 1 step 1 until dim1+cond + 1 do
write(out, nl, 1, <<dddddddddd>, t, t+unk+cond+1,
(w_neq(t+unk+cond+1) shift (-24))extract 24,
w_neq(t+unk+cond+1) extract 24);
_
comment back-sol of normals;
____________________________
if sol then
begin
row := unk + cond;
col := (dim_1 + cond + 1)*(dim_1 + cond)//2
_ + dim_1*(dim - 1)*cond + 1;
_
comment enp and variance;
_________________________
status := 0.0;
for t := 1 step 1 until unk do
status := status + w_neq(t)**2;
for t := unk + 1 step 1 until row do
status := status - w_neq(t)**2;
row := row + 1;
status := sqrt(abs status);
if w_neq(row) <'-50 then w_neq(row) := '-50;
if status < '-20*w_neq(row) then
status := '-20*w_neq(row);
w_neq(0) := mu*ln(w_neq(row)/status);
nll_trans := w_neq(row);
\f
comment nll_trans_tx * page 8 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment back-sol of correlates;
_______________________________
t := unk + cond;
for t2 := 1 step 1 until cond do
begin
row := row - 1;
col := col - 1;
w_neq(row) := w_neq(row)/neq(col);
t := t - 1;
for t1 := 1 step 1 until t do
begin
col := col - 1;
w_neq(row-t1) := w_neq(row-t1) - w_neq(row)*neq(col);
end t1-loop;
end t2-loop;
_
comment back-sol of elements;
_____________________________
save_col := col;
for t3 := 1 step 1 until dim do
begin
col := save_col;
for t := dim step -1 until 0 do
begin
row := row - 1;
col := col - 1;
w_neq(row) := w_neq(row)/neq(col);
for t1 := 1 step 1 until t do
begin
col := col - 1;
w_neq(row-t1) := w_neq(row-t1) - w_neq(row)*neq(col);
end t1-loop;
end t-loop;
end t2-loop;
end sol-clause
<*reduce coef of unknown points*>
_______________________________
else if new > 0 then
begin
t_frst := t_rhs + 1;
t_last := t_rhs + new*dim;
t1 := 4*(unk + cond);
cwa(t_frst) := cwa(t_rhs-1) + t1;
for t:= t_frst + 1 step 1 until t_last do
cwa(t) := cwa(t-1) + t1;
\f
comment nll_trans_tx * page 9 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
<*
if fp_mode(5) then
begin
write(out, nl, 1, <:addr af new-cols:>, nl, 1);
for t := 1 step 1 until t_last do
write(out, nl, 1, <<-ddddddd>, t, cwa(t));
end;
*>
_
comment set catalogue of unkn points matrix;
____________________________________________
cat_f := 2*(dim_1 + cond + 1);
x_ref := cat_f + 2*obs_count;
neq_tail := 4*new*dim*(unk + cond);
neq_step := 4*dim_1;
neq_max := neq_step*(dim - 1);
NEQ_addr := cca( 0);
NEQ_disp := cca(-1);
for t := 1 step 1 until obs_count do
begin
comment
if fp_mode(5) then
write(out, nl, 2, <:col xno xref :>, cca.cat_f(t), cca.x_ref(t));
if cca.cat_f(t) >= 0 then
begin
ccf := cca.cat_f(t)*dim;
cxf := cca.x_ref(t)*dim + t_frst;
for t1 := 1 step 1 until dim do
begin
ccf := ccf + 1;
row :=
col_index(cxf) := 4*ccf;
col :=
col_addr(cxf) := NEQ_addr + 2*(ccf - 1)*ccf;
cxa(t1) := cwa(cxf);
cxf := cxf + 1;
comment
if fp_mode(5) then
write(out, nl, 1, <:NEQcol,addr, index :>, <<-dddddddd>,
cxf-1, col_addr(cxf-1), col_index(cxf-1)//4);
_
comment rhs in NEQ;
___________________
epu.word(1) := zmls_1;
epu.word(2) := cca(1) + (t-1) shift 2;
epu.word(3) := cca(t_rhs) + (t-1) shift 2
_ + (t1-1)*4*obs_count;
epu.word(4) := add_1;
epu.word(5) :=
epu.word(8) := NEQ_addr + 2*(new*dim+1)*(new*dim) + row;
epu.word(6) :=
epu.word(9) := epu.word(5) + NEQ_disp;
epu.word(7) := str_1;
word := word + 18;
\f
comment nll_trans_tx * page 10 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment dia-elem in NEQ;
________________________
epu.word(1) := zmla + 1;
epu.word(2) :=
epu.word(3) := cca(1) + (t-1) shift 2;
epu.word(4) := add_1;
epu.word(5) :=
epu.word(8) := col + row;
epu.word(6) :=
epu.word(9) := epu.word(5) + NEQ_disp;
epu.word(7) := str_1;
word := word + 18;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
_
comment load coef from obs_eq;
______________________________
t2 := 0;
for neq_disp := 0 step neq_step until neq_max do
begin
t2 := t2 + 1;
for t1 := 0 step 1 until dim do
begin
epu.word(1) := zmls_1;
epu.word(2) := cca(1) + (t-1) shift 2;
epu.word(3) := cca(t1+1) + (t-1) shift 2;
epu.word(4) := add_1;
epu.word(5) :=
epu.word(8) := cxa(t2) + t1 shift 2
_ + neq_disp;
epu.word(6) :=
epu.word(9) := epu.word(5) + neq_tail;
epu.word(7) := str_1;
word := word + 18;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
end neq_disp_loop;
end cca.cat_f-clause;
end t-loop;
\f
comment nll_trans_tx * page 11 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment include rhs;
____________________
t_last := t_last + 1;
cwa(t_last) := cwa(t_rhs);
col_addr(t_last) := NEQ_addr + 2*(new*dim+1)*new*dim;
col_index(t_last) := 4*(new*dim + 1);
_
comment insert variance;
________________________
epu.word(1) := zmla + dim*obs_count;
epu.word(2) :=
epu.word(3) := cca(t_rhs);
epu.word(4) := add_1;
epu.word(5) :=
epu.word(8) := col_addr(t_last) + col_index(t_last);
epu.word(6) :=
epu.word(9) := epu.word(5) + NEQ_disp;
epu.word(7) := str_1;
word := word + 18;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
_
comment disp of first triang part;
__________________________________
cca_step := 4*dim_1;
cca_max := cca_step*dim;
cca_disp := 0;
_
comment loop over all columns of new;
_____________________________________
for col := t_frst step 1 until t_last do
begin
if col < t_last then
<*skip rhs*>
begin
_
comment first triang part;
__________________________
for t1 := 1 step 1 until t_coef do
begin
epu.word(1) := z_mls_m1 + t1;
epu.word(2) := cwa(col) + cca_disp;
epu.word(3) := cwa(t1);
epu.word(4) := chl_30;
epu.word(5) := status_addr;
epu.word(6) := neq_tail;
word := word + 12;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
_
comment move oc-array pointer;
______________________________
cca_disp := (cca_disp + cca_step) mod cca_max;
\f
comment nll_trans_tx * page 12 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment reduce with condition submatrix;
________________________________________
for t1 := t_coef + 1 step 1 until t_cond do
begin
epu.word(1) := zmla + unk;
epu.word(2) := cwa(col);
epu.word(3) := cwa(t1);
epu.word(4) := mlsm1 + t1 - t_coef;
epu.word(5) := epu.word(2) + unk shift 2;
epu.word(6) := epu.word(3) + unk shift 2;
epu.word(7) := chl30;
epu.word(8) := status_addr;
epu.word(9) := neq_tail;
word := word + 18;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t1-loop;
end skip rhs-clause;
\f
comment nll_trans_tx * page 13 23 01 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
_
comment autoreduction of new-cols;
__________________________________
for t := t_frst step 1 until col do
begin
not_transp := col_index(col) >= col_index(t);
comment
if fp_mode(5) then
write(out, nl, 1, <:col,t,coladdr,colindex,taddr,tindex:>,
nl, 1, <<-ddddddd>, col, t, col_addr(col), col_index(col),
col_addr(t), col_index(t));
epu.word( 1) := z_mls + unk;
epu.word( 2) := cwa(col);
epu.word( 3) := cwa(t);
epu.word( 4) := mla + cond;
epu.word( 5) := epu.word(2) + unk shift 2;
epu.word( 6) := epu.word(3) + unk shift 2;
epu.word( 7) := add_1;
epu.word( 8) :=
epu.word(11) := col_addr(if not_transp then col
_ else t)
_ + col_index(if not_transp then t
_ else col);
epu.word( 9) :=
epu.word(12) := epu.word(8) + NEQ_disp;
epu.word(10) := str_1;
word := word + 24;
if word > epu_max then
to_epu(epu, word, epu_lng, false);
end t-loop;
end col-loop;
_
comment start epu;
__________________
if word <> 0 then
to_epu(epu, word, epu_lng, false);
end no sol clause;
_
comment close epu;
__________________
changerec_6(epu, 0);
close(epu, false);
end nll_trans;
end
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message nll_trans not ok
lookup nll_trans)
end
▶EOF◀