Task: LU decomposition








VB: Option Base 1
Private Function pivotize(m As Variant) As Variant
    Dim n As Integer: n = UBound(m)
    Dim im() As Double
    ReDim im(n, n)
    For i = 1 To n
        For j = 1 To n
            im(i, j) = 0
        Next j
        im(i, i) = 1
    Next i
    For i = 1 To n
        mx = Abs(m(i, i))
        row_ = i
        For j = i To n
            If Abs(m(j, i)) > mx Then
                mx = Abs(m(j, i))
                row_ = j
            End If
        Next j
        If i <> Row Then
            For j = 1 To n
                tmp = im(i, j)
                im(i, j) = im(row_, j)
                im(row_, j) = tmp
            Next j
        End If
    Next i
    pivotize = im
End Function
 
Private Function lu(a As Variant) As Variant
    Dim n As Integer: n = UBound(a)
    Dim l() As Double
    ReDim l(n, n)
    For i = 1 To n
        For j = 1 To n
            l(i, j) = 0
        Next j
    Next i
    u = l
    p = pivotize(a)
    a2 = WorksheetFunction.MMult(p, a)
    For j = 1 To n
        l(j, j) = 1#
        For i = 1 To j
            sum1 = 0#
            For k = 1 To i
                sum1 = sum1 + u(k, j) * l(i, k)
            Next k
            u(i, j) = a2(i, j) - sum1
        Next i
        For i = j + 1 To n
            sum2 = 0#
            For k = 1 To j
                sum2 = sum2 + u(k, j) * l(i, k)
            Next k
            l(i, j) = (a2(i, j) - sum2) / u(j, j)
        Next i
    Next j
    Dim res(4) As Variant
    res(1) = a
    res(2) = l
    res(3) = u
    res(4) = p
    lu = res
End Function
 
Public Sub main()
    
    a = [{1, 3, 5; 2, 4, 7; 1, 1, 0}]
    Debug.Print "== a,l,u,p: =="
    result = lu(a)
    For i = 1 To 4
        For j = 1 To UBound(result(1))
            For k = 1 To UBound(result(1), 2)
                Debug.Print result(i)(j, k),
            Next k
            Debug.Print
        Next j
        Debug.Print
    Next i
    a = [{11, 9,24, 2; 1, 5, 2, 6; 3,17,18, 1; 2, 5, 7, 1}]
    Debug.Print "== a,l,u,p: =="
    result = lu(a)
    For i = 1 To 4
        For j = 1 To UBound(result(1))
            For k = 1 To UBound(result(1), 2)
                Debug.Print Format(result(i)(j, k), "0.#####"),
            Next k
            Debug.Print
        Next j
        Debug.Print
    Next i
End Sub



Fortran: program lu1
  implicit none
  call check( reshape([real(8)::1,2,1,3,4,1,5,7,0                  ],[3,3]) )
  call check( reshape([real(8)::11,1,3,2,9,5,17,5,24,2,18,7,2,6,1,1],[4,4]) )
 
contains
 
  subroutine check(a)
    real(8), intent(in)   :: a(:,:)
    integer               :: i,j,n
    real(8), allocatable  :: aa(:,:),l(:,:),u(:,:)
    integer, allocatable  :: p(:,:)
    integer, allocatable  :: ipiv(:)
    n = size(a,1)
    allocate(aa(n,n),l(n,n),u(n,n),p(n,n),ipiv(n))
    forall (j=1:n,i=1:n)
      aa(i,j) = a(i,j)
      u (i,j) = 0d0
      p (i,j) = merge(1  ,0  ,i.eq.j)
      l (i,j) = merge(1d0,0d0,i.eq.j)
    end forall
    call lu(aa, ipiv)
    do i = 1,n
       l(i, :i-1) = aa(i, :i-1)
       u(i,i:   ) = aa(i,i:   )
    end do
    p(ipiv,:) = p
    call mat_print('a',a)
    call mat_print('p',p)
    call mat_print('l',l)
    call mat_print('u',u)
    print *, "residual"
    print *, "|| P.A - L.U || =  ", maxval(abs(matmul(p,a)-matmul(l,u)))
  end subroutine
 
  subroutine lu(a,p)

    real(8), intent(inout) :: a(:,:)
    integer, intent(out  ) :: p(:)
    integer                :: n, i,j,k,kmax
    n = size(a,1)
    p = [ ( i, i=1,n ) ]
    do k = 1,n-1
        kmax = maxloc(abs(a(p(k:),k)),1) + k-1
        if (kmax /= k ) then
            p([k, kmax]) = p([kmax, k])
            a([k, kmax],:) = a([kmax, k],:)
        end if
        a(k+1:,k) = a(k+1:,k) / a(k,k)
        forall (j=k+1:n) a(k+1:,j) = a(k+1:,j) - a(k,j)*a(k+1:,k)
    end do
  end subroutine

  subroutine mat_print(amsg,a)
    character(*), intent(in) :: amsg
    class    (*), intent(in) :: a(:,:)
    integer                  :: i
    print*,' '
    print*,amsg
    do i=1,size(a,1)
      select type (a)
        type is (real(8)) ; print'(100f8.2)',a(i,:)
        type is (integer) ; print'(100i8  )',a(i,:)
      end select
    end do
    print*,' '
  end subroutine

end program