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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
! vim: set ts=4 sw=4 et ft=fortran:
module rats
type rational
integer :: numerator
integer :: denominator
end type rational
type, extends(rational) :: printable_rational
contains
procedure, pass :: printme => rat_print
end type printable_rational
interface operator(+)
module procedure rat_add
end interface
interface operator(-)
module procedure rat_sub
end interface
interface operator (*)
module procedure rat_mul
end interface
interface operator(/)
module procedure rat_div
end interface
! Interface to allow implementation of rat_print in submodule
interface
module subroutine rat_print(self)
class(printable_rational), intent(inout) :: self
end subroutine rat_print
end interface
contains
integer function gcd(a, b)
integer, intent(in) :: a, b
integer :: j, k, t
j = a; k = b
do while (k /= 0)
t = mod(j, k)
j = k
k = t
end do
gcd = a
end function gcd
integer function lcm(a, b)
integer, intent(in) :: a, b
lcm = abs(a * b) / gcd(a, b)
end function lcm
type(rational) function rat_normalize(q)
type(rational), intent(in) :: q
integer :: n
n = gcd(abs(q%numerator), abs(q%denominator))
rat_normalize%numerator = sign(q%numerator / n, sign(1, q%numerator) * sign(1, q%denominator))
rat_normalize%denominator = q%denominator / n
end function rat_normalize
integer function rat_numerator(q)
type(rational), intent(in) :: q
rat_numerator = q%numerator
end function rat_numerator
integer function rat_denominator(q)
type(rational), intent(in) :: q
rat_denominator =q%denominator
end function rat_denominator
type(rational) function rat_add(r, q)
type(rational), intent(in) :: r, q
integer :: n
n = lcm(r%denominator, q%denominator)
rat_add%numerator = (n / r%denominator) * r%numerator + (n / q%denominator) * q%numerator
rat_add%denominator = n
rat_add = rat_normalize(rat_add)
end function rat_add
type(rational) function rat_sub(r, q)
type(rational), intent(in) :: r, q
rat_sub = r + rational(- q%numerator, q%denominator)
end function rat_sub
type(rational) function rat_mul(r, q)
type(rational), intent(in) :: r, q
rat_mul%numerator = r%numerator * q%numerator
rat_mul%denominator = r%denominator * q%denominator
rat_mul = rat_normalize(rat_mul)
end function rat_mul
type(rational) function rat_div(r, q)
type(rational), intent(in) :: r, q
rat_div = r * rational(q%denominator, q%numerator)
end function rat_div
end module rats
submodule (rats) rats_print_implementation
contains
module procedure rat_print
print '(I0, "/", I0)', self%numerator, self%denominator
end procedure rat_print
end submodule rats_print_implementation
program bottles
use rats
implicit none
character(len=*), parameter :: towels = 'Don''t Panic!'
integer :: nbottles = 99
type(rational) :: r = rational(1, 2), q = rational(1, 6)
type(printable_rational) :: p
do while (nbottles > 0)
call print_bottles(nbottles)
nbottles = nbottles - 1
end do
print *, towels
r = r - q
write(*, '(I0, "/", I0)') rat_numerator(r), rat_denominator(r)
p = printable_rational(r)
call p%printme()
contains
subroutine print_bottles(n)
implicit none
integer, intent(in) :: n
#if defined(VERBOSE)
select case (n)
case (2)
write(*, 100) n
write(*, 110) n
write(*, 120)
write(*, 230)
case (1)
write(*, 200)
write(*, 210)
write(*, 120)
write(*, 330)
case default
write(*, 100) n
write(*, 110) n
write(*, 120)
write(*, 130) n - 1
end select
100 format (I0, 1X, 'bottles of beer on the wall,')
110 format (I0, 1X, 'bottles of beer.')
120 format ('Take one down, pass it around,')
130 format (I0, 1X, 'bottles of beer on the wall.', /)
200 format ('One last bottle of beer on the wall,')
210 format ('one last bottle of beer.')
230 format ('one last bottle of beer on the wall.', /)
330 format ('no more bottles of beer on the wall.', /)
#endif
end subroutine print_bottles
subroutine share_bottles(n, m)
use, intrinsic :: ieee_arithmetic
implicit none
integer, intent(in) :: n, m
double precision :: double
doubleprecision :: another_double
if (m == 0) then
double = ieee_value(double, IEEE_QUIET_NAN)
error stop
else
double = real(n, kind(double)) / real(m, kind(another_double))
print '(A,F0.2,A)', 'Everyone gets ', double, ' bottles!'
endif
end subroutine share_bottles
end program bottles
|
