Технический форум - Помощь с программой. Фортран и Паскаль

Технический форум (http://www.tehnari.ru/)

- Помощь студентам (http://www.tehnari.ru/f41/)

Помощь с программой. Фортран и Паскаль

нужна помощь с программой, не хочет работать
+нужно перевести программу на паскаль
могу скинуть условие если нужно

Код:

External F

integer c

real s,F,A,B,fint,E

common /z/c

E=0.001

B=1.3

do c=1,5,1

A=cor(F,0,1,E)

!a=c*0.2

S=fint(F,A,B,E)

write(*,10)S

10 format(x,'площадь равна=',F6.2)

pause

enddo

END



Real function F(x)

real x

common /z/c

F=x**3+c*x-c

end







real function fint(f,a,b,eps)

external f

real x,a,b,eps,sp,ss,h,d,f

integer n

n=100

sp=0.

11 ss=0.

h=(b-a)/n

x=a

do x=a,b,h

ss=ss+f(x)*h

end do

d=abs(sp-ss)

sp=ss

n=2*n

if (d>=eps) goto 11            

fint=ss

end



real function COR(f,a,b,e)

external F

real x,e,f,xl,xp,u,v,d

integer a,b

logical P

xl=a

xp=b

U=f(xl)

v=f(xp)

p=.false.

do while(abs(xl-xp)>e.and..not.p)

x=xp-v*(xl-xp)/(u-v)

d=f(x)

if((u*d)>0)then

 xl=x

 u=d

 else

  if((u*d)<0)then

  xp=x

  v=d

  else

  p=.true.

  endif

endif

enddo

cor=x

return

end

Цитата:

Сообщение от mp_12332 (Сообщение 1024861)

могу скинуть условие если нужно

Очень желательно!

не могу определить где у меня ошибка, программа компилируется, запускается и ничего не происходит, просто пустое окно программы

Ну, по отладке фортрановской программы я - пас, а вот с Паскалем помогу. Как я понимаю, для каждого из значений "c" нужно:
1. Найти корень x0 уравнения F(x,c)=0
2. Методом прямоугольников сосчитать интеграл F(x)dx в пределах от x0 до b
В связи с этим вопрос: как (каким методом) Вы ищете корень? Что-то понять не могу.

А, кажется понял - методом хорд (секущих)?

Цитата:

Сообщение от Vladimir_S (Сообщение 1024874)

А, кажется понял - методом хорд (секущих)?

да, именно им

Так, ну получите. Программа полностью отлажена.
А ошибка Ваша - в некорректной постановке условия выхода из цикла в подпрограмме поиска корня. Разность xl-xp вовсе не обязана уменьшаться. Нужно сравнивать предыдущее значение найденного корня с последующим, и когда разность между ними станет меньше меры точности, то прерывать цикл.

Код:

Const

 a=0;

 b=1.3;

 e=0.001;



Var

 c,Sq:Array[1..5] of real;

 i:integer;



function F(x,c:real):real;

begin

 F:=x*x*x+c*x-c;

end;



function Fint(x0,c:real):real;

var

 x,h,ss,sp,d:real;

 n,i:integer;

begin

 n:=100;

 sp:=0;

 Repeat

  ss:=0;

  h:=(b-x0)/n;

  x:=x0;

  for i:=1 to n do

   begin

    x:=x+h;

    ss:=ss+F(x,c)*h;

   end;

  d:=abs(sp-ss);

  sp:=ss;

  n:=2*n;

 Until d<=e;

 Fint:=ss;

end;



function COR(c:real):real;

var

 x_old,x_new,dif,xl,xp,U,V,D:real;

 p:boolean;

begin

 xl:=a;

 xp:=b;

 dif:=b-a;

 U:=F(xl,c);

 V:=F(xp,c);

 p:=false;

 while (dif>e) and not(p) do

  begin

   x_new:=xp-V*(xl-xp)/(U-V);

   D:=F(x_new,c);

   if U*D>0 then

    begin

     xl:=x_new;

     U:=D;

    end

   else

   if U*D<0 then

    begin

     xp:=x_new;

     V:=D;

    end

   else

   p:=true;

   dif:=abs(x_old-x_new);

   x_old:=x_new;

  end;

 COR:=x_new;

end;



Begin

 for i:=1 to 5 do

  begin

   c[i]:=i;

   Sq[i]:=Fint(Cor(c[i]),c[i]);

   writeln('c = ',c[i]:3:1,'   x0 = ',Cor(c[i]):0:5,'    Square = ',Sq[i]:0:5);

  end;

 Readln

End.

Цитата:

Сообщение от Vladimir_S (Сообщение 1024894)

А ошибка Ваша - в некорректной постановке условия выхода из цикла в подпрограмме поиска корня.

Проблема в том, что эту п/п нам дал преподаватель

Цитата:

Сообщение от mp_12332 (Сообщение 1024900)

Проблема в том, что эту п/п нам дал преподаватель

Гнать! В три шеи!! Без выходного пособия!!!

Цитата:

Сообщение от Vladimir_S (Сообщение 1024905)

Гнать! В три шеи!! Без выходного пособия!!!

Хотелось бы, спасибо за помощь