Language: Turbo Pascal.
Objective: This program performs multiple non-linear regression, according to a function previously defined by the user.
Notes: The compilation of this program must be done under the Turbo Pascal compiler, version 5.0 or superior.
***** Begin of Program Listing *****
Program Morgana;
{--------------------------------------------------------------------------}
{- -}
{- M O R G A N A -}
{- -}
{- -}
{- Non-Linear Multiple Regression Program -}
{- -}
{- -}
{- Reference: -}
{- -}
{- - CACECI, M.S. & CACHERIS, W.P.: Byte, May 1984, 340-62. -}
{- -}
{- -}
{- Antonio Augusto Gorni --- May 13, 1990 -}
{- -}
{- Lattest Revision: August 28, 1991 -}
{- -}
{--------------------------------------------------------------------------}
{$R+}
Uses
Dos, Crt, Printer;
const
IOerr : boolean = false; { Detecta Erro de E/S }
MNP = 350; {Numero Maximo Possivel de Dados}
ALFA = 1.0; {Coeficiente de Reflexao, >0}
BETA = 0.5; {Coeficiente de Contracao, 0~1}
GAMMA = 2.0; {Coeficiente de Expansao, >1}
ROOT2 = 1.414214;
TYPE
VECTOR = ARRAY[1..20] OF REAL;
DATAROW = ARRAY[1..20] OF REAL;
INDEX = 0..255;
String40 = String[40];
VAR
DONE : BOOLEAN;
I,J,K : INTEGER;
H,L : ARRAY[1..20] OF INDEX;
NP, M, N,
NVPP,
MAXITER,
NITER,NDAT : INTEGER;
NEXT,
CENTER,
MEAN, ERROR,
MAXERR,
P, Q,
STEP : VECTOR;
SIMP : ARRAY[1..20] OF VECTOR;
DATA : ARRAY[1..500] OF DATAROW;
var
Func : integer;
Narq : string;
Bandeira, SalvaDados : boolean;
function Potencia(x, y : real) : real;
begin
Potencia:=exp(Ln(x)*y);
end; {Potencia}
{- This is the Function to be Programmed by the User -}
Function F(X: Vector; D: Datarow) : REAL;
begin
If D[2]=0 then Bandeira:=False
else
begin
F:=x[1]+X[2]*(exp(0.126-1.75*0.07+0.594*0.07*0.07+
(2851+2968*0.07-1120*0.07*0.07)/D[1])*
Potencia(D[2],0.21)*Potencia(D[3],0.13));
Bandeira:=True;
end
end;
procedure IOCheck;
{---------------------------------------------------}
{- Check for I/O error; print message if needed. -}
{---------------------------------------------------}
type
String80 = string[80];
var
IOcode : integer;
procedure Error(Msg : String80);
begin
Writeln;
Write(^G); { Beep! }
Writeln(Msg);
Writeln;
end; { procedure Error }
begin { procedure IOCheck }
IOcode := IOresult;
IOerr := IOcode <> 0;
if IOerr then
case IOcode of
2 : Error('File not found.');
3 : Error('Path not found.');
4 : Error('Too many open files.');
5 : Error('File access denied.');
6 : Error('Invalid file handle.');
12 : Error('Invalid file access code.');
15 : Error('Invalid drive number.');
16 : Error('Cannot remove current directory.');
17 : Error('Cannot rename across drives.');
100 : Error('Disk read error.');
101 : Error('Disk write error.');
102 : Error('File not assigned.');
103 : Error('File not open.');
104 : Error('File not open for input.');
105 : Error('File not open for output.');
106 : Error('Invalid numeric format.');
else
begin
Writeln;
Writeln(^G);
Writeln('Unidentified error message = ', IOcode, '. See manual.');
Writeln;
end;
end; { case }
end; { procedure IOCheck }
function FileExists(Fname : String40) : boolean;
var
CheckFile : file;
begin
Assign(CheckFile, Fname);
{$I-} Reset(CheckFile); {$I+}
if IOresult = 0 then
begin
FileExists := true;
Close(CheckFile)
end
else
FileExists := false;
end; { function FileExists }
procedure Tela1;
begin
TextMode(0);
GoToXY(1,6);
write('****************************************');
write('* *');
write('* M O R G A N A *');
write('* *');
write('* *');
write('* Developed by *');
write('* *');
write('* Antonio Augusto Gorni - QTT/M *');
write('* COSIPA - C.P. 11 - 11573-900 *');
write('* Cubatao, SP Brazil *');
write('* *');
write('* Lattest Revision: 26/08/1991 *');
write('* *');
write('****************************************');
delay(5000);
TextMode(2)
end; { procedure Tela1 }
procedure Flash;
begin
TextBackground(0);
TextColor(31);
end;
procedure Normal;
begin
TextBackground(0);
TextColor(7);
end;
procedure Inverse;
begin
TextBackground(7);
TextColor(0);
end;
procedure Centraliza(var Buffer : string);
begin
GotoXY(round((80-Length(Buffer))/2+1),1);
Inverse;
Writeln(Buffer);
Normal;
end; {procedure Centraliza}
procedure Tabula(var Buffer, BufImpr : string;
Posicao : integer);
var
i, Compr : integer;
begin
for i := 1 to Posicao - Length(BufImpr) do
Buffer := ' ' + Buffer;
BufImpr:=BufImpr+Buffer;
end; {Tabula}
procedure CabImpr(var BufImpr, Buffer : string;
var NroPag : integer);
var
Ano, Mes, Dia, DiaSemana, Hora, Minuto, Segundo, CentSegundo : word;
begin
Writeln(Lst,BufImpr);
Writeln(Lst,Buffer);
GetDate(Ano, Mes, Dia, DiaSemana);
GetTime(Hora, Minuto, Segundo, CentSegundo);
Write(Lst,'Page no. ',NroPag,' ***** ');
Write(Lst,Dia,'/',Mes,'/',Ano,', ',Hora,':');
If Minuto<10 then Write(Lst,'0');
Writeln(Lst,Minuto);
Writeln(Lst); Writeln(Lst); Writeln(Lst);
end; {CabImpr}
Procedure Eject;
begin
Writeln(Lst,#$C);
end; {Eject}
procedure Dir(var Caminho : string;
Espec : string);
var
Contador, i, j, NroLin : integer;
Flag : boolean;
Buffer : string;
Tipo : word;
ArqDados : SearchRec;
ArqRes : Array [1..255] of string[12];
begin
Contador := 0;
Tipo := 0;
FindFirst(Caminho + Espec, Tipo, ArqDados);
If DosError = 0 then
begin
ArqRes[Contador+1] := ArqDados.Name;
Contador := Contador + 1;
Flag := true;
While Flag do
begin
FindNext(ArqDados);
If DosError = 0 then
begin
ArqRes[Contador+1] := ArqDados.Name;
Contador := Contador + 1;
end
else Flag := false;
end;
end;
ClrScr;
Write('DIRETORIO: '); Inverse; Writeln(Caminho); Normal; Writeln;
if Contador = 0 then
begin
GotoXY(1,7); Flash;
Writeln('No File Was Found in this Directory!');
Normal;
GotoXY(1,14); Write('Press to Continue... '); Readln(Buffer);
end
else
begin
For i:=1 to Trunc(Contador/5)+1 do
begin
if i mod 20 = 0 then
begin
Writeln; Writeln;
Write('Press to Continue... '); Readln(Buffer); ClrScr;
GotoXY(1,4);
Write('DIRECTORY: '); Inverse; Writeln(Caminho); Normal; Writeln;
end;
for j := 1 to 5 do
begin
if 5*(i-1)+j <= Contador then
begin
GotoXY((j-1)*15+1,WhereY);
write(ArqRes[5*(i-1)+j]);
end;
end;
Writeln;
end;
Writeln; Writeln;
Write('Press to Continue... '); Readln(Buffer);
end;
end; {Dir}
PROCEDURE SUM_OF_RESIDUALS (VAR X : VECTOR);
VAR I : INTEGER;
BEGIN
X[N] := 0.0;
FOR I := 1 TO NP DO
X[N] := X[N] + SQR(F(X,DATA[I]) - DATA [I,NVPP]);
END;
Procedure New_Vertex;
var Media : Real;
begin
Media:=0.0;
For i:=1 to N do
begin
Media:=Media+Error[i];
Simp[H[N],i]:=Next[i];
end;
Media:=Media/N;
GotoXY(1,15);
Writeln('# ',Niter:4,' -> ',Mean);
end;
PROCEDURE ORDER;
VAR I,J : INDEX;
BEGIN
FOR J:=1 TO N DO
BEGIN
FOR I:=1 TO N DO
BEGIN
IF SIMP[I,J]SIMP[H[J],J] THEN H[J]:=I
END
END
END;
procedure MenuPrincipal(var Funcao : integer);
var
NroFuncoes : integer;
Buffer : string;
begin
Window(1,1,80,25);
ClrScr;
Buffer := 'NON-LINEAR MULTIPLE REGRESSION';
Centraliza(Buffer);
GotoXY(29,6); Writeln('<1> Data Input');
GotoXY(29,8); Writeln('<2> Data Correction');
GotoXY(29,10); Writeln('<3> Data Suppression');
GotoXY(29,12); Writeln('<4> Data Output');
GotoXY(29,14); Writeln('<5> Non-Linear Multiple Regression');
GotoXY(29,16); Writeln('<6> End');
Funcao:=100;
While (Funcao < 1) or (Funcao > 7) do
Begin
GotoXY(29,21); Write('Your Option? '); Readln(Funcao);
End;
end; {procedure MenuPrincipal}
procedure EntradaDados;
var
Buffer, Espec, Caminho : string;
Funcao, Cod, Nr, i,j : integer;
InFile : text;
begin
ClrScr;
Buffer := 'DATA INPUT';
Centraliza(Buffer);
Window(1,4,80,25);
if SalvaDados then
begin
ClrScr;
write(^G);
GotoXY(1,9); Flash; Writeln('Data Not Saved Yet!'); Normal;
Buffer := '';
While ((Buffer <> 'Y') and (Buffer <> 'N')) do
begin
GotoXY(1,13); Write('Do You Want to Continue (Y/N)? '); Readln(Buffer);
end;
ClrScr;
end;
if (Buffer = 'Y') or (not SalvaDados) then
begin
GotoXY(32,6); Writeln('<1> New Data');
GotoXY(32,10); Writeln('<2> More Data');
Funcao := 100;
While ((Funcao < 1) or (Funcao > 2)) do
begin
GotoXY(32,18); Write('Your Choice? '); Readln(Funcao);
end;
If Funcao = 1 then
begin
ClrScr;
Buffer:='';
While (Buffer<>'Y') and (Buffer<>'N') do
begin
GotoXY(1,10);
Write('The Proposed Function is Already Programmed (Y/N)? ');
Readln(Buffer);
end;
If Buffer='N' then
begin
ClrScr; GotoXY(1,8);
Writeln('Define the Proposed Function as "Function F" in this Listing;');
Writeln;
Writeln('X[i] Is the Array with the Constants to be Adjusted;');
Writeln('D[i] Is the Array with the Experimental Data;');
Writeln('ESTADO Is a Flag Variable which Signs Problems during the Fitting Process.');
Writeln;
Writeln('Press to Continue...'); Readln(Buffer); ClrScr;
Writeln; Writeln;
Halt;
end;
SalvaDados := False;
NP := 0;
Narq:='';
end;
Buffer := 'INPUT OPTIONS';
Window(1,1,80,25);
ClrScr;
Centraliza(Buffer);
GotoXY(35,9); Writeln('<1> Keyboard');
GotoXY(35,13); Writeln('<2> Disk');
Funcao := 100;
While ((Funcao < 1) or (Funcao > 2)) do
begin
GotoXY(35,22); Write('Your Choice? '); Readln(Funcao);
end;
If Funcao = 1 then
begin
Buffer := 'INPUT VIA KEYBOARD';
Window(1,1,80,25);
ClrScr;
Centraliza(Buffer);
Window(1,4,80,25);
if np=0 then
begin
Write('Number of Independent Variables? ');
Readln(nvpp); nvpp:=nvpp+1;
writeln; writeln;
end;
Writeln('Now Enter the Data.');
Writeln('Write to Finish');
Writeln; Buffer := '';
While Buffer <> 'END' do
begin
NP := NP + 1;
Writeln;
Writeln('Point #', NP);
for i:=1 to nvpp do
begin
if i=nvpp then
begin
Write('Dependent Variable? '); Readln(Buffer);
end
else
begin
Write('Variable ',i,'? '); Readln(Buffer);
end;
if Buffer='END' then i:=nvpp
else Val(Buffer,Data[NP,i],Cod);
end;
end;
NP := NP - 1;
if NP <> 0 then SalvaDados := true;
end
else
begin
Buffer := 'INPUT VIA DISK';
Window(1,1,80,25);
ClrScr;
Centraliza(Buffer);
Window(1,4,80,25);
Narq := '?';
While Narq = '?' do
begin
GotoXY(1,6);
Write('File Name (? to List Directory)? ');
Readln(Narq);
If Narq = '?' then
begin
Writeln; Write('Drive or Path? '); Readln(Caminho);
Dir(Caminho,'*.MRG'); ClrScr;
end;
end;
Narq := Narq + '.MRG';
If not FileExists(Narq) then
begin
ClrScr;
GotoXY(1,9);
Write(^G);
Flash; Writeln('File ',Narq,' does not Exist!'); Normal;
Writeln; GotoXY(1,13);
Write('Press to Continue... ');
Readln(Buffer);
end
else
begin
If NP <> 0 then SalvaDados := true;
GotoXY(1,16); Write('Reading '); Flash; Writeln(Narq);
Assign(InFile,Narq);
Reset(InFile);
{I-} Readln(InFile, nvpp); {I+}
IOCheck;
{I-} Readln(InFile, Nr); {I+}
IOCheck;
for i := 1 to Nr do
for j := 1 to nvpp do
begin
{I-} Readln(InFile, Data[NP+i,j]); {i+}
IOCheck;
end;
Close(InFile);
NP := NP + Nr
end;
end;
end;
end; {EntradaDados}
Procedure CorrigeDados;
var
Buffer : string;
Cod, Nponto,i : integer;
begin
ClrScr;
Buffer := 'DATA CORRECTION';
Centraliza(Buffer);
Window(1,4,80,25);
While Buffer <> 'END' do
begin
ClrScr;
GotoXY(1,7); Writeln('Index of the Point ( to Finish)? ');
Readln(Buffer); Writeln;
If Buffer <> 'END' then
begin
Val(Buffer, Nponto, Cod);
If ((Nponto >= 1) and (Nponto <= NP)) then
begin
for i:=1 to nvpp do
begin
if i=nvpp then write('Dependente Variable = ')
else write('X[',i,']',' = ');
write(Data[Nponto,i],'. New Value? ');
Readln(Buffer);
If Buffer <> '' then Val(Buffer,Data[Nponto,i],Cod);
SalvaDados := True;
end;
end;
end;
end;
end; {Corrige Dados}
Procedure SuprimeDados;
var
Cod, Nponto, NroSupr, i, j, k, Troca : integer;
Vsupr : array [1..30] of integer;
Buffer, Buffer1 : string;
begin
NroSupr := 0;
ClrScr;
Buffer := 'DATA SUPPRESSION';
Centraliza(Buffer);
Window(1,4,80,25);
While Buffer <> 'END' do
begin
ClrScr;
GotoXY(1,7); Writeln('Point Index ( para Terminar)? ');
Readln(Buffer);
If Buffer <> 'END' then
begin
Val(Buffer, Nponto, Cod);
If ((Nponto >= 1) and (Nponto <= NP)) then
begin
writeln;
for i:=1 to nvpp do
begin
if i mod 2 = 1 then GotoXY(1,WhereY)
else GotoXY(41,WhereY);
if i = nvpp then Write('Dependent Variable = ')
else Write('X[',i,'] = ');
if i mod 2 = 1 then Write(Data[Nponto,i])
else Writeln(Data[Nponto,i]);
end;
Buffer1 := '';
While ((Buffer1 <> 'Y') and (Buffer1 <> 'N')) do
begin
GotoXY(1,12); Writeln(^G); Write('Confirm (Y/N)! ');
Readln(Buffer1);
end;
If Buffer1 = 'Y' then
begin
NroSupr := NroSupr + 1; Vsupr[NroSupr] := Nponto;
end
else ClrScr;
end;
end;
end;
If NroSupr > 0 then
begin
GotoXY(1,14); Write(^G); Flash;
Writeln('Making Suppresions...');
Normal;
for i := 1 to NroSupr - 1 do for j := i + 1 to NroSupr do
If Vsupr[j] > Vsupr[i] then
begin
Troca := Vsupr[j]; Vsupr[j] := Vsupr[i]; Vsupr[i] := Troca;
end;
for j := 1 to NroSupr do
begin
For i := Vsupr[j] to NP - 1 do
For k := 1 to nvpp do Data[i,k] := Data[i+1,k];
NP := NP - 1;
end;
end;
SalvaDados := True;
end; {SuprimeDados}
Procedure SaidaDados;
var
Opcao, Contador, i, NroPag : integer;
BufAux, Buffer, BufImpr, Mensagem, Caminho : string;
OutFile : text;
begin
ClrScr;
Buffer := 'DATA OUTPUT';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(35,4); Writeln('<1> Screen');
GotoXY(35,8); Writeln('<2> Printer');
GotoXY(35,12); Writeln('<3> Disk');
Opcao := 100;
While ((Opcao < 1) or (Opcao > 3)) do
begin
GotoXY(35,18); Write('Your Choice? '); Readln(Opcao);
end;
Case Opcao of
1 : begin
Window(1,1,80,25); ClrScr;
Buffer := 'DATA OUTPUT';
Centraliza(Buffer);
Window(1,4,80,25);
Contador := 0;
For i := 1 to NP do
begin
Writeln('Point # ',i); Contador:=Contador+1;
For j:=1 to nvpp do
begin
if j mod 2 = 1 then GotoXY(1,WhereY)
else GotoXY(41,WhereY);
if j = nvpp then Write('Dependente Variable = '
else Write('X[',j,'] = ');
if (j mod 2 = 1) and (j <> nvpp) then Write(Data[i,j])
else
begin
Writeln(Data[i,j]); Contador:=Contador+1;
end;
if j = nvpp then
begin
Writeln; Contador:=Contador+1;
end;
If ((Contador >= 16) and (i < NP)) and (j mod 2 = 0) then
begin
GotoXY(1,21);
Flash; Write('Press to Continue...'); Normal;
Contador := 0;
Readln(Buffer);
ClrScr; GotoXY(1,1);
end;
end;
end;
GotoXY(1,21);
Flash; Write('Press to Continue.'); Normal;
Readln(Buffer);
ClrScr;
end;
2 : begin
Window(1,1,80,25); ClrScr;
Buffer := 'DATA PRINTING';
Centraliza(Buffer);
Window(1,4,80,25); GotoXY(1,8);
Writeln('Enter Data Identification Message.');
Readln(Mensagem);
Writeln; Writeln; Writeln;
Write('Prepare Printer, Mark Start of Report.');
Writeln; Writeln;
Write('Press to Continue...');
NroPag := 1; Readln(Buffer);
BufImpr := 'Data for Non-Linear Multiple Regression';
CabImpr(BufImpr,Mensagem,NroPag); Contador := 0;
For i:=1 to NP do
begin
Writeln(Lst); Writeln(Lst,'Point #',i); BufImpr:='';
Contador:=Contador+2;
for j:=1 to nvpp do
begin
Str(Data[i,j],Buffer);
Tabula(Buffer,BufImpr,(j-1)*19);
if j mod 4 = 0 then
begin
Writeln(Lst,BufImpr);
BufImpr:='';
Contador:=Contador+1;
end;
If ((Contador >= 55) and (i < NP)) then
begin
BufAux:=BufImpr;
NroPag := NroPag + 1; Eject;
BufImpr := 'Data for Non-Linear Regression';
CabImpr(BufImpr,Mensagem,NroPag); Contador := 0;
BufImpr := BufAux;
end;
end;
if nvpp mod 4 <> 0 then
begin
Writeln(Lst,BufImpr);
BufImpr:='';
Contador:=Contador+1;
end;
end;
Eject;
ClrScr;
end;
3 : begin
Window(1,1,80,25); ClrScr;
Buffer := 'DATA SAVING IN DISK';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(1,6);
If Narq<>'' then
begin
Buffer:='';
While ((Buffer<>'Y') and (Buffer<>'N')) do
begin
GotoXY(1,8); Write('Do You Want to Save in '); Flash; Write(Narq);
Normal; Write(' (Y/N)? '); Readln(Buffer); ClrScr;
end;
end;
If ((Narq='') or (Buffer='N')) then
begin
Narq := '?';
While Narq = '?' do
begin
GotoXY(1,6);
Write('File Name (? to List Directory)? ');
Readln(Narq);
If Narq = '?' then
begin
Writeln; Write('Drive or Path? '); Readln(Caminho);
Dir(Caminho,'*.MRG'); ClrScr;
end
else Narq:=Narq+'.MRG';
end;
end;
GotoXY(1,16); Write('Saving '); Flash; Writeln(Narq);
Assign(OutFile,Narq);
Rewrite(OutFile);
{I-} Writeln(OutFile, nvpp); {I+}
IOCheck;
{I-} Writeln(OutFile, NP); {I+}
IOCheck;
for i := 1 to NP do
for j := 1 to nvpp do
begin
{I-} Writeln(OutFile, Data[i,j]); {i+}
IOCheck;
end;
Close(OutFile); SalvaDados := false;
end;
end; {Case}
end; {SaidaDados}
Procedure AjustaCurvas;
var
Contador : index;
Console, Impressora, Buffer, BufImpr, BufAux : string;
a1, b1, s1, s2, y, st, d, p1, d2, be, xe, z, ff, d1, ae, fe, ye,
z1, st1, st2, MediaY : real;
Ano, Mes, Dia, DiaSemana, Hora, Minuto, Segundo, CentSegundo : word;
ep, pn, c : real;
Impressao : array[1..7,1..2] of string[80];
begin
Console:='Con';
Impressora:='Lst';
ClrScr;
Buffer := 'NON-LINEAR MULTIPLE REGRESSION';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(1,5);
Write('Maximum Number of Interactions? '); Readln(Maxiter); Writeln;
Write('Number of Constants to Fit? '); Readln(m); n:=m+1;
Writeln;
For i:=1 to M do
begin
Write('Guess of the Constant ',i,'? '); Readln(Simp[1,i]);
end;
Writeln;
For i:=1 to M do
begin
Write('Increment of the Parameter ',i,'? '); Readln(Step[i]);
end;
Writeln;
For i:=1 to N do
If i = n then
begin
Write('Precision of the Residuals? '); Readln(Maxerr[i]);
end
else
begin
Write('Parameter Precision ',i,'? '); Readln(Maxerr[i]);
end;
ClrScr;
GotoXY(1,8); Writeln('Cogito, Ergo Sum!');
GotoXY(1,10); Writeln('Maximum Number of Interactions: ',MAXITER);
SUM_OF_RESIDUALS(SIMP[1]);
FOR I:=1 TO M DO
BEGIN
P[I]:=STEP[I]*(SQRT(N)+M-1)/(M*ROOT2);
Q[I]:=STEP[I]*(SQRT(N)-1)/(M*ROOT2)
END;
FOR I:=2 TO N DO
BEGIN
FOR J:=1 TO M DO SIMP[I,J]:= SIMP[1,J]+Q[J];
SIMP[I,I-1]:=SIMP[1,I-1]+P[I-1];
SUM_OF_RESIDUALS(SIMP[I])
END;
FOR I:=1 TO N DO
BEGIN
L[I]:=1; H[I]:=1
END;
ORDER;
NITER:=0;
REPEAT
DONE:=TRUE;
NITER:=SUCC(NITER);
FOR I:=1 TO N DO CENTER[I]:=0.0;
FOR I:=1 TO N DO
IF I<>H[N] THEN
FOR J:=1 TO M DO
CENTER[J]:=CENTER[J]+SIMP[I,J];
FOR I:=1 TO N DO
BEGIN
CENTER[I]:=CENTER[I]/M;
NEXT[I]:=(1.0+ALFA)*CENTER[I]-ALFA*SIMP[H[N],I]
END;
SUM_OF_RESIDUALS(NEXT);
IF NEXT[N]<=SIMP[L[N],N] THEN
BEGIN
NEW_VERTEX;
FOR I:=1 TO M DO
NEXT[I]:=GAMMA*SIMP[H[N],I]+(1.0-GAMMA)*CENTER[I];
SUM_OF_RESIDUALS(NEXT);
IF NEXT[N]<=SIMP[L[N],N] THEN NEW_VERTEX
END
ELSE
IF NEXT[N]<=SIMP[H[N],N] THEN NEW_VERTEX
ELSE
BEGIN
FOR I:=1 TO M DO
NEXT[I]:=BETA*SIMP[H[N],I]+(1.0-BETA)*CENTER[I];
SUM_OF_RESIDUALS(NEXT);
IF NEXT[N]<=SIMP[H[N],N] THEN NEW_VERTEX
ELSE
FOR I:=1 TO N DO
BEGIN
FOR J:=1 TO M DO SIMP[I,J]:=(SIMP[I,J]+SIMP[L[N],J])*BETA;
SUM_OF_RESIDUALS(SIMP[I])
END
END;
ORDER;
FOR J:=1 TO N DO
BEGIN
ERROR[J]:=(SIMP[H[J],J]-SIMP[L[J],J])/SIMP[H[J],J];
IF DONE THEN
IF ABS(ERROR[J])>ABS(MAXERR[J]) THEN DONE:=FALSE
END
UNTIL (DONE OR (NITER=MAXITER));
FOR I:=1 TO N DO
BEGIN
MEAN[I]:=0.0;
FOR J:=1 TO N DO MEAN[I]:=MEAN[I]+SIMP[J,I];
MEAN[I]:=MEAN[I]/N
END;
st:=0.; st1:=0.;
for j:=1 to NP do st1:=st1+Data[j,nvpp];
MediaY:=st1/NP;
st1:=0.;
for j:= 1 to NP do
begin
y:=F(Mean,Data[j]);
d:=Data[j,nvpp]-y; st:=st+d*d; d:=Data[j,nvpp]-MediaY; st1:=st1+d*d;
end;
c:=abs(1-(st/(NP-2))/(st1/(NP-1)));
if c>1 then c:=0.001;
ep:=sqrt(st/NP); ff:=c*(NP-2)/(1-c);
p1:=1; d1:=1; d2:=NP-2;
if ((d1=0) or (d2=0) or (ff=0)) then pn:=p1
else
begin
if ff < 1 then
begin
ae:=d2; be:=d1; fe:=1/ff
end
else
begin
ae:=d1; be:=d2; fe:=ff
end;
a1:=2/(9*ae); b1:=2/(9*be); xe:=(1-b1)*Potencia(fe,0.3333333)-1+a1;
ye:=sqrt(b1*Potencia(fe,0.66666667)+a1); z:=abs(xe/ye);
if be < 4 then z:=z*(1+0.08*Potencia(z,4)/Potencia(be,3));
z1:=0.115194+z*(0.000344+z*0.019527);
p1:=0.5/Potencia(1+z*(0.196854+z*z1),4);
if ff<0 then pn:=p1*100
else pn:=(1-p1)*100;
end;
if pn=100 then pn:=99.999999; Bandeira:=True;
ClrScr; GotoXY(1,6); Inverse; Writeln('End of Calculations!'); Normal;
GotoXY(1,9); Writeln('Maximum Number of Iteractions: ',MaxIter);
GotoXY(1,11); Writeln('Effective Number of Iteractions: ', NIter);
GotoXY(1,18); Flash; Write('Press to Continue...'); Normal;
Readln(Buffer);
ClrScr; GotoXY(1,2); Writeln('Solutions:'); GotoXY(1,4);
For i:=1 to M do
begin
Writeln('X(',i,') = ',Mean[i]);
end;
GotoXY(1,WhereY+2);
Flash; Write('Press to Continue...'); Normal; Readln(Buffer);
ClrScr; GotoXY(1,2); Writeln('Estimated Fractionary Errors:');
GotoXY(1,4);
For i:=1 to M do
begin
Writeln('Err(',i,') -> ',Error[i]);
end;
GotoXY(1,WhereY+2);
Flash; Write('Press to Continue...'); Normal; Readln(Buffer);
ClrScr; GotoXY(1,6); Writeln('R^2: ',c); GotoXY(1,9);
Write('E.P.E.: ',ep); GotoXY(1,12);
Writeln('% Confidence: ',pn); GotoXY(1,WhereY+4);
Flash; Write('Press to Continue...'); Normal; Readln(Buffer);
ClrScr;
repeat
GotoXY(1,6); Write('Do Your Want to Print Results (Y/N)? ');
Readln(Buffer);
until (Buffer='Y') or (Buffer='N');
if Buffer='Y' then
begin
ClrScr; GotoXY(1,6); Writeln('Enter Results Identification Message.');
Readln(Buffer); ClrScr;
GotoXY(1,6); Write('Prepare Printer and Press !');
Readln(BufAux);
Writeln(Lst,'NON-LINEAR MULTIPLE REGRESSION');
Writeln(Lst,'Version 1.1990, IBM-XT'); Writeln(Lst);
If Narq<>'' then
begin
Write(Lst,'Data from');
If SalvaDados then Write(Lst,' (partially)');
Write(Lst,' the File ',Narq,' *** ')
end
else
Write(Lst,'Data Entered via Keyboard *** ');
GetDate(Ano, Mes, Dia, DiaSemana);
GetTime(Hora, Minuto, Segundo, CentSegundo);
Write(Lst,Dia,'/',Mes,'/',Ano,', ',Hora,':');
If Minuto<10 then Write(Lst,'0');
Writeln(Lst,Minuto);
Writeln(Lst,''); Writeln(Lst,Buffer); Writeln(Lst,''); Writeln(Lst,'');
Writeln(Lst,'Maximum Number of Iteractions: ',MaxIter);
Writeln(Lst,'Effective Number of Iteractions: ', NIter);
Writeln(Lst); Writeln(Lst);
Writeln(Lst,'Solutions:'); Writeln(Lst);
For i:=1 to M do Writeln(Lst,'X(',i,') = ',Mean[i]);
Writeln(Lst); Writeln(Lst);
Writeln(Lst,'Estimated Fractionary Errors:'); Writeln(Lst);
For i:=1 to M do Writeln(Lst,'Err(',i,') -> ',Error[i]);
Writeln(Lst); Writeln(Lst);
Writeln(Lst,'R^2: ',c);
Writeln(Lst,'E.P.E.: ',ep);
Writeln(Lst,'% Confidence: ',pn); Writeln(Lst); Writeln(Lst);
end;
end; {AjustaCurvas}
procedure Fim;
var
Buffer : string;
begin
If SalvaDados then
begin
ClrScr;
Buffer := 'END OF PROGRAM RUN';
Centraliza(Buffer);
Window(1,4,80,25);
GotoXY(1,9); Flash;
Writeln(^G'Data Were Not Saved Yet!');
Normal;
Buffer := '';
While ((Buffer<>'Y') and (Buffer<>'N')) do
begin
GotoXY(1,12); Write('Quit Program (Y/N)? '); Readln(Buffer);
end;
if Buffer = 'Y' then
begin
ClrScr;
Halt;
end;
end
else
begin
ClrScr;
Halt
end;
end; {Fim}
begin { program Morgana }
Tela1;
SalvaDados := false;
Bandeira := false;
While true do
begin
MenuPrincipal(Func);
case Func of
1 : EntradaDados;
2 : CorrigeDados;
3 : SuprimeDados;
4 : SaidaDados;
5 : AjustaCurvas;
6 : Fim;
end; {case}
end;
end. { program Morgana }
***** End of Program Listing ******
Return to the Software Menu.
 |
Last Update: 28 June 1996 | |
| © Antonio Augusto Gorni |