|
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: 19968 (0x4e00)
Types: TextFile
Names: »nllfnctx«
└─⟦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_reduction epu * page 1 5 12 78, 9.57;
; nll_fnc
; ********
nll_fnc = set 1 disc
nll_fnc = algol
external real procedure nll_fnc
_______________________________
_ (nlu, nlr, gen_catalog, SING, params);
zone nlr;
array nlu, SING, params;
integer array gen_catalog;
comment
nll_fnc (return, real)
the procedure operates on one datamatic block of normal equations
after CHOLESKY's method.
THe modes of operation are as follows:
1 : reduction of one block in part of a triangular array, i.e.
the block is first reduced with previously reduced blocks and
subsequently with itself.
2a: reduction of one or more right-hand sides
2b: back-solution of the right-hand sides (only implemented for
one rhs at present - and yet only in single precision.
nlu (call and return, array)
the unreduced block of normal equations stored in double precision
with the head in the first half of the array and the tails in the
last half. the first part of the head contains a catalogue
describing the block
byte content
2 the length of the array
4 sumcheck word
6 block no starting from 1 and upwards
8 - 1
10 first column no in block
12 last column no in block
14 relative byte addr of row no 0 in first col of block
16 - - - - - - - - secnd - - -
12+2*relcolnr_o rel byte addr of row no 0 il rel col no
12+2*last rel colno rel byte addr or row no 0 in last col
14+2*last_rel_col_no no of saved zeroes in fistr col
16+2*last rel col no of save
_ fields in nlu and nlr
_
byte name content
2 lng length of block
4 recsum sum of records
6 blocknr
8 sing
10 fc first col in block
12 lc last col in block
14 i1(fc) index of 1first row
16 i1(fc+1) index of first row
sz(fc) save d zeroes
_ sz(lc) saved zeroes
_ n first coeff of normals
\f
comment nll_reduction epu * page 2 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 ;
comment
_
gen_catalog (call) general catalogue of the blocks
_
_ fields in gen cat:
gc_lc integer 1:blocks col no of last col in block
SING (array, return) bit pattern of sing
_ 1=sing, 0=not sing
params (call and return) array
parameters for control and information exchange
fields in params
byte nr type content
2 integer exp limit for sing action
4 integer max loss of exponent
8 real sqrt of red rhs scalar product
9 boolean true when rhs
10 boolean true when back solution
SING, exp limit, and maxloss are used only when the boolean in
byte 9 is true, and sqr rhs scalar product only when false;
\f
comment nll_reduction epu * page 3 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 ;
begin
comment nll parameters;
real array field i1u, i1r;
integer array field cat_i1r, cat_i1u, cat_szr, cat_szu;
integer field lng_f, sum_f, block_f, sing_f, ctw_f,
_ dsp_f, fcol_f, lcol_f, explim_f, maxloss_f,
_ loss_f, res_f, rmax_f, grp_f;
real field KT;
integer r, s, t, u, fc, lc, fr, lr, fu, lu,
_ segs_pr_bl, block, neq_blocks, red_blocks,
_ rm1, szr, szu, min_szu, sing, sbt, spt,
_ maxloss, maxtest, expNI, explim, rmax,
_ fnc_gr, u1, r1, rhs_nmb;
real sum, NI;
boolean rhs, back_sol, fnc;
boolean field rhs_f, back_sol_f, fnc_f;
comment epu parameters;
zone epu(4*128, 1, nll_block);
integer array field word;
array field status_f;
integer add1, zadd1, zsub1, mla, zmla, mls, zmls, div1,
_ dia, chl, str1, sqr1, z, max_word,
_ code_length, save_prod_addr,
_ nlu_base, tail_displ,
_ nlr_base, nlr_file, nlr_block,
_ one_addr, fnc_addr;
real save_prod, one;
comment def of fields in params;
explim_f := 2;
maxloss_f := 4;
KT := 8;
rhs_f := 9;
back_sol_f := 10;
rmax_f := 12;
comment info from params;
rhs := params.rhs_f;
back_sol := params.back_sol_f;
comment def of initial fields in nl;
lng_f := 2;
sum_f := lng_f + 2;
block_f := sum_f + 2;
sing_f := block_f + 2;
dsp_f := sing_f + 2;
grp_f := dsp_f +2;
fcol_f := grp_f + 2;
lcol_f := fcol_f + 2;
\f
comment nll_reduction epu * page 4 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 ;
_
comment def of cat and sz fields in nlu;
________________________________________
red_blocks := nlu.block_f - 1;
rhs_nmb := gen_catalog(red_blocks) + 1;
fu := nlu.fcol_f;
lu := nlu.lcol_f;
cat_i1u := lcol_f - 2*(fu - 1);
cat_szu := cat_i1u + 2*(lu - fu + 1);
status_f := cat_szu + 2*(lu - 2*fu + 2);
segs_pr_bl := nlu.lng_f//1024;
tail_displ := nlu.dsp_f;
fnc_gr := nlu.grp_f;
nlu_base := abs_addr(nlu);
rmax := params.rmax_f;
fnc := fnc_gr > 0;
comment temp storage for product sum;
save_prod_addr := abs_addr(save_prod);
comment def of params of nlr;
nlr_base := abs_addr(nlr);
getposition(nlr, nlr_file, nlr_block);
comment def of epu variables;
code_length := 4*4*128;
max_word := code_length - 30;
open(epu, 14, <:ympe:>, 55 shift 17);
outrec_6(epu, code_length);
comment epu instructions;
z := 1 shift 23;
add1 := 0 shift 12 + 1;
zadd1 := z + add1;
zsub1 := z + 1 shift 12 + 1;
mla := 2 shift 12 + 0;
zmla := 1 shift 23 + 2 shift 12 + 0;
mls := 3 shift 12 + 0;
zmls := z + mls;
str1 := 4 shift 12 + 1;
div1 := 5 shift 12 + 1;
sqr1 := 6 shift 12 + 1;
dia := 7 shift 12 + params.explim_f;
chl := 8 shift 12 + params.explim_f;
comment prepare blockskip;
minszu := (-1) shift (-1);
for t := fu step 1 until lu do
if nlu.cat_szu(t) < min_szu then
min_szu := nlu.cat_szu(t);
\f
comment nll_reduction epu * page 5 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 ;
_
comment block loop;
___________________
for block := 0 step 1 until red_blocks do
if gen_catalog(block) > min_szu then
begin comment block prod feasible;
setposition(nlr, nlr_file, block*segsprbl + nlr_block);
invar(nlr);
word := 0;
fr := gen_catalog(block - 1) + 1;
lr := gen_catalog(block);
cat_i1r := lcol_f - 2*(fr - 1);
cat_szr := cat_i1r + 2*(lr - fr + 1);
for u := fu step 1 until lu do
begin comment reduce one column;
i1u := nlu.cat_i1u(u) + nlu_base;
szu := nlu.cat_szu(u) + 1;
for r := fr step 1 until lr do
if szu <= r then
begin comment scalar product;
i1r := nlr.cat_i1r(r) + nlr_base;
szr := nlr.cat_szr(r) + 1;
if szr < szu then szr := szu;
rm1 := r - szr;
szr := szr shift 2;
if r <= rmax then
begin comment complete reduction;
if rm1 <= 4095 then
epu.word( 1) := zmls + rm1
else
begin
epu.word( 1) := zmls + 4095;
epu.word( 2) := i1u + szr;
epu.word( 3) := i1r + szr;
epu.word( 4) := mls + rm1 - 4095;
szr := 4095 shift 2 + szr;
word := word + 6;
end;
epu.word(2) := i1u + szr;
epu.word(3) := i1r + szr;
epu.word(4) := chl;
epu.word(5) := nlu_base + status_f + u shift 2;
epu.word(6) := tail_displ;
word := word + 12;
end complete reduction
\f
<* nll_reduction epu * page 6 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 *>
else
begin comment partial reduction;
rm1 := rm1 + 1 - r + rmax;
if rm1 > 0 then
begin
if rm1 <= 4095 then
epu.word( 1) := zmls + rm1
else
begin
epu.word( 1) := zmls + 4095;
epu.word( 2) := i1u + szr;
epu.word( 3) := i1r + szr;
epu.word( 4) := mls + rm1 - 4095;
szr := 4095 shift 2 + szr;
word := word + 6;
end;
epu.word(2) := i1u + szr;
epu.word(3) := i1r + szr;
epu.word(4) := add1;
epu.word(5) :=
epu.word(8) := i1u + r shift 2;
epu.word(6) :=
epu.word(9) := epu.word(5) + tail_displ;
epu.word(7) := str1;
word := word + 18;
end rm1 > 0;
end partial reduction;
if word > max_word then
to_epu(epu, word, code_length, false);
end scalar product;
end red of one col;
if word <> 0 then
to_epu(epu,word, code_length, false);
end block reduction;
\f
comment nll_reduction epu * page 7 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 ;
_
comment autoreduction of block;
_______________________________
if -, (rhs or back_sol or fnc) then
begin
word := 0;
for u := fu step 1 until lu do
begin comment col of unred block;
i1u := nlu.cat_i1u(u) + nlu_base;
szu := nlu.cat_szu(u) + 1;
for r := fu step 1 until u do
if szu <= r then
begin comment scalar product;
i1r := nlu.cat_i1u(r) + nlu_base;
szr := nlu.cat_szu(r) + 1;
if szr < szu then szr := szu;
rm1 := r - szr;
szr := szr shift 2;
if r <= rmax then
begin comment complete reduction;
if rm1 <= 4095 then
epu.word( 1) := zmls + rm1
else
begin
epu.word( 1) := zmls + 4095;
epu.word( 2) := i1u + szr;
epu.word( 3) := i1r + szr;
epu.word( 4) := mls + rm1 - 4095;
szr := 4095 shift 2 + szr;
word := word + 6;
end;
epu.word(2) := i1u + szr;
epu.word(3) := i1r + szr;
epu.word(4) := chl;
epu.word(5) := nlu_base + status_f + u shift 2;
epu.word(6) := tail_displ;
word := word + 12;
end complete reduction
\f
<* nll_reduction epu * page 8 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 *>
else
begin comment partial reduction;
rm1 := rm1 + 1 - r + rmax;
if rm1 > 0 then
begin
if rm1 <= 4095 then
epu.word( 1) := zmls + rm1
else
begin
epu.word( 1) := zmls + 4095;
epu.word( 2) := i1u + szr;
epu.word( 3) := i1r + szr;
epu.word( 4) := mls + rm1 - 4095;
szr := 4095 shift 2 + szr;
word := word + 6;
end;
epu.word(2) := i1u + szr;
epu.word(3) := i1r + szr;
epu.word(4) := add1;
epu.word(5) :=
epu.word(8) := i1u + r shift 2;
epu.word(6) :=
epu.word(9) := epu.word(5) + tail_displ;
epu.word(7) := str1;
word := word + 18;
end rm1 > 0;
end partial reduction;
if word > max_word then
to_epu(epu, word, code_length, false);
end scalar product;
end red of col;
\f
if word <> 0 then
to_epu(epu,word, code_length, false);
comment * page ;
comment test of exponent losses;
maxloss := params.maxloss_f;
sing := 0;
spt := (fu + 47)//48;
sbt := (fu - 1) mod 48;
if sbt <> 0 then
SING(spt) := SING(spt) shift (sbt - 48);
comment exp loss test loop;
for u := fu step 1 until lu do
begin
sbt := sbt + 1;
if sbt = 49 then
begin
sbt := 1;
spt := spt + 1;
end;
SING(spt) := SING(spt) shift 1;
if u <= rmax then
begin
loss_f := status_f + u shift 2;
res_f := loss_f - 2;
if nlu.loss_f > maxloss then
maxloss := nlu.loss_f;
if nlu.res_f > 2 then
begin
sing := sing + 1;
SING(spt) := SING(spt) add 1;
end;
end u<=rmax;
end u loop;
nlu.sing_f := sing;
SING(spt) := SING(spt) shift (48 - sbt);
params.maxloss_f := maxloss;
nll_fnc := maxloss;
end -, (rhs or back_sol)
\f
<* nll_reduction epu * page 10 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 *>
else if rhs then
begin comment reduction of rhs;
max_word := code_length - 36;
word := 0;
save_prod_addr := absaddr(save_prod);
for u := fu step 1 until lu do
begin comment red of rhs cols;
i1u := nlu.cat_i1u(u) + nlu_base;
szu := nlu.cat_szu(u) + 1;
rm1 := u - szu;
szu := szu shift 2;
if fu - 1 <= rmax then
begin comment complete reduction of rhs;
if rm1 <= 4095 then
epu.word( 1) := zmls + rm1
else
begin
epu.word( 1) := zmls + 4095;
epu.word( 2) :=
epu.word( 3) := i1u + szu;
epu.word( 4) := mls + rm1 - 4095;
szu := 4095 shift 2 + szu;
word := word + 6;
end;
epu.word( 2) :=
epu.word( 3) := i1u + szu;
epu.word( 4) := sqr1;
epu.word( 5) := nlu_base + status_f + u shift 2;
epu.word( 7) := add1;
epu.word( 8) :=
epu.word(11) := i1u + u shift 2;
epu.word( 9) := epu.word(8) + tail_displ;
epu.word(10) := sqr1;
end complete reduction
else
\f
<* nll_reduction epu * page 11 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 *>
begin comment partial reduction;
rm1 := rm1 - fu + 1 + rmax;
if rm1 > 0 then
begin
if rm1 <= 4095 then
epu.word( 1) := zmls + rm1
else
begin
epu.word( 1) := zmls + 4095;
epu.word( 2) :=
epu.word( 3) := i1u + szu;
epu.word( 4) := mls + rm1 - 4095;
szu := 4095 shift 2 + szu;
word := word + 6;
end;
epu.word(2) :=
epu.word(3) := i1u + szu;
epu.word(4) := add1;
epu.word(5) :=
epu.word(8) := i1u + u shift 2;
epu.word(6) :=
epu.word(9) := epu.word(5) + tail_displ;
epu.word(7) := str1;
word := word - 6;
end
else
word := word - 24;
end partial reduction;
word := word + 24;
if word > max_word then
to_epu(epu, word, code_length, false);
end u-control;
if word <> 0 then
to_epu(epu,word, code_length, false);
i1u := nlu.cat_i1u(fu);
nll_fnc :=
NI := nlu.i1u(fu);
\f
if fu - 1 <= rmax then
begin comment enp of first rhs col;
save_prod := nlu.status_f(fu);
params.KT := if NI > '-280 and save_prod > '-280 then
_ (mu*ln(NI/save_prod)) else (-'50);
end enp;
end rhs or back sol
\f
<* nll_reduction epu * page 13 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 *>
else if fnc then
begin
one := 1.0;
one_addr := abs_addr(one);
word := 0;
for t := fu step fnc_gr until lu do
begin
for u := 0 step 1 until fnc_gr - 1 do
begin
i1_u := nlu.cat_i1u(t + u) + nlu_base;
sz_u := nlu.cat_szu(t + u) + 1;
fnc_addr := i1u + (t + u - szu + 1) shift 2;
for r := 0 step 1 until u do
if szu <= t + r then
begin
i1r := nlu.cat_i1u(t + r) + nlu_base;
szr := nlu.cat_szu(t + r) + 1;
if szr < szu then szr := szu;
rm1 := rhs_nmb - szr;
szr := szr shift 2;
if rm1 <= 4095 then
epu.word(1) := zmla + rm1
else
begin
epu.word(1) := zmla + 4095;
epu.word(2) := i1u + szr;
epu.word(3) := i1r + szr;
epu.word(4) := mla + rm1 - 4095;
szr := 4095 shift 2 + szr;
word := word + 6;
end;
epu.word(2) := i1u + szr;
epu.word(3) := i1r + szr;
epu.word(4) := div_1;
epu.word(5) := fnc_addr + r shift 2;
epu.word(6) := one_addr;
word := word + 12;
if word > max_word then
to_epu(epu, word, code_length, false);
end r-loop;
end u-loop;
end t-loop;
\f
if word <> 0 then
to_epu(epu,word, code_length, false);
end fnc ;
\f
comment nll_reduction epu * page 15 5 12 78, 9.57
0 1 2 3 4 5 6 7 8 9 ;
i1u := nlu.cat_i1u(fu);
comment removed later;
if back_sol then
begin comment back-solution of nlu;
if false then
begin
_
comment clear tail of rhs;
__________________________
t := 0;
for r := fu step 1 until lu do
t := t + r - nlu.cat_szu(r);
word := 0;
epu.word(1) := z + str_1 + (t - 1)//2;
write(out, nl, 1, <:antal clearede elem:>, t);
epu.word(2) := nlu.cat_i1u(fu) + nlu_base + tail_displ;
epu.word(3) := epu.word(2) + (t//2)*4;
word := 6;
epuprint(epu, 6);
write(out, nl, 1, <:nlu.lngf, nlubase tail displ i1u :>,
<<-ddddd>, nlu.lng_f, nlubase, taildispl, i1u, nl, 1, fu);
end;
for block := red_blocks step -1 until 0 do
begin
setposition(nlr, nlr_file, segs_pr_bl*block + nlr_block);
invar(nlr);
fr := gen_catalog(block - 1) + 1;
lr := gen_catalog(block);
word := 0;
cat_i1r := lcol_f - 2*(fr - 1);
cat_szr := cat_i1r + 2*(lr - fr +1);
for r := lr step -1 until fr do
begin
i1r := nlr.cat_i1r(r);
szr := nlr.cat_szr(r);
rm1 := r - 1;
NI := nlu.i1u(r) := nlu.i1u(r)/nlr.i1r(r);
for t := szr + 1 step 1 until rm1 do
nlu.i1u(t) := nlu.i1u(t) - NI*nlr.i1r(t);
end;
end back sol blocks;
end rhs red and back sol;
changerec_6(epu, 0);
close(epu, true);
end nll_fnc;
end
\f
; nll_reduction epu * page 16 5 12 78, 9.57;
if ok.no
mode warning.yes
if warning.yes
(mode 0.yes
message nll_fnc not ok
lookup nll_fnc)
end
finis
▶EOF◀