正交函数分解(EOF)源代码(Visual Basic 6.0)

'*************************************

' 全局变量，便于主函数调用。

' VB 6.0 的函数返回的参数偏少，

' 使用全局变量在一定程度可以解决这个问题。

'****************************************

Public A() As Single ' 协方差/相关系数矩阵A

Public V() As Single '特征向量为列组成的矩阵，即空间函数V （EOF）Public T() As Single '时间系数矩阵T（PC）

Public B() As Single '特征值λ（E）,按从大到小排列

Public GM() As Single '解释的方差(%)（特征向量对X场的累积贡献率）P Public GA() As Single

Public GB() As Single '个体i特征向量对X场的贡献率ρ

Public XF() As Single '模拟结果

'********************************************************

' 函数名：CovarMat

' 函数用途: 计算协方差（相关系数）矩阵

' 参数说明：矩阵下标为1：N,从1开始；

' X,存放原始观测值，二维实型数组，X(P,P)。

' 返回：计算协方差（相关系数）矩阵。

'*******************************************************

Function CovarMat(X() As Single) As Single()

Dim XX() As Single

Dim P As Integer, N As Integer

Dim px As Single

P = UBound(X, 1)

N = UBound(X, 2)

px = IIf(N > 0, 1 / N, 1)

ReDim Preserve XX(1 To P, 1 To P)

Dim iAs Integer, j As Integer, k As Integer

' 求X乘以X的转置,即A=XXˊ

For i = 1 To P

For j = 1 To P

XX(i, j) = 0

For k = 1 To N

XX(i, j) = XX(i, j) + X(i, k) * X(j, k)

Next k

XX(i, j) = XX(i, j) * px

Next j

Next i

CovarMat = XX

End Function

'********************************************************

' 函数名：EOF

' 函数用途: EOF,经验正交分解法(EOF)

' 参数说明：矩阵下标为1：N,从1开始；

' X,存放原始观测值，二维实型数组，X(P,N)。

' P,整型变量，空间格点数。

' N,整型变量，序列的时间长度。

' XF,返回时存放恢复值，二维实型数组，XF(P,N)。

'*******************************************************

Sub EOF(X() As Single, ByRef S() As String)

Dim V1() As Single

Dim VF() As Single, TF() As Single

Dim P As Integer, N As Integer

P = UBound(X, 1)

N = UBound(X, 2)

ReDimXF(1 To P, 1 To N)

ReDimT(1 To P, 1 To N)

ReDimA(1 To P, 1 To P)

ReDimV(1 To P, 1 To P)

ReDimV1(1 To P, 1 To P)

ReDimB(1 To P)

ReDimGM(1 To P)

ReDimGA(1 To P)

ReDimGB(1 To P)

ReDimVF(1 To P, 1 To P)

ReDimTF(1 To P, 1 To N)

' 求X的协方差（相关系数）矩阵

A = CovarMat(X)

Dim iAs Integer, j As Integer, k As Integer, L As Integer

' 用Jacobi法求A的特征值和特征向量

' 返回时B存放矩阵的全部特征值，V存放特征向量为列组成的矩阵Call Jacobi(A, P, 0.000001, V, B, L)

For i = 1 To P

GA(i) = 0

For j = 1 Toi

GA(i) = GA(i) + B(j)

Next j

Next i

For i = 1 To P

GM(i) = GA(i) / GA(P)

GB(i) = B(i) / GA(P)

Next i

For i = 1 To P

For j = 1 To P

V1(i, j) = V(j, i)

Next j

Next i

T = MATMUL(V1, X) '时间系数

'输出结果字符串

Dim lsAs Integer

ls = UBound(S)

ReDim Preserve S(ls + 2)

S(ls) = MA TtoString(B, 1, , "特征值λ（E）")

S(ls + 1) = MA TtoString(GB, 1, 100, "个体i特征向量对X场的贡献率ρ")

S(ls + 2) = MA TtoString(GM, 1, 100, "解释的方差(%)（特征向量对X场的累积贡献率）P")

For i = 1 To P

For j = 1 Tolw

VF(i, j) = V(i, j)

Next j

Next i

For i = 1 Tolw

For j = 1 To N

TF(i, j) = T(i, j)

Next j

Next i

XF = MATMUL(VF, TF) '模拟值

End Sub

'*******************

'函数名：MATtoString