Skip to content

Commit 33b4df2

Browse files
awvwgkawvwgk
committed
Rewrite tests for quadrature modules
1 parent adc86dd commit 33b4df2

File tree

3 files changed

+445
-235
lines changed

3 files changed

+445
-235
lines changed

‎src/tests/quadrature/test_gauss.f90

Lines changed: 124 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,34 @@
1-
program test_gauss_
1+
module test_gauss
22
use stdlib_kinds, only: dp
3-
use stdlib_error, only: check
3+
use stdlib_test, only : new_unittest, unittest_type, error_type, check
44
use stdlib_quadrature , only: gauss_legendre, gauss_legendre_lobatto
55

66
implicit none
77

8-
call test_gauss
9-
call test_gauss_lobatto
108

119
contains
1210

13-
subroutine test_gauss
11+
!> Collect all exported unit tests
12+
subroutine collect_gauss(testsuite)
13+
!> Collection of tests
14+
type(unittest_type), allocatable, intent(out) :: testsuite(:)
15+
16+
testsuite = [ &
17+
new_unittest("gauss-analytic", test_gauss_analytic), &
18+
new_unittest("gauss-5", test_gauss_5), &
19+
new_unittest("gauss-32", test_gauss_32), &
20+
new_unittest("gauss-64", test_gauss_64), &
21+
new_unittest("gauss-lobatto-analytic", test_gauss_lobatto_analytic), &
22+
new_unittest("gauss-lobatto-5", test_gauss_lobatto_5), &
23+
new_unittest("gauss-lobatto-32", test_gauss_lobatto_32), &
24+
new_unittest("gauss-lobatto-64", test_gauss_lobatto_64) &
25+
]
26+
end subroutine
27+
28+
subroutine test_gauss_analytic(error)
29+
!> Error handling
30+
type(error_type), allocatable, intent(out) :: error
31+
1432
integer :: i
1533
real(dp) :: analytic, numeric
1634

@@ -23,10 +41,19 @@ subroutine test_gauss
2341
call gauss_legendre(x,w)
2442
numeric = sum(x**2 * w)
2543
!print *, i, numeric
26-
call check(abs(numeric-analytic) < 2*epsilon(analytic))
44+
call check(error, abs(numeric-analytic) < 2*epsilon(analytic))
45+
if (allocated(error)) return
2746
end block
2847
end do
2948

49+
end subroutine
50+
51+
subroutine test_gauss_5(error)
52+
!> Error handling
53+
type(error_type), allocatable, intent(out) :: error
54+
55+
integer :: i
56+
3057
! test the values of nodes and weights
3158
i = 5
3259
block
@@ -44,10 +71,19 @@ subroutine test_gauss
4471
wref(4)=0.47862867049936647_dp
4572
wref(5)=0.23692688505618909_dp
4673

47-
call check (all(abs(x-xref) < 2*epsilon(x(1))))
48-
call check (all(abs(w-wref) < 2*epsilon(w(1))))
74+
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
75+
if (allocated(error)) return
76+
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
4977
end block
5078

79+
end subroutine
80+
81+
subroutine test_gauss_32(error)
82+
!> Error handling
83+
type(error_type), allocatable, intent(out) :: error
84+
85+
integer :: i
86+
5187
i = 32
5288
block
5389
real(dp), dimension(i) :: x,w,xref,wref
@@ -120,10 +156,19 @@ subroutine test_gauss
120156
wref(31)=0.016274394730905671_dp
121157
wref(32)=0.0070186100094700966_dp
122158

123-
call check (all(abs(x-xref) < 2*epsilon(x(1))))
124-
call check (all(abs(w-wref) < 2*epsilon(w(1))))
159+
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
160+
if (allocated(error)) return
161+
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
125162
end block
126163

164+
end subroutine
165+
166+
subroutine test_gauss_64(error)
167+
!> Error handling
168+
type(error_type), allocatable, intent(out) :: error
169+
170+
integer :: i
171+
127172

128173
i = 64
129174
block
@@ -262,15 +307,19 @@ subroutine test_gauss
262307
wref(63)=0.0041470332605624676_dp
263308
wref(64)=0.0017832807216964329_dp
264309

265-
call check (all(abs(x-xref) < 2*epsilon(x(1))))
266-
call check (all(abs(w-wref) < 2*epsilon(w(1))))
310+
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
311+
if (allocated(error)) return
312+
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
267313
end block
268314

269315

270316

271317
end subroutine
272318

273-
subroutine test_gauss_lobatto
319+
subroutine test_gauss_lobatto_analytic(error)
320+
!> Error handling
321+
type(error_type), allocatable, intent(out) :: error
322+
274323
integer :: i
275324
real(dp) :: analytic, numeric
276325

@@ -283,10 +332,19 @@ subroutine test_gauss_lobatto
283332
call gauss_legendre_lobatto(x,w)
284333
numeric = sum(x**2 * w)
285334
!print *, i, numeric
286-
call check(abs(numeric-analytic) < 2*epsilon(analytic))
335+
call check(error, abs(numeric-analytic) < 2*epsilon(analytic))
336+
if (allocated(error)) return
287337
end block
288338
end do
289339

340+
end subroutine
341+
342+
subroutine test_gauss_lobatto_5(error)
343+
!> Error handling
344+
type(error_type), allocatable, intent(out) :: error
345+
346+
integer :: i
347+
290348

291349
! test the values of nodes and weights
292350
i = 5
@@ -308,10 +366,19 @@ subroutine test_gauss_lobatto
308366
wref(5)=0.10000000000000000_dp
309367

310368

311-
call check (all(abs(x-xref) < 2*epsilon(x(1))))
312-
call check (all(abs(w-wref) < 2*epsilon(w(1))))
369+
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
370+
if (allocated(error)) return
371+
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
313372
end block
314373

374+
end subroutine
375+
376+
subroutine test_gauss_lobatto_32(error)
377+
!> Error handling
378+
type(error_type), allocatable, intent(out) :: error
379+
380+
integer :: i
381+
315382
i = 32
316383
block
317384
real(dp), dimension(i) :: x,w,xref,wref
@@ -383,10 +450,19 @@ subroutine test_gauss_lobatto
383450
wref(31)=0.012398106501373844_dp
384451
wref(32)=0.0020161290322580645_dp
385452

386-
call check (all(abs(x-xref) < 2*epsilon(x(1))))
387-
call check (all(abs(w-wref) < 2*epsilon(w(1))))
453+
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
454+
if (allocated(error)) return
455+
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
388456
end block
389457

458+
end subroutine
459+
460+
subroutine test_gauss_lobatto_64(error)
461+
!> Error handling
462+
type(error_type), allocatable, intent(out) :: error
463+
464+
integer :: i
465+
390466

391467
i = 64
392468
block
@@ -524,10 +600,38 @@ subroutine test_gauss_lobatto
524600
wref(63)=0.0030560082449124904_dp
525601
wref(64)=0.00049603174603174603_dp
526602

527-
call check (all(abs(x-xref) < 2*epsilon(x(1))))
528-
call check (all(abs(w-wref) < 2*epsilon(w(1))))
603+
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
604+
if (allocated(error)) return
605+
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
529606
end block
530607

531608
end subroutine
532609

610+
end module
611+
612+
613+
program tester
614+
use, intrinsic :: iso_fortran_env, only : error_unit
615+
use stdlib_test, only : run_testsuite, new_testsuite, testsuite_type
616+
use test_gauss, only : collect_gauss
617+
implicit none
618+
integer :: stat, is
619+
type(testsuite_type), allocatable :: testsuites(:)
620+
character(len=*), parameter :: fmt = '("#", *(1x, a))'
621+
622+
stat = 0
623+
624+
testsuites = [ &
625+
new_testsuite("gauss", collect_gauss) &
626+
]
627+
628+
do is = 1, size(testsuites)
629+
write(error_unit, fmt) "Testing:", testsuites(is)%name
630+
call run_testsuite(testsuites(is)%collect, error_unit, stat)
631+
end do
632+
633+
if (stat > 0) then
634+
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
635+
error stop
636+
end if
533637
end program

0 commit comments

Comments
 (0)