-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathmain.f90
93 lines (77 loc) · 4.25 KB
/
main.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
! Forsynth: a multitracks stereo sound synthesis project
! License GPL-3.0-or-later
! Vincent Magnin
! Last modification: 2025-03-13
program main
use, intrinsic :: ieee_arithmetic, only: ieee_is_nan
use forsynth, only: wp, test_the_machine
use signals, only: weierstrass
use morse_code
use acoustics, only: dB_to_linear, linear_to_dB
use envelopes, only: fit_exp, ADSR_envelope
use music, only: fr
implicit none
! 2.2204460492503131E-016 with real64:
real(wp), parameter :: tol = 10*epsilon(1._wp)
! Test the available KIND:
call test_the_machine()
!************************************************
if (weierstrass(0.5_wp, 2.05_wp, 0._wp) /= +2._wp) error stop "ERROR weierstrass() [1]"
!************************************************
if (string_to_morse("RADIOACTIVITY") /= ".-. .- -.. .. --- .- -.-. - .. ...- .. - -.--") &
& error stop "ERROR string_to_morse() [1]"
if (string_to_morse("DISCOVERED BY MADAME CURIE") /= &
& "-.. .. ... -.-. --- ...- . .-. . -.. -... -.-- -- .- -.. .- -- . -.-. ..- .-. .. .") &
& error stop "ERROR string_to_morse() [2]"
!************************************************
call assert_reals_equal(dB_to_linear( 0._wp), 1.0_wp, tolerance=tol)
call assert_reals_equal(dB_to_linear(-06._wp), 0.50118_wp, tolerance=1e-4_wp)
call assert_reals_equal(dB_to_linear(-20._wp), 0.1_wp, tolerance=tol)
call assert_reals_equal(dB_to_linear(+20._wp), 10._wp, tolerance=tol)
!************************************************
call assert_reals_equal(linear_to_dB(1.0_wp), 0._wp, tolerance=tol)
call assert_reals_equal(linear_to_dB(0.50118_wp), -06._wp ,tolerance=1e-4_wp)
call assert_reals_equal(linear_to_dB(0.1_wp), -20._wp, tolerance=tol)
call assert_reals_equal(linear_to_dB(10._wp), +20._wp ,tolerance=tol)
!************************************************
call assert_reals_equal(fit_exp(-1._wp, x1=0._wp, y1=1._wp, x2=1._wp, y2=exp(1._wp)), &
& exp(-1._wp), tolerance=tol)
call assert_reals_equal(fit_exp(0._wp, x1=-1._wp, y1=exp(-1._wp), x2=+1._wp, y2=exp(+1._wp)), &
& 1._wp, tolerance=tol)
!************************************************
call assert_reals_equal(fr("A4"), 440.0_wp, tolerance=tol)
call assert_reals_equal(fr("A3"), 220.0_wp, tolerance=tol)
call assert_reals_equal(fr("A5"), 880.0_wp, tolerance=tol)
call assert_reals_equal(fr("G4"), 440.0_wp*2**(-2/12._wp), tolerance=tol)
call assert_reals_equal(fr("F#4"), 440.0_wp*2**(-3/12._wp), tolerance=tol)
call assert_reals_equal(fr("Fb4"), 440.0_wp*2**(-5/12._wp), tolerance=tol)
!************************************************
block
type(ADSR_envelope) :: env
call env%new(A=30._wp, D=20._wp, S=80._wp, R=30._wp)
call assert_reals_equal(env%get_level(t=0._wp, t1=0._wp, t2=100._wp), 0._wp, tolerance=tol)
call assert_reals_equal(env%get_level(t=100._wp,t1=0._wp, t2=100._wp), 0._wp, tolerance=tol)
call assert_reals_equal(env%get_level(t=30._wp, t1=0._wp, t2=100._wp), 1._wp, tolerance=tol)
call assert_reals_equal(env%get_level(t=15._wp, t1=0._wp, t2=100._wp), 0.5_wp, tolerance=tol)
call assert_reals_equal(env%get_level(t=40._wp, t1=0._wp, t2=100._wp), 0.9_wp, tolerance=tol)
call assert_reals_equal(env%get_level(t=60._wp, t1=0._wp, t2=100._wp), 0.8_wp, tolerance=tol)
call assert_reals_equal(env%get_level(t=85._wp, t1=0._wp, t2=100._wp), 0.4_wp, tolerance=tol)
end block
contains
! A routine testing if a=b within the given tolerance.
subroutine assert_reals_equal(a, b, tolerance)
real(wp), intent(in) :: a, b, tolerance
real(wp) :: r
character(len=*), parameter :: FORMATER = '(a,es22.15,a,es22.15,a,es8.1,a)'
if (b /= 0.0_wp) then
r = abs((a - b)/b)
else
r = abs(a - b)
end if
! Note that the -Ofast compiler option is disabling ieee_is_nan()
if (ieee_is_nan(a) .or. (r > tolerance)) then
print FORMATER, "*** bug *** ", b, " /= ", a, " ; r = ", r
error stop
end if
end subroutine assert_reals_equal
end program main