primflgs.bas

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

Attribute VB_Name = "PrimFlgs"
Attribute VB_Description = "The Sieve of Erathostenes: a variation of Chartres' Algorithm 311."
'Subject: Generates PrimFlgs.bin, an encoded list of prime numbers
'         read by library function Nxtprm(). The prime / not prime
'         information is stored for 90 integers in 4 bytes.
'Author : Sjoerd.J.Schaper - [e-mail]
'URL    : http://largeint.sourceforge.net/index.html
'Date   : 21-12-2003
'Code   : Visual Basic for Windows 5.0
Option Explicit
Dim bv() As Long  '  bit vector

Sub Sieve(lP As Long)
Dim bi(7 To 95) As Long, bo(7 To 95) As Long
Dim c As Long, dP As Long, dt As Integer, f As String
Dim dword As String * 4, i As Long, j As Long
Dim k As Integer, li As Long, lv As Long, m As Long
Dim N As Long, P As Long, P6 As Long, t As Long
  On Error GoTo errhand
  Key = 0: tim = Timer: f = "0"
  '
  N = 1: dt = 4: t = 5
  For k = 1 To 30
     dt = 6 - dt: t = t + dt
     bi(t) = N: bo(t) = Not N '         store masks
     N = N * 2
  Next k
  '
  Data = " filling slate..." + vbCrLf
  PrimList.Box.Text = Data: DoEvents
  lv = (lP - 7) \ 90
  ReDim bv(lv) As Long '                preprocessed bit vector
  bv(0) = &HB76BDBF '                   5 & 7-folds excluded
  For i = 0 To lv - 1
     bv(i) = &H1BF6FDBF '               5-folds excluded
  Next i
  '
  Data = Data + " erasing multiples..." + vbCrLf
  PrimList.Box.Text = Data: DoEvents
  li = (Sqr(lP) - 7) \ 90: dt = 4
  For i = 0 To li
     c = bv(i): t = 5 '                 read 30-bit chunk
     For k = 1 To 30
        dt = 6 - dt: t = t + dt '       skip multiples of 2 and 3
        If c And bi(t) Then
           P = i * 90 + t '             calculate prime,
           dP = dt * P: P6 = 6 * P '     steps
           N = P * P '                  initial N = k * P
           Do While N < lP
              j = (N - 7) \ 90 '        point to multiple N
              m = N - j * 90
              bv(j) = bv(j) And bo(m) ' clear bit
              dP = P6 - dP: N = N + dP 'step to next N
           Loop
        End If
        DoEvents: If Key Then GoTo break
     Next k
  Next i
  f = Str$(CSng(Timer - tim))
  '
  Data = Data + " writing slate to disk..." + vbCrLf
  PrimList.Box.Text = Data: DoEvents
  Lognr = FreeFile
  Open WrkD + "primflgs.bin" For Binary Shared As #Lognr
  For i = 0 To lv - 1
     dword = Mkl$(bv(i))
     Put #Lognr, , dword
  Next i
'
eind:
  Data = Data & vbCrLf & "Timer: " + f + " s"
  PrimList.Box.Text = Data
  Close Lognr: Data = ""
  On Error GoTo 0
  Exit Sub
break:
  Data = " break, P = " & P & vbCrLf
  GoTo eind
errhand:
  MsgBox "PrimFlgs", 48, "Error"
  Resume eind
End Sub