T:  writeln('пределы интегрирования не соответствуют условию');

      f6:=-9999999999.;

  K1: end;

 BEGIN

  NAH:  writeln('введите значения a,b');

        readln(a,b); z:=f6(a,b);

      if z=-9999999999. then goto p;

        writeln('z=',z);

     P:  readln;

       writeln(' будем еще вычислять z ? , если "да" ',

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

       readln(lit);

     if (lit='Y') or (lit='y') then goto NAH;

                              END.

7.3. Подпрограммы-процедуры

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

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

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

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

begin операторы

end;

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

ax2+bx+c=0,

ky2+my+d=0,

sz2+tz+p=0,

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

  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;

    procedure prmas(a:mas;n:integer; Var s:real; Var k,no:integer);

            Var i:integer;

        Begin   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

           for i:=1 to 7 do  Begin

          writeln('ввести значение a[',i,']');

        readln(a[i]);  end;

         prmas(a,7,s,k,no);

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

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

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

          readln;

  END.

  Program Prim36; { массива 2, размерность первого массива 7, второго – 5}          label j;          Type mas=array[1..7] of real;          Var  k,no,y:integer;               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,' значение элемента массива');

            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  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;

Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26