How can I combine more programms? - Programmers Heaven

Howdy, Stranger!

It looks like you're new here. If you want to get involved, click one of these buttons!

Categories

How can I combine more programms?

nubensnubens Posts: 2Member
I need to combine 4 programms in one. I tried with exec and swapvectors,but it's not working. Please help!
This is how I tried to unite them:
program final;
{$M 4000,0,0}
uses dos,crt;

procedure bessel;
begin
swapvectors;
exec('c:program files pwork', 'bessel');
swapvectors;
exec('bessel.exe','');
swapvectors;end;

procedure kelvin;
begin
swapvectors;
exec('c:program files pwork', 'kelvin');
swapvectors;
exec('kelvin.exe','');
swapvectors;end;

procedure regresie_polinomiala;
begin
swapvectors;
exec('c:program files pwork', 'regresie_polinomiala');
swapvectors;
exec('regresie_polinomiala.exe','');
swapvectors;end;

procedure newton_stanga;
begin
swapvectors;
exec('c:program files pwork', 'newton_stanga');
swapvectors;
exec('newton_stanga.exe','');
swapvectors;end;

begin
writeln('loading...');
bessel;
kelvin;
regresie_polinomiala;
newton_stanga;
readln;
readkey;
end.

these are the original programms:
PROGRAM Bessel;
USES Crt;
{$M 4000,0,0 }
CONST eps1=1E-164;
VAR x:Real;

FUNCTION Jn(n:Integer;x:real):real;
VAR i : integer;
z1,z2,z3,zs : real;

BEGIN
zs:=1;
FOR i:=1 TO n DO BEGIN
z1:=x/2/i;
zs:=zs*z1;END;
z2:=zs;
i:=0;
REPEAT
z1:=-x/2/(i+1); z3:=x/2/(n+i+1);
z2:=z2*z1*z3; zs:=zs+z2; i:=i+1
UNTIL (Abs(z2) < eps1);
Jn:=zs
END;

FUNCTION J0(x:real):real;
VAR y,f,t:real;
BEGIN
IF (x<3)THEN BEGIN
y:=Sqr(x/3);
J0:=(((((0.00021*y-0.0039444)*y+0.0444479)*y-0.3163866)*y+1.2656208)*y-2.2499997)*y+1
END
ELSE BEGIN
y:=3/x;
f:=(((((0.00014476*y-0.00072805)*y+0.00137237)*y-0.00009512)*y-0.0055274)*y-0.00000077)*y+0.79788456;
t:=(((((0.00013558*y-0.00029333)*y-0.00054125)*y+0.00262573)*y-0.00003954)*y-0.04166397)*y-
0.78539816+x;
J0:=1/Sqrt(x)*f*Cos(t)
END;
END;

FUNCTION J1(x:real):real;
VAR y,f,t:real;
BEGIN
IF (x<3)THEN BEGIN
y:=Sqr(x/3);
J1:=((((((0.00001109*y-0.00031761)*y+
0.00443319)*y-0.03954289)*y+
0.21093573)*y-0.56249985)*y+0.5)*x
END
ELSE
BEGIN
y:=3/x;
f:=(((((-0.00020033*y+0.00113653)*y-0.00249511)*y+0.00017105)*y+
0.01659667)*y+0.00000156)*y+0.79788456;
t:=(((((-0.00029166*y+0.00079824)*y+0.00074348)*y-0.00637879)*y+0.00005659)*
y+0.12499612)*y-2.35619449+x;
J1:=1/Sqrt(x)*f*Cos(t)
END
END;

BEGIN {Main Prog}
ClrScr;
REPEAT
Write('x=');ReadLn(x);
WriteLn('J0=',J0(x):10:7,' J1=',J1(x):10:7);
WriteLn('J0=',Jn(0,x):10:7,'J1=',Jn(1,x):10:7)
UNTIL (x<0);
readkey;
END.

PROGRAM KELVIN;
USES Crt,Printer,Graph;
TYPE
VECTOR = ARRAY[1..8] OF real;
VALKELVIN = RECORD
Z:real;
KEL: VECTOR;
END;
FILETYPE = file OF VALKELVIN;
VAR
SETKELVIN: VALKELVIN;
FILEKELVIN: FILETYPE;
NUMAR: integer;
RASPUNS: string[2];
X,XINF,XSUP,DELTAX,EPS: real;
KELVIN: VECTOR;
PROCEDURE CALCUL_KELVIN(X,EPS:real;VAR KELVIN: VECTOR);
{CALCULUL VALORILOR FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA, PENTRU...}
{ARGUMENTUL X SI DIFERENTA MAXIMA ADMISA DINTRE DOUA SUME PARTIALE EPS}
CONST GAMA = 0.5772156649015328606065;
VAR
B1,B2,BD1,BD2,A1,A2:real;
TKEL,SKEL: VECTOR;
PRECISE: boolean;
n,m: real;
i: integer;
BEGIN
B1 := 1;
B2 := sqr(X/2);
BD1 := 2/X;
BD2 := X/2;
TKEL[1] := 1;
TKEL[2] := sqr(X/2);
TKEL[3] := 0;
TKEL[4] := X/2;
A1 := 0;
A2 := 1;
TKEL[5] := -ln(X/2) - GAMA + PI/4*sqr(X/2);
TKEL[6] := -PI/4 + sqr(X/2)*(1-ln(X/2)-GAMA);
TKEL[7] := -1/X + PI/4*(X/2);
TKEL[8] := (X/2)*((1-ln(X/2)-GAMA)-1/2);
n := 0;
m := 1;
REPEAT
PRECISE := TRUE;
n := n + 2;
m := m + 2;
B1 :=-B1/((n-1)*(n-1)*n*n)*sqr(X/2)*sqr(X/2);
B2 :=-B2/((m-1)*(m-1)*m*m)*sqr(X/2)*sqr(X/2);
BD1 :=-BD1/((n-1)*(n-1)*n*n)*sqr(X/2)*sqr(X/2);
BD2:=-BD2/((m-1)*(m-1)*m*m)*
sqr(X/2)*sqr(X/2);
A1 := A1 + 1/(n-1) + 1/n;
A2 := A2 + 1/(m-1) + 1/m;
SKEL[1]:=TKEL[1] + B1;
SKEL[2]:=TKEL[2] + B2;
SKEL[3]:=TKEL[3] + n*BD1;
SKEL[4]:=TKEL[4] + m*BD2;
SKEL[5]:=TKEL[5]+B1*(A1-ln(X/2)-GAMA)+PI/4*B2;
SKEL[6]:=TKEL[6]-PI/4*B1+B2*(A2-ln(X/2)-GAMA);
SKEL[7]:=TKEL[7]+BD1*(n*(A1-ln(X/2)-GAMA)-1/2)+PI/4*m*BD2;
SKEL[8]:=TKEL[8]-PI/4*n*BD1+BD2*(m*(A2-ln(X/2)-GAMA)-1/2);
FOR i := 1 TO 8 DO
IF abs(SKEL[i]-TKEL[i]) >= EPS THEN
PRECISE := FALSE;
FOR i := 1 TO 8 DO
TKEL[i] := SKEL[i]
UNTIL PRECISE;
FOR i := 1 TO 8 DO
KELVIN[i] := SKEL[i]
END;{CALCUL_KELVIN}
PROCEDURE CREARE(VAR FILEKELVIN:FILETYPE);
{CREEAZA FISIERUL VALORILOR FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA}
VAR i: integer;
BEGIN
assign(FILEKELVIN,'KELVIN.dat');
rewrite(FILEKELVIN);
write('X inf = ');
readln(XINF);
write('X sup = ');
readln(XSUP);
write('DELTA X = ');
readln(DELTAX);
write('EPSILON = ');
readln(EPS);
X := XINF;
WHILE X <= XSUP + 1E-10 DO
BEGIN
CALCUL_KELVIN(X,EPS,KELVIN);
WITH SETKELVIN DO
BEGIN
Z := X;
FOR i := 1 TO 8 DO
KEL[i] := KELVIN[i]
END;
write(FILEKELVIN,SETKELVIN);
writeln('X= ',X:7:3);
X := X + DELTAX
END;
close(FILEKELVIN);
writeln;
writeln;
writeln('FISIERul CU VALORILE FUNCTIILOR KELVIN A FOST CREAT')
END;{CREARE}
PROCEDURE LISTARE(VAR FILEKELVIN:FILETYPE);
{LISTEAZA VALORILE FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA}
VAR
LIM1,LIM2,i,POZ:longint;
ALFA,BETA,GAMA: real;
BEGIN
assign(FILEKELVIN,'KELVIN.dat');
reset(FILEKELVIN);
read(FILEKELVIN,SETKELVIN);
ALFA := SETKELVIN.Z;
read(FILEKELVIN,SETKELVIN);
BETA := SETKELVIN.Z;
GAMA := BETA - ALFA;
write('X inf = ');
readln(XINF);
write('X sup = ');
readln(XSUP);
LIM1 := trunc((XINF-ALFA)/GAMA+1E-06);
LIM2 := trunc((XSUP-ALFA)/GAMA+1E-06);
writeln(lst,'X':3,'ber(x)':18,'bei(x)':19,'d(ber)/dx':19,'d(bei)/dx':19);
writeln(lst);
FOR i := LIM1 TO LIM2 DO
BEGIN
seek(FILEKELVIN,i);
read(FILEKELVIN,SETKELVIN);
WITH SETKELVIN DO
writeln(lst,Z:7:3,' ',KEL[1],' ',KEL[2],' ',KEL[3],' ',KEL[4])
END;
writeln(lst);
writeln(lst);
readln;
writeln(lst,'X':3,'ker(x)':18,'kei(x)':19,'d(ker)/dx':19,'d(kei)/dx':19);
writeln(lst);
FOR i := LIM1 TO LIM2 DO
BEGIN
seek(FILEKELVIN,i);
read(FILEKELVIN,SETKELVIN);
WITH SETKELVIN DO
writeln(lst,Z:7:3,' ',KEL[5],' ',KEL[6],' ',KEL[7],' ',KEL[8])
END;
close(FILEKELVIN)
END;{LISTARE}
PROCEDURE GRAFIC(VAR FILEKELVIN: FILETYPE);
{TRASEAZA GRAFICELE FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA}
VAR
GrDriver,GrMode,GrError: integer;
SETKELVIN: VALKELVIN;
FUNC: ARRAY[1..8] OF string[10];
MAXIM,MINIM: real;
RASPUNS,RASP: string[2];
LIM1,LIM2,i,POZ: longint;
k: integer;
DIMX,DIMY,ORIGINE,DELTA,X0,Y0,N1,N2,N3: word;
X,Y: array[1..2] OF word;
ALFA,BETA,GAMA,VALX,VALY: real;
SX,SY,S1Y,S2Y,S3Y: string[10];
TEXTY: string;
BEGIN
assign(FILEKELVIN,'KELVIN.dat');
reset(FILEKELVIN);
FUNC[1] := 'ber(x)';
FUNC[2] := 'bei(x)';
FUNC[3] := 'd(ber)/dx';
FUNC[4] := 'd(bei)/dx';
FUNC[5] := 'ker(x)';
FUNC[6] := 'kei(x)';
FUNC[7] := 'd(ker)/dx';
FUNC[8] := 'd(kei)/dx';
RASPUNS := 'DA';
WHILE (RASPUNS = 'DA') or (RASPUNS = 'da') DO
BEGIN
i := 1;
RASP := 'NU';
WHILE (i <= 8) AND ((RASP = 'NU') OR (RASP = 'nu')) DO
BEGIN
write('GRAFICUL FUNCTIEI ',FUNC[i],'...DA(da)/ NU(nu)?...');
readln(RASP);
IF (RASP='DA') or (RASP='da') THEN
k:=i;
i := i + 1
END;
seek(FILEKELVIN,0);
read(FILEKELVIN,SETKELVIN);
ALFA := SETKELVIN.Z;
read(FILEKELVIN,SETKELVIN);
BETA := SETKELVIN.Z;
GAMA := BETA - ALFA;
write('X inf = ');
readln(XINF);
write('X sup = ');
readln(XSUP);
LIM1 := trunc((XINF-ALFA)/GAMA+1E-06);
LIM2 := trunc((XSUP-ALFA)/GAMA+1E-06);
seek(FILEKELVIN,LIM1);
read(FILEKELVIN,SETKELVIN);
WITH SETKELVIN DO
BEGIN
MAXIM := KEL[k];
MINIM := KEL[k]
END;
FOR i := LIM1 TO LIM2 DO
BEGIN
seek(FILEKELVIN,i);
read(FILEKELVIN,SETKELVIN);
WITH SETKELVIN DO
BEGIN
IF MAXIM<KEL[k] THEN
MAXIM:= KEL[k];
IF MINIM>KEL[k] THEN
MINIM := KEL[k]
END
END;
DetectGraph(GrDriver,GrMode);
InitGraph(GrDriver,GrMode,'d:pascalBGI');
GrError := GraphResult;
IF GrError <> GrOK THEN
BEGIN
writeln('EROARE:,GraphErrorMsg(GrError)');
CloseGraph;
close(FILEKELVIN);
Exit
END;
SetGraphMode(GetMaxMode);
DIMX := GetMaxX - 20;
DIMY := GetMaxY - 20;
IF MAXIM*MINIM < 0 THEN
ORIGINE:=trunc(DIMY/(MAXIM-MINIM)*MAXIM)
ELSE
ORIGINE := DIMY;
DELTA := ORIGINE - 10;
SetTextStyle(SmallFont,HorizDir,2);
SetColor(Green);
Line(0,0,0,DIMY);
Line(0,ORIGINE,DIMX+20,ORIGINE);
MoveTo(DIMX,DELTA);
OutText('x');
MoveTo(20,20);
OutText(FUNC[k]);
SetColor(Cyan);
FOR i := 0 TO 9 DO
BEGIN
X0 := trunc(DIMX*i/10);
Y0 := DIMY - trunc(DIMY*i/10);
Line(X0,DELTA,X0,ORIGINE+10);
IF i > 0 THEN
MoveTo(X0 - 40,ORIGINE - 20)
ELSE MoveTo(X0,ORIGINE - 20);
VALX := XINF + (XSUP - XINF)*i/10;
Str(VALX:8:3,SX);
IF i > 1 THEN OutText(SX);
Line(0,Y0,20,Y0);
MoveTo(30,Y0);
VALY := MINIM + (MAXIM - MINIM)*i/10;
IF (abs(VALY)<1E3) and (abs(VALY)>=0.1) THEN
BEGIN
Str(VALY:8:4,SY);
OutText(SY)
END
ELSE
BEGIN
Str(VALY,TEXTY);
N1 := pos('.',TEXTY);
N2 := pos('E',TEXTY);
N3 := length(TEXTY);
S1Y := copy(TEXTY,1,N1);
S2Y := copy(TEXTY,N1+1,3);
S3Y := copy(TEXTY,N2,N3-N2+1);
OutText(S1Y+S2Y+S3Y)
END
END;
SetColor(Red);
seek(FILEKELVIN,LIM1);
read(FILEKELVIN,SETKELVIN);
X[1]:=trunc((SETKELVIN.Z-XINF)*DIMX/(XSUP-XINF));
Y[1] := DIMY-trunc((SETKELVIN.KEL[k]-MINIM)*DIMY/(MAXIM-MINIM));
FOR i := LIM1+1 TO LIM2 DO
BEGIN
seek(FILEKELVIN,i);
read(FILEKELVIN,SETKELVIN);
X[2]:=trunc((SETKELVIN.Z-XINF)*DIMX/(XSUP-XINF));
Y[2]:=DIMY-trunc((SETKELVIN.KEL[k]- MINIM)* DIMY/(MAXIM - MINIM));
Line(X[1],Y[1],X[2],Y[2]);
X[1] := X[2];
Y[1] := Y[2];
END;
readln;
CloseGraph;
write('DORITI TRASAREA ALTUI GRAFIC?.DA/NU');
readln(RASPUNS)
END;{WHILE}
close(FILEKELVIN)
END;{GRAFIC}
BEGIN{FUNCTII_KELVIN}
RASPUNS := 'DA';
WHILE (RASPUNS = 'DA') or (RASPUNS = 'da') DO
BEGIN
writeln('1: CREARE FISIERE FUNCTII KELVIN');
writeln('2: LISTARE VALORI FUNCTII KELVIN');
writeln('3: TRASARE GRAFIC FUNCTII KELVIN');
writeln;
writeln;
write('TASTATI NUMARUL VARIANTEI ');
readln(NUMAR);
CASE NUMAR OF
1: CREARE(FILEKELVIN);
2: LISTARE(FILEKELVIN);
3: GRAFIC(FILEKELVIN)
END;
writeln;
writeln;
write('CONTINUATI?...DA(da)/NU(nu)... ');
readln(RASPUNS)
END
END{FUNCTII_KELVIN}.

PROGRAM Regresie_polinomiala;
USES Crt;
CONST
nmax=20;
mmax=10;
TYPE
index=1..nmax;
grad=0..mmax;
mat=ARRAY[index,index] OF Real;
vec=ARRAY[index] OF Real;
vec1=ARRAY[grad] OF Real;
VAR
a:mat;
x,y,xsol:vec;
c:vec1;
n:index;
m:grad;
flg:Boolean;
PROCEDURE Gauss(n:index;a:mat;VAR xsol:vec;VAR flg:Boolean);
VAR
i,j,jp,k:index;
max,x:Real;
PROCEDURE schimba(i,j:index);
VAR
k:index;
x:Real;
BEGIN
FOR k:=1 TO nmax DO
BEGIN
x:=a[i,k]; a[i,k]:=a[j,k]; a[j,k]:=x
END
END; {Proc. schimba}
BEGIN
flg:=True;
FOR i:=1 TO n-1 DO
BEGIN
jp:=i; max:=Abs(a[i,i]);
FOR j:=i+1 TO n DO
IF Abs(a[j,i])>max THEN
BEGIN max:=Abs(a[j,i]); jp:=j; END;
IF max=0 THEN
BEGIN flg:=False; Exit END;
IF jp<>i THEN schimba(i,jp);
FOR j:=i+1 TO n DO
BEGIN
x:=a[j,i]/a[i,i];
FOR k:=i+1 TO n+1 DO
a[j,k]:=a[j,k]-a[i,k]*x
END
END;
IF a[n,n]=0 THEN BEGIN flg:=False; Exit END;
a[n+1,n]:=a[n,n+1]/a[n,n];
FOR i:=n-1 DOWNTO 1 DO
BEGIN
a[n+1,i]:=0;
FOR k:=i+1 TO n DO
a[n+1,i]:=a[n+1,i]+a[i,k]*a[n+1,k];
a[n+1,i]:=(a[i,n+1]-a[n+1,i])/a[i,i]
END;
FOR i:=1 TO n DO xsol[i]:=a[n+1,i]
END;
PROCEDURE Wait;
VAR
cc:Char;
BEGIN
WriteLn('Press a Key !');
REPEAT cc:=ReadKey; UNTIL cc<>''
END;
PROCEDURE Sistem(n:index;m:grad;VAR a:mat);
VAR
i,j,k,e : Integer;
sc,st : Real;
FUNCTION pr(baza:Real;exponent:Integer):Real;
VAR
i : Integer;
tr : Real;
BEGIN
tr:=1;
IF (exponent=0) THEN tr:=1
ELSE FOR i:=1 TO exponent DO
tr:=tr*baza;
pr:=tr;
END;
BEGIN
FOR i:=1 TO m+1 DO
BEGIN
st:=0;
FOR k:=1 TO n DO st:=st+y[k]*pr(x[k],i-1);
a[i,m+2]:=st;
FOR j:=i TO m+1 DO
BEGIN
sc:=0; e:=i+j-2;
FOR k:=1 TO n DO sc:=sc+pr(x[k],e);
a[i,j]:=sc; a[j,i]:=sc
END
END
END;
PROCEDURE scriesist;
VAR
i,j:index;
BEGIN
WriteLn;
FOR i:=1 TO m+1 DO
BEGIN
FOR j:=1 TO m+1 DO Write(a[i,j]:12:2);
WriteLn(' ',a[i,m+2]:12:2)
END;
WriteLn
END;
PROCEDURE Date;
VAR
k:Integer;
BEGIN
Write('Nr. date experimentale=');ReadLn(n);WriteLn;
FOR k:=1 TO n DO
BEGIN
Write('x(',k,')=');ReadLn(x[k]);Write('y(',k,')=');ReadLn(y[k])
END;
Write('Gradul polinomului de regresie=');ReadLn(m);WriteLn;
END;
PROCEDURE scriesol;
VAR
i:Integer;
BEGIN
WriteLn; WriteLn('Solutia');
FOR i:=1 TO m+1 DO Write(xsol[i]:12:3); WriteLn
END;
BEGIN {Main Prog.}
ClrScr; Date; Sistem(n,m,a); Scriesist;
Gauss(m+1,a,xsol,flg); Scriesol; Wait
END {Regresie_polinomiala}.

program newtown_stanga;
var a,b,n,i,k:integer; {a si b sunt extemitatile intervalului pe care e definita f}
x,y,c:array[0..10] of real;
xd,h,p,t:real;
function deltayO(k:integer):real;
var d:real;
begin
if k mod 2=0 then c[0]:=1
else c[0]:=-1;
for i:=n downto 1 do
c[i]:=0;
d:=0;
for i:=n downto 1 do
c[i]:=c[i-1]*(k-i+1)/i;
for i:=k downto 0 do
d:=d+c[i]*y[i];
deltayO:=d;
end;
begin
write('introduce a:');
readln(a);
write('introduce b:');
readln(b);
write('nr de noduri:');
readln(n);
writeln('introduce valoare functiei in nodurile date:');
for i:=1 to n do
read(y[i]);readln;
write('introduce valoarea argumentului in care vrem sa interpolam:');
readln(xd);
x[0]:=a;
x[n]:=b;
h:=(b-a)/n;
for i:=n-1 downto 1 do
x[i]:=x[n]+i*h;
t:=1;
p:=y[n];
for k:=n downto 1 do begin
t:=t*(xd-x[k-1])/(k*h);
p:=p+deltayO(k)*t;end;
writeln('valoarea interpolata in punctul ',xd:6:3,' este:',p:7:3);
readln;
end.


Comments

  • zibadianzibadian Posts: 6,349Member
    : I need to combine 4 programms in one. I tried with exec and swapvectors,but it's not working. Please help!
    : This is how I tried to unite them:
    : program final;
    : {$M 4000,0,0}
    : uses dos,crt;
    :
    : procedure bessel;
    : begin
    : swapvectors;
    : exec('c:program files pwork', 'bessel');
    : swapvectors;
    : exec('bessel.exe','');
    : swapvectors;end;
    :
    : procedure kelvin;
    : begin
    : swapvectors;
    : exec('c:program files pwork', 'kelvin');
    : swapvectors;
    : exec('kelvin.exe','');
    : swapvectors;end;
    :
    : procedure regresie_polinomiala;
    : begin
    : swapvectors;
    : exec('c:program files pwork', 'regresie_polinomiala');
    : swapvectors;
    : exec('regresie_polinomiala.exe','');
    : swapvectors;end;
    :
    : procedure newton_stanga;
    : begin
    : swapvectors;
    : exec('c:program files pwork', 'newton_stanga');
    : swapvectors;
    : exec('newton_stanga.exe','');
    : swapvectors;end;
    :
    : begin
    : writeln('loading...');
    : bessel;
    : kelvin;
    : regresie_polinomiala;
    : newton_stanga;
    : readln;
    : readkey;
    : end.
    :
    : these are the original programms:
    : PROGRAM Bessel;
    : USES Crt;
    : {$M 4000,0,0 }
    : CONST eps1=1E-164;
    : VAR x:Real;
    :
    : FUNCTION Jn(n:Integer;x:real):real;
    : VAR i : integer;
    : z1,z2,z3,zs : real;
    :
    : BEGIN
    : zs:=1;
    : FOR i:=1 TO n DO BEGIN
    : z1:=x/2/i;
    : zs:=zs*z1;END;
    : z2:=zs;
    : i:=0;
    : REPEAT
    : z1:=-x/2/(i+1); z3:=x/2/(n+i+1);
    : z2:=z2*z1*z3; zs:=zs+z2; i:=i+1
    : UNTIL (Abs(z2) < eps1);
    : Jn:=zs
    : END;
    :
    : FUNCTION J0(x:real):real;
    : VAR y,f,t:real;
    : BEGIN
    : IF (x<3)THEN BEGIN
    : y:=Sqr(x/3);
    : J0:=(((((0.00021*y-0.0039444)*y+0.0444479)*y-0.3163866)*y+1.2656208)*y-2.2499997)*y+1
    : END
    : ELSE BEGIN
    : y:=3/x;
    : f:=(((((0.00014476*y-0.00072805)*y+0.00137237)*y-0.00009512)*y-0.0055274)*y-0.00000077)*y+0.79788456;
    : t:=(((((0.00013558*y-0.00029333)*y-0.00054125)*y+0.00262573)*y-0.00003954)*y-0.04166397)*y-
    : 0.78539816+x;
    : J0:=1/Sqrt(x)*f*Cos(t)
    : END;
    : END;
    :
    : FUNCTION J1(x:real):real;
    : VAR y,f,t:real;
    : BEGIN
    : IF (x<3)THEN BEGIN
    : y:=Sqr(x/3);
    : J1:=((((((0.00001109*y-0.00031761)*y+
    : 0.00443319)*y-0.03954289)*y+
    : 0.21093573)*y-0.56249985)*y+0.5)*x
    : END
    : ELSE
    : BEGIN
    : y:=3/x;
    : f:=(((((-0.00020033*y+0.00113653)*y-0.00249511)*y+0.00017105)*y+
    : 0.01659667)*y+0.00000156)*y+0.79788456;
    : t:=(((((-0.00029166*y+0.00079824)*y+0.00074348)*y-0.00637879)*y+0.00005659)*
    : y+0.12499612)*y-2.35619449+x;
    : J1:=1/Sqrt(x)*f*Cos(t)
    : END
    : END;
    :
    : BEGIN {Main Prog}
    : ClrScr;
    : REPEAT
    : Write('x=');ReadLn(x);
    : WriteLn('J0=',J0(x):10:7,' J1=',J1(x):10:7);
    : WriteLn('J0=',Jn(0,x):10:7,'J1=',Jn(1,x):10:7)
    : UNTIL (x<0);
    : readkey;
    : END.
    :
    : PROGRAM KELVIN;
    : USES Crt,Printer,Graph;
    : TYPE
    : VECTOR = ARRAY[1..8] OF real;
    : VALKELVIN = RECORD
    : Z:real;
    : KEL: VECTOR;
    : END;
    : FILETYPE = file OF VALKELVIN;
    : VAR
    : SETKELVIN: VALKELVIN;
    : FILEKELVIN: FILETYPE;
    : NUMAR: integer;
    : RASPUNS: string[2];
    : X,XINF,XSUP,DELTAX,EPS: real;
    : KELVIN: VECTOR;
    : PROCEDURE CALCUL_KELVIN(X,EPS:real;VAR KELVIN: VECTOR);
    : {CALCULUL VALORILOR FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA, PENTRU...}
    : {ARGUMENTUL X SI DIFERENTA MAXIMA ADMISA DINTRE DOUA SUME PARTIALE EPS}
    : CONST GAMA = 0.5772156649015328606065;
    : VAR
    : B1,B2,BD1,BD2,A1,A2:real;
    : TKEL,SKEL: VECTOR;
    : PRECISE: boolean;
    : n,m: real;
    : i: integer;
    : BEGIN
    : B1 := 1;
    : B2 := sqr(X/2);
    : BD1 := 2/X;
    : BD2 := X/2;
    : TKEL[1] := 1;
    : TKEL[2] := sqr(X/2);
    : TKEL[3] := 0;
    : TKEL[4] := X/2;
    : A1 := 0;
    : A2 := 1;
    : TKEL[5] := -ln(X/2) - GAMA + PI/4*sqr(X/2);
    : TKEL[6] := -PI/4 + sqr(X/2)*(1-ln(X/2)-GAMA);
    : TKEL[7] := -1/X + PI/4*(X/2);
    : TKEL[8] := (X/2)*((1-ln(X/2)-GAMA)-1/2);
    : n := 0;
    : m := 1;
    : REPEAT
    : PRECISE := TRUE;
    : n := n + 2;
    : m := m + 2;
    : B1 :=-B1/((n-1)*(n-1)*n*n)*sqr(X/2)*sqr(X/2);
    : B2 :=-B2/((m-1)*(m-1)*m*m)*sqr(X/2)*sqr(X/2);
    : BD1 :=-BD1/((n-1)*(n-1)*n*n)*sqr(X/2)*sqr(X/2);
    : BD2:=-BD2/((m-1)*(m-1)*m*m)*
    : sqr(X/2)*sqr(X/2);
    : A1 := A1 + 1/(n-1) + 1/n;
    : A2 := A2 + 1/(m-1) + 1/m;
    : SKEL[1]:=TKEL[1] + B1;
    : SKEL[2]:=TKEL[2] + B2;
    : SKEL[3]:=TKEL[3] + n*BD1;
    : SKEL[4]:=TKEL[4] + m*BD2;
    : SKEL[5]:=TKEL[5]+B1*(A1-ln(X/2)-GAMA)+PI/4*B2;
    : SKEL[6]:=TKEL[6]-PI/4*B1+B2*(A2-ln(X/2)-GAMA);
    : SKEL[7]:=TKEL[7]+BD1*(n*(A1-ln(X/2)-GAMA)-1/2)+PI/4*m*BD2;
    : SKEL[8]:=TKEL[8]-PI/4*n*BD1+BD2*(m*(A2-ln(X/2)-GAMA)-1/2);
    : FOR i := 1 TO 8 DO
    : IF abs(SKEL[i]-TKEL[i]) >= EPS THEN
    : PRECISE := FALSE;
    : FOR i := 1 TO 8 DO
    : TKEL[i] := SKEL[i]
    : UNTIL PRECISE;
    : FOR i := 1 TO 8 DO
    : KELVIN[i] := SKEL[i]
    : END;{CALCUL_KELVIN}
    : PROCEDURE CREARE(VAR FILEKELVIN:FILETYPE);
    : {CREEAZA FISIERUL VALORILOR FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA}
    : VAR i: integer;
    : BEGIN
    : assign(FILEKELVIN,'KELVIN.dat');
    : rewrite(FILEKELVIN);
    : write('X inf = ');
    : readln(XINF);
    : write('X sup = ');
    : readln(XSUP);
    : write('DELTA X = ');
    : readln(DELTAX);
    : write('EPSILON = ');
    : readln(EPS);
    : X := XINF;
    : WHILE X <= XSUP + 1E-10 DO
    : BEGIN
    : CALCUL_KELVIN(X,EPS,KELVIN);
    : WITH SETKELVIN DO
    : BEGIN
    : Z := X;
    : FOR i := 1 TO 8 DO
    : KEL[i] := KELVIN[i]
    : END;
    : write(FILEKELVIN,SETKELVIN);
    : writeln('X= ',X:7:3);
    : X := X + DELTAX
    : END;
    : close(FILEKELVIN);
    : writeln;
    : writeln;
    : writeln('FISIERul CU VALORILE FUNCTIILOR KELVIN A FOST CREAT')
    : END;{CREARE}
    : PROCEDURE LISTARE(VAR FILEKELVIN:FILETYPE);
    : {LISTEAZA VALORILE FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA}
    : VAR
    : LIM1,LIM2,i,POZ:longint;
    : ALFA,BETA,GAMA: real;
    : BEGIN
    : assign(FILEKELVIN,'KELVIN.dat');
    : reset(FILEKELVIN);
    : read(FILEKELVIN,SETKELVIN);
    : ALFA := SETKELVIN.Z;
    : read(FILEKELVIN,SETKELVIN);
    : BETA := SETKELVIN.Z;
    : GAMA := BETA - ALFA;
    : write('X inf = ');
    : readln(XINF);
    : write('X sup = ');
    : readln(XSUP);
    : LIM1 := trunc((XINF-ALFA)/GAMA+1E-06);
    : LIM2 := trunc((XSUP-ALFA)/GAMA+1E-06);
    : writeln(lst,'X':3,'ber(x)':18,'bei(x)':19,'d(ber)/dx':19,'d(bei)/dx':19);
    : writeln(lst);
    : FOR i := LIM1 TO LIM2 DO
    : BEGIN
    : seek(FILEKELVIN,i);
    : read(FILEKELVIN,SETKELVIN);
    : WITH SETKELVIN DO
    : writeln(lst,Z:7:3,' ',KEL[1],' ',KEL[2],' ',KEL[3],' ',KEL[4])
    : END;
    : writeln(lst);
    : writeln(lst);
    : readln;
    : writeln(lst,'X':3,'ker(x)':18,'kei(x)':19,'d(ker)/dx':19,'d(kei)/dx':19);
    : writeln(lst);
    : FOR i := LIM1 TO LIM2 DO
    : BEGIN
    : seek(FILEKELVIN,i);
    : read(FILEKELVIN,SETKELVIN);
    : WITH SETKELVIN DO
    : writeln(lst,Z:7:3,' ',KEL[5],' ',KEL[6],' ',KEL[7],' ',KEL[8])
    : END;
    : close(FILEKELVIN)
    : END;{LISTARE}
    : PROCEDURE GRAFIC(VAR FILEKELVIN: FILETYPE);
    : {TRASEAZA GRAFICELE FUNCTIILOR KELVIN SI ALE DERIVATELOR ACESTORA}
    : VAR
    : GrDriver,GrMode,GrError: integer;
    : SETKELVIN: VALKELVIN;
    : FUNC: ARRAY[1..8] OF string[10];
    : MAXIM,MINIM: real;
    : RASPUNS,RASP: string[2];
    : LIM1,LIM2,i,POZ: longint;
    : k: integer;
    : DIMX,DIMY,ORIGINE,DELTA,X0,Y0,N1,N2,N3: word;
    : X,Y: array[1..2] OF word;
    : ALFA,BETA,GAMA,VALX,VALY: real;
    : SX,SY,S1Y,S2Y,S3Y: string[10];
    : TEXTY: string;
    : BEGIN
    : assign(FILEKELVIN,'KELVIN.dat');
    : reset(FILEKELVIN);
    : FUNC[1] := 'ber(x)';
    : FUNC[2] := 'bei(x)';
    : FUNC[3] := 'd(ber)/dx';
    : FUNC[4] := 'd(bei)/dx';
    : FUNC[5] := 'ker(x)';
    : FUNC[6] := 'kei(x)';
    : FUNC[7] := 'd(ker)/dx';
    : FUNC[8] := 'd(kei)/dx';
    : RASPUNS := 'DA';
    : WHILE (RASPUNS = 'DA') or (RASPUNS = 'da') DO
    : BEGIN
    : i := 1;
    : RASP := 'NU';
    : WHILE (i <= 8) AND ((RASP = 'NU') OR (RASP = 'nu')) DO
    : BEGIN
    : write('GRAFICUL FUNCTIEI ',FUNC[i],'...DA(da)/ NU(nu)?...');
    : readln(RASP);
    : IF (RASP='DA') or (RASP='da') THEN
    : k:=i;
    : i := i + 1
    : END;
    : seek(FILEKELVIN,0);
    : read(FILEKELVIN,SETKELVIN);
    : ALFA := SETKELVIN.Z;
    : read(FILEKELVIN,SETKELVIN);
    : BETA := SETKELVIN.Z;
    : GAMA := BETA - ALFA;
    : write('X inf = ');
    : readln(XINF);
    : write('X sup = ');
    : readln(XSUP);
    : LIM1 := trunc((XINF-ALFA)/GAMA+1E-06);
    : LIM2 := trunc((XSUP-ALFA)/GAMA+1E-06);
    : seek(FILEKELVIN,LIM1);
    : read(FILEKELVIN,SETKELVIN);
    : WITH SETKELVIN DO
    : BEGIN
    : MAXIM := KEL[k];
    : MINIM := KEL[k]
    : END;
    : FOR i := LIM1 TO LIM2 DO
    : BEGIN
    : seek(FILEKELVIN,i);
    : read(FILEKELVIN,SETKELVIN);
    : WITH SETKELVIN DO
    : BEGIN
    : IF MAXIM<KEL[k] THEN
    : MAXIM:= KEL[k];
    : IF MINIM>KEL[k] THEN
    : MINIM := KEL[k]
    : END
    : END;
    : DetectGraph(GrDriver,GrMode);
    : InitGraph(GrDriver,GrMode,'d:pascalBGI');
    : GrError := GraphResult;
    : IF GrError <> GrOK THEN
    : BEGIN
    : writeln('EROARE:,GraphErrorMsg(GrError)');
    : CloseGraph;
    : close(FILEKELVIN);
    : Exit
    : END;
    : SetGraphMode(GetMaxMode);
    : DIMX := GetMaxX - 20;
    : DIMY := GetMaxY - 20;
    : IF MAXIM*MINIM < 0 THEN
    : ORIGINE:=trunc(DIMY/(MAXIM-MINIM)*MAXIM)
    : ELSE
    : ORIGINE := DIMY;
    : DELTA := ORIGINE - 10;
    : SetTextStyle(SmallFont,HorizDir,2);
    : SetColor(Green);
    : Line(0,0,0,DIMY);
    : Line(0,ORIGINE,DIMX+20,ORIGINE);
    : MoveTo(DIMX,DELTA);
    : OutText('x');
    : MoveTo(20,20);
    : OutText(FUNC[k]);
    : SetColor(Cyan);
    : FOR i := 0 TO 9 DO
    : BEGIN
    : X0 := trunc(DIMX*i/10);
    : Y0 := DIMY - trunc(DIMY*i/10);
    : Line(X0,DELTA,X0,ORIGINE+10);
    : IF i > 0 THEN
    : MoveTo(X0 - 40,ORIGINE - 20)
    : ELSE MoveTo(X0,ORIGINE - 20);
    : VALX := XINF + (XSUP - XINF)*i/10;
    : Str(VALX:8:3,SX);
    : IF i > 1 THEN OutText(SX);
    : Line(0,Y0,20,Y0);
    : MoveTo(30,Y0);
    : VALY := MINIM + (MAXIM - MINIM)*i/10;
    : IF (abs(VALY)<1E3) and (abs(VALY)>=0.1) THEN
    : BEGIN
    : Str(VALY:8:4,SY);
    : OutText(SY)
    : END
    : ELSE
    : BEGIN
    : Str(VALY,TEXTY);
    : N1 := pos('.',TEXTY);
    : N2 := pos('E',TEXTY);
    : N3 := length(TEXTY);
    : S1Y := copy(TEXTY,1,N1);
    : S2Y := copy(TEXTY,N1+1,3);
    : S3Y := copy(TEXTY,N2,N3-N2+1);
    : OutText(S1Y+S2Y+S3Y)
    : END
    : END;
    : SetColor(Red);
    : seek(FILEKELVIN,LIM1);
    : read(FILEKELVIN,SETKELVIN);
    : X[1]:=trunc((SETKELVIN.Z-XINF)*DIMX/(XSUP-XINF));
    : Y[1] := DIMY-trunc((SETKELVIN.KEL[k]-MINIM)*DIMY/(MAXIM-MINIM));
    : FOR i := LIM1+1 TO LIM2 DO
    : BEGIN
    : seek(FILEKELVIN,i);
    : read(FILEKELVIN,SETKELVIN);
    : X[2]:=trunc((SETKELVIN.Z-XINF)*DIMX/(XSUP-XINF));
    : Y[2]:=DIMY-trunc((SETKELVIN.KEL[k]- MINIM)* DIMY/(MAXIM - MINIM));
    : Line(X[1],Y[1],X[2],Y[2]);
    : X[1] := X[2];
    : Y[1] := Y[2];
    : END;
    : readln;
    : CloseGraph;
    : write('DORITI TRASAREA ALTUI GRAFIC?.DA/NU');
    : readln(RASPUNS)
    : END;{WHILE}
    : close(FILEKELVIN)
    : END;{GRAFIC}
    : BEGIN{FUNCTII_KELVIN}
    : RASPUNS := 'DA';
    : WHILE (RASPUNS = 'DA') or (RASPUNS = 'da') DO
    : BEGIN
    : writeln('1: CREARE FISIERE FUNCTII KELVIN');
    : writeln('2: LISTARE VALORI FUNCTII KELVIN');
    : writeln('3: TRASARE GRAFIC FUNCTII KELVIN');
    : writeln;
    : writeln;
    : write('TASTATI NUMARUL VARIANTEI ');
    : readln(NUMAR);
    : CASE NUMAR OF
    : 1: CREARE(FILEKELVIN);
    : 2: LISTARE(FILEKELVIN);
    : 3: GRAFIC(FILEKELVIN)
    : END;
    : writeln;
    : writeln;
    : write('CONTINUATI?...DA(da)/NU(nu)... ');
    : readln(RASPUNS)
    : END
    : END{FUNCTII_KELVIN}.
    :
    : PROGRAM Regresie_polinomiala;
    : USES Crt;
    : CONST
    : nmax=20;
    : mmax=10;
    : TYPE
    : index=1..nmax;
    : grad=0..mmax;
    : mat=ARRAY[index,index] OF Real;
    : vec=ARRAY[index] OF Real;
    : vec1=ARRAY[grad] OF Real;
    : VAR
    : a:mat;
    : x,y,xsol:vec;
    : c:vec1;
    : n:index;
    : m:grad;
    : flg:Boolean;
    : PROCEDURE Gauss(n:index;a:mat;VAR xsol:vec;VAR flg:Boolean);
    : VAR
    : i,j,jp,k:index;
    : max,x:Real;
    : PROCEDURE schimba(i,j:index);
    : VAR
    : k:index;
    : x:Real;
    : BEGIN
    : FOR k:=1 TO nmax DO
    : BEGIN
    : x:=a[i,k]; a[i,k]:=a[j,k]; a[j,k]:=x
    : END
    : END; {Proc. schimba}
    : BEGIN
    : flg:=True;
    : FOR i:=1 TO n-1 DO
    : BEGIN
    : jp:=i; max:=Abs(a[i,i]);
    : FOR j:=i+1 TO n DO
    : IF Abs(a[j,i])>max THEN
    : BEGIN max:=Abs(a[j,i]); jp:=j; END;
    : IF max=0 THEN
    : BEGIN flg:=False; Exit END;
    : IF jp<>i THEN schimba(i,jp);
    : FOR j:=i+1 TO n DO
    : BEGIN
    : x:=a[j,i]/a[i,i];
    : FOR k:=i+1 TO n+1 DO
    : a[j,k]:=a[j,k]-a[i,k]*x
    : END
    : END;
    : IF a[n,n]=0 THEN BEGIN flg:=False; Exit END;
    : a[n+1,n]:=a[n,n+1]/a[n,n];
    : FOR i:=n-1 DOWNTO 1 DO
    : BEGIN
    : a[n+1,i]:=0;
    : FOR k:=i+1 TO n DO
    : a[n+1,i]:=a[n+1,i]+a[i,k]*a[n+1,k];
    : a[n+1,i]:=(a[i,n+1]-a[n+1,i])/a[i,i]
    : END;
    : FOR i:=1 TO n DO xsol[i]:=a[n+1,i]
    : END;
    : PROCEDURE Wait;
    : VAR
    : cc:Char;
    : BEGIN
    : WriteLn('Press a Key !');
    : REPEAT cc:=ReadKey; UNTIL cc<>''
    : END;
    : PROCEDURE Sistem(n:index;m:grad;VAR a:mat);
    : VAR
    : i,j,k,e : Integer;
    : sc,st : Real;
    : FUNCTION pr(baza:Real;exponent:Integer):Real;
    : VAR
    : i : Integer;
    : tr : Real;
    : BEGIN
    : tr:=1;
    : IF (exponent=0) THEN tr:=1
    : ELSE FOR i:=1 TO exponent DO
    : tr:=tr*baza;
    : pr:=tr;
    : END;
    : BEGIN
    : FOR i:=1 TO m+1 DO
    : BEGIN
    : st:=0;
    : FOR k:=1 TO n DO st:=st+y[k]*pr(x[k],i-1);
    : a[i,m+2]:=st;
    : FOR j:=i TO m+1 DO
    : BEGIN
    : sc:=0; e:=i+j-2;
    : FOR k:=1 TO n DO sc:=sc+pr(x[k],e);
    : a[i,j]:=sc; a[j,i]:=sc
    : END
    : END
    : END;
    : PROCEDURE scriesist;
    : VAR
    : i,j:index;
    : BEGIN
    : WriteLn;
    : FOR i:=1 TO m+1 DO
    : BEGIN
    : FOR j:=1 TO m+1 DO Write(a[i,j]:12:2);
    : WriteLn(' ',a[i,m+2]:12:2)
    : END;
    : WriteLn
    : END;
    : PROCEDURE Date;
    : VAR
    : k:Integer;
    : BEGIN
    : Write('Nr. date experimentale=');ReadLn(n);WriteLn;
    : FOR k:=1 TO n DO
    : BEGIN
    : Write('x(',k,')=');ReadLn(x[k]);Write('y(',k,')=');ReadLn(y[k])
    : END;
    : Write('Gradul polinomului de regresie=');ReadLn(m);WriteLn;
    : END;
    : PROCEDURE scriesol;
    : VAR
    : i:Integer;
    : BEGIN
    : WriteLn; WriteLn('Solutia');
    : FOR i:=1 TO m+1 DO Write(xsol[i]:12:3); WriteLn
    : END;
    : BEGIN {Main Prog.}
    : ClrScr; Date; Sistem(n,m,a); Scriesist;
    : Gauss(m+1,a,xsol,flg); Scriesol; Wait
    : END {Regresie_polinomiala}.
    :
    : program newtown_stanga;
    : var a,b,n,i,k:integer; {a si b sunt extemitatile intervalului pe care e definita f}
    : x,y,c:array[0..10] of real;
    : xd,h,p,t:real;
    : function deltayO(k:integer):real;
    : var d:real;
    : begin
    : if k mod 2=0 then c[0]:=1
    : else c[0]:=-1;
    : for i:=n downto 1 do
    : c[i]:=0;
    : d:=0;
    : for i:=n downto 1 do
    : c[i]:=c[i-1]*(k-i+1)/i;
    : for i:=k downto 0 do
    : d:=d+c[i]*y[i];
    : deltayO:=d;
    : end;
    : begin
    : write('introduce a:');
    : readln(a);
    : write('introduce b:');
    : readln(b);
    : write('nr de noduri:');
    : readln(n);
    : writeln('introduce valoare functiei in nodurile date:');
    : for i:=1 to n do
    : read(y[i]);readln;
    : write('introduce valoarea argumentului in care vrem sa interpolam:');
    : readln(xd);
    : x[0]:=a;
    : x[n]:=b;
    : h:=(b-a)/n;
    : for i:=n-1 downto 1 do
    : x[i]:=x[n]+i*h;
    : t:=1;
    : p:=y[n];
    : for k:=n downto 1 do begin
    : t:=t*(xd-x[k-1])/(k*h);
    : p:=p+deltayO(k)*t;end;
    : writeln('valoarea interpolata in punctul ',xd:6:3,' este:',p:7:3);
    : readln;
    : end.
    :
    :
    :
    Change each program into a procedure. The use a code like this to combine them into a single program:
    [code]
    var
    i: integer;
    begin
    repeat
    writeln('1: bessel');
    writeln('2: Kelvin');
    { etc. }
    writeln('99: Quit');
    readln(i);
    case i of
    1: CallBessel;
    2: CallKelvin;
    { etc. }
    end;
    until i = 99;
    end.
    [/code]
  • nubensnubens Posts: 2Member
    : Change each program into a procedure. The use a code like this to combine them into a single program:
    : [code]
    : var
    : i: integer;
    : begin
    : repeat
    : writeln('1: bessel');
    : writeln('2: Kelvin');
    : { etc. }
    : writeln('99: Quit');
    : readln(i);
    : case i of
    : 1: CallBessel;
    : 2: CallKelvin;
    : { etc. }
    : end;
    : until i = 99;
    : end.
    : [/code]
    :

    Thank you.
Sign In or Register to comment.