2 задачи помогите решить

type
aType = array [1..200] of Word;
var
A, B, C : aType;
Nom, Na, Nb, Nc : Byte;

function isPrimary(N : Word) : Boolean;
var
D : Word; Q : Real;
begin
if N = 0 then begin isPrimary := False; Exit; end;
if N = 1 then begin isPrimary := True; Exit; end;
if N = 2 then begin isPrimary := True; Exit; end;
if N = 3 then begin isPrimary := True; Exit; end;
if N mod 2 = 0 then begin isPrimary := False; Exit; end;
if N mod 3 = 0 then begin isPrimary := False; Exit; end;

D := 3; Q := Sqrt(N);
while D <= Q do
begin
if N mod D = 0 then begin isPrimary := False; Exit; end;
D := D + 2;
end;

isPrimary := True;
end;

procedure Primary;
var
Nom : Byte;
begin
Nb := 0;
for Nom := 1 to Na do
if isPrimary(A[Nom]) then
begin
Inc(Nb);
B[Nb] := A[Nom];
end;
end;

function isIdeal(N : Word) : Boolean;
var
D, S : Word; Q : Real;
begin
S := 1; D := 2; Q := N / 2;
while D <= Q do
begin
if N mod D = 0 then S := S + D;
D := D + 1;
end;
isIdeal := (S = N);
end;

procedure Ideal;
var
Nom : Byte;
begin
Nc := 0;
for Nom := 1 to Na do
if isIdeal(A[Nom]) then
begin
Inc(Nc);
C[Nc] := A[Nom];
end;
end;

procedure DelIdeal;
var
Nom, Pos : Byte;
begin
for Nom := Na downto 1 do
if isIdeal(A[Nom]) then
begin
Dec(Na);
for Pos := Nom to Na do A[Pos] := A[Pos + 1];
end;
end;

procedure OutArr(S : String; M : aType; N : Byte);
var
Nom : Byte;
begin
WriteLn(S);
for Nom := 1 to N do Write(M[Nom], ' '); WriteLn;
end;

begin
Write('Введите N = '); ReadLn(Na);
for Nom := 1 to Na do begin Write('A[', Nom, '] = '); ReadLn(A[Nom]); end;

Primary;
Ideal;

OutArr('Исходный массив :', A, Na);
OutArr('Массив простых чисел :', B, Nb);
OutArr('Массив идеальных чисел :', C, Nc);
DelIdeal;
OutArr('Исходный массив без идеальных чисел :', A, Na);
end.