clientmodule.bas

这些是我特地制作的分布式计算的示例程序

Attribute VB_Name = "ClientModule"
'分布式计算开发示例
'原作者 郝佳男
'force to declare the var
Option Explicit
'Some Global vars

'Public zht As Long

'Begin Positon
Public BeginPos As Long

'End Position
Public EndPos As Long

'Begin Time
Public BeginTime As Date

'Current Position
Public CurPos As Long

'The result
Public result$

'is computing
Public js As Boolean

'No Task Flag
Public NoTask As Boolean

'Flag to mode function
Public nkj(32) As Integer

Public Function GetReturn() As String
'assemble the returning string
Dim s As String
'prefix
s = "RES"
'add beignpos
s = s + Trim$(CStr(BeginPos))
'add split space and endpos
s = s + " " + Trim$(CStr(EndPos))
'add split space and result
s = s + " " + result$
'return the value
GetReturn = s

End Function

Public Sub xx(s$)
'Display and log the information
'File Access Number
Dim fn As Long
'Display it in textbox
Form1.Text3.Text = s$ + vbCrLf + Form1.Text3
'get File Access Number
fn = FreeFile
'Open logfile
Open "Log.txt" For Append As #fn
'File #fn is opend
    'write it to file
    Print #fn, Form1.Text3
'Close the file
Close #fn

End Sub

Sub BBPstart(nit1 As Long, nit2 As Long, njmp As Long)
' ---------------- BBP ---------------------
' -----------------------------------------------
' the following are a complete program for BBP
' -----------------------------------------------
' BBP is a arithmetic that can compute the PI

Dim lng As Integer
Dim mlng As Long
Dim m As Long
Dim s As Double
Dim d16lng As Double
Dim wk As Double
Dim sbuf$
Dim i As Long, j As Long
Dim fn As Long
Dim t0$
Dim td1 As Double
Dim td2 As Double
Dim td3 As Double

'display the information
xx "计算开始"
'Clear the result
result$ = ""
'Get handle
fn = FreeFile
'Open a reult file that you can check it
'Open "piHEX.txt" For Output As fn
't0$ = Time$

'generate result once a term
lng = 8
'set DEc to HEX factor
d16lng = 16# ^ lng
'check the param
If nit1 > nit2 Then
'head>tail?
    'tail:=head
    nit2 = nit1
End If
'clear mlng
mlng = 0
'main loop
For m = nit1 To nit2
    'release control that the message pump is alive
    'we can remove it to improve the performance
    'however, it may looks like the computer is down
    DoEvents
    'compute mlng
    mlng = lng * (m - 1)
    
    'call sub routine
    Call bbp(mlng, s)
    's is the return value
    
    'inc the mlng
    mlng = mlng + 8
    'compute temp var wk
    wk# = Int(s * d16lng)
    'j is the sub result in DEC
    j = Int(wk# - Int(wk# / 16) * 16)
    'convert it to HEX
    If j < 10 Then sbuf$ = Trim$(Str$(j)) Else sbuf$ = Chr$(64 + j - 9)
    'refresh wk
    wk# = Int(wk# / 16)
    'add new sub result to sub buf
    sbuf$ = Hex$(wk) + sbuf$
    'loop to add prefix zero
    For i = 1 To 8 - Len(sbuf$)
        sbuf$ = "0" + sbuf$
    Next i
    
    'add it to result
    result$ = result$ + sbuf$
    'write it to file
    'Print #fn, sbuf$;
    'judge if we should refresh the label
    If ((m - nit1 + 1) Mod njmp) = 0 Then
    'we should refresh the label
        'compute the percent
        'current
        td1 = m - nit1 + 1
        'total
        td2 = (nit2 - nit1 + 1)
        'divide
        td3 = td1 / td2
        'convert format
        td3 = td3 * 100
        td3 = Int(td3)
        'set the label
        Form1.Label11.Caption = CStr(td3) + "%"
    End If
Next m

'the computition is completed
'display the information
xx "计算完成"
'close the reult file
'Close #fn
'release the control
'DoEvents
js = False
'judge if the auto-connect is true
If Form1.Check1.Value = 1 Then
'auto-connect is set
    'judge if the winsock is closed
    If Form1.Winsock1.State <> sckClosed Then
    'not closed
        'close it
        Form1.Winsock1.Close
    End If
    'set the remote host by text
    Form1.Winsock1.RemoteHost = Form1.Text1.Text
    'set the remote port by text
    Form1.Winsock1.RemotePort = CInt(Form1.Text2.Text)
    'display the information
    xx "连接中..."
    'zht = 1
    'connect it
    Form1.Winsock1.Connect
End If

End Sub

' ------ BBP algorithm --------------------------
Sub bbp(n As Long, s As Double)
Dim p As Double
'for direct division
Dim p2 As Double
Dim p3 As Double
Dim p4 As Double
'
Dim p16 As Double
Dim tk As Double
Dim k As Long
Dim nk As Long
Dim j As Integer
Dim s1 As Double
Dim s2 As Double
Dim s3 As Double

Dim pp As Double
'part sum
Dim dm1 As Double
Dim dm2 As Double
Dim dm3 As Double
Dim dm4 As Double
'a multiplicator
Dim b16 As Double
'antoher multiplicator
Dim r As Double


'initilize the vars
p = 9#
p16 = 1#
s = 2# / 15#
'a loop
For k = 1 To n + 12
  'inc p2
  p2 = p + 3#
  'inc p3
  p3 = p + 4#
  'inc p4
  p4 = p + 5#
  'compare n and k
  If k <= n Then
  'k is smaller or equ
  'we must compute 16^nk mod p
  'in simple algorithm,it may overflow
  'however, we must get the nicety value
  'so we use a special algorithm
  'the algorithm is so long...
     'If k = 0 Then
     ' s = 2# / 15#
     'Else
      'get differ
      nk = n - k
      'loop to generate binary mask
      For j = 1 To 32
       nkj(j) = nk Mod 2
       nk = nk \ 2
       If nk = 0 Then
        Exit For
       End If
      Next j
      'set the length
      nkj(0) = j
      
      'dm1
      'init pp and b16 and r
      r = 4#
      pp = p
      b16 = 16#
      'loop each mask
      For j = 1 To nkj(0)
        'judge the mask
        If nkj(j) = 1 Then
        'have mask
            'multiple b16
            r = b16 * r
            'get the remainer
            r = r - pp * Int(r / pp)
        End If
        'jump out if j equal length
        If j = nkj(0) Then
         'exit loop
         Exit For
        End If
        'multiple b16
        b16 = b16 * b16
        'get the remainer
        b16 = b16 - pp * Int(b16 / pp)
      Next j
      'compute quotient
      dm1 = r / pp

      'dm2
      'init pp and b16 and r
      r = 2#
      pp = p2
      b16 = 16#
      'loop each mask
      For j = 1 To nkj(0)
      'judge the mask
        If nkj(j) = 1 Then
        'have mask
            'multiple b16
            r = b16 * r
            'get the remainer
            r = r - pp * Int(r / pp)
        End If
        'jump out if j equal length
        If j = nkj(0) Then
         'exit loop
         Exit For
        End If
        'multiple b16
        b16 = b16 * b16
        'get the remainer
        b16 = b16 - pp * Int(b16 / pp)
      Next j
      'compute quotient
      dm2 = r / pp

      'dm3
      'init pp and b16 and r
      r = 1#
      pp = p3
      b16 = 16#
      'loop each mask
      For j = 1 To nkj(0)
      'judge the mask
        If nkj(j) = 1 Then
        'have mask
            'multiple b16
            r = b16 * r
            'get the remainer
            r = r - pp * Int(r / pp)
        End If
        'jump out if j equal length
        If j = nkj(0) Then
         'exit loop
         Exit For
        End If
        'multiple b16
        b16 = b16 * b16
        'get the remainer
        b16 = b16 - pp * Int(b16 / pp)
      Next j
      'compute quotient
      dm3 = r / pp
      
      'dm4
      'init pp and b16 and r
      r = 1#
      pp = p4
      b16 = 16#
      'loop each mask
      For j = 1 To nkj(0)
      'judge the mask
        If nkj(j) = 1 Then
        'have mask
            'multiple b16
            r = b16 * r
            'get the remainer
            r = r - pp * Int(r / pp)
        End If
        'jump out if j equal length
        If j = nkj(0) Then
         'exit loop
         Exit For
        End If
        'multiple b16
        b16 = b16 * b16
        'get the remainer
        b16 = b16 - pp * Int(b16 / pp)
      Next j
      'compute quotient
      dm4 = r / pp
      
      'sum all
      s = s + (dm1 - dm2 - dm3 - dm4)
      's = s + (dmod#(4#, p) - dmod#(2#, p2) - dmod#(1#, p3) - dmod#(1#, p4))
      'format |s|<=1
      Do While s > 1
        s = s - 1
      Loop
      
      'format |s|<=1
      Do While s < 0
        s = s + 1
      Loop
     'End If
  Else
  'k>n
  
    'compute it in a simple way
    p16 = p16 / 16#
    'direct divide it
    tk = p16 * (4# / p - 2# / p2 - 1# / p3 - 1# / p4)
    'sum it
    s = s + tk
    'format it to decreace it
    If s > 1 Then
     s = s - 1
    End If
    'judge if the result is too small
    'the small result can not effect the result
    If tk < 1E-17 Then
    'the result is too small
     'exit loop
     Exit For
    End If
  End If
  ' inc p
  p = p + 8#
Next k

End Sub