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
|
module sum_m
private
public :: sum_t
requirement R(T, Tadd, Tzero)
type :: T; end type
function Tadd(x, y) result(z)
type(T), intent(in) :: x, y
type(T) :: z
end function
function Tzero() result(z)
type(T) :: z
end function
end requirement
template sum_t(T, Tadd, Tzero)
require :: R(T, Tadd, Tzero)
private
public :: sum_generic
contains
function sum_generic(x) result(r)
type(T), intent(in) :: x(:)
type(T) :: r
integer :: i
r = Tzero()
do i = 1, size(x)
r = Tadd(r, x(i))
end do
end function
end template
contains
real function real_add(x, y) result(z)
real, intent(in) :: x, y
z = x + y
end function
real function real_zero() result(z)
z = 0
end function
integer function int_add(x, y) result(z)
integer, intent(in) :: x, y
z = x + y
end function
integer function int_zero() result(z)
z = 0
end function
subroutine test_template()
instantiate sum_t(real, real_add, real_zero), only: sum_real => sum_generic
instantiate sum_t(integer, int_add, int_zero), only: sum_integer => sum_generic
real :: x(10)
integer :: y(10)
x = 1
print*, "The result is ", sum_real(x)
if (abs(sum_real(x) - 10.0) > 1e-5) error stop
y = 1
print*, "The result is ", sum_integer(a, b)
if (sum_integer(a, b) /= 10) error stop
end subroutine
end module
program sum
use sum_m, only: test_template
call test_template()
end program
|
