?? map_form.frm
字號:
grid_co(grid_no, 10) = yy2
grid_co(grid_no, 11) = xx1
grid_co(grid_no, 12) = yy1
Next j
Next i
'Determining grid cells whether containning a deposit
For i = 1 To deposit_num
xx = deposit_co(i, 1)
yy = deposit_co(i, 2)
ixx = Fix((xx - xmin) / dx) + 1
iyy = Fix((yy - ymin) / dy) + 1
ii = (iyy - 1) * l + ixx
grid_dep(ii, 1) = 1
Next i
'Initialize the grid_dep
For i = 1 To k * l
For j = 1 To m
grid_dep(i, j + 1) = -1
Next j
Next i
'Determining map patterns whether exist in grid cells
For j = 1 To m
'Open the map pattern file and input the data
filename = file(2 * j)
Open filename For Input As #2
Call InputEvi(evidence_co, point_num, region_num, 2)
For ij = 1 To k
yg = grid_co((ij - 1) * l + 1, 2)
kk = 0
For i1 = 1 To region_num
kkks = 0
For ii = kk + 1 To kk + point_num(i1) - 1
xx1 = evidence_co(ii, 1)
yy1 = evidence_co(ii, 2)
xx2 = evidence_co(ii + 1, 1)
yy2 = evidence_co(ii + 1, 2)
If ii < kk + point_num(i1) - 1 Then
xx3 = evidence_co(ii + 2, 1)
yy3 = evidence_co(ii + 2, 2)
ElseIf ii = kk + point_num(i1) - 1 Then
xx3 = evidence_co(kk + 2, 1)
yy3 = evidence_co(kk + 2, 2)
End If
'Determining the intersecting points of the scanning line and the polygon boundaries
If yy1 <> yy2 Then
If (yg > yy1 And yg < yy2) Or (yg < yy1 And yg > yy2) Then
kkks = kkks + 1
joint_co(kkks) = (xx2 - xx1) * (yg - yy1) / (yy2 - yy1) + xx1
ElseIf yg = yy2 Then
If (yy3 > yg And yy1 < yg) Or (yy3 < yg And yy1 > yg) Then
kkks = kkks + 1
joint_co(kkks) = xx2
ElseIf yy3 > yg And yy1 > yg Then
kkks = kkks + 2
joint_co(kkks - 1) = xx2
joint_co(kkks) = xx2
ElseIf yy3 < yg And yy1 < yg Then
ixx = Fix((xx2 - xmin) / dx) + 1
iyy = Fix((yy2 - ymin) / dy) + 1
grid_dep((iyy - 1) * l + ixx) = 1
End If
End If
ElseIf yy1 = yg And yy2 = yg Then
kkks = kkks + 2
joint_co(kkks - 1) = xx1
joint_co(kkks) = xx2
End If
Next ii
'Sort the X_coordinates
For iii = 1 To kkks - 1
For jjj = iii + 1 To kkks
If joint_co(iii) > joint_co(jjj) Then
xs = joint_co(iii)
joint_co(iii) = joint_co(jjj)
joint_co(jjj) = xs
End If
Next jjj
Next iii
'Determining the grid_dep() values
kks = kkks \ 2
For iii = 1 To kks
For jjj = 1 To l
If grid_co((ij - 1) * l + jjj, 1) >= joint_co(2 * iii - 1) And grid_co((ij - 1) * l + jjj, 1) <= joint_co(2 * iii) Then
grid_dep((ij - 1) * l + jjj, j + 1) = 1
End If
Next jjj
Next iii
kk = kk + point_num(i1)
Next i1
Next ij
Close #2
'Open the unmapped region file and input the data
filename = file(2 * j + 1)
Open filename For Input As #2
Call InputEvi(evidence_co, point_num, region_num, 2)
For ij = 1 To k
yg = grid_co((ij - 1) * l + 1, 2)
kk = 0
For i1 = 1 To region_num
kkks = 0
For ii = kk + 1 To kk + point_num(i1) - 1
xx1 = evidence_co(ii, 1)
yy1 = evidence_co(ii, 2)
xx2 = evidence_co(ii + 1, 1)
yy2 = evidence_co(ii + 1, 2)
If ii < kk + point_num(i1) - 1 Then
xx3 = evidence_co(ii + 2, 1)
yy3 = evidence_co(ii + 2, 2)
ElseIf ii = kk + point_num(i1) - 1 Then
xx3 = evidence_co(kk + 2, 1)
yy3 = evidence_co(kk + 2, 2)
End If
'Determining the intersecting points of the scanning line and the polygon boundaries
If yy1 <> yy2 Then
If (yg > yy1 And yg < yy2) Or (yg < yy1 And yg > yy2) Then
kkks = kkks + 1
joint_co(kkks) = (xx2 - xx1) * (yg - yy1) / (yy2 - yy1) + xx1
ElseIf yg = yy2 Then
If (yy3 > yg And yy1 < yg) Or (yy3 < yg And yy1 > yg) Then
kkks = kkks + 1
joint_co(kkks) = xx2
ElseIf yy3 > yg And yy1 > yg Then
kkks = kkks + 2
joint_co(kkks - 1) = xx2
joint_co(kkks) = xx2
ElseIf yy3 < yg And yy1 < yg Then
ixx = Fix((xx2 - xmin) / dx) + 1
iyy = Fix((yy2 - ymin) / dy) + 1
grid_dep((iyy - 1) * l + ixx) = 0
End If
End If
ElseIf yy1 = yg And yy2 = yg Then
kkks = kkks + 2
joint_co(kkks - 1) = xx1
joint_co(kkks) = xx2
End If
Next ii
'Sort the X_coordinates
For iii = 1 To kkks - 1
For jjj = iii + 1 To kkks
If joint_co(iii) > joint_co(jjj) Then
xs = joint_co(iii)
joint_co(iii) = joint_co(jjj)
joint_co(jjj) = xs
End If
Next jjj
Next iii
'Determining the grid_dep() values
kks = kkks \ 2
For iii = 1 To kks
For jjj = 1 To l
If grid_co((ij - 1) * l + jjj, 1) >= joint_co(2 * iii - 1) And grid_co((ij - 1) * l + jjj, 1) <= joint_co(2 * iii) Then
grid_dep((ij - 1) * l + jjj, j + 1) = 0
End If
Next jjj
Next iii
kk = kk + point_num(i1)
Next i1
Next ij
Close #2
Next j
'Calculating the certainty factors for all map patterns
kkd = 0
For i = 1 To k * l
If grid_dep(i, 1) = 1 Then
kkd = kkd + 1
End If
Next i
For j = 1 To m
kke1 = 0
kke2 = 0
kke = 0
kkef = 0
For i = 1 To k * l
If grid_dep(i, j + 1) = 1 Then
kke1 = kke1 + grid_dep(i, 1) * grid_dep(i, j + 1)
kke = kke + 1
ElseIf grid_dep(i, j + 1) = -1 Then
kke2 = kke2 + grid_dep(i, 1) * (-grid_dep(i, j + 1))
kkef = kkef + 1
End If
Next i
py = CDbl(kkd) / CDbl(k * l)
pyz = CDbl(kke1) / CDbl(kke)
pyzf = CDbl(kke2) / CDbl(kkef)
If pyz >= py Then
cf(j, 1) = (pyz - py) / ((1 - py) * pyz)
Else
cf(j, 1) = (pyz - py) / (py * (1 - pyz))
End If
If pyzf >= py Then
cf(j, 2) = (pyzf - py) / ((1 - py) * pyzf)
Else
cf(j, 2) = (pyzf - py) / (py * (1 - pyzf))
End If
Next j
'Synthesizing the bpa functions for all grid cells
If m >= 2 Then
For i = 1 To k * l
myz = 1
myf = 1
For j = 1 To m
If (grid_dep(i, j + 1) = 1 And cf(j, 1) > 0) Or (grid_dep(i, j + 1) = -1 And cf(j, 2) > 0) Then
If grid_dep(i, j + 1) = 1 Then
myz = myz * (1 - cf(j, 1))
ElseIf grid_dep(i, j + 1) = -1 Then
myz = myz * (1 - cf(j, 2))
End If
ElseIf (grid_dep(i, j + 1) = 1 And cf(j, 1) < 0) Or (grid_dep(i, j + 1) = -1 And cf(j, 2) < 0) Then
If grid_dep(i, j + 1) = 1 Then
myf = myf * (1 + cf(j, 1))
ElseIf grid_dep(i, j + 1) = -1 Then
myf = myf * (1 + cf(j, 2))
End If
ElseIf grid_dep(i, j + 1) = 0 Then
myz = 0
End If
Next j
myz = 1# - myz
myf = 1# - myf
km = 1# / (1# + myz * (-1# * myf))
bpa(i) = km * myz * (1# + (-1# * myf))
Next i
Else
For i = 1 To k * l
If grid_dep(i, 2) = 1 Then
If cf(1, 1) > 0 Then
bpa(i) = cf(1, 1)
ElseIf cf(1, 1) <= 0 Then
bpa(i) = 0
End If
ElseIf grid_dep(i, 2) = -1 Then
If cf(1, 2) > 0 Then
bpa(i) = cf(1, 2)
ElseIf cf(1, 2) <= 0 Then
bpa(i) = 0
End If
ElseIf grid_dep(i, 2) = 0 Then
bpa(i) = 0
End If
Next i
End If
'Output the results into the MapInfo Interchange files (*.mif and *.mid)
filename = Text4.Text
Open filename For Output As #3
ii = Len(Trim(filename))
filename1 = Left(Trim(filename), ii - 3) + "mid"
Open filename1 For Output As #4
filename2 = Left(Trim(filename), ii - 3) + "grd"
Open filename2 For Output As #5
Call Output(grid_co, grid_dep, bpa, 3, 4, 5, xmin, ymin, xmax, ymax, m, k, l, "CombinedBPA")
Close #3
Close #4
Close #5
Screen.MousePointer = vbDefault
map_form.Print " Program Runs OK!"
Exit Sub
errprint:
Screen.MousePointer = vbDefault
ShowError
Exit Sub
End Sub
Private Sub Exit_Click()
Unload map_form
End Sub
Private Sub WEM_Click()
SetHourglass
'//////////////////////////////////////////////////////////
'THIS PROGRAM IS FOR WEIGHTS OF EVIDENCE MODELING PROCEDURE
'ORIGINATED BY: CHEN YONGLIANG
'AFFILIATE TO: JILIN UNIVERSITY, CHANGCHUN P.R.CHINA
'DATE: SEPTEMBER 20,2000
'///////////////////////////////////////////////////////////
Dim xmin As Double, xmax As Double, ymin As Double, ymax As Double, xx As Double, yy As Double, yg As Double
Dim dx As Double, dy As Double
Dim m As Integer, np As Integer, k As Integer, l As Integer
Dim grid_no As Integer, i As Integer, ii As Integer, ij As Integer, j As Integer, deposit_num As Integer, ixx As Integer, iyy As Integer
Dim grid_co() As Double, deposit_co(1000, 2) As Double, evidence_co(10000, 2) As Double, joint_co(100) As Double
Dim grid_dep() As Integer, point_num(1000) As Integer
Dim weight() As Double, odds() As Double
Dim filename As String * 80, filename1 As String * 80, filename2 As String * 80, filename3 As String * 80
Dim region_num As Integer, kk As Integer, i1 As Integer, kkks As Integer, iii As Integer, jjj As Integer
Dim kks As Integer, kkd As Integer, kke1 As Integer, kke2 As Integer, kke3 As Integer, kke4 As Integer
Dim kke5 As Integer, kke6 As Integer, kke7 As Integer, kke8 As Integer
Dim kke11 As Integer, kke12 As Integer, kke21 As Integer, kke22 As Integer
Dim kkef11 As Integer, kkef12 As Integer, kkef21 As Integer, kkef22 As Integer
Dim j1 As Integer, j2 As Integer
Dim ctest() As Double, misdeviate() As Double, postdeviate() As Double, weightvar() As Double
Dim xs As Double, xx1 As Double, xx2 As Double, xx3 As Double
Dim yy1 As Double, yy2 As Double, yy3 As Double
Dim ccc As Double, sum1 As Double, sum2 As Double, sum3 As Double, sum4 As Double, sum5 As Double, sum6 As Double, sum7 As Double, sum8 As Double
Dim file() As String * 80
'The number of evidences
m = Val(Text1.Text)
'The number of scanning lines
k = Val(Text2.Text)
ReDim file(2 * m + 1)
On Error GoTo errprint
'Open *.txt file and input map layer file names and addresses
filename = Text3.Text
Open filename For Input As #1
For i = 1 To 2 * m + 1
Input #1, file(i)
Next i
Close #1
'Open the *.mif file and input the data of deposit map layer
filename = file(1)
Open filename For Input As #1
Call InputDep(deposit_co, deposit_num, 1, xmin, ymin, xmax, ymax)
Close #1
ccc = (xmax - xmin) / (ymax - ymin)
'The number of columns
l = CInt(k * ccc)
dx = (xmax - xmin) / CDbl(l)
dy = (ymax - ymin) / CDbl(k)
ReDim grid_co(k * l, 12), grid_dep(k * l, m + 1), odds(k * l), weight(m, 3), ctest(m, m)
ReDim weightvar(m, 2), postdeviate(k * l), misdeviate(m)
'Generate the uniform grid cells
For i = 1 To k
For j = 1 To l
grid_no = (i - 1) * l + j
xx = xmin + j * dx - dx / 2#
yy = ymin + i * dy - dy / 2#
xx1 = xx - dx / 2#
yy1 = yy - dy / 2#
xx2 = xx + dx / 2#
yy2 = yy + dy / 2#
grid_co(grid_no, 1) = xx
grid_co(grid_no, 2) = yy
grid_co(grid_no, 3) = xx1
grid_co(grid_no, 4) = yy1
grid_co(grid_no, 5) = xx2
grid_co(grid_no, 6) = yy1
grid_co(grid_no, 7) = xx2
grid_co(grid_no, 8) = yy2
grid_co(grid_no, 9) = xx1
grid_co(grid_no, 10) = yy2
grid_co(grid_no, 11) = xx1
grid_co(grid_no, 12) = yy1
Next j
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -