DP Tool Club 15/CD_ASCQ_15_070894.iso/vrac/sk210f.zip/SHFINANC.PAS

Pascal/Delphi Source File | 1994-05-15 | 14KB | 487 lines

{$I SHDEFINE.INC}

{$I SHUNITSW.INC}

{V-}
unit ShFinanc;
{
                                ShFinanc

                      A Financial Calculation Unit

                                   by

                              Bill Madison

                   W. G. Madison and Associates, Ltd.
                          13819 Shavano Downs
                            P.O. Box 780956
                       San Antonio, TX 78278-0956
                             [phone]
                             CIS 73240,342
                Internet [e-mail]

                Copyright 1990, '94 Madison & Associates
                          All Rights Reserved

        This file may  be used and distributed  only in accord-
        ance with the provisions described on the title page of
                  the accompanying documentation file
                              SKYHAWK.DOC
}


interface

uses
  TpCrt,
  TpString,
  Tp8087,
  ShUtilPk,
  ShErrMsg;

const
  Copyr = 'Copyright 1990, 1994 by W.G. Madison';

type
  AnnType   = (Ordinary, Due);
{$IFNDEF Gen87}
  extended = real;
  Float           = real;
{$ELSE}
  Float           = extended;
{$ENDIF}

const
  finOK                     = 0;
  finErrParamTooSmall       = 200;
  finIntOutOfRange          = 201;
  finIllegalNumPeriods      = 202;
  finUnknownAnnuityType     = 203;
  finIllegalPresentValue    = 204;
  fin80x87error             = 205;
  finNoConvergence          = 206;
  finIndeterminateForm      = 207;

  {80x87 errors}
  finInvalidOperation       =  1;
  finDenormalizedOperand    =  2;
  finDivideByZero           =  4;
  finOverflow               =  8;
  finUnderflow              = 16;

  FW  = 17;
  DP  = 10;
  IW  =  6;

var
  finError,
  fin87error  : word;

procedure finErrCheckOn;
{Turns error checking on. Errors will abort program with a message.}

procedure finErrCheckOff;
{Turns error checking off. Results will be returned by function
 finErrCode.}

function finErrCode : word;
{Returns the error code from the last operation, and resets the error
 code to zero (finOK).}

function fin87errCode : word;
{Returns the 80x87 error code if finErrCode has returned fin80x87error.}

function finErrMsg(Code : word) : string;
{Returns the error message corresponding to the supplied Code.}

function CompPresVal(N : integer; I : Float) : Float;
{The compound present value of 1 for N periods at I.}

function CompAmount(N : integer; I : Float) : Float;
{The compound amount of 1 for N periods at I.}

function AnnuityPresVal(N     : integer;
                        I     : Float;
                        AType : AnnType) : Float;
{The present value of an annuity (of type AType) of 1 for N payment
 periods at an interest rate of I per period.}

function AnnuityAmount(N : integer;
                       I : Float;
                       AType : AnnType) : Float;
{The amount of an annuity (of type AType) of 1 for N payment periods at
 an interest rate of I per period.}

function NumPay(PresVal,
                I       : Float;
                AType   : AnnType) : integer;
{The number of payments needed to retire a mortgage of 1 whose present
 value is PresVal at an interest rate of I per period.}

function R(Rexp : Float; Count : integer) : Float;
{Returns Rexp correctly rounded to Count places to the right of the
 decimal point.}

function IfromPresVal(PresVal : Float;
                      N       : integer;
                      AType   : AnnType;
                      Err     : Float) : Float;
{The interest rate of an annuity (of type AType) of 1 whose present
 value is PresVal for N payments, where Err is the allowable absolute
 error of calculation.}

implementation

const
  HaltOnErrors  : boolean = true;
  ErrorCode     : word    = 0;
  Error87Code   : word    = 0;

  LoMsgNum                = 200;
  HiMsgNum                = 207;
  ErrMsgs       : array[LoMsgNum..HiMsgNum] of string[50] =
                         ('Error parameter too small.',
                          'Interest parameter out of range.',
                          'Number of periods <= 0.',
                          'Annuity type must be ''Ordinary'' or ''Due''.',
                          'Illegal Present Value.',
                          '80x87 error - ',
                          'Iterative procedure; value does not converge.',
                          'Indeterminate for N = 1; Type = DUE');

  Err87Msgs     : array[1..5] of string[50] =
                         ('Invalid operation (e.g., LN(-1)).',
                          'Denormalized operand.',
                          'Divide by zero.',
                          'Overflow error.',
                          'Underflow error.');

  ValStr        : string  = '';

procedure finErrCheckOn;
{Turns error checking on. Errors will abort program with a message.}
  begin {finErrCheckOn}
{$IFNDEF HaltOnFinancError}
    HaltOnErrors := true;
  {$IFOPT N+}
    Exceptions8087(true);
  {$ENDIF}
{$ENDIF}
    end; {finErrCheckOn}

procedure finErrCheckOff;
{Turns error checking off. Results will be returned by function
 finErrCode.}
  begin {finErrCheckOff}
{$IFNDEF HaltOnFinancError}
    HaltOnErrors := false;
  {$IFOPT N+}
    Exceptions8087(false);
  {$ENDIF}
{$ENDIF}
    end; {finErrCheckOff}

function finErrCode : word;
{Returns the error code from the last operation, and resets the error
 code to zero (finOK).}
  begin {finErrCode}
    finErrCode := ErrorCode;
{$IFOPT N+}
    if ErrorCode = fin80x87error then
      Error87Code := Error8087 and $1F;
{$ELSE}
    Error87Code := 0;
{$ENDIF}
    ErrorCode := 0;
    end; {finErrCode}

function fin87errCode : word;
{Returns the 80x87 error code if finErrCode has returned fin80x87error.}
  begin {fin87errCode}
    fin87errCode  := Error87Code;
    Error87Code := 0;
    end; {fin87errCode}

function finErrMsg(Code : word) : string;
{Returns the error message corresponding to the supplied Code.}
  var
    Msg1,
    Msg2  : string;
    C87   : word;
    T1    : byte;
  begin {finErrMsg}
    case Code of
      finOK       : Msg1 := '';
      LoMsgNum..HiMsgNum
                  : Msg1 := '(Error ' + Long2Str(Code) + ') ' + ErrMsgs[Code];
      else          Msg1 := 'Unknown error code ' + Long2Str(Code);
      end; {case}
    if ValStr <> '' then begin
      Msg1 := Msg1 + ValStr;
      ValStr := '';
      end;
    Msg2 := '';
    T1 := 0;
    if Code = fin80x87error then begin
      C87 := fin87errCode;
      while C87 <> 0 do begin
        inc(T1);
        if (C87 and 1) <> 0 then
          Msg2 := Msg2 + ^M^J^I + Err87Msgs[T1];
        C87 := C87 shr 1;
        end; {while}
      end; {if}
    finErrMsg := Msg1 + Msg2;
    end; {finErrMsg}

procedure ProcessError(Code : word; Source : string);
  begin {ProcessError}
    if HaltOnErrors then
      HaltMsg(Code, ErrMsgs[Code] + ' (' + Source + ')')
    else
      ErrorCode := Code;
    end; {ProcessError}

function CompPresVal(N : integer; I : Float) : Float;
{The compound present value of 1 for N periods at I.}
var
  XN  : Float;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'CompPresVal');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'CompPresVal');
    exit;
    end;
  XN := N;
  CompPresVal := Exp(Ln(1.0 + I) * (-XN));
  end;

function CompAmount(N : integer; I : Float) : Float;
{The compound amount of 1 for N periods at I.}
var
  XN  : Float;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'CompAmount');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'CompAmount');
    exit;
    end;
  XN  := N;
  CompAmount := Exp(Ln(1.0 + I) * XN);
  end;

function AnnuityPresVal(N     : integer;
                        I     : Float;
                        AType : AnnType) : Float;
{The present value of an annuity of 1 for N payment periods at an
 interest rate of I per period.}
var
  CPV : Float;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'AnnuityPresVal');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'AnnuityPresVal');
    exit;
    end;
  CPV := 1.0 - CompPresVal(N, I);
  case AType of
    Ordinary  : AnnuityPresVal := CPV / I;
    Due       : AnnuityPresVal := (1.0 + I) * CPV / I;
    else        begin
                  ProcessError(finUnknownAnnuityType, 'AnnuityPresVal');
                  exit;
                  end;
    end; {case}
  end;

function AnnuityAmount
              (N : integer; I : Float; AType : AnnType) : Float;
{The amount of an annuity of 1 for N payment periods at an
 interest rate of I per period.}
var
  CA  : Float;
begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'AnnuityAmount');
    exit;
    end;
  if (I <= 0.0) or (I >= 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'AnnuityAmount');
    exit;
    end;
  CA := CompAmount(N, I) - 1.0;
  case AType of
    Ordinary  : AnnuityAmount := CA / I;
    Due       : AnnuityAmount := (1.0 + I) * CA / I;
    else        begin
                  ProcessError(finUnknownAnnuityType, 'AnnuityAmount');
                  exit;
                  end;
    end; {case}
  end;

function NumPay(PresVal, I : Float; AType : AnnType) : integer;
{The number of payments needed to retire a mortgage of 1 whose present
 value is PresVal at an interest rate of I per period.}
begin
  if (I <= 0.0) or (I > 1.0) then begin
    Str(I:FW:DP, ValStr);
    ProcessError(finIntOutOfRange, 'NumPay');
    exit;
    end;
  case AType of
    Ordinary  : ;
    Due       : PresVal := PresVal / (1.0 + I);
    else        begin
                  ProcessError(finUnknownAnnuityType, 'NumPay');
                  exit;
                  end;
    end; {case}
  if (PresVal <= 0) or (PresVal >= (1.0 / I)) then begin
    Str(PresVal:FW:DP, ValStr);
    ProcessError(finIllegalPresentValue, 'NumPay');
    exit;
    end;
  NumPay := -Round(Ln(1.0 - (PresVal * I)) / Ln(1.0 + I));
  end;

function R(Rexp : Float; Count : integer) : Float;
{Returns Rexp correctly rounded to Count places to the right of the
 decimal point.}
var
  R1  : Float;
begin
  R1 := Exp(Ln(10.0) * Count);
  R := Int(((Rexp * R1) + 0.5)) / R1;
  end;

function IfromPresVal(PresVal : Float;
                      N       : integer;
                      AType   : AnnType;
                      Err     : Float) : Float;
{The interest rate of an ordinary annuity of 1 whose present value is
 PresVal for N payments, where Err is the allowable absolute error of
 calculation.}

const
{$IFDEF Gen87}
  MinErr = 1.0E-16;
{$ELSE}
  MinErr = 1.0E-9;
{$ENDIF}

var
  UorD    : (Up, Down);
  B1      : boolean;
  Last,
  MErr,
  Q1,
  Q2,
  ANI,
  Intvl,
  Trial   : Float;

begin
  if N <= 0 then begin
    Str(N:IW, ValStr);
    ProcessError(finIllegalNumPeriods, 'IfromPresVal');
    exit;
    end;
  if (N = 1) and (AType = Due) then begin
    ProcessError(finIndeterminateForm, 'IfromPresVal');
    exit;
    end;
  if Err < MinErr then begin
    Str(Err:FW:DP, ValStr);
    ProcessError(finErrParamTooSmall, 'IfromPresVal');
    exit;
    end;
  if not (AType in [Ordinary..Due]) then
    begin
      ProcessError(finUnknownAnnuityType, 'IfromPresVal');
      exit;
      end;
  if (PresVal <= 0) or (PresVal >= (1.0 * N)) then begin
    Str(PresVal:FW:DP, ValStr);
    ProcessError(finIllegalPresentValue, 'IfromPresVal');
    exit;
    end;
  UorD := Up;
  Intvl := 0.001;
  Trial := 0.01;

  MErr  := -1.0 * Err;
  repeat
    while Intvl >= Trial do
      Intvl := Intvl * 0.1;
    case UorD of
      Up    : begin
                while (PresVal <= AnnuityPresVal(N, Trial, AType)) and
                      (Trial <= 1.0 - Intvl) do begin
                  ANI := AnnuityPresVal(N, Trial, AType);
                  if ANI = Last then begin
                    Str(ANI:FW:DP, ValStr);
                    ProcessError(finNoConvergence, 'IfromPresVal');
                    exit;
                    end
                  else
                    Last := ANI;
                  Q1 := ANI / PresVal;
                  Q2 := 1.0 - Q1;
                  if (Q2 <= Err) and (Q2 >= MErr) then begin
                    IfromPresVal := Trial;
                    exit;
                    end;
                  Trial := Trial + Intvl;
                  end;
                end;
      Down  : begin
                while (PresVal > AnnuityPresVal(N, Trial, AType)) and
                      (Trial >= Intvl) do begin
                  ANI := AnnuityPresVal(N, Trial, AType);
                  if ANI = Last then begin
                    Str(ANI:FW:DP, ValStr);
                    ProcessError(finNoConvergence, 'IfromPresVal');
                    exit
                    end
                  else
                    Last := ANI;
                  Q1 := ANI / PresVal;
                  Q2 := 1.0 - Q1;
                  if (Q2 >= Err) and (Q2 <= MErr) then begin
                    IfromPresVal := Trial;
                    exit;
                    end;
                  Trial := Trial - Intvl;
                  end;
                end;
      end; {case}
    Intvl := 0.1 * Intvl;
    boolean(UorD) := not (boolean(UorD));  {Flip the value of UorD}
    ANI := AnnuityPresVal(N, Trial, AType);
    Q1 := ANI / PresVal;
    Q2 := 1.0 - Q1;
    B1 := (Q2 >= Err) and (Q2 <= MErr);
    until B1;
  IfromPresVal := Trial;
  end; {IfromPresVal}
end.