LM算法求解最小二乘問題

Module VarLM
  Implicit none
  !//Nparas爲參數個數，Ndata爲數據個數,Niters爲最大迭代次數
  Integer     ,Parameter :: Nparas = 2,Ndata = 9,Niters = 50,Fileid = 11
  !//臨時變量，order=1，繼續迭代，否則停止迭代
  Integer                :: order
  !//循環變量，it爲迭代次數循環變量
  Integer                :: it,i,ii
  !//x_1爲觀測數據自變量，y_1爲觀測數據因變量，兩者均爲已知數據
  Real(kind=8),Parameter :: x_1(Ndata) = [0.25,0.5,1.0,1.5,2.0,3.0,4.0,6.0,8.0]
  Real(kind=8),Parameter :: y_1(Ndata)  = [19.306,18.182,16.126,14.302,12.685,9.978,7.849,4.857,3.005]   
  !//a0與b0分別爲參數猜測初始值,RealA、RealB爲真值
  Real(kind=8),Parameter :: a0 = 0.,b0 = 0.,RealA = 20.5,RealB = 0.24
  !//誤差限度
  Real(kind=4)           :: eps = 1e-8
  !//y_est爲估計值，d爲估計值和實際值y_1之間的誤差，rd爲數組d的變形
  Real(kind=8)           :: y_est(Ndata) = 0.,d(Ndata) = 0.,rd(Ndata,1) = 0.
  !//J爲雅可比矩陣，JT爲J的轉置矩陣，H爲海森矩陣
  Real(kind=8)           :: J(Ndata,Nparas) = 0.,JT(Nparas,Ndata) = 0.,H(Nparas,Nparas) = 0.
  !//Inv_H_1m爲H_1m的逆矩陣
  Real(kind=8)           :: H_Lm(Nparas,Nparas)=0.,Inv_H_Lm(Nparas,Nparas)=0.
  !//eye爲單位矩陣，delta爲步長矩陣
  Real(kind=8)           :: eye(Nparas,Nparas) = 0.0,delta(Nparas,1) = 0.0
  !//a_est，b_est分別爲反演參數
  Real(kind=8)           :: a_est = 0.,b_est = 0.,e = 0.
  !//計算新對應的值
  Real(kind=8)           :: y_est_Lm(Ndata) = 0.,d_Lm(Ndata) = 0.,e_Lm = 0.
  !//臨時變量，lamda爲LM算法的阻尼係數初始值
  Real(kind=8)           :: a_Lm,b_Lm,lamda = 0.01,v = 10.d0,temp
 
End Module VarLM
  

Program LM
  Include 'link_fnl_shared.h'
  Use VarLM
  Use LINRG_INT
  Implicit None
  
  !//生成單位矩陣
  Forall( i = 1:Nparas, ii = 1:Nparas, i==ii ) eye(i,ii) = 1.d0
  
  !//第一步：變量賦值
  order = 1
  a_est = a0
  b_est = b0
  
  !//第二步：迭代
  Write(*,"('------------------------------------------------')") 
  loop1: Do it = 1,Niters
    If ( order==1 ) Then  !//根據當前估計值，計算雅可比矩陣
      
      y_est = a_est*Exp( -b_est*x_1 ) !//根據當前a_est，b_est及x_1，得到函數值y_est
      d = y_1 - y_est   !//計算已知值y_1與y_est的誤差
      
      loop2: Do i = 1,Ndata  !//計算雅可比矩陣。dy/da = Exp(-b*x)，dy/db = -a*x*Exp(-b*x)
        J(i,1) = Exp( -b_est*x_1(i) ) 
        J(i,2) = -a_est*x_1(i)*Exp( -b_est*x_1(i) )
      End Do loop2    
      
      JT=Transpose(J)   
      H = Matmul( JT,J )  !//計算海森矩陣
      
    End If
    If ( it==1 ) e = Dot_Product(d,d)  !//若是第一次迭代，計算誤差epsilon
    H_Lm = H + lamda*eye   !//根據阻尼係數lamda混合得到H矩陣
    !// 縧amda*I縇evenberg靠縧amda*diag(A'A)縈arquardt靠
    !//計算步長delta，並根據步長計算新的參數估計值
    Call LINRG( H_Lm,Inv_H_Lm )   !//使用imsl函數庫，計算H_Lm的逆矩陣Inv_H_Lm
    
    rd = Reshape( d,[Ndata,1] )  !//爲了滿足內部函數Matmul的計算法則，對d的數組形狀進行改變
    delta = Matmul( Inv_H_Lm,matmul( JT,rd ) )  !//delta爲增量
    a_Lm = a_est + delta(1,1)
    b_Lm = b_est + delta(2,1)
    
    !//如果||delta||<1e-8，終止迭代
    If ( Dot_Product(delta(:,1),delta(:,1))<eps ) Exit
    !//計算新的可能估計值對應的y和計算殘差e
    y_est_Lm = a_Lm*Exp( -b_Lm*x_1 )
    d_Lm = y_1 - y_est_Lm
    e_Lm = Dot_Product( d_Lm,d_Lm )  !//e_LM等於||y_1 - y_est_LM||
    
    !//根據誤差，決定如何更新參數和阻尼係數
    !//迭代成功時將lamda減小，否則增大lamda
    If ( e_Lm<e ) Then
      lamda = lamda/v
      a_est = a_Lm
      b_est = b_Lm
      e = e_Lm
      order = 1
    Else
      order = 0
      lamda = lamda*v
    End If
    
    Write(*,"('a_est=',g0,2X,'b_est=',g0)") a_est,b_est
  End Do loop1
  Write(*,"('------------------------------------------------')") 
  Write(*,"('停止迭代，總共迭代',g0,'次')") it - 1
  !//輸出正反演數據以及百分比誤差輸出到文件,總共100個數據點,計算區域爲[0-50]
  Open(Fileid,file='原始數據與反演數據.dat',status='unknown')
  Do i = 0,100
    temp = i/2.d0
    Write(Fileid,'(f7.3,3f15.8)') temp,RealA*Exp( -RealB*temp ),a_est*Exp( -b_est*temp ),&
      Abs( a_est*Exp( -b_est*temp )-RealA*Exp( -RealB*temp ) )/RealA/Exp( -RealB*ii )*100
  End Do
  Close(Fileid)
  !//輸出反演參數a_est，b_est以及原始數據和擬合數據
  Write(*,"(/,'反演參數爲：')")
  Write(*,"('a_est=',g0)") a_est
  Write(*,"('b_est=',g0)") b_est
  Write(*,"(/,'原始數據爲：')") 
  Write(*,'(3f9.4/)') y_1
  Write(*,"('擬合數據爲：')") 
  Write(*,'(3f9.4/)') a_est*Exp( -b_est*x_1 )
  Write(*,"('------------------------------------------------')") 
  
End Program LM