Проблема не дающая заснуть уже четвертый день:
Дана целая матрица размера nxm. Для каждой строки матрицы найти сумму четных элементов и произведение нечетных. Результаты оформить в виде матрицы (nx2). В полученной матрице упорядочить (переставить) строки по возрастанию второго элемента в строке.
Буду признателен за любую помощь.

А что уже готово, какие моменты неопнятны/не получаются ? Вот загляни в наш FAQ по массивам и матрицам, может найдешь ответы на свои вопросы : http://forum.pascal.net.ru/index.php?showtopic=2694

На усмотрение модератора выкладываю свое решение, захотелось отвлечься и решил сделать задачу :p2:

код временно скрыт... Пусть автор сначала скажет что у него конктретно не получается. админ.

вырезанно

АВТОР ПРОГРАММЫ: klem4

uses crt;
const
   n=3;
   m=4;
type

   TArr = array[1..n, 1..m] of integer;

var
   arr : TArr;

   result : TArr;

   t : byte;

procedure InitArray(var x : TArr);
const
   rnd = 11;
var
   i,j : byte;
begin
   randomize;
   for i := 1 to n do
    for j := 1 to m do
     x[i,j] := random(rnd);
end;

procedure PrintArray(x : TArr ; sizeN, sizeM : byte);
var
   i,j : byte;
begin
   for i := 1 to sizeN do begin
      writeln;
      for j := 1 to sizeM do
       write(x[i,j] : 2, '  ');
   end;
   writeln;
end;

function Addition(x : TArr; i : byte) : integer;
var
   j : byte;
   S : integer;
begin

   s := 0;
   j := 2;

   while(j<=m) do begin
      inc(s, x[i,j]);
      inc(j, 2);
   end;

   Addition := s;

end;

function Multiplication(x : TArr; i : byte) : integer;
var
   j : byte;
   p : integer;
begin

   p := 1;
   j := 1;

   while(j<=m) do begin
      p := p*x[i,j];
      inc(j, 2);
   end;

   Multiplication := p;

end;

procedure SortResult(var x : TArr);
var
   i,temp : byte;
   flag : boolean;
begin

   flag := false;

   repeat

      flag := true;

      for i := 1 to n-1 do
       if not(x[i, 2]>=x[succ(i), 2]) then begin

          flag := false;

          temp := x[i, 1];
          x[i, 1] := x[succ(i), 1];
          x[succ(i), 1] := temp;

          temp := x[i, 2];
          x[i, 2] := x[succ(i), 2];
          x[succ(i), 2] := temp;

       end;

   until flag;

end;

Begin

   clrscr;

   InitArray(arr);

   PrintArray(arr, n, m);

   for t := 1 to n do begin
      result[t, 1] := Addition(arr, t);
      result[t, 2] := Multiplication(arr, t);
   end;

   PrintArray(result, n, 2);

   SortResult(result);

   PrintArray(result, n, 2);

   readln;
End.

program test;
uses crt;
Const
 NN=10;
 MM=10;
type
 TElem = integer;
 Matrix = array[1..NN,1..MM] of integer;
Procedure ReadMatr(var A:Matrix; var n,m:word );
var
 i,j:word;
begin
 clscr;
 repeat
  write('Enter stroks: '); readln(N)
 until (N>0) and (N<=NN);
 repeat
  write('Enter stolbs: '); readln(M)
 until (M>0) and (M<=MM);
 For i:=1 to n do
 begin
  For j:=1 to m do
  begin
   write('A[',i,j,']= ');
   readln(A[i,j])
  end
 end
end;
begin

For i:=1 to n do
begin
  For j:=1 to m do
  begin
  if i mod 2 = 0 then
  ...........................

Первый момент: неясно как Для каждой строки матрицы найти сумму четных элементов и произведение нечетных.

Procedure PrintMatr(A:Matrix; n,m:word);
Var
 i,j:word;
begin
For i:=1 to n do
 begin
  For j:=1 to m do write(A[i,j],' ');
  writeln
 end
end;
var
 n,m:word;
 a:matrix;
Begin
 Readmatr(a,n,m);
 PrintMatr(a,n,m);3
readln;
end.

А второй: как результаты оформить в виде матрицы (nx2). В полученной матрице упорядочить (переставить) строки по возрастанию второго элемента в строке.
В общем-то получается что ничего неясно... Сделал я похоже в своей жизни вторую ошибку.

Еще один вариант, более простой и, по-моему, более правильно интерпретирующий условие (пока тоже скрыто) :

uses crt;
const
   n=3;
   m=4;
type
  TVec = array[1 .. m] of integer;
  TArr = array[1 .. n] of TVec;


procedure InitArray(var x : TArr);
var i, j : byte;
begin
  randomize;
  for i := 1 to n do
    for j := 1 to m do
      x[i, j] := random(11);
end;

procedure PrintArray(x : TArr ; sizeN, sizeM : byte);
var i, j : byte;
begin
  for i := 1 to sizeN do begin
    writeln;
    for j := 1 to sizeM do
      write(x[i,j]: 2, '  ');
  end;
  writeln;
end;

function Addition(x : TArr; i : byte) : integer;
var
  j : byte;
  S : integer;
begin
  s := 0;
  for j := 1 to m do
    if not odd(x[i, j]) then
      inc(s, x[i, j]);
  Addition := s;
end;

function Multiplication(x : TArr; i : byte) : integer;
var
  j : byte;
  p : integer;
begin
  p := 1;
  for j := 1 to m do
    if odd(x[i, j]) then
      p := p * x[i, j];
  Multiplication := p;
end;

procedure SortResult(var x : TArr);
var
  i: byte;
  flag: boolean;
  T: TVec;
begin
  flag := false;
  repeat

    flag := true;
    for i := 1 to n-1 do
      if x[i, 2] < x[succ(i), 2] then begin
        flag := false;
        T := x[i]; x[i] := x[succ(i)]; x[succ(i)] := T
      end;

   until flag;
end;

var
  arr, _result : TArr;
  t: byte;

Begin
  clrscr;
  InitArray(arr);
  PrintArray(arr, n, m);

  for t := 1 to n do begin
    _result[t, 1] := Addition(arr, t);
    _result[t, 2] := Multiplication(arr, t);
  end;

  PrintArray(_result, n, 2);
  SortResult(_result);
  PrintArray(_result, n, 2);
  readln;
End.

const m = ...; n = ...;
{ a - сама матрица, i - номер строки, в которой искать сумму }
function sum(a: matrix; i: byte): integer;
var j, s: integer;
begin
  s := 0;
  for j := 1 to m do
    if not odd(a[i, j]) then inc(s, a[i, j]);
  sum := s;
end;

Для умножения - аналогично...


Посмотри FAQ: Методы сортировок
и заодно вот это: FAQ: Как задать матрицу, чтобы быстро поменять местами ее строки
Этого должно хватить.

"Не сразу Москва строилась" (С)

:fire: :help:
Я в тупике (точнее тупик в моей голове) :ypr: . Ну не могу я написать эту :ryg: программу. Мож чего не догнал :orangun: И так еще раз и попорядку:
1. Мне надо ВВЕСТИ матрицу в память (точно вот так):

program test;
uses crt;
const
 NN=10;
 MM=10;
type
 TElem = integer;
 Matrix = array[1..NN,1..MM] of integer;
Procedure ReadMatr(var A:Matrix; var n,m:word );
var
 i,j:word;
begin
 clrscr;
 repeat
  write('Enter stroks: '); readln(N)
 until (N>0) and (N<=NN);
 repeat
  write('Enter stolbs: '); readln(M)
 until (M>0) and (M<=MM);
 For i:=1 to n do
 begin
  For j:=1 to m do
  begin
   write('A[',i,j,']= ');
   readln(A[i,j])
  end
 end
end;

2.Для каждой строки матрицы найти сумму четных элементов и произведение нечетных.

Сумма ЧЕТНЫХ:

function sum(a: matrix; i: byte): integer;
var j, s, n: integer;
begin
  s := 0;
  for j:= 1 to n do
    if odd(a[i, j]) then inc(s, a[i, j]);
  sum := s;
end;

Произведение НЕЧЕТНЫХ:

function umn(a: matrix; i: byte): integer;
var j, r, n: integer;
begin
  r := 0;
  for j:= 1 to n do
    if not odd(a[i, j]) then (r, a[i, j])*(r, a[i,j]);
  umn := r;
end;

3. Вывести s и r виде матрицы матрицы (nx2). В полученной матрице упорядочить (переставить) строки по возрастанию второго элемента в строке.

???

В итоге если это правильно написать и составить по пунктам 1, 2, 3 должно работать, но как это сделать не понятно???
:help:

jetman, во-первых, посмотри пост №6 (я его только что открыл, раньше ты его не мог видеть, ну и пост №4 заодно...), а во вторых:

function umn(a: matrix; i: byte): integer;
var j, r, n: integer;
begin
  r := 0; { <-- Здесь первая ошибка !!! }
  for j:= 1 to n do
    if not odd(a[i, j]) then (r, a[i, j])*(r, a[i,j]); { <-- Вторая ошибка !!! }
  umn := r;
end;

Первая ошибка: после того, как ты R присвоил 0, неважно, что ты будешь делать дальше, у тебя произведение ВСЕГДА будет равно 0... Нулем инициализируется переменная при сложении; при умножении надо инициализировать единицей...

Вторая: (r, a[i, j])*(r, a[i,j]) ... Что бы этим хотел сделать? Вот так находится произведение:

...
if not odd(a[i, j]) then r := r * a[i, j];
...

Я конечно дико извиняюсь , но ведь приведенные вами программы работают по принципу случайных чисел, а мне (как я понял) нужно вводит матрицу самому (вручную) или я опять чего-то непонял

Ну, так замени

     x[i,j] := random(11);

на

begin
  write('x[', i, ',', j, '] = '); readln(x[i,j]);
end;

в процедуре InitArray...

program test;

uses crt;

const

   n=5; {Должен ведь ограничивать максимальный размер матрицы,

   m=5; но почему то этого не делает}

type

  TVec = array[1 .. m] of integer;

  TArr = array[1 .. n] of TVec;

procedure InitArray(var x : TArr);

var i, j, m, n : byte;

begin

clrscr;

  repeat

   begin;

    write('Enter lines quantity, please: ');

    readln(n);

   end;

  until (n>0) and (n<=n);

  repeat

   begin

    write('Enter columns quantity, please: '); 

    readln(m)
 
end

  until (m>0) and (m<=m);

  for i := 1 to n do

    for j := 1 to m do

begin;      

write('x[', i, ',', j, '] = '); readln(x[i,j]);

end;

end;

procedure PrintArray(x : TArr ; sizeN, sizeM : byte);

var i, j : byte;

begin

  for i := 1 to sizeN do begin

    writeln;

    for j := 1 to sizeM do

      write(x[i,j]: 2, '  ');

  end;

  writeln;

end;

function Addition(x : TArr; i : byte) : integer;

var

  j : byte;

  S : integer;

begin

  s := 0;

  for j := 1 to m do

    if not odd(x[i, j]) then

      inc(s, x[i, j]);

  Addition := s;

end;

function Multiplication(x : TArr; i : byte) : integer;

var

  j : byte;

  p : integer;

begin

  p := 1;

  for j := 1 to m do

    if odd(x[i, j]) then

      p := p * x[i, j];

  Multiplication := p;

end;

procedure SortResult(var x : TArr);

var

  i: byte;

  flag: boolean;

  T: TVec;

begin

  flag := false;

  repeat

    flag := true;

    for i := 1 to n-1 do

      if x[i, 2] < x[succ(i), 2] then begin

        flag := false;

        T := x[i]; x[i] := x[succ(i)]; x[succ(i)] := T

      end;

   until flag;

end;

var

  arr, _result : TArr;

  t: byte;

Begin

  clrscr;

  InitArray(arr);

  PrintArray(arr, n, m);

  for t := 1 to n do begin

    _result[t, 1] := Addition(arr, t);

    _result[t, 2] := Multiplication(arr, t);

  end;

  writeln('Interval result');

  PrintArray(_result, n, 2);

  writeln('Final result');
  
  SortResult(_result);

  PrintArray(_result, n, 2);

writeln('Press enter for exit');  

readln;

End.

Получилось вот так, но есть одна проблема лишние нули (и как я понимаю неверный результат).

:yes: Должен... При условии, что ты будешь матрицу вводить, как положено! Смотри внимательно:

procedure InitArray(var x : TArr);
var i, j, m, n : byte;
begin
  clrscr;
  repeat
    (*
    begin;
    { Это лишнее: Repeat ...  Until сами являются операторными скобками }
    *)

    write('Enter lines quantity, please: '); readln(n);

    (*
    end;
    { Это тоже, соответственно }
    *)
  until (n>0) and (n<=n);
  {
    А вот теперь объясни мне, с каким именно N здесь: (n <= N)
    происходит сравнение??? Это условие выполнится ВСЕГДА!
    n = n в любом случае (ты работаешь с одним и тем же числом,
    т.к. локальная переменная перекрывает глобальную)...
  }

  ... { дальше - то же самое...  }
end;

Вывод: никогда не давай локальным переменным тех же имен, что и глобальным... Вот правильный вариант InitArray:

program test;
uses crt;
const
   _n=5; _m=5;

type
  TVec = array[1 .. _m] of integer;
  TArr = array[1 .. _n] of TVec;

var
  m, n: integer;

procedure InitArray(var x : TArr);
var 
  i, j: byte;
begin
  clrscr;
  repeat
     write('Enter lines quantity, please: '); readln(n);
  until (n>0) and (n<=_n);

  repeat
     write('Enter columns quantity, please: '); readln(m)
  until (m>0) and (m<=_m);

  for i := 1 to n do
    for j := 1 to m do begin;      
      write('x[', i, ',', j, '] = '); readln(x[i,j]);
    end;
end;

Все работает, поверить не могу, ОГРОМНОЕ Вам человеческое спасибо volvo, klem4, altair