{прием образа диска}
const max_err=5*6500000;
type t_mem=array[0..$FFFE]of byte;
var
fl:file;
a:^t_mem;
dat:byte;
err:longint;
pos:word;
TrNum:byte;
(****************************************************************************)
procedure error(ms:string;_pos:word);
begin
writeln('ошибка приема ',ms,' в позиции ',_pos);
halt;
end;
(****************************************************************************)
function getDats(var ddt:byte):boolean;
 begin
err:=0;
repeat
inc(err);
if err>max_err then begin getDats:=false;exit;end;
until (port[$037A] and $04)<>0;
dat:=(port[$0379] shr 3)and$0F;
err:=0;
repeat
inc(err);
if err>max_err then begin getDats:=false;exit;end;
until (port[$037A] and $04)=0;
ddt:=((port[$0379] shl 1)and$F0)or dat;
getDats:=true;
 end;
(****************************************************************************)
begin
TrNum:=0;
new(a);
assign(fl,'c:\disk0000.drv');
rewrite(fl,1);
writeln('Get dats...');
pos:=0;
while getDats(dat) do
 begin
a^[pos]:=dat;
inc(pos);
if pos=256*16 then
  begin
writeln('Write result: ',pos,' byte TRACK:',TrNum);
blockwrite(fl,a^,pos);
inc(TrNum);
pos:=0;
  end;
 end;
close(fl);
writeln('Ok');
dispose(a);
end.