add tests

fortran-lang · Jul 3, 2024 · 6862209 · 6862209
1 parent 6e36e6b
commit 6862209
Show file tree

Hide file tree

Showing 3 changed files with 91 additions and 4 deletions.
diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt
@@ -10,6 +10,15 @@ macro(ADDTEST name)
              WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
 endmacro(ADDTEST)
 
+macro(ADDTESTPP name)
+    add_executable(test_${name} test_${name}.F90)
+    target_link_libraries(test_${name} "${PROJECT_NAME}" "test-drive::test-drive")
+    add_test(NAME ${name}
+             COMMAND $<TARGET_FILE:test_${name}> ${CMAKE_CURRENT_BINARY_DIR}
+             WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
+endmacro(ADDTESTPP)
+
+
 add_subdirectory(array)
 add_subdirectory(ascii)
 add_subdirectory(bitsets)
@@ -30,4 +39,4 @@ add_subdirectory(system)
 add_subdirectory(quadrature)
 add_subdirectory(math)
 add_subdirectory(stringlist)
-add_subdirectory(terminal)
+add_subdirectory(terminal)
diff --git a/test/linalg/CMakeLists.txt b/test/linalg/CMakeLists.txt
@@ -1,15 +1,22 @@
 set(
   fppFiles
   "test_linalg.fypp"
-  "test_blas_lapack.fypp"
   "test_linalg_eigenvalues.fypp"
   "test_linalg_solve.fypp"
   "test_linalg_lstsq.fypp"
   "test_linalg_determinant.fypp"
   "test_linalg_svd.fypp"
   "test_linalg_matrix_property_checks.fypp"
 )
+
+# Preprocessed files to contain preprocessor directives -> .F90
+set(
+  cppFiles
+  "test_blas_lapack.fypp"
+)
+
 fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
+fypp_f90pp("${fyppFlags}" "${cppFiles}" outPreprocFiles)
 
 ADDTEST(linalg)
 ADDTEST(linalg_determinant)
@@ -18,4 +25,4 @@ ADDTEST(linalg_matrix_property_checks)
 ADDTEST(linalg_solve)
 ADDTEST(linalg_lstsq)
 ADDTEST(linalg_svd)
-ADDTEST(blas_lapack)
+ADDTESTPP(blas_lapack)
diff --git a/test/linalg/test_blas_lapack.fypp b/test/linalg/test_blas_lapack.fypp
@@ -30,7 +30,9 @@ contains
             new_unittest("test_gemv${t1[0]}$${k1}$", test_gemv${t1[0]}$${k1}$), &
             new_unittest("test_getri${t1[0]}$${k1}$", test_getri${t1[0]}$${k1}$), &
   #:endfor
-            new_unittest("test_idamax", test_idamax) &
+            new_unittest("test_idamax", test_idamax), &
+            new_unittest("test_external_blas",external_blas_test), &
+            new_unittest("test_external_lapack",external_lapack_test) &
             ]
 
     end subroutine collect_blas_lapack
@@ -117,6 +119,75 @@ contains
 
     end subroutine test_idamax
 
+    !> Test availability of the external BLAS interface
+    subroutine external_blas_test(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+
+#ifdef STDLIB_EXTERNAL_BLAS           
+        interface 
+            subroutine saxpy(n,sa,sx,incx,sy,incy)
+                 import sp,ilp 
+                 implicit none(type,external) 
+                 real(sp), intent(in) :: sa,sx(*)
+                 integer(ilp), intent(in) :: incx,incy,n
+                 real(sp), intent(inout) :: sy(*)
+            end subroutine saxpy        
+        end interface
+
+        integer(ilp), parameter :: n = 5, inc=1
+        real(sp) :: a,x(n),y(n)
+
+        x = 1.0_sp
+        y = 2.0_sp
+        a = 3.0_sp
+
+        call saxpy(n,a,x,inc,y,inc)
+        call check(error, all(abs(y-5.0_sp)<sqrt(epsilon(0.0_sp))), "saxpy: check result")
+        if (allocated(error)) return
+
+#else
+        call skip_test(error, "Not using an external BLAS")
+#endif        
+
+    end subroutine external_blas_test        
+
+    !> Test availability of the external BLAS interface
+    subroutine external_lapack_test(error)
+        !> Error handling
+        type(error_type), allocatable, intent(out) :: error
+
+#ifdef STDLIB_EXTERNAL_LAPACK       
+        interface 
+           subroutine dgetrf( m, n, a, lda, ipiv, info )
+                import dp,ilp
+                implicit none(type,external) 
+                integer(ilp), intent(out) :: info,ipiv(*)
+                integer(ilp), intent(in) :: lda,m,n
+                real(dp), intent(inout) :: a(lda,*)
+           end subroutine dgetrf       
+        end interface
+
+        integer(ilp), parameter :: n = 3
+        real(dp) :: A(n,n)
+        integer(ilp) :: ipiv(n),info
+
+
+        A = eye(n)        
+        info = 123
+
+        ! Factorize matrix 
+        call dgetrf(n,n,A,n,ipiv,info)
+
+        call check(error, info==0, "dgetrf: check result")
+        if (allocated(error)) return
+
+#else
+        call skip_test(error, "Not using an external LAPACK")
+#endif        
+
+    end subroutine external_lapack_test                  
+
 end module test_blas_lapack