Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/STAT.ZIP/MATH.PAS

Pascal/Delphi Source File | 1990-08-05 | 9.3 KB | 404 lines

{--------------------------------------------------------------------------}
{                         Norton Mathematical Library                      }
{                                                                          }
{                              Version   1.00                              }
{                                                                          }
{                                                                          }
{                    Copyright 1990 Norton Associcates                     }
{                           All Rights Reserved                            }
{                          Restricted by License                           }
{--------------------------------------------------------------------------}

                     {--------------------------------}
                     {       Unit:   Math             }
                     {--------------------------------}


{$S-,R-,V-,D-,A+,B+,N+,E-,I-}

UNIT
    math;

INTERFACE

CONST
     PI       = 3.14159265359;
     pi_2     = PI / 2.0;
     pi2      = PI * 2.0;
     rad      = 180.0 / PI;
     i_rad    = PI / 180.0;
     one      = 1.00;
     zero     = 0.00;
     infinity = 1.0e09;
     i_ln10     : DOUBLE =  1.0/2.302585093;

FUNCTION deg_rad( x : SINGLE) : SINGLE;
FUNCTION rad_deg( x : SINGLE) : SINGLE;

FUNCTION arcsin( x : SINGLE) : SINGLE;
FUNCTION arccos( x : SINGLE) : SINGLE;
FUNCTION arctan2( x , y : SINGLE) : SINGLE;

FUNCTION tan( x : SINGLE) : SINGLE;
FUNCTION secant( x : SINGLE) : SINGLE;
FUNCTION cosecant( x : SINGLE) : SINGLE;
FUNCTION cotan( x : SINGLE) : SINGLE;

FUNCTION factorial( number : WORD) : SINGLE;

FUNCTION power( x , y : EXTENDED) : EXTENDED;
FUNCTION log10( x : SINGLE) : SINGLE;
FUNCTION logxy( x , y : SINGLE) : SINGLE;
FUNCTION dprod( x , y : EXTENDED) : EXTENDED;
FUNCTION dble( x : EXTENDED) : EXTENDED;
PROCEDURE secantmethod(VAR xn,xn_1,fxn,fxn_1 : EXTENDED);

FUNCTION sinh( x : EXTENDED) : SINGLE;
FUNCTION cosh( x : EXTENDED) : SINGLE;
FUNCTION tanh( x : EXTENDED) : SINGLE;

{*****************************************************************************}
{*****************************************************************************}
IMPLEMENTATION
{*****************************************************************************}
{*****************************************************************************}

FUNCTION deg_rad( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Convert from degrees to radians
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
     deg_rad := x * i_rad;
END;

FUNCTION rad_deg( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Convert from radians to degrees
  Version: 1.0
  Date   : 5 May 1990 }
BEGIN
     rad_deg := x * rad;
END;

FUNCTION arcsin( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate the arc sin
  Version: 1.0
  Date   : 5 May 1990 }
VAR
   dummy : SINGLE;
BEGIN

{ see if x is in range }
     IF ABS(x) > one THEN
     BEGIN
          WRITELN('arcsin> input parameter out of range ',x:10:3);
          HALT;
     END;
     dummy := SQRT(one - x * x);
     IF dummy = zero THEN
     BEGIN
        IF x > zero THEN
           arcsin := pi_2
        ELSE
           arcsin := -pi_2;
     END
     ELSE
        arcsin := ARCTAN( x / dummy);
END;

FUNCTION arccos( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate the arc cosine
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN

{ check to see if x is in range }
     IF ABS(x) > one THEN
     BEGIN
          WRITELN('arccos> input parameter out of range ',x:10:3);
          HALT;
     END;
     IF x = zero THEN arccos := pi_2
     ELSE IF x > zero THEN arccos := ARCTAN(SQRT(one - x * x ) / x)
                      ELSE arccos := PI + ARCTAN(SQRT(one - x * x ) / x);
END;

FUNCTION factorial( number : WORD) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate factorial
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   fact : DOUBLE;
   i    : WORD;

BEGIN
    fact := one;
    FOR i := 2 TO number DO
        fact := fact * i;
    factorial := fact;
END;

FUNCTION tan( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate tangent
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   dumcos,dumsin : SINGLE;

BEGIN
     dumcos := COS(x);
     dumsin := SIN(x);
     IF dumcos = zero THEN
     BEGIN
         IF dumsin > zero THEN
            tan := infinity
         ELSE
         BEGIN
            IF dumsin = zero THEN
               tan := zero
            ELSE
               tan := -infinity;
         END;
     END
     ELSE
         tan := dumsin / dumcos;
END;

FUNCTION arctan2( x , y : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate arc tangent : all four quadrants
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   angle : SINGLE;

BEGIN

{ make sure x and y are in range }
     IF (x <> zero) AND (y <> zero) THEN
     BEGIN
        angle := ARCTAN(ABS(y/x));
        IF x > zero THEN
        BEGIN
          IF y > zero THEN arctan2 := angle
                      ELSE arctan2 := pi2 - angle;
        END
        ELSE
        BEGIN
          IF y > zero THEN arctan2 := PI - angle
                      ELSE arctan2 := PI + angle;
        END;
     END
     ELSE
     BEGIN
        IF (x = zero) AND (y = zero) THEN
        BEGIN
            WRITELN('arctan2> x and y values = 0.0');
            HALT;
        END
        ELSE
        BEGIN
            IF x = zero THEN
            BEGIN
               IF y > zero THEN arctan2 := pi_2
                           ELSE arctan2 := 3.0 * pi_2;
            END
            ELSE
            BEGIN
               IF x >= zero THEN arctan2 := zero
                            ELSE arctan2 := PI;
            END;
        END;
     END;
END;

FUNCTION secant( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate secant of x
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   test : SINGLE;

BEGIN
     test := COS(x);
     IF test = zero THEN
     BEGIN
        WRITELN('secant> can not divide by zero ', x:10:5);
        HALT;
     END
     ELSE
        secant := 1.0 / test;
END;

FUNCTION cosecant( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate cosecant of x
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   test : SINGLE;

BEGIN
     test := SIN(x);
     IF test = zero THEN
     BEGIN
        WRITELN('cosecant> can not divide by zero ',x:10:5);
        HALT;
     END
     ELSE
        cosecant := 1.0 / test;
END;

FUNCTION cotan( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Calculate costangent of x
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   test : SINGLE;

BEGIN
     test := tan(x);
     IF test = zero THEN
     BEGIN
        WRITELN('cotangent> can not divide by zero ',x:10:5);
        HALT;
     END
     ELSE
        cotan := 1.0 / test;
END;

FUNCTION power( x , y : EXTENDED) : EXTENDED;
{ Author : Norton Associates
  Purpose: Raise x to y
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
     IF  x > zero  THEN
        power := EXP( LN(x ) * y)
     ELSE IF x = zero THEN
             power := zero
          ELSE
              power := -one;
END;

FUNCTION log10( x : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Find logarithm base 10 of x
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
     log10 := LN(x)* i_ln10;
END;

FUNCTION logxy( x , y : SINGLE) : SINGLE;
{ Author : Norton Associates
  Purpose: Find logarithm base y of x
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   test : SINGLE;

BEGIN
     test := LN(y);
     IF test = zero THEN
     BEGIN
         WRITELN('logxy> can not divide by zero ',y:10:5);
         HALT;
     END
     ELSE
         logxy := LN(x)/test;
END;

FUNCTION dprod( x , y : EXTENDED) : EXTENDED;
{ Author : Norton Associates
  Purpose: Find double precision of two values
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
     dprod := x * y;
END;

FUNCTION dble( x : EXTENDED) : EXTENDED;
{ Author : Norton Associates
  Purpose: Find double precision of a value
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
      dble := x;
END;

PROCEDURE secantmethod( VAR xn, xn_1, fxn, fxn_1 : EXTENDED);
{ Author : Norton Associates
  Purpose: Find root of equation based upon secant method
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   newvar : EXTENDED;

BEGIN

     newvar := xn - ( (fxn * ( xn - xn_1 ))/( fxn - fxn_1 ) );
     xn_1   := xn;
     fxn_1  := fxn;
     xn     := newvar;
END;

FUNCTION sinh( x : EXTENDED) : SINGLE;
{ Author : Norton Associates
  Purpose: Determine hyperbolic sine of x
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
     sinh := (EXP(x) - EXP(-x) ) * 0.5;
END;

FUNCTION cosh( x : EXTENDED) : SINGLE;
{ Author : Norton Associates
  Purpose: Determine hyperbolic cosine of x
  Version: 1.0
  Date   : 5 May 1990 }

BEGIN
     cosh := (EXP(x) + EXP(-x) ) * 0.5;
END;

FUNCTION tanh( x : EXTENDED) : SINGLE;
{ Author : Norton Associates
  Purpose: Determine hyperbolic tangent of x
  Version: 1.0
  Date   : 5 May 1990 }

VAR
   a : EXTENDED;
   b : EXTENDED;
BEGIN
     a := EXP(x);
     b := EXP(-x);
     tanh := (a - b)/(a + b);
END;
BEGIN

END.