home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / SNCNDN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-29  |  1.7 KB  |  76 lines
  1. PROCEDURE sncndn(uu,emmc: real; VAR sn,cn,dn: real);
  2. LABEL 1;
  3. CONST
  4.    ca=0.0003;
  5. VAR
  6.    a,b,c,d,emc,u: real;
  7.    i,ii,l: integer;
  8.    bo: boolean;
  9.    em,en: ARRAY [1..13] OF real;
  10. FUNCTION cosh(u: real): real;
  11.    BEGIN cosh := 0.5*(exp(u)+exp(-u)) END;
  12. FUNCTION tanh(u: real): real;
  13.    VAR
  14.       u2,epu,emu: real;
  15.    BEGIN
  16.       epu := exp(u);
  17.       emu := 1.0/epu;
  18.       IF (abs(u)<0.3) THEN BEGIN
  19.          u2 := u*u;
  20.          tanh := 2*u*(1+u2/6*(1+u2/20*(1+u2/42*(1+u2/72))))/(epu+emu) END
  21.       ELSE BEGIN tanh := (epu-emu)/(epu+emu) END
  22.    END;
  23. BEGIN
  24.    emc := emmc;
  25.    u := uu;
  26.    IF (emc <> 0.0) THEN BEGIN
  27.       bo := (emc < 0.0);
  28.       IF (bo) THEN BEGIN
  29.          d := 1.0-emc;
  30.          emc := -emc/d;
  31.          d := sqrt(d);
  32.          u := d*u
  33.       END;
  34.       a := 1.0;
  35.       dn := 1.0;
  36.       FOR i := 1 TO 13 DO BEGIN
  37.          l := i;
  38.          em[i] := a;
  39.          emc := sqrt(emc);
  40.          en[i] := emc;
  41.          c := 0.5*(a+emc);
  42.          IF (abs(a-emc) <= ca*a) THEN GOTO 1;
  43.          emc := a*emc;
  44.          a := c
  45.       END;
  46. 1:      u := c*u;
  47.       sn := sin(u);
  48.       cn := cos(u);
  49.       IF (sn <> 0.0) THEN BEGIN
  50.          a := cn/sn;
  51.          c := a*c;
  52.          FOR ii := l DOWNTO 1 DO BEGIN
  53.             b := em[ii];
  54.             a := c*a;
  55.             c := dn*c;
  56.             dn := (en[ii]+a)/(b+a);
  57.             a := c/b
  58.          END;
  59.          a := 1.0/sqrt(sqr(c)+1.0);
  60.          IF (sn < 0.0) THEN sn := -a
  61.          ELSE sn := a;
  62.          cn := c*sn
  63.       END;
  64.       IF (bo) THEN BEGIN
  65.          a := dn;
  66.          dn := cn;
  67.          cn := a;
  68.          sn := sn/d
  69.       END;
  70.    END ELSE BEGIN
  71.       cn := 1.0/cosh(u);
  72.       dn := cn;
  73.       sn := tanh(u)
  74.    END
  75. END;
  76.