подпрограммы

uses crt;
var mas:array[1..500] of word;
     i,j:word;
 
procedure poisk;
var s:string;
     a,b,c,d,x:byte;
begin
  j:=0;
  for i:=1000 to 9999 do
  begin
    str(i,s);
    val(s[1],a,x);
    val(s[2],b,x);
    val(s[3],c,x);
    val(s[4],d,x);
    if (a<b)and(b<c)and(c<d) then
    begin
      j:=j+1;
      mas[j]:=i;
    end;
  end;
end;
begin
  clrscr;
  poisk;
  for i:=1 to j do
  begin
    write(mas[i],'  ');
    if i mod 10 =0 then
    writeln;
  end;
  readln;
end.

uses crt;
type Arr=array[1..100]of integer;
var a,b:arr;
n,i:integer;
 
procedure search(a:arr; na:integer; var b:arr; var nb:integer);
var i,c1,c2,c3,c4:integer;
begin
 nb:=0;
 for i:=1 to na do
 begin
  c1:=a[i] div 1000;
  c2:=a[i] mod 1000 div 100;
  c3:=a[i] mod 100 div 10;
  c4:=a[i] mod 10;
  if  (c1<>0) and (c1<c2) and (c2<c3) and (c3<c4) then
  begin
   inc(nb);
   b[nb]:=a[i];
  end;
end;
 
procedure input(var a:arr; n:integer);
var i:integer;
begin
 for i:=1 to n do
 begin
  write('M[',i,'] -> ');
  readln(a[i]);
 end;
end;
 
procedure print(a:arr; n:integer);
var i:integer;
begin
 for i:=1 to n do write(a[i],' ');
 writeln;
end;
 
BEGIN
 clrscr;
 write('Введите размерность массива -> ');
 readln(n);
 writeln('Введите массив');
 input(a,n);
 search(a,n,b,k);
 writeln('Найденные числа');
 print(b,k);
 readln;
end.