pi_agm.bas

一个VB小程序,能够进行大数的计算,可以作为学习的参考

Attribute VB_Name = "Pi_AGM"
Attribute VB_Description = "Calculation of pi with the 1976 Salamin-Brent arithmetic-geometric mean (AGM) algorithm."
'Author : Sjoerd.J.Schaper - [e-mail]
'URL    : http://largeint.sourceforge.net/index.html
'Date   : 11-11-2004
'Code   : Visual Basic for Windows 5.0
Option Explicit
Public Const a = 1, b = 2, d = 3 '    shared pointers
Public Const p = 4, q = 5, s = 6

Sub PiAGM(imx As Integer)
Dim e() As Integer, g As String, i As Integer
  On Error GoTo errhand
  Data = "": Key = 0: tim = Timer
  Slate.Box.Text = "initializing..."
  DoEvents
  '
  ReDim e(13) '                       number of correct digits
  e(1) = 1: e(2) = 3: e(3) = 9: e(4) = 20
  e(5) = 42: e(6) = 85: e(7) = 173
  e(8) = 347: e(9) = 697: e(10) = 1393
  e(11) = 2792: e(12) = 5586: e(13) = 11175
  Pwr10 a, e(imx) + 4 '               initialize arithmetic mean A,
  Squ a, s: Rsft s, 1 '               sum S,
  Isqrt s, b '                        geometric mean B
  '
  For i = 1 To imx
   Slate.Box.Text = "working... " & i
    DoEvents: If Key Then GoTo break
    Copyf a, d
    Subt d, b: Rsft d, 1 '            D:= (A[n-1] - B[n-1]) / 2
    Squ d, t0: Lsft t0, i
    Subt s, t0 '                      S[n]:= S[n-1] - D^2 * 2^i
    Mult a, b, d: Swp a, d
    Add a, b: Rsft a, 1 '             A[n]:= (A[n-1] + B[n-1]) / 2
    Copyf a, b: Sqrt d, b '           B[n]:= Sqrt(A[n-1] * B[n-1])
  Next i
  Squ a, d: Lsft d, 1 '               D:= 2 * A[n]^ 2
  Setl a, e(imx)
  Printr d, s, a, "pi = ", ""
'
eind:
  Data = Data & dbCrLf & "Timer: " & CSng(Timer - tim) & "s"
  Slate.Box.Text = Data
  Slate.Box.SelStart = Len(Slate.Box.Text) + 1
  Lognr = FreeFile
  Open WrkD + "pi_agm.log" For Output As Lognr
  Print #Lognr, Data
  Data = "": Close Lognr
  On Error GoTo 0
  Exit Sub
break:
  Data = Data & vbCrLf & " break" & vbCrLf
  GoTo eind
errhand:
  MsgBox "Pi-AGM", 48, "Error"
  Resume eind
End Sub

Private Sub Sqrt(i0 As Long, i1 As Long)
Dim r As Boolean
'Return i1:= integer square root(i0), using i1 as seed.
  Do
    Copyf i0, t0: Divd t0, i1, t1
    Add i1, t1: Rsft i1, 1
    Subt t1, i1
    r = CLng(Gete(t1, 1)) + Gete(t1, 0) < 2
    r = r And (Getl(t1) = Gets(t1))
  Loop Until r
End Sub