unit2.pas

用于开发税务票据管理的软件

unit Unit2;

interface
uses
  Windows, Messages, SysUtils, Classes,unit1, Graphics, Controls, Forms, Dialogs;
procedure ODEINT(var YSTART:array of real; NVAR:integer;X1, X2, EPS,
   H1, HMIN:real;var NOK, NBAD:integer;var XP:array of real;var YP:matrx2);
Function BESSJ0(X:real):real;
Function BESSJ1(X:real):real;
Function BESSJ(N:Integer; X:Real):Real;

implementation
procedure RK4(Y,DYDX:array of real;N:integer;X,H:real;var YOUT:array of real);
var
    YT, DYT, DYM:array[0..10] of real; HH,H6,XH:real;
    I:integer;
begin
    HH:=H * 0.5;
    H6:=H / 6;
    XH:=X + HH;
    For I:=1 To N do
        YT[I]:=Y[I] + HH * DYDX[I];
    DERIVS(XH, YT, DYT);
    For I:=1 To N do
        YT[I]:=Y[I] + HH * DYT[I];
    DERIVS(XH, YT, DYM);
    For I:=1 To N do
    begin
        YT[I]:=Y[I] + H * DYM[I];
        DYM[I]:=DYT[I] + DYM[I];
    end; 
    DERIVS(X + H, YT, DYT);
    For I:=1 To N do
        YOUT[I]:=Y[I] + H6 * (DYDX[I] + DYT[I] + 2 * DYM[I]);
end;

procedure RKQC(var Y:array of real; DYDX:array of real; N:integer;
      var X:real; HTRY, EPS:real; YSCAL:array of real;var HDID, HEND:real);
label 1;
const
    ONE = 1;  SAFETY = 0.9;  ERRCON = 0.0006;  FCOR = 0.066667;
var
    YTEMP, YSAV, DYSAV:array[0..10] of real;
    PGROW,PSHRNK,XSAV,H,HH,ERRMAX:real;  I:integer;
begin
    PGROW:=-0.2;
    PSHRNK:=-0.25;
    XSAV:=X;
    For I:=1 To N do
    begin
        YSAV[I]:=Y[I];
        DYSAV[I]:=DYDX[I];
    end; 
    H:=HTRY;
1:  HH:=0.5 * H;
    RK4(YSAV, DYSAV, N, XSAV, HH, YTEMP);
    X:=XSAV + HH;
    DERIVS(X, YTEMP, DYDX);
    RK4(YTEMP, DYDX, N, X, HH, Y);
    X:=XSAV + H;
    If X = XSAV Then
    begin
      ShowMessage('Stepsize not significant in RKQC.');
      Exit;
    end;
    RK4(YSAV, DYSAV, N, XSAV, H, YTEMP);
    ERRMAX:=0;
    For I:=1 To N do
    begin
      YTEMP[I]:=Y[I] - YTEMP[I];
      If ERRMAX < Abs(YTEMP[I] / YSCAL[I]) Then
         ERRMAX:=Abs(YTEMP[I] / YSCAL[I]);
    end;
    ERRMAX:=ERRMAX / EPS;
    If ERRMAX > ONE Then
    begin
      H:=SAFETY * H * Exp(PSHRNK * Ln(ERRMAX));
      goto 1;
    end
    Else
    begin
      HDID:=H;
      If ERRMAX > ERRCON Then
        HEND:=SAFETY * H * Exp(PGROW * Ln(ERRMAX))
      Else
        HEND:=4 * H;
    end;
    For I:=1 To N do
      Y[I]:=Y[I] + YTEMP[I] * FCOR;
end;

procedure ODEINT(var YSTART:array of real; NVAR:integer;X1, X2, EPS,
   H1, HMIN:real;var NOK, NBAD:integer;var XP:array of real;var YP:matrx2);
const
    MAXSTP = 10000;  TWO = 2;  ZERO = 0;  TINY = 1E-30;
var
    YSCAL, Y, DYDX:array[0..10] of real; X,ZZ,H,XSAV,HDID,HEND:real;
    I,NSTP:integer;
begin
    X:=X1;
    If X2-X1 >= 0 THEN
      ZZ:=1
    Else
      ZZ:=-1;
    H:=Abs(H1) * ZZ;
    NOK:=0;
    NBAD:=0;
    KOUNT:=0;
    For I:=1 To NVAR do
        Y[I]:=YSTART[I];
    If KMAX > 0 Then XSAV:=X - DXSAV * TWO;
    For NSTP:=1 To MAXSTP do
    begin
        DERIVS(X, Y, DYDX);
        For I:=1 To NVAR do
            YSCAL[I]:=Abs(Y[I]) + Abs(H * DYDX[I]) + TINY;
        If KMAX > 0 Then
        begin
            If Abs(X - XSAV) > Abs(DXSAV) Then
            begin
                If KOUNT < KMAX - 1 Then
                begin
                    KOUNT:=KOUNT + 1;
                    XP[KOUNT]:=X;
                    For I:=1 To NVAR do
                        YP[I, KOUNT]:=Y[I];
                    XSAV:=X;
                end;
            end;
        end;
        If (X + H - X2) * (X + H - X1) > ZERO Then H:=X2 - X;
        RKQC(Y, DYDX, NVAR, X, H, EPS, YSCAL, HDID, HEND);
        If HDID = H Then 
            NOK:=NOK + 1
        Else
            NBAD:=NBAD + 1;
        If (X - X2) * (X2 - X1) >= ZERO Then
        begin
            For I:=1 To NVAR do
                YSTART[I]:=Y[I];
            If KMAX <> 0 Then
            begin
                KOUNT:=KOUNT + 1;
                XP[KOUNT]:=X;
                For I:=1 To NVAR do
                    YP[I, KOUNT]:=Y[I]
            end;
            Exit;
        end;
        If Abs(HEND) < HMIN Then
        begin
            ShowMessage('Stepsize smaller than minimum.');
            Exit;
        end;
        H:=HEND;
    end; 
    ShowMessage('Too many steps.');
end;

Function BESSJ0(X:real):real;
var
   AAA,BBB,CCC,Y,AX,Z,DDD,EEE,XX:real;
const
  P1=1;                    P2=-0.001098628627;
  P3=0.2734510407e-4;      P4=-0.2073370639e-5;
  P5=2.093887211E-07;
  Q1=-0.1562499995e-1;     Q2=0.1430488765e-3;
  Q3=-0.6911147651e-5;     Q4=7.621095161E-07;
  Q5=-9.34945152E-08;
  R1=57568490574;          R2=-13362590354;
  R3=651619640.7;          R4=-11214424.18;
  R5=77392.33017;          R6=-184.9052456;
  S1=57568490411;          S2=1029532985;
  S3=9494680.718;          S4=59272.64853;
  S5=267.8532712;          S6=1;
begin
  If Abs(X) < 8 Then
    begin
      Y:=X * X;
      BBB:=Y* (R4+ Y* (R5+ Y* R6));
      AAA:=R1+ Y* (R2+ Y* (R3+ BBB));
      CCC:=Y* (S3+ Y* (S4+ Y* (S5+ Y* S6)));
      BESSJ0:= AAA / (S1+ Y* (S2+ CCC));
    end
  Else
    begin
      AX:=Abs(X);
      Z:=8/ AX;
      Y:=Z* Z;
      XX:= AX- 0.785398164;
      CCC:=Y* (P3+ Y* (P4+ Y* P5));
      AAA:=P1+ Y* (P2+ CCC);
      DDD:=Y* (Q3+ Y* (Q4+ Y* Q5));
      EEE:=Z* Sin(XX) * (Q1+ Y* (Q2+ DDD));
      BESSJ0:= Sqrt(0.636619772 / AX) * (Cos(XX) * AAA- EEE);
    end;
end;

Function BESSJ1(X:real):real;
var
    AAA,BBB,CCC,AX,Z,Y,XX,SGN:real;
const
    R1 = 72362614232;         R2 = -7895059235;
    R3 = 242396853.1;         R4 = -2972611.439;
    R5 = 15704.4826;          R6 = -30.16036606;
    S1 = 144725228442;        S2 = 2300535178;
    S3 = 18583304.74;         S4 = 99447.43394;
    S5 = 376.9991397;         S6 = 1;
    P1 = 1;                   P2 = 0.00183105;
    P3 = -0.3516396496e-4;    P4 = 0.000002457520174;
    P5 = -0.240337019e-6;
    Q1 = 0.04687499995;       Q2 = -0.2002690873e-3;
    Q3 = 0.8449199096e-5;     Q4 = -0.88228987e-6;
    Q5 = 0.105787412e-6;
begin
    If Abs(X) < 8 Then
      begin
        Y:=X * X;
        AAA:=R1 + Y * (R2 + Y * (R3 + Y * (R4 + Y * (R5 + Y * R6))));
        BBB:=S1 + Y * (S2 + Y * (S3 + Y * (S4 + Y * (S5 + Y * S6))));
        BESSJ1:=X * AAA / BBB;
      end
    Else
      begin
        AX:=Abs(X);
        Z:=8 / AX;
        Y:=Z * Z;
        XX:=AX - 2.356194491;
        AAA:=P1 + Y * (P2 + Y * (P3 + Y * (P4 + Y * P5)));
        BBB:=Q1 + Y * (Q2 + Y * (Q3 + Y * (Q4 + Y * Q5)));
        CCC:=Sqrt(0.636619772 / AX);
        if X > 0 then
          SGN:= 1
        else
          SGN:= -1;
        BESSJ1:=CCC * (Cos(XX) * AAA - Z * Sin(XX) * BBB * Sgn);
      end;
end;

Function BESSJ(N:Integer; X:Real):Real;
var
    BJ,BJM,BJP,SUM,TOX,ANS:Real; J,JSUM,M:Integer;
const
    IACC = 40;    BIGNO = 1.0e10;    BIGNI = 1.0e-10;
begin
    If N < 2 Then
        ShowMessage('bad argument N in BASSJ');
    TOX:= 2 / X;
    if X > 1.0 * N then
    begin
        BJM:=BESSJ0(X);
        BJ:=BESSJ1(X);
        For J:=1 To N - 1 do
        begin
            BJP:=J * TOX * BJ - BJM;
            BJM:=BJ;
            BJ:=BJP;
        end;
        ANS:=BJ
    end
    Else
    begin
        M:=2 * ((N + Trunc(Sqrt(IACC * N))) div 2);
        ANS:=0.0;
        JSUM:=0;
        Sum:=0;
        BJP:=0;
        BJ:=1;
        For J:=M DownTo 1 do
          begin
            BJM:=J * TOX * BJ - BJP;
            BJP:=BJ;
            BJ:=BJM;
            If Abs(BJ) > BIGNO Then
              begin
                BJ:=BJ * BIGNI;
                BJP:=BJP * BIGNI;
                ANS:=ANS * BIGNI;
                Sum:=Sum * BIGNI;
              end;
            If JSUM <> 0 Then Sum:=Sum + BJ;
            JSUM:=1 - JSUM;
            If J = N Then ANS:=BJP;
        end;
        Sum:=2 * Sum - BJ;
        ans:=ans / Sum
    end;
    BESSJ:=ans;
end;


end.