home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / SMOOFT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-29  |  1.2 KB  |  49 lines
  1. PROCEDURE smooft(VAR y: glyarray; n: integer; pts: real);
  2. (* Programs using routine SMOOFT must define the type
  3. TYPE
  4.    glyarray = ARRAY [1..mp] OF real;
  5. in the main routine, with mp >= (integral power of 2) >= n+2*pts *)
  6. VAR
  7.    nmin,m,mo2,k,j: integer;
  8.    yn,y1,rn1,fac,cnst: real;
  9. BEGIN
  10.    m := 2;
  11.    nmin := n+round(2.0*pts);
  12.    WHILE (m < nmin) DO m := 2*m;
  13.    cnst := sqr(pts/m);
  14.    y1 := y[1];
  15.    yn := y[n];
  16.    rn1 := 1.0/(n-1.0);
  17.    FOR j := 1 TO n DO BEGIN
  18.       y[j] := y[j]-rn1*(y1*(n-j)+yn*(j-1))
  19.    END;
  20.    IF (n+1 <= m) THEN BEGIN
  21.       FOR j := n+1 TO m DO BEGIN
  22.          y[j] := 0.0
  23.       END
  24.    END;
  25.    mo2 := m DIV 2;
  26.    realft(y,mo2,1);
  27.    y[1] := y[1]/mo2;
  28.    fac := 1.0;
  29.    FOR j := 1 TO (mo2-1) DO BEGIN
  30.       k := 2*j+1;
  31.       IF (fac <> 0.0) THEN BEGIN
  32.          fac := (1.0-cnst*j*j)/mo2;
  33.          IF (fac < 0.0) THEN fac := 0.0;
  34.          y[k] := fac*y[k];
  35.          y[k+1] := fac*y[k+1]
  36.       END ELSE BEGIN
  37.          y[k] := 0.0;
  38.          y[k+1] := 0.0
  39.       END
  40.    END;
  41.    fac := (1.0-0.25*pts*pts)/mo2;
  42.    IF (fac < 0.0) THEN fac := 0.0;
  43.    y[2] := fac*y[2];
  44.    realft(y,mo2,-1);
  45.    FOR j := 1 TO n DO BEGIN
  46.       y[j] := rn1*(y1*(n-j)+yn*(j-1))+y[j]
  47.    END
  48. END;
  49.