home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / cpm / alphatronic / JRTPAS40.ZIP / COS.PAS < prev    next >
Pascal/Delphi Source File  |  1999-04-03  |  2KB  |  76 lines
  1.  
  2. EXTERN
  3.  
  4.  
  5. {=================================================================}
  6. FUNCTION cos (x : real) : real;
  7. CONST
  8. half_pi = 1.5707963267948;
  9. pi = 3.1415926535897;
  10. two_pi = 6.2831853071796;
  11. VAR
  12. i : integer;
  13.  
  14.  
  15. {=================================================================}
  16. PROCEDURE compute_cos;
  17. VAR
  18. result, result2, f, exclam, x2, power, odd1 : real;
  19. i : integer;
  20.  
  21.  
  22. {=================================================================}
  23. PROCEDURE factorial;
  24.  
  25. BEGIN
  26. f := f + 2.0;
  27. exclam := exclam * (f - 1.0) * f;
  28. END;
  29.  
  30. BEGIN  (* compute_cos *)
  31.  
  32. x2 := sqr(x);
  33. power := x * x2;
  34. odd1 :=  - 1.0;
  35. i := 0;
  36. result := x;
  37. exclam := 6.0;
  38. f := 3.0;
  39. REPEAT
  40.        result2 := result;
  41.        result := result + odd1 * (power / exclam);
  42.        power := power * x2;
  43.        odd1 :=  - odd1;
  44.        factorial;
  45.        i := i + 1;
  46.        IF i > 5 THEN
  47.               BEGIN
  48.               i := 0;
  49.               IF abs(result - result2) < (1e-12 * result) THEN
  50.                      result2 := result;
  51.               END;
  52. UNTIL result = result2;
  53. cos := result;
  54. END;  (* compute_cos *)
  55.  
  56. BEGIN  (* cos *)
  57.  
  58. IF x = 0.0 THEN
  59.        cos := 1.0
  60. ELSE
  61.        BEGIN  (* else_1 *)
  62.        
  63.        x := x + half_pi;
  64.        IF (x = 0.0) OR (x = pi) OR (x = two_pi) THEN
  65.               cos := 0.0
  66.        ELSE
  67.               BEGIN
  68.               WHILE x < 0.0 DO
  69.                      x := x + two_pi;
  70.               WHILE x > two_pi DO
  71.                      x := x - two_pi;
  72.               compute_cos;
  73.               END;  (* else *)
  74.        END;  (* else_1 *)
  75. END;  (* cos *)  .
  76.