home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 04 / quellen / mathfunc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1979-12-31  |  10.3 KB  |  353 lines
  1. (****************************************************************************)
  2. (*                             MATHFUNC.PAS                                 *)
  3. (*                              Version 1.1                                 *)
  4. (* Formulierung einiger nuetzlicher mathematischer Funktionen und           *)
  5. (* Konstanten. Dabei werden folgende Standardfunktionen vorausgesetzt:      *)
  6. (* Sin(x), Cos(x), Exp(x), ArcTan(x), Ln(x), Sqrt(x), Sqr(x)                *)
  7. (*                                                                          *)
  8. (* Modifikationen gegenueber der in PASCAL 3/87 veroeffentlichten Version:  *)
  9. (*  Fehlerkorrektur: x_hoch_y, arcosh                                       *)
  10. (*  Verbesserungen : sinh, cosh, tanh                                       *)
  11. (*  Erweiterungen  : Fehlerbehandlung in Verbindung mit der Fehlerprozedur  *)
  12. (*                   'CalcError' des math. Ausdruckauswerters in PASCAL     *)
  13. (*                   6/87, "CALC - ein mathematischer Compiler".            *)
  14. (****************************************************************************)
  15.  
  16. (* folgende Konstanten je nach Compiler in globalen Vereinbarungsteil ueber-
  17.    nehmen !                                                                 *)
  18.  
  19. CONST Wurzel_2 = 1.414213562;
  20.       Pi       = 3.141592654;
  21.       E        = 2.718281829;
  22.       Pi_Halbe = 1.570796327;                            (* Pi_Halbe = Pi/2 *)
  23.  
  24. (*****************************************************************************)
  25. (*   Das Vorzeichen von x ermitteln                                          *)
  26.  
  27.  
  28. FUNCTION Sign(x : REAL) : INTEGER;
  29.  
  30. BEGIN
  31.   If x > 0.0 THEN sign := 1
  32.     ELSE if x = 0.0 THEN sign := 0
  33.       ELSE Sign := -1
  34.  END;
  35.  
  36. (****************************************************************************)
  37. (* groessten, gemeinsamen Teiler von 'n1' und 'n2' ermitteln:               *)
  38.  
  39. FUNCTION ggT (n1, n2: INTEGER): INTEGER;
  40.  
  41. BEGIN
  42.   n1 := ABS(n1);    (* Berechnung erfolgt nach dem Euklid'schen Algorithmus *)
  43.   n2 := ABS(n2);
  44.   IF (n1 <> 0) AND (n2 <> 0) THEN                          (* ggT(0,0) := 0 *)
  45.     IF n2 <> 0 THEN                   (* Teilung durch Null ist unzulaessig *)
  46.       REPEAT
  47.         n1 := (n1 MOD n2);
  48.         IF n1 > 0 THEN
  49.           n2 := (n2 MOD n1);
  50.       UNTIL (n1 = 0) OR (n2 = 0);
  51.   ggT := n1 + n2;
  52. END;
  53.  
  54. (****************************************************************************)
  55. (* kleinstes, gemeinsames Vielfaches von 'n1' und 'n2' ermitteln:           *)
  56.  
  57. FUNCTION kgV (n1, n2: INTEGER): INTEGER;
  58.  
  59. VAR n: INTEGER;
  60.  
  61. BEGIN
  62.   n := ggT(n1, n2);
  63.   IF n <> 0 THEN
  64.     kgV := (n1 DIV ggT(n1, n2)) * n2   (* kgv(n1,n2) := n1 * n2 / ggT(n1,n2 *)
  65.   ELSE
  66.     kgV := 0
  67. END;
  68.  
  69. (****************************************************************************)
  70. (* Bogenmass nach Altgrad umrechnen:                                        *)
  71.  
  72. FUNCTION AltGrad (x: REAL): REAL;
  73.  
  74. CONST k_180_durch_Pi = 57.29577951;            (* k_180_durch_pi = 180 / Pi *)
  75.  
  76. BEGIN
  77.   AltGrad := x * k_180_durch_Pi;
  78. END;
  79.  
  80. (****************************************************************************)
  81. (* Altgrad nach Bogenmass umrechnen:                                        *)
  82.  
  83. FUNCTION Radiant (alpha: REAL): REAL;
  84.  
  85. CONST Pi_durch_180 = 0.017453292;                (* Pi_durch_180 = Pi / 180 *)
  86.  
  87. BEGIN
  88.   Radiant := alpha * Pi_durch_180;
  89. END;
  90.  
  91. (****************************************************************************)
  92. (* is' klar !?                                                              *)
  93.  
  94. FUNCTION Fakultaet (n: INTEGER): REAL;
  95.  
  96. CONST fak_00 = 1.000000000E00;                              (* fak_00 =  0! *)
  97.       fak_08 = 4.032000000E04;                              (* fak_08 =  8! *)
  98.       fak_16 = 2.092278989E13;                              (* fak_16 = 16! *)
  99.       fak_24 = 6.204484016E23;                              (* fak_24 = 24! *)
  100.       fak_32 = 2.631308368E35;                              (* fak_32 = 32! *)
  101.  
  102. VAR i, d: INTEGER;
  103.     r   : REAL;
  104.  
  105. BEGIN
  106.   IF n < 0 THEN                        (* n! ist fuer n < 0 nicht definiert *)
  107.     CalcError(3, 'Fakultaet(x)')
  108.   ELSE
  109.     BEGIN
  110.       d := (n DIV 8);
  111.       CASE d OF             (* dieser kleine Trick dient zur Beschleunigung *)
  112.         0 : r := 1.00;
  113.         1 : r := fak_08;
  114.         2 : r := fak_16;
  115.         3 : r := fak_24;
  116.         4 : r := fak_32;
  117.       END;
  118.       IF (d * 8 < n) THEN
  119.         FOR i := d * 8 + 1 TO n DO  r := r * i;
  120.       Fakultaet := r;
  121.     END;
  122. END;
  123.  
  124. (****************************************************************************)
  125.  
  126. FUNCTION Kehrwert (x: REAL): REAL;
  127.  
  128. BEGIN
  129.   IF x <> 0 THEN
  130.     Kehrwert := 1 / x
  131.   ELSE
  132.     CalcError(3, 'in Kehrwert(x): x = 0')
  133. END;
  134.  
  135. (****************************************************************************)
  136. (* Logarithmus von 'x' zur Basis 'b':                                       *)
  137.  
  138. FUNCTION Logarithmus (x, b: REAL): REAL;
  139.  
  140. BEGIN
  141.   IF (x > 0.0) AND (b <> 1.0) AND (b > 0.0) THEN
  142.     Logarithmus := Ln(x) / Ln(b)
  143.   ELSE
  144.     CalcError(3, 'Logarithmus(x,b): x <= 0 oder b <= 0 oder b = 1')
  145. END;
  146.  
  147. (****************************************************************************)
  148. (* Zehner-Logarithmus von 'x':                                              *)
  149.  
  150. FUNCTION lg (x: REAL): REAL;
  151.  
  152. CONST rez_ln_10 = 0.434294481;                    (* rez_ln_10 = 1 / ln(10) *)
  153.  
  154. BEGIN
  155.   IF x > 0.0 THEN
  156.     lg := Ln(x) * rez_ln_10
  157.   ELSE
  158.     CalcError(3, 'lg(x): x <= 0')
  159. END;
  160.  
  161. (****************************************************************************)
  162. (* Zweier-Logarithmus von 'x':                                              *)
  163.  
  164. FUNCTION ld (x: REAL): REAL;
  165.  
  166. CONST rez_ln_2 = 1.442695041;                       (* rez_ln_2 = 1 / ln(2) *)
  167.  
  168. BEGIN
  169.   IF x > 0.0 THEN
  170.     ld := Ln(x) * rez_ln_2
  171.   ELSE
  172.     CalcError(3, 'ld(x): x <= 0')
  173. END;
  174.  
  175. (****************************************************************************)
  176. (* Berechnung von 'x hoch y':                                               *)
  177.  
  178. FUNCTION x_hoch_y (x, y: REAL): REAL;
  179.  
  180. VAR ganz_y: INTEGER;
  181.  
  182. BEGIN
  183.   IF (x <> 0.0) OR (y <> 0.0) THEN
  184.     IF x > 0.0 THEN
  185.     if abs(y*ln(abs(x))) > 86.0 THEN
  186.      CalcError(3,'x_hoch_y(x,y): ABS(y*ln(X)) > 86.0')
  187.      else  x_hoch_y := Exp(y * Ln(x))
  188.     ELSE
  189.       BEGIN
  190.         ganz_y := Trunc(y);
  191.         IF ABS(y) > ABS(ganz_y) THEN
  192.           CalcError(3, 'x_hoch_y(x,y): nur ganzzahlige Exponenten zulaessig')
  193.         ELSE
  194.           IF x <> 0.0 THEN
  195.             IF (ganz_y MOD 2) = 0 THEN
  196.               if abs(y*ln(abs(x))) > 86.0 THEN
  197.                CalcError(3,'x_hoch_y(x,y): ABS(y*ln(X)) > 86.0')
  198.               else x_hoch_y :=  Exp(Ln(ABS(x)) * y)
  199.             ELSE
  200.              if abs(y*ln(abs(x))) > 86.0 THEN
  201.                CalcError(3,'x_hoch_y(x,y): ABS(y*ln(X)) > 86.0')
  202.              else x_hoch_y := -Exp(Ln(ABS(x)) * y)       (* ungerader Exponent *)
  203.           ELSE
  204.             x_hoch_y := 0
  205.       END
  206.   ELSE
  207.     x_hoch_y := 1.0
  208. END;
  209.  
  210. (****************************************************************************)
  211.  
  212. (* Sinus hyp.:                                                              *)
  213.  
  214. FUNCTION sinh (x: REAL): REAL;
  215.  
  216. BEGIN
  217.   x := Exp(x);
  218.   sinh := 0.5 * (x-1/x);
  219. END;
  220.  
  221. (* Cosinus hyp.:                                                            *)
  222.  
  223. FUNCTION cosh (x: REAL): REAL;
  224.  
  225. BEGIN
  226.   x := Exp(x);
  227.   cosh := 0.5 * (x+1/x);
  228. END;
  229.  
  230. (* Tangens hyp.:                                                            *)
  231.  
  232. FUNCTION tanh (x: REAL): REAL;
  233.  
  234. BEGIN
  235.   tanh := 1-2/(1+Exp(2*x));
  236. END;
  237.  
  238. (* Cotangens hyp.:                                                          *)
  239.  
  240. FUNCTION coth (x: REAL): REAL;
  241.  
  242. BEGIN
  243.   coth := 1 / tanh(x)
  244. END;
  245.  
  246. (****************************************************************************)
  247.  
  248. (* Umkehrfunktion zu sinh(x):                                               *)
  249.  
  250. FUNCTION arsinh (x: REAL): REAL;
  251.  
  252. BEGIN
  253.   arsinh := Ln(x + Sqrt(Sqr(x) + 1));
  254. END;
  255.  
  256. (* Umkehrfunktion zu cosh(x):                                               *)
  257.  
  258. FUNCTION arcosh (x: REAL): REAL;
  259.  
  260. BEGIN
  261.   IF x < 1.0 THEN
  262.     CalcError(3, 'arcosh(x): x < 1')
  263.   ELSE
  264.     arcosh := Ln(x + Sqrt(Sqr(x) - 1));
  265. END;
  266.  
  267. (* Umkehrfunktion zu tanh(x):                                               *)
  268.  
  269. FUNCTION artanh (x: REAL): REAL;
  270.  
  271. BEGIN
  272.   IF ABS(x) < 1.0 THEN
  273.     artanh := 0.5 * Ln((1 + x) / (1 - x))
  274.   ELSE
  275.     CalcError(3, 'artanh(x): x <= -1 oder x >= 1')
  276. END;
  277.  
  278. (* Umkehrfunktion zu coth(x):                                               *)
  279.  
  280. FUNCTION arcoth (x: REAL): REAL;
  281.  
  282. BEGIN
  283.   IF ABS(x) > 1.0 THEN
  284.     arcoth := 0.5 * Ln((x + 1) / (x - 1))
  285.   ELSE
  286.     CalcError(3, 'arcoth(x): -1 <= x <= 1')
  287. END;
  288.  
  289. (****************************************************************************)
  290.  
  291. (* Tangens von 'x':                                                         *)
  292.  
  293. FUNCTION tan (x: REAL): REAL;
  294.  
  295. BEGIN
  296.   IF Cos(x) <> 0 THEN
  297.     tan := Sin(x) * Kehrwert(Cos(x))
  298.   ELSE
  299.     CalcError(3, 'tan(x): x = (Pi/2)')
  300. END;
  301.  
  302. (* Cotangens von 'x':                                                       *)
  303.  
  304. FUNCTION cot (x: REAL): REAL;
  305.  
  306. VAR tmp: REAL;
  307.  
  308. BEGIN
  309.   tmp := Int(x/Pi_Halbe);
  310.   IF tmp * Pi_Halbe <> x THEN
  311.     cot := Kehrwert(tan(x))
  312.   ELSE
  313.     CalcError(3, 'cot(x): x = Vielfaches von Pi/2')
  314. END;
  315.  
  316. (****************************************************************************)
  317.  
  318. (* Umkehrfunktion zu sin(x):                                                *)
  319.  
  320. FUNCTION arcsin (x: REAL): REAL;
  321.  
  322. BEGIN
  323.   IF ABS(x) > 1.0 THEN
  324.     CalcError(3, 'arcsin(x): x < -1 oder x > 1')
  325.   ELSE
  326.     IF ABS(x) < 1.0 THEN
  327.       arcsin := ArcTan(x / Sqrt(1 - Sqr(x)))
  328.     ELSE
  329.       arcsin := x * Pi_Halbe
  330. END;
  331.  
  332. (* Umkehrfunktion zu cos(x):                                                *)
  333.  
  334. FUNCTION arccos (x: REAL): REAL;
  335.  
  336. BEGIN
  337.   IF ABS(x) > 1.0 THEN
  338.     CalcError(3, 'arccos(x): x < -1 oder x > 1')
  339.   ELSE
  340.     arccos := Pi_Halbe - arcsin(x);
  341. END;
  342.  
  343. (* Umkehrfunktion zu cot(x):                                                *)
  344.  
  345. FUNCTION arccot (x: REAL): REAL;
  346.  
  347. BEGIN
  348.   arccot := Pi_Halbe - ArcTan(x);
  349. END;
  350.  
  351. (****************************************************************************)
  352. (*                        Ende von MATHFUNC.PAS                             *)
  353.