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

Welcome to the new platform of Programmer's Heaven! We apologize for the inconvenience caused, if you visited us from a broken link of the previous version. The main reason to move to a new platform is to provide more effective and collaborative experience to you all. Please feel free to experience the new platform and use its exciting features. Contact us for any issue that you need to get clarified. We are more than happy to help you.

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.