I : integer;

begin

x2:=x*x;

sum:=t5+x2*(t6+x2*(t7+x2*(t8+x2*(t9+x2*(t10+x2*(t11+x2*t12))))));

erf:=2.0*exp(-x2)/sqrtpi*(x*(1+x2*(t2+x2*(t3+x2*(t4+x2*sum)))))

end; { function erf }

function erfc(x: real): real;

{ complement of error function }

const sqrtpi = 1.7724538;

var x2,v,sum : real;

begin

x2:=x*x;

v:=1.0/(2.0*x2);

sum:=v/(1+8*v/(1+9*v/(1+10*v/(1+11*v/(1+12*v)))));

sum:=v/(1+3*v/(1+4*v/(1+5*v/(1+6*v/(1+7*sum)))));

erfc:=1.0/(exp(x2)*x*sqrtpi*(1+v/(1+2*sum)))

end; { function ercf }

begin { main }

ClrScr;

done:=false;

writeln;

repeat

write('Arg? ');

readln(x);

if x<0.0 then done:=true

else

begin

if x=0.0 then

begin

er:=0.0;

ec:=1.0

end

else

begin

if x<1.5 then

begin

er:=erf(x);

ec:=1.0-er

end

else

begin

ec:=erfc(x);

er:=1.0-ec

end { if }

end;

writeln('X= ',x:8:4,', Erf= ',er:12,', Erfc= ',ec:12)

end { if }

until done

end.

Программа 20. Вычисление функции ошибок распределения Гаусса(вар.2).

program erfd3;

{ evaluation of the gaussian error function }

var x,er,ec : real;

done : boolean;

function erf(x: real): real;

{ infinite series expansion of the Gaussian error function }

const sqrtpi = 1.7724538;

tol = 1.0E-4;

var x2,sum,sum1,term: real;

I : integer;

begin

x2:=x*x;

sum:=x;

term:=x;

i:=0;

repeat

i:=i+1;

sum1:=sum;

term:=2.0*term*x2/(1.0+2.0*i);

sum:=term+sum1

until term<tol*sum;

erf:=2.0*sum*exp(-x2)/sqrtpi

end; { erf }

function erfc(x: real): real;

{ complement of error function }

const sqrtpi = 1.7724538;

terms = 12;

var x2,u,v,sum : real;

I : integer;

begin

x2:=x*x;

v:=1.0/(2.0*x2);

u:=1.0+v*(terms+1.0);

for i:=terms downto 1 do

begin

sum:=1.0+i*v/u;

u:=sum

end;

erfc:=exp(-x2)/(x*sum*sqrtpi)

end; { ercf }

begin { main }

ClrScr;

done:=false;

writeln;

repeat

write('Arg? ');

readln(x);

if x<0.0 then done:=true

else

begin

if x=0.0 then

begin

er:=0.0;

ec:=1.0

end

else

begin

if x<1.5 then

begin

er:=erf(x);

ec:=1.0-er

end

else

begin

ec:=erfc(x);

er:=1.0-ec

end { if }

end;

writeln('X= ',x:8:4,' Erf= ',er:12:8,', Erfc= ',ec:12)

end { if }

until done

end.

Программа 21. Интегрирование методом Симпсона (вар.3)

program erfsimp;

{ integration by Simpson's method }

const tol = 1.0E-4;

var done : boolean;

sum,upper,lower,

erf,twopi : real;

function fx(x: real): real;

begin

fx:=exp(-x*x)

end; { function fx }

procedure simps(

lower,upper,tol : real;

Var sum : real);

{ numerical integration by Simpson's rule }

{ function is fx, limits are lower and upper }

{ with number of regions equal to pieces }

{ partition is delta_x, answer is sum }

Var I : integer;

X,delta_x,even_sum,

odd_sum,end_sum,

sum1 : real;

pieces : integer;

begin

pieces:=2;

delta_x:=(upper-lower)/pieces;

odd_sum:=fx(lower+delta_x);

even_sum:=0.0;

end_sum:=fx(lower)+fx(upper);

sum:=(end_sum+4.0*odd_sum)*delta_x/3.0;

writeln(pieces:5,sum);

repeat

pieces:=pieces*2;

sum1:=sum;

delta_x:=(upper-lower)/pieces;

even_sum:=even_sum+odd_sum;

odd_sum:=0.0;

for i:=1 to pieces div 2 do

begin

x:=lower+delta_x*(2.0*i-1.0);

odd_sum:=odd_sum+fx(x)

end;

sum:=(end_sum+4.0*odd_sum+2.0*even_sum)*delta_x/3.0;

until abs(sum-sum1)<=abs(tol*sum1)

end; { simps }

begin { main program }

ClrScr;

done:=false;

twopi:=2.0/sqrt(pi);

lower:=0.0;

repeat

writeln;

writeln('Erf? ');

readln(upper);

if upper<0.0 then done:=true

else if upper=0.0 then

writeln('Erf of 0.0 is 0.0')

else { upper>0 }

begin

simps(lower,upper,tol,sum);

erf:=twopi*sum;

writeln('Erf of ',upper:7:2,', is ',erf:12:8)

end

until done

end.

Программа 22. Решение системы уравнений методом Гаусса-Зейделя.

(Требуется согласовать упрощения)

program gausid;

{ pascal program to perform simultaneous solution }

{ by Gauss-Seidel }

{ procedure SEID is included }

const maxr = 8;

maxc = 8;

type ary = array[1..maxr] of real;

arys = array[1..maxc] of real;

ary2s = array[1..maxr,1..maxc] of real;

var y : ary;

coef : arys;

a : ary2s;

n,m : integer;

first,

error : boolean;

procedure get_data

(var a : ary2s;

var y : ary;

var n,m: integer);

{ get values for n and arrays a,y }

var i,j : integer;

begin

writeln;

repeat

write('How many equations? ');

readln(n);

if first then first:=false else ClrScr

until n<maxr;

m:=n;

if n>1 then

begin

for i:=1 to n do

begin

writeln('Equation',i:3);

for j:=1 to n do

begin

write(j:3,':');

read(a[i,j])

end;

write(' C:');

read(y[i]);

readln { clear the line }

end;

writeln;

for i:=1 to n do

begin

for j:=1 to m do

write(a[i,j]:7:4,' ');

writeln(':',y[i]:7:4)

end;

writeln

end { if n>1 }

else if n<0 then n:=-n;

m:=n

end; { procedure get_data }

procedure write_data;

{ print out the answers }