《物元可拓源码》由会员分享，可在线阅读，更多相关《物元可拓源码（4页珍藏版）》请在金锄头文库上搜索。
1、物元可拓法于80年代由我国蔡文教授创立，目前已广泛应用于新产品构思 与设计、优化决策、控制、识别与评价等各个领域，无论在理论还是在实践上都 发挥了越来越重要的作用。物元是描述事物的名称、特征及量值3个基本元素的简称，在形式上可记 为 M = (N，c，v) = (N，c，c(N)。其中 M、N、c、v 分别是 Matter、 Name，character，Value的缩写。可拓集合是用关联度将模糊集合的0，1 闭合区间连续取值拓广到(-8, +8)实数轴，以表达物元的量值为实轴上的一 点时符合要求的程度。物元分析是研究物元及其变化并用以解决矛盾问题的规律 和方法，可拓学是用形式化的工具，从定性
2、和定量两个角度去研究解决矛盾问题 的规律和方法。物元可拓法结合二者，是将辨证逻辑和形式逻辑相结合的可拓逻 辑，丰富了事物的内涵，客观地反映了物质世界的真实状态。本次选用评价因子污染贡献率方法来确定权系数。主要计算程序：Dim sRow As Integer, sCol As Integer 起始的行与列Dim i As Integer, j As Integer循环变量Dim Xj As Double定义实测值Dim Aij As Double, Bij As Double定义标准域区间Dim Apj As Double, Bpj As Double定义节域变量Dim YZS As Integ
3、er定义评价因子个数Dim DJS As Integer定义评价等级数得到起始行列值sRow = InputBox(请输入监测数据第一个数的行号！、输入行号，0)sCol = InputBox(请输入监测数据第一个数的列号！，输入列号”，0)YZS = InputBox(请输入评价因子个数也”输入因子个数,0)DJS = InputBox(请输入评价等级个数也”输入评价等级数”，0)插入标记列文字With Sheets(sheet1)For i = 1 To DJSCells(sRow + DJS + 2 + i, sCol - 1).Value =关联函数 k_等级”& iNext iCel
4、ls(sRow + 2 * DJS + 3, sCol - 1).Value = X/SCells(sRow + 2 * DJS + 4, sCol - 1).Value =”归一化权重”For i = 1 To DJSCells(sRow + 2 * DJS + 4 + i, sCol - 1).Value =关联度 K_等级”& iNext iCells(sRow + 3 * DJS + 5, sCol - 1).Value =可拓指数”按列循环计算For j = sCol To sCol + YZS - 1赋初值Xj = Cells(sRow, j).Value实测值Apj = Cell
5、s(sRow + 1, j).Value可拓域最小值Bpj = Cells(sRow + DJS + 2, j).Value 可拓域最大值For i = 1 To DJS对aij,bij赋值Aij = Cells(sRow + i, j).ValueBij = Cells(sRow + i + 1, j).Value按条件选择公式计算关联度If Xj Aij And Xj Bij Then xjXij 点 x 位于本标准之内If Xj = (Aij + Bij) / 2) ThenCells(sRow + i + DJS + 2, j).Value = -(Aij - Xj) / (Bij -
6、 Aij)ElseCells(sRow + i + DJS + 2, j).Value = -(Xj - Bij) / (Bij - Aij) End IfElse xjXij点x位于本标准之外If Xj Aij Then x位于标准的左边,此时有x(ai+bi)/2If Xj Bij Then x位于标准的右边,此时有x(ai+bi)/2If Xj = (Apj + Bpj) / 2 ThenCells(sRow + i + DJS + 2, j).Value = (Xj - Bij) / (Apj + Bij - 2 * Xj) ElseCells(sRow + i + DJS + 2,
7、j).Value = (Xj - Bij) / (Bij - Bpj)End IfEnd IfEnd IfNext iNext j计算X/SFor j = sCol To sCol + YZS - 1Dim a As Doublea = 0For i = 1 To DJS + 2a = a + Cells(sRow + i, j)Next iCells(sRow + 2 * DJS + 3, j).Value = Cells(sRow, j).Value * (DJS + 2) / a Next j 计算权重 计算x/s的总和 a = 0 For i = sCol To sCol + YZS
8、- 1a = a + Cells(sRow + 2 * DJS + 3, i) Next iFor j = sCol To sCol + YZS - 1Cells(sRow + 2 * DJS + 4, j).Value = Cells(sRow + 2 * DJS + 3, j).Value / aNext j计算关联度Cells(sRow + 2 * DJS + 4, sCol + YZS)=综合关联度For i = 1 To DJSFor j = sCol To sCol + YZS - 1Cells(sRow + 2 * DJS + 4 + i, j).Value = Cells(sR
9、ow + DJS + 2 + i, j).V alue * Cells(sRow + 2 * DJS + 4, j).ValueNext jDim k As Integera = 0For k = sCol To sCol + YZS - 1a = a + Cells(sRow + 2 * DJS + 4 + i, k)综合关联度累加Next kCells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value = a Next i 计算可拓指数 找最小与最大关联度 Dim Kmax, Kmin As Double Kmax = Cells(sRow + 2 * D
10、JS + 4 + 1, sCol + YZS).Value Kmin = Kmax For i = 2 To DJSIf Kmax Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value ThenKmin = Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).ValueEnd IfNext iDim KXP() As DoubleReDim KXP(DJS) As DoubleFor i = 1 To DJSKXP(i) = (Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value
11、 - Kmin) / (Kmax -Kmin)Next iDim FZ, FM As DoubleFor i = 1 To DJSFZ = FZ + i * KXP(i)FM = FM + KXP(i)Next iCells(sRow + 3 * DJS + 5, sCol).Value = FZ / FMEnd With我做地下水水质评价时用到的公式是这样的：矩跟关联度的公式是通常用到的那个,即：P(xj,xij)=|xj-0.5(aij + bij)|-0.5(bij-aij)关联函数计算公式：当 xj 属于 xij 时,ki(xj) = -p(xj,xij)/|xij|当 xj 不属于
12、xij 时,ki(xj) = p(xj,xij)/p(xj,xrj)-p(xj,xij)综合关联度计算公式：Kj(p)=a1*kj(x1)+a2*kj(x2) + .+an*kj(xn)权重用的污染因子贡献率法：ai = (xi/Si)/(x1/S1+x2/S2+.xn/Sn)可拓指数用公式：KXP=(Kj(X)-Min(Kj(X)/(Max(Kj(X)-Min(Kj(X)由于涉及的内容或者思路一同,可能选用的关联度计算公式，权重计算公式不同，酌情参考。参考源程序里最初的部分，后面的变量说明有详细解释，定义要评价的参数个数，评价的等级等， 相应的在excel表格里的参数个数与评价等级的行数要与之对应。PS:上面的代码里因子个数是通过跳出的对话框手动输入进去的。
