home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MISC / MATH / DELPX02.ZIP / FNUNIT.INC < prev    next >
Encoding:
Text File  |  1991-06-17  |  3.1 KB  |  116 lines
  1.  
  2.  
  3. function min_function(plot : Boolean; var point : TsingleArray) : mysingle;
  4.  
  5. var    F : mysingle;
  6.        data : integer;
  7.        A1,A2,A3,A4,A5,x1,x2,x3,x4,x5 : mysingle;
  8.        i : integer;
  9.        s2 : mysingle;
  10.        x,y : integer;
  11.        scale : Mysingle;
  12.        inc : mysingle;  { decay rate of weighting exponential }
  13.  
  14. {$I equ.inc}{function Fn(i)}
  15.  
  16. begin
  17.  
  18.   A1 := point[1];
  19.   A2 := point[3];
  20.   A3 := point[5];
  21.   A4 := point[7];
  22.   A5 := point[9];
  23.   x1 := point[2];
  24.   x2 := point[4];
  25.   x3 := point[6];
  26.   x4 := point[8];
  27.   x5 := point[10];
  28.  
  29.   s2 := 0;
  30.   scale := 32768/(FullScale - ZeroScale);
  31.   inc := weighting/(endFit1-startFit1);
  32.   IF CHECK THEN BEGIN
  33.     FOR I := 1 TO NUMVAR DO WRITE('PNT[',I,']:',POINT[I]:8,' ');
  34.   END
  35.   ELSE
  36.  
  37.   i := startFit1;
  38.  
  39.   if weighting<>0 then begin
  40.     repeat
  41.       F := (Fn(i-StartFit1) - zero_scale)*scale;
  42.       s2 := s2 + sqr(F-dataPTR^[i])*exp((i-StartFit1)*inc);
  43.       i := i + round(skip_points*exp(-(i-StartFit1)*inc));
  44.     until i>EndFit1;
  45.   end;
  46.  
  47.   if weighting=0  then begin
  48.     repeat
  49.       F := (Fn(i - StartFit1) - zero_scale)*scale;
  50.       s2 := s2 + sqr(F-dataPTR^[i]);
  51.       i := i + skip_points;
  52.     until i>EndFit1;
  53.   end;
  54.  
  55.   if ((s2<=minstore) or plot) then begin
  56.     for i := StartFit1 to EndFit1 do begin
  57.       F := (Fn(i - StartFit1) - zero_scale)*scale;
  58.       if F > 32767 then F := 32767;
  59.       if F < -32766 then F := -32766;
  60.       solutionPTR^[i] := round(F);
  61.     end;
  62. {    IF NOT CHECK THEN}
  63. {      autoscale_plot(0,14,Xoffset,Yoffset,Xscale,Yscale,minData,}
  64.                      'invert',StartFit1,EndFit1,skip_points,solutionPTR);}
  65. {    IF NOT CHECK THEN
  66.     autoscale_plot(0,14,Xoffset,Yoffset,Xscale,Yscale,minData,
  67.                      'invert',StartFit1,EndFit1,skip_points,solutionPTR);}
  68.   end;
  69.   min_function := s2;
  70.   IF CHECK THEN WRITE('S2:',S2:6,#13,#10);
  71.  
  72. end;{ of function min_function----------------------------------------------}
  73. {---------------------------------------------------------------------------}
  74. {---------------------------------------------------------------------------}
  75.  
  76.  
  77. procedure choose_equ;
  78.  
  79. var template, equs : text;
  80.     ch : char;
  81.  
  82. begin
  83.   set_screen_size;
  84.   window(1,1,width,height);
  85.   clrscr;
  86.   assign(template,'equ.scr');
  87.   assign(equs,'equ.inc');
  88.   reset(template);
  89.   reset(equs);
  90.   while (not EOF(template)) do begin
  91.     read(template,ch);
  92.     write(ch);
  93.   end;
  94.   window(2,1,width,height);
  95.   gotoXY(1,1);
  96.   while (not EOF(equs)) do begin
  97.     read(equs,ch);
  98.     write(ch);
  99.   end;
  100.   close(template);
  101.   close(equs);
  102.   gotoXY(2,23);
  103.   window(2,23,78,23);
  104.   write('Choose one of the above equations by number:');
  105.   window(whereX+2,23,whereX+4,23);
  106.   textbackground(15);
  107.   textcolor(0);
  108.   writeln;
  109.   repeat
  110.     read(eq_num);
  111.   until ((IOresult=0) and (inputcheck(eq_num,1,7)));
  112.   textcolor(15);
  113.   textbackground(0);
  114. end; { of procedure choose_equ.---------------------------------------------}
  115. {---------------------------------------------------------------------------}
  116. {---------------------------------------------------------------------------}