Error handling tests.

Author: loiseaujc

src/stdlib_linalg_matrix_functions.fypp

@@ -40,17 +40,20 @@ contains
 
         ! Deal with optional args.
         order_ = 10 ; if (present(order)) order_ = order
+        print *, "inside expm :", order_
 
         ! Problem's dimension.
         m = size(A, 1) ; n = size(A, 2)
 
         if (m /= n) then
-            err = linalg_state_type(this,LINALG_VALUE_ERROR,'Invalid matrix size A=',[m, n])
+            err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'Invalid matrix size A=',[m, n])
             call linalg_error_handling(err0, err)
+            return
         else if (order_ < 0) then
-            err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Order of Pade approximation &
+            err0 = linalg_state_type(this, LINALG_VALUE_ERROR, 'Order of Pade approximation &
                                     needs to be positive, order=', order_)
             call linalg_error_handling(err0, err)
+            return
         endif
 
         ! Compute the L-infinity norm.
@@ -100,11 +103,11 @@ contains
 
         ! Matrix squaring.
         block
-        ${rt}$ :: E_tmp(n, n)
-        do k = 1, s
-            E_tmp = E
-            call gemm("N", "N", n, n, n, one_${ri}$, E_tmp, n, E_tmp, n, zero_${ri}$, E, n)
-        enddo
+            ${rt}$ :: E_tmp(n, n)
+            do k = 1, s
+                E_tmp = E
+                call gemm("N", "N", n, n, n, one_${ri}$, E_tmp, n, E_tmp, n, zero_${ri}$, E, n)
+            enddo
         end block
         return
     contains

test/linalg/test_linalg_expm.fypp

@@ -5,6 +5,8 @@ module test_linalg_expm
     use testdrive, only: error_type, check, new_unittest, unittest_type
     use stdlib_linalg_constants
     use stdlib_linalg, only: expm, eye, mnorm
+    use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
+         LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
 
     implicit none (type,external)
 
@@ -21,6 +23,7 @@ module test_linalg_expm
 
         #: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
@@ -61,6 +64,39 @@ module test_linalg_expm
     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.
+        E = expm(A, order=-1, err=err)
+        ! Check result.
+        call check(error, err%error(), "Negative Pade order")
+        if (allocated(error)) return
+
+        ! Compute matrix exponential.
+        E = expm(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