From 40765adbd8ec5783c2a311dbf3d104d4270cce09 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Mon, 15 Jul 2024 00:15:09 +0200 Subject: [PATCH] fix test svd (related to signs of singular values) --- test/linalg/test_linalg_svd.fypp | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/test/linalg/test_linalg_svd.fypp b/test/linalg/test_linalg_svd.fypp index d5a01d123..fdb5d5a0e 100644 --- a/test/linalg/test_linalg_svd.fypp +++ b/test/linalg/test_linalg_svd.fypp @@ -93,7 +93,7 @@ module test_linalg_svd if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(u-u_sol)<=tol) .or. all(abs(u+u_sol)<=tol), test//': U') + call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U') if (allocated(error)) return !> [S, U]. Overwrite A matrix @@ -104,7 +104,7 @@ module test_linalg_svd if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(u-u_sol)<=tol) .or. all(abs(u+u_sol)<=tol), test//': U') + call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U') if (allocated(error)) return !> [S, U, V^T] @@ -116,9 +116,9 @@ module test_linalg_svd if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(u-u_sol)<=tol) .or. all(abs(u+u_sol)<=tol), test//': U') + call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U') if (allocated(error)) return - call check(error, all(abs(vt-vt_sol)<=tol) .or. all(abs(vt+vt_sol)<=tol), test//': V^T') + call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T') if (allocated(error)) return !> [S, V^T]. Do not overwrite A matrix @@ -130,7 +130,7 @@ module test_linalg_svd if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(vt-vt_sol)<=tol) .or. all(abs(vt+vt_sol)<=tol), test//': V^T') + call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T') if (allocated(error)) return !> [S, V^T]. Overwrite A matrix @@ -141,7 +141,7 @@ module test_linalg_svd if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(vt-vt_sol)<=tol) .or. all(abs(vt+vt_sol)<=tol), test//': V^T') + call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T') if (allocated(error)) return !> [U, S, V^T]. @@ -151,11 +151,11 @@ module test_linalg_svd test = '[U, S, V^T]' call check(error,state%ok(),test//': '//state%print()) if (allocated(error)) return - call check(error, all(abs(u-u_sol)<=tol) .or. all(abs(u+u_sol)<=tol), test//': U') + call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U') if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(vt-vt_sol)<=tol) .or. all(abs(vt+vt_sol)<=tol), test//': V^T') + call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T') if (allocated(error)) return !> [U, S, V^T]. Partial storage -> compare until k=2 columns of U rows of V^T @@ -167,11 +167,11 @@ module test_linalg_svd test = '[U, S, V^T], partial storage' call check(error,state%ok(),test//': '//state%print()) if (allocated(error)) return - call check(error, all(abs(u(:,:2)-u_sol(:,:2))<=tol) .or. all(abs(u(:,:2)+u_sol(:,:2))<=tol), test//': U(:,:2)') + call check(error, all(abs(abs(u(:,:2))-abs(u_sol(:,:2)))<=tol), test//': U(:,:2)') if (allocated(error)) return call check(error, all(abs(s-s_sol)<=tol), test//': S') if (allocated(error)) return - call check(error, all(abs(vt(:2,:)-vt_sol(:2,:))<=tol) .or. all(abs(vt(:2,:)+vt_sol(:2,:))<=tol), test//': V^T(:2,:)') + call check(error, all(abs(abs(vt(:2,:))-abs(vt_sol(:2,:)))<=tol), test//': V^T(:2,:)') if (allocated(error)) return end subroutine test_svd_${ri}$