# Cod sursa(job #164449)

Utilizator Data 24 martie 2008 11:19:26 Oz 0 fpc done Arhiva de probleme 1.19 kb
``````var f,g:text;
p,k,l,s,r,x,y,cmmdc,n,m,i,j:longint;
cd,a,b,c:array[1..10000] of longint;
ok:boolean;
procedure QuickSort( Lo, Hi: Integer);
procedure Sort(l, r: Integer);
var i, j, x, y: integer;
begin
i := l; j := r; x := a[(l+r) DIV 2];
repeat
while a[i]<x do i:=i+1;
while x<a[j] do j:=j-1;
if i<=j then begin
y:=a[i]; a[i]:=a[j]; a[j]:=y;
y:=b[i]; b[i]:=b[j]; b[j]:=y;
y:=c[i]; c[i]:=c[j]; c[j]:=y;
i:=i+1; j:=j-1;
end;
until i > j;
if l < j then Sort(l, j);
if i < r then Sort(i, r);
end;
begin
sort(lo,hi);
end;
begin
assign(f,'oz.in');reset(f);
assign(g,'oz.out');rewrite(g);
for i:=1 to m do
for i:=m+1 to 2*m do begin
a[i]:=b[i-m];
b[i]:=a[i-m];
c[i]:=c[i-m];
end;
m:=2*m;
quicksort(1,m);
i:=1;
p:=1;
repeat
k:=i;
if a[i]<>a[i+1] then begin cmmdc:=1; inc(i); end
else begin
cmmdc:=c[i];
while a[i]=a[i+1] do begin
x:=cmmdc;
y:=c[i+1];
r:=x mod y;
while r>0 do begin
x:=y;
y:=r;
r:= x mod y;
end;
cmmdc:=y;
inc(i);
end;
inc(i);
end;
s:=c[k] div cmmdc;
for l:=k+1 to i-1 do
s:=c[l]*s;
inc(p);
cd[p]:=s;
inc(j);
until i>m;
for i:=1 to p do
write(g,cd[i],' ');
writeln(g);
close(f);
close(g);
end.``````