diff --git a/doc/specs/stdlib_linalg.md b/doc/specs/stdlib_linalg.md index 8f1fe2e47..a56cbc16c 100644 --- a/doc/specs/stdlib_linalg.md +++ b/doc/specs/stdlib_linalg.md @@ -1884,3 +1884,38 @@ If `err` is not present, exceptions trigger an `error stop`. {!example/linalg/example_mnorm.f90!} ``` +## `expm` - Computes the matrix exponential {#expm} + +### Status + +Experimental + +### Description + +Given a matrix \(A\), this function compute its matrix exponential \(E = \exp(A)\) using a Pade approximation. + +### Syntax + +`E = ` [[stdlib_linalg(module):expm(interface)]] `(a [, order, err])` + +### Arguments + +`a`: Shall be a rank-2 `real` or `complex` array containing the data. It is an `intent(in)` argument. + +`order` (optional): Shall be a non-negative `integer` value specifying the order of the Pade approximation. By default `order=10`. It is an `intent(in)` argument. + +`err` (optional): Shall be a `type(linalg_state_type)` value. This is an `intent(out)` argument. + +### Return value + +The returned array `E` contains the Pade approximation of \(\exp(A)\). + +If `A` is non-square or `order` is negative, it raise a `LINALG_VALUE_ERROR`. +If `err` is not present, exceptions trigger an `error stop`. + +### Example + +```fortran +{!example/linalg/example_expm.f90!} +``` + diff --git a/example/linalg/CMakeLists.txt b/example/linalg/CMakeLists.txt index 10f982a02..693fb0308 100644 --- a/example/linalg/CMakeLists.txt +++ b/example/linalg/CMakeLists.txt @@ -52,3 +52,4 @@ ADD_EXAMPLE(qr) ADD_EXAMPLE(qr_space) ADD_EXAMPLE(cholesky) ADD_EXAMPLE(chol) +ADD_EXAMPLE(expm) diff --git a/example/linalg/example_expm.f90 b/example/linalg/example_expm.f90 new file mode 100644 index 000000000..492b20323 --- /dev/null +++ b/example/linalg/example_expm.f90 @@ -0,0 +1,7 @@ +program example_expm + use stdlib_linalg, only: expm + implicit none + real :: A(3, 3), E(3, 3) + A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3]) + E = expm(A) +end program example_expm diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index c3cd99120..763e9a3ba 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -32,16 +32,17 @@ set(fppFiles stdlib_linalg_kronecker.fypp stdlib_linalg_cross_product.fypp stdlib_linalg_eigenvalues.fypp - stdlib_linalg_solve.fypp + stdlib_linalg_solve.fypp stdlib_linalg_determinant.fypp stdlib_linalg_qr.fypp stdlib_linalg_inverse.fypp stdlib_linalg_pinv.fypp stdlib_linalg_norms.fypp stdlib_linalg_state.fypp - stdlib_linalg_svd.fypp + stdlib_linalg_svd.fypp stdlib_linalg_cholesky.fypp stdlib_linalg_schur.fypp + stdlib_linalg_matrix_functions.fypp stdlib_optval.fypp stdlib_selection.fypp stdlib_sorting.fypp diff --git a/src/stdlib_constants.fypp b/src/stdlib_constants.fypp index 019d20141..8eef2ec10 100644 --- a/src/stdlib_constants.fypp +++ b/src/stdlib_constants.fypp @@ -71,6 +71,7 @@ module stdlib_constants #:for k, t, s in R_KINDS_TYPES ${t}$, parameter, public :: zero_${s}$ = 0._${k}$ ${t}$, parameter, public :: one_${s}$ = 1._${k}$ + ${t}$, parameter, public :: log2_${s}$ = log(2.0_${k}$) #:endfor #:for k, t, s in C_KINDS_TYPES ${t}$, parameter, public :: zero_${s}$ = (0._${k}$,0._${k}$) diff --git a/src/stdlib_linalg.fypp b/src/stdlib_linalg.fypp index c33668839..a757d59b5 100644 --- a/src/stdlib_linalg.fypp +++ b/src/stdlib_linalg.fypp @@ -28,6 +28,7 @@ module stdlib_linalg public :: eigh public :: eigvals public :: eigvalsh + public :: expm, matrix_exp public :: eye public :: inv public :: invert @@ -1678,6 +1679,108 @@ module stdlib_linalg #:endfor end interface mnorm + !> Matrix exponential: function interface + interface expm + !! version : experimental + !! + !! Computes the exponential of a matrix using a rational Pade approximation. + !! ([Specification](../page/specs/stdlib_linalg.html#expm)) + !! + !! ### Description + !! + !! This interface provides methods for computing the exponential of a matrix + !! represented as a standard Fortran rank-2 array. Supported data types include + !! `real` and `complex`. + !! + !! By default, the order of the Pade approximation is set to 10. It can be changed + !! via the `order` argument which must be non-negative. + !! + !! If the input matrix is non-square or the order of the Pade approximation is + !! negative, the function returns an error state. + !! + !! ### Example + !! + !! ```fortran + !! real(dp) :: A(3, 3), E(3, 3) + !! + !! A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3]) + !! + !! ! Default Pade approximation of the matrix exponential. + !! E = expm(A) + !! + !! ! Pade approximation with specified order. + !! E = expm(A, order=12) + !! ``` + !! + #:for rk,rt,ri in RC_KINDS_TYPES + module function stdlib_linalg_${ri}$_expm_fun(A, order) result(E) + !> Input matrix a(n, n). + ${rt}$, intent(in) :: A(:, :) + !> [optional] Order of the Pade approximation (default `order=10`) + integer(ilp), optional, intent(in) :: order + !> Exponential of the input matrix E = exp(A). + ${rt}$, allocatable :: E(:, :) + end function stdlib_linalg_${ri}$_expm_fun + #:endfor + end interface expm + + !> Matrix exponential: subroutine interface + interface matrix_exp + !! version : experimental + !! + !! Computes the exponential of a matrix using a rational Pade approximation. + !! ([Specification](../page/specs/stdlib_linalg.html#matrix_exp)) + !! + !! ### Description + !! + !! This interface provides methods for computing the exponential of a matrix + !! represented as a standard Fortran rank-2 array. Supported data types include + !! `real` and `complex`. + !! + !! By default, the order of the Pade approximation is set to 10. It can be changed + !! via the `order` argument which must be non-negative. + !! + !! If the input matrix is non-square or the order of the Pade approximation is + !! negative, the function returns an error state. + !! + !! ### Example + !! + !! ```fortran + !! real(dp) :: A(3, 3), E(3, 3) + !! + !! A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3]) + !! + !! ! Default Pade approximation of the matrix exponential. + !! call matrix_exp(A, E) ! Out-of-place + !! ! call matrix_exp(A) for in-place computation. + !! + !! ! Pade approximation with specified order. + !! call matrix_exp(A, E, order=12) + !! ``` + !! + #:for rk,rt,ri in RC_KINDS_TYPES + module subroutine stdlib_linalg_${ri}$_expm_inplace(A, order, err) + !> Input matrix A(n, n) / Output matrix E = exp(A) + ${rt}$, intent(inout) :: A(:, :) + !> [optional] Order of the Pade approximation (default `order=10`) + integer(ilp), optional, intent(in) :: order + !> [optional] Error handling. + type(linalg_state_type), optional, intent(out) :: err + end subroutine stdlib_linalg_${ri}$_expm_inplace + + module subroutine stdlib_linalg_${ri}$_expm(A, E, order, err) + !> Input matrix A(n, n) + ${rt}$, intent(in) :: A(:, :) + !> Output matrix exponential E = exp(A) + ${rt}$, intent(out) :: E(:, :) + !> [optional] Order of the Pade approximation (default `order=10`) + integer(ilp), optional, intent(in) :: order + !> [optional] Error handling. + type(linalg_state_type), optional, intent(out) :: err + end subroutine stdlib_linalg_${ri}$_expm + #:endfor + end interface matrix_exp + contains diff --git a/src/stdlib_linalg_matrix_functions.fypp b/src/stdlib_linalg_matrix_functions.fypp new file mode 100644 index 000000000..bb7be9601 --- /dev/null +++ b/src/stdlib_linalg_matrix_functions.fypp @@ -0,0 +1,159 @@ +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +submodule (stdlib_linalg) stdlib_linalg_matrix_functions + use stdlib_constants + use stdlib_linalg_constants + use stdlib_linalg_blas, only: gemm + use stdlib_linalg_lapack, only: gesv + use stdlib_linalg_lapack_aux, only: handle_gesv_info + use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, & + LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR + implicit none + + character(len=*), parameter :: this = "matrix_exponential" + +contains + + #:for rk,rt,ri in RC_KINDS_TYPES + module function stdlib_linalg_${ri}$_expm_fun(A, order) result(E) + !> Input matrix A(n, n). + ${rt}$, intent(in) :: A(:, :) + !> [optional] Order of the Pade approximation. + integer(ilp), optional, intent(in) :: order + !> Exponential of the input matrix E = exp(A). + ${rt}$, allocatable :: E(:, :) + + E = A ; call stdlib_linalg_${ri}$_expm_inplace(E, order) + end function + + module subroutine stdlib_linalg_${ri}$_expm(A, E, order, err) + !> Input matrix A(n, n). + ${rt}$, intent(in) :: A(:, :) + !> [optional] Order of the Pade approximation. + integer(ilp), optional, intent(in) :: order + !> [optional] State return flag. + type(linalg_state_type), optional, intent(out) :: err + !> Exponential of the input matrix E = exp(A). + ${rt}$, intent(out) :: E(:, :) + + type(linalg_state_type) :: err0 + integer(ilp) :: lda, n, lde, ne + + ! Check E sizes + lda = size(A, 1, kind=ilp) ; n = size(A, 2, kind=ilp) + lde = size(E, 1, kind=ilp) ; ne = size(E, 2, kind=ilp) + + if (lda<1 .or. n<1 .or. lda .F90 @@ -41,4 +42,5 @@ ADDTEST(linalg_qr) ADDTEST(linalg_schur) ADDTEST(linalg_svd) ADDTEST(linalg_sparse) -ADDTESTPP(blas_lapack) +ADDTEST(linalg_expm) +ADDTESTPP(blas_lapack) \ No newline at end of file diff --git a/test/linalg/test_linalg_expm.fypp b/test/linalg/test_linalg_expm.fypp new file mode 100644 index 000000000..06dc848fe --- /dev/null +++ b/test/linalg/test_linalg_expm.fypp @@ -0,0 +1,137 @@ +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +! Test Schur decomposition +module test_linalg_expm + use testdrive, only: error_type, check, new_unittest, unittest_type + use stdlib_linalg_constants + use stdlib_linalg, only: expm, eye, norm, matrix_exp + use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, & + LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR + + implicit none (type,external) + + public :: test_expm_computation + + contains + + !> schur decomposition tests + subroutine test_expm_computation(tests) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: tests(:) + + allocate(tests(0)) + + #:for rk,rt,ri in RC_KINDS_TYPES + tests = [tests, new_unittest("expm_${ri}$",test_expm_${ri}$)] + tests = [tests, new_unittest("Error-handling expm_${ri}$",test_error_handling_expm_${ri}$)] + #:endfor + + end subroutine test_expm_computation + + !> Matrix exponential with analytic expression. + #:for rk,rt,ri in RC_KINDS_TYPES + subroutine test_expm_${ri}$(error) + type(error_type), allocatable, intent(out) :: error + ! Problem dimension. + integer(ilp), parameter :: n = 5, m = 6 + ! Test matrix. + ${rt}$ :: A(n, n), E(n, n), Eref(n, n) + real(${rk}$) :: err + integer(ilp) :: i, j + + ! Initialize matrix. + A = 0.0_${rk}$ + do i = 1, n-1 + A(i, i+1) = m*1.0_${rk}$ + enddo + + ! Reference with analytical exponential. + Eref = eye(n, mold=1.0_${rk}$) + do i = 1, n-1 + do j = 1, n-i + Eref(i, i+j) = Eref(i, i+j-1)*m/j + enddo + enddo + + ! Compute matrix exponential. + E = expm(A) + + ! Check result. + err = norm(Eref - E, "inf") + call check(error, err < (n**2)*epsilon(1.0_${rk}$), "Analytical matrix exponential.") + if (allocated(error)) return + return + end subroutine test_expm_${ri}$ + #:endfor + + !> Test error handler. + #:for rk,rt,ri in RC_KINDS_TYPES + subroutine test_error_handling_expm_${ri}$(error) + type(error_type), allocatable, intent(out) :: error + ! Problem dimension. + integer(ilp), parameter :: n = 5, m = 6 + ! Test matrix. + ${rt}$ :: A(n, n), E(n, n) + type(linalg_state_type) :: err + integer(ilp) :: i + + ! Initialize matrix. + A = 0.0_${rk}$ + do i = 1, n-1 + A(i, i+1) = m*1.0_${rk}$ + enddo + + ! Compute matrix exponential. + call matrix_exp(A, E, order=-1, err=err) + ! Check result. + call check(error, err%error(), "Negative Pade order") + if (allocated(error)) return + + call matrix_exp(A, order=-1, err=err) + ! Check result. + call check(error, err%error(), "Negative Pade order") + if (allocated(error)) return + + ! Compute matrix exponential. + call matrix_exp(A, E(:n, :n-1), err=err) + ! Check result. + call check(error, err%error(), "Invalid matrix size") + if (allocated(error)) return + + ! Compute matrix exponential. + call matrix_exp(A(:n, :n-1), err=err) + ! Check result. + call check(error, err%error(), "Invalid matrix size") + if (allocated(error)) return + + return + end subroutine test_error_handling_expm_${ri}$ + #:endfor + +end module test_linalg_expm + +program test_expm + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_linalg_expm, only : test_expm_computation + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("linalg_expm", test_expm_computation) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program test_expm