first test program

Author: perazz

test/linalg/CMakeLists.txt

@@ -8,6 +8,7 @@ set(
   "test_linalg_inverse.fypp"
   "test_linalg_lstsq.fypp"
   "test_linalg_norm.fypp"
+  "test_linalg_mnorm.fypp"
   "test_linalg_determinant.fypp"
   "test_linalg_qr.fypp"
   "test_linalg_svd.fypp"
@@ -22,6 +23,7 @@ ADDTEST(linalg_eigenvalues)
 ADDTEST(linalg_matrix_property_checks)
 ADDTEST(linalg_inverse)
 ADDTEST(linalg_norm)
+ADDTEST(linalg_mnorm)
 ADDTEST(linalg_solve)
 ADDTEST(linalg_lstsq)
 ADDTEST(linalg_qr)

test/linalg/test_linalg_mnorm.fypp

@@ -0,0 +1,122 @@
+#:include "common.fypp"
+#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
+module test_linalg_mnorm
+    use testdrive, only: error_type, check, new_unittest, unittest_type
+    use stdlib_linalg_constants
+    use stdlib_linalg, only: mnorm, linalg_state_type
+    use stdlib_linalg_state, only: linalg_state_type
+
+    implicit none (type,external)
+
+    contains
+
+    !> Matrix norm tests
+    subroutine test_matrix_norms(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("test_matrix_norms_${ri}$",test_matrix_norms_${ri}$)]
+        #:endfor
+        
+    end subroutine test_matrix_norms
+    
+    #:for rk,rt,ri in RC_KINDS_TYPES
+    !> Test 1-norm, 2-norm (Euclidean), and infinity norm for ${rt}$ matrices
+    subroutine test_matrix_norms_${ri}$(error)
+        type(error_type), allocatable, intent(out) :: error
+        
+        integer(ilp) :: i,j,m,n
+        integer(ilp), parameter :: mtx_dim = 5
+        real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
+        ${rt}$, allocatable :: A(:,:)
+        type(linalg_state_type) :: err
+        character(64) :: msg
+
+        allocate(A(mtx_dim,mtx_dim))
+
+        ! Initialize matrix with small values to avoid overflow
+        A = reshape([(0.01_${rk}$*(i-mtx_dim/2_ilp), i=1_ilp,mtx_dim*mtx_dim)], [mtx_dim,mtx_dim])
+
+        ! 1-norm (Maximum absolute column sum)
+        call check(error, abs(mnorm(A, '1', err) - maxval(sum(abs(A), dim=1),1)) < tol*mnorm(A, '1', err), &
+                   'Matrix 1-norm does not match expected value')
+        if (allocated(error)) return
+
+        ! 2-norm (Frobenius norm)
+        call check(error, abs(mnorm(A, '2', err) - sqrt(sum(A**2)) < tol*mnorm(A, '2', err), &
+                   'Matrix Frobenius norm does not match expected value')
+        if (allocated(error)) return
+
+        ! Inf-norm (Maximum absolute row sum)
+        call check(error, abs(mnorm(A, 'Inf', err) -  maxval(sum(abs(A), dim=2),1)) < tol*mnorm(A, 'Inf', err), &
+                   'Matrix Infinity norm does not match expected value')
+        if (allocated(error)) return
+
+    end subroutine test_matrix_norms_${ri}$
+    
+    #:for rank in range(3, MAXRANK)
+    !> Test N-D norms
+    subroutine test_mnorm_${ri}$_${rank}$d(error)
+        type(error_type), allocatable, intent(out) :: error
+
+        integer(ilp) :: j,dim(2)
+        integer(ilp), parameter :: ndim = ${rank}$
+        integer(ilp), parameter :: n   = 2_ilp**ndim
+        real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
+        ${rt}$, allocatable :: a(:), b${ranksuffix(rank)}$
+        
+        character(64) :: msg
+        
+        allocate(a(n), b${fixedranksuffix(rank,2)}$)
+        
+        ! Init as a range,but with small elements such that all power norms will 
+        ! never overflow, even in single precision
+        a = [(0.01_${rk}$*(j-n/2_ilp), j=1_ilp,n)]        
+        b = reshape(a, shape(b))
+        
+        
+        
+        ! Test norm as collapsed around dimension
+        do dim = 1, ndim
+            write(msg,"('Not all dim=',i0,' Euclidean norms match ${rt}$ `norm2` intrinsic')") dim
+            call check(error,all(abs(mnorm(b,2,dim)-norm2(b,dim))<tol*max(1.0_${rk}$,norm(b,2,dim))),&
+                       trim(msg)) 
+            if (allocated(error)) return             
+        end do
+        
+    end subroutine test_mnorm_${ri}$_${rank}$d
+    #:endif    
+    
+    
+    #:endfor
+
+end module test_linalg_mnorm
+
+program test_mnorm
+    use, intrinsic :: iso_fortran_env, only : error_unit
+    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
+    use test_linalg_mnorm, only : test_matrix_norms
+    implicit none
+    integer :: stat, is
+    type(testsuite_type), allocatable :: testsuites(:)
+    character(len=*), parameter :: fmt = '("#", *(1x, a))'
+
+    stat = 0
+
+    testsuites = [ &
+        new_testsuite("matrix_norms", test_matrix_norms) &
+        ]
+
+    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_mnorm