|
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: »tresource«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »tresource«
procedure resource_used(out_z);
_____________________
comment subprogram resource_used;
zone out_z;
begin
boolean list,listunk,found,first;
long array field r_name,doc,en_name,en_doc;
long field r_userb,r_projb,en_base,userb,projb;
integer field r_slice_l,r_slices,r_proj,r_entries;
integer array field r_first_bs,cur,rec;
integer i,j,h,user,users,segm,userno,perm_entries,perm_segm;
long array cat_name(1:2);
zone cat(128,1,stderror);
r_name:=0;
r_proj:=10;
r_userb:=14;
r_projb:=18;
r_firstbs:=18;
userb:=usr_hi;
projb:=max_hi;
r_slicel:=10;
r_slices:=12;
r_entries:=14;
en_base:=6; en_name:=6; en_doc:=16;
init(false);
ch := 0; <*character counter*>
update := false;
all := false;
if readparam(param) = 4 then
begin
integer array resource(1:(9+7*discs//2)*(maxtracks*(513//rec_lng)));
tp:=0; action:=3;
repeat tp:=tp+1;
if param(1)=real (case tp of(
<:list:>,
<:listu:> add 'n',
<::>)) then action:=tp;
until action<>3 or tp=2;
if false then write(out,"nl",1,<:resource : :>,tp,action);
if action=3 then action:=1 else action:=action+1;
list:=action>=2;
listunk:=action=3;
action:=1;
case action of
begin
<*1_____update resources_____ *>
begin
all := true;
cur:=users:=0;
for track := 1 step 1 until max_tracks do
begin
repeat
rest := inrec_6(s_cat, rec_lng);
h_key := s_cat.h_key_f;
if h_key <> -1 and h_key <> -2 then
begin
users:=users+1;
for i:=1,2 do resource.cur.r_name(i):=s_cat.name_f(i);
resource.cur.r_proj:=s_cat.project_user;
resource.cur.r_userb:=s_cat.userb;
resource.cur.r_projb:=s_cat.projb;
doc:=r_first_bs;
d_f:=4;
for i:=1 step 2 until discs do
begin
for j:=1,2 do resource.cur.doc(j):=disc.d_f(j);
resource.cur.doc.r_slicel:=sr(i);
resource.cur.doc.r_slices:=0;
resource.cur.doc.rentries:=0;
d_f:=d_f+8;
doc:=doc+14;
end document;
cur:=cur+18+14*discs//2;
end h_key;
until rest < rec_lng;
end track;
resource.cur.rname(1):=long <:unkno:> add 'w';
resource.cur.rname(2):=long <:n:>;
doc:=r_first_bs;
d_f:=4;
for i:=1 step 2 until discs do
begin
for j:=1,2 do resource.cur.doc(j):=disc.d_f(j);
resource.cur.doc.r_slicel:=sr(i);
resource.cur.doc.r_slices:=0;
resource.cur.doc.r_entries:=0;
d_f:=d_f+8;
doc:=doc+14;
end;
rec:=0;
catname(1):=long <:catal:> add 'o';
catname(2):=long <:g:>;
i:=lookup_entry(cat_name,tail);
if i<>0 then alarm(<:***catalog error :>,i);
segm:=tail(1);
cur:=0;
open(cat,4,<:catalog:>,0);
perm_entries:=perm_segm:=0;
for segm:=segm step -1 until 1 do
begin
inrec6(cat,512);
for rec:=0 step 34 until 512-34 do
begin
if cat.rec(1)<>-1 then
begin
if cat.rec(1) extract 3>=3 then
begin
perm_entries:=perm_entries+1;
if false then
write(out,"nl",1,true,13,cat.rec.en_name,true,6,cat.rec(8),
true,12,cat.rec.en_doc,
cat.rec.en_base shift (-24) extract 24,
cat.rec.en_base extract 24);
cur:=-(18+14*discs//2);
user:=0;
repeat user:=user+1;
cur:=cur+18+14*discs//2;
userno:=resource.cur.r_proj extract 8;
found:=(cat.rec.en_base=resource.cur.r_userb and
resource.cur.r_userb<>resource.cur.r_projb) or
(cat.rec.en_base=resource.cur.r_projb and (userno=0 ));
until found or user=users+1;
if listunk and -,found then
begin
write(out_z,"nl",1,<:**:>,true,12,cat.rec.enname,
true,12,cat.rec.endoc,<< -ddddddd>,
cat.rec.enbase shift (-24) extract 24,
cat.rec.enbase extract 24);
end;
doc:=r_first_bs;
i:=-1;
repeat i:=i+2;
if cat.rec(8)>=0 then
found:=resource.cur.doc(1)=cat.rec.endoc(1) and
resource.cur.doc(2)=cat.rec.endoc(2) else
found:=lookupauxentry(cat.rec.en_name,resource.cur.doc,tail)=0;
if permentries<8 and false then write(out,"nl",1,
true,12,resource.cur.rname,true,12,cat.rec.en_name,
true,8,resource.cur.doc,<:::>,true,8,cat.rec.endoc,
resource.cur.doc.rslicel,resource.cur.r_proj);
if found then
begin
resource.cur.doc.rentries:=resource.cur.doc.rentries+1;
if cat.rec(8)>0 then
begin
resource.cur.doc.rslices:=resource.cur.doc.rslices+
(cat.rec(8)+resource.cur.doc.rslicel-1)//
resource.cur.doc.rslicel;
perm_segm:=perm_segm+cat.rec(8);
end segments>0;
end document found;
doc:=doc+14;
until found or i>=discs;
end permkey;
end entry;
end record;
end segments;
if list then
begin
write(out_z,"ff",1,"nl",2,<:resource list: users:>,users,
<: entries:>,permentries,<: segments:>,permsegm,"nl",1,
true,11,<:name:>,true,11,<:doc:>,
<:__entries:>,<:_segments:>,<:___slicel:>);
cur:=0;
for user:=1 step 1 until users+1 do
begin
write(outz,"nl",1,true,11,resource.cur.rname);
first:=true;
doc:=r_first_bs;
for i:=2 step 2 until discs do
begin
found:=resource.cur.doc.rslices>0 or
resource.cur.doc.rentries>0;
if found then
begin
if -,first then write(out_z,"nl",1,"sp",11);
first:=false;
write(out_z,true,11,resource.cur.doc,
true,9,<< ddddddd>,resource.cur.doc.rentries,
true,9,resource.cur.doc.rslices*resource.cur.doc.rslicel,
true,9,resource.cur.doc.rslicel);
end found;
doc:=doc+14;
end discs;
cur:=cur+18+14*discs//2;
end user;
end list;
<*update resources used*>
cur:=-(18+14*discs//2);
for user:=1 step 1 until users do
begin
cur:=cur+18+14*discs//2;
h:=hash(resource.cur.r_name,max_tracks);
found:=search(h, max_tracks,resource.cur.r_name,1,true);
if -,found then found:=search(0,h,resource.cur.rname,1,true);
if found then
begin
di_f:=first_bs_ref-size_bs_ref;
doc:=r_first_bs;
found:=false;
for t:=1 step 2 until discs do
begin
di_f:=di_f+size_bs_ref;
s_cat.dif(7):=resource.cur.doc.rslices*resource.cur.doc.rslicel;
s_cat.dif(6):=resource.cur.doc.rentries;
doc:=doc+14;
end discs;
end found else error(2);
end users;
end action 1;
end action;
end param=.text else error(8);
if readparam(param) <> 0 then error(13);
end resource;
procedure quicksort(lo,r,projno,names);
value lo,r; integer lo,r;
integer array projno;
long array names;
begin
integer i,j,k;
integer x,w;
long wl;
long array field lwi,lwj;
i:=lo; j:=r;
x:=projno((lo+r)//2);
while i<=j do begin
while projno(i)<x do i:=i+1;
while projno(j)>x do j:=j-1;
if i<=j then begin
w:=projno(i); projno(i):=projno(j); projno(j):=w;
lwi:=(i-1)*8; lwj:=(j-1)*8;
wl:=names.lwi(1); names.lwi(1):=names.lwj(1); names.lwj(1):=wl;
wl:=names.lwi(2); names.lwi(2):=names.lwj(2); names.lwj(2):=wl;
i:=i+1; j:=j-1;
end i<=j;
end loop;
if lo<j then quicksort(lo,j,projno,names);
if i<r then quicksort(i,r,projno,names);
end quicksort;
▶EOF◀