home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / FIXRTS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-29  |  1.3 KB  |  50 lines
  1. PROCEDURE fixrts(VAR d: glnparray; npoles: integer);
  2. (* Programs using routine FIXRTS must define the type
  3. TYPE
  4.    glnparray = ARRAY [1..npoles] OF real;
  5.    glcarray = ARRAY [1..2*npoles+2] OF real;
  6. in the main routine. *)
  7. VAR
  8.    j,i: integer;
  9.    size,dum: real;
  10.    polish: boolean;
  11.    a,roots: glcarray;
  12. BEGIN
  13.    a[2*npoles+1] := 1.0;
  14.    a[2*npoles+2] := 0.0;
  15.    FOR j := npoles DOWNTO 1 DO BEGIN
  16.       a[2*j-1] := -d[npoles+1-j];
  17.       a[2*j] := 0.0
  18.    END;
  19.    polish := true;
  20.    zroots(a,npoles,roots,polish);
  21.    FOR j := 1 TO npoles DO BEGIN
  22.       size := sqr(roots[2*j-1])+sqr(roots[2*j]);
  23.       IF (size > 1.0) THEN BEGIN
  24.          roots[2*j-1] := roots[2*j-1]/size;
  25.          roots[2*j] := roots[2*j]/size
  26.       END
  27.    END;
  28.    a[1] := -roots[1];
  29.    a[2] := -roots[2];
  30.    a[3] := 1.0;
  31.    a[4] := 0.0;
  32.    FOR j := 2 TO npoles DO BEGIN
  33.       a[2*j+1] := 1.0;
  34.       a[2*j+2] := 0.0;
  35.       FOR i := j DOWNTO 2 DO BEGIN
  36.          dum := a[2*i-1];
  37.          a[2*i-1] := a[2*i-3]-a[2*i-1]*roots[2*j-1]
  38.                +a[2*i]*roots[2*j];
  39.          a[2*i] := a[2*i-2]-dum*roots[2*j]
  40.                -a[2*i]*roots[2*j-1]
  41.       END;
  42.       dum := a[1];
  43.       a[1] := -a[1]*roots[2*j-1]+a[2]*roots[2*j];
  44.       a[2] := -dum*roots[2*j]-a[2]*roots[2*j-1]
  45.    END;
  46.    FOR j := 1 TO npoles DO BEGIN
  47.       d[npoles+1-j] := -a[2*j-1]
  48.    END
  49. END;
  50.