Описание процедуры:

Procedure имя (входные формальные параметры: тип;

Var выходные формальные параметры: тип);

описания (если они есть)

begin операторы

end;

Пусть необходимо найти корни квадратных уравнений

ax2+bx+c=0,

ky2+my+d=0,

sz2+tz+p=0,

где коэффициенты a, b, c вводятся по запросу. количество уравнений не ограничено. результаты вычислений выводить на экран (в основную программу не возвращать)

Program Prim33;

label K,NAH;

Var
let:char; a,b,c:real;

procedure root(a,b,c:real); {процедура не имеет выходных параметров}

label K;

Var d,x1d,x1m,x2d,x2m:real;

Begin
if a=0 then
Begin

writeln('уравнение первой степени, корень один');

x1d:=-c/b;
writeln('x=',x1d);
goto K; end

else
d:=b*b-4*a*c;

if d>=0 then
Begin

writeln('уравнение второй степени, корни действительные');

x1d:=(-b-sqrt(d))/(2*a);

x2d:=(-b+sqrt(d))/(2*a);

writeln('x1d=',x1d,' x2d=',x2d);
goto K;
end

else writeln('уравнение второй степени, корни комплексные');

x1d:=-b/(2*a); x2d:=x1d;

x1m:=-sqrt(-d)/(2*a);
x2m:=-x1m;

writeln('z1=',x1d,' ',x1m,' i;');

writeln('z2=',x2d,' ',x2m,' i;');

K: end;

BEGIN
NAH: writeln('введите a,b,c');
readln(a,b,c);
root(a,b,c);

writeln('будет еще уравнение? если "да", нажмите клавишу"Y"',

'если "нет", нажмите любую клавишу');

read(let);

if (let='Y') or (let='y') then
goto nah
else
goto K;

K: END.

Найти x, y, z -- корни системы уравнений:

Как известно из линейной алгебры ,

где

Раскрытие определителя

производится по схеме: т.е.

в процедуре a,b,c,d - входные данные, x,y,z - результаты.

Program Prim34;

label N,K;

Type
w=array[1..3] of integer;

Var
a,b,c,d:w;
x,y,z:real;
let:char;

function det(a:w;b:w;c:w):real;

Begin
det:=a[1]*b[2]*c[3]+b[1]*c[2]*a[3]+c[1]*a[2]*b[3]

-c[1]*b[2]*a[3]-a[1]*c[2]*b[3]-b[1]*a[2]*c[3];
end;

procedure ur(a,b,c,d:w; Var x,y,z:real);

Var
d0:real;

Begin
d0:=det(a,b,c);

if d0=0 then
Begin
writeln('det=0 решения нет');

let:='0';
Exit;
end
else {EXIT - выход из процедуры}

x:=det(d,b,c)/d0;

y:=det(a,d,c)/d0;

z:=det(a,b,d)/d0;
let:='1';
end;

BEGIN
N: writeln('введите a1,b1,c1,d1');
readln(a[1],b[1],c[1],d[1]);

writeln('введите a2,b2,c2,d2');
readln(a[2],b[2],c[2],d[2]);

writeln('введите a3,b3,c3,d3');
readln(a[3],b[3],c[3],d[3]);

ur(a,b,c,d,x,y,z);

if let='0' then
goto K
else

writeln('/ ',a[1],'x+',b[1],'y+',c[1],'z=',d[1]);

writeln('система i ',a[2],'x+',b[2],'y+',c[2],'z=',d[2]);

writeln(' \ ',a[3],'x+',b[3],'y+',c[3],'z=',d[3]);

writeln('имеет решение: x=',x,' y=',y,' z=',z);

K: writeln('Будет ещё ур-е? да - "Y" , нет - любая клавиша ');

read(let);

if (let='Y') or (let='y') then
goto N;

END.

Имеется одномерный массив. Необходимо определить сумму положительных элементов, номер последнего отрицательного элемента, количество отрицательных элементов массива.

Задача 1. Массив один и состоит из 7 элементов.

Задача 2. Массивов два, размерность первого - 7 элементов, второго - 5.

Задача 3. Количество массивов не ограничено, количество элементов в массивах произвольное, но не более 70.

Program Prim35; { массив 1 и состоит из 7 <элементов}
label j;
Type mas=array[1..7] of real;
Var
n,k,i,no:integer;
a:mas; s:real;
ch:char;

BEGIN
prmas(7,s,k,no);
y:=0;

j: writeln('сумма положительных элементов =',s);

writeln('последний отрицательный элемент имеет N=', no);

writeln('количество отрицательных элементов =', k);
y:=y+1;

if y=1 then
Begin
prmas(5,s,k,no);
goto j; end

else
readln;

END.

Program Prim37; {массивы с переменнымиизмерениями, количество массивов не ограничено}
Type
mas=array[1..70] of real;
Var n,k,i,no,kol,r,j:integer;
a,b:mas;
s:real;
ch:char; procedure prmas(n:integer; var s:real; var k,no:integer);
var i:integer;
a:mas;

begin
for i:=1 to n do
begin

writeln('введите ',i,'  значение элемента массива ', j);

readln(a[i]);
end;

s:=0;
k:=0;
no:=0;

for i:=1 to n do
Begin

if a[i]>=0 then s:=s+a[i] else Begin k:=i; no:=no+1;

end; end; end;

BEGIN

writeln('задайте количество массивов');
readln(kol);

for j:=1 to kol do
Begin

writeln(' задайте размерность массива', j);
readln(r);

prmas(r,s,k,no);

writeln(' сумма положительных элементов =',s);

writeln(' последний отрицательный элемент имеет N=', no);

writeln(' количество отрицательных элементов =', k); end;

readln;

END.