1module mod_list
2 implicit none
3 private
4
5 ! singly linked list
6 type :: list_type
7 type(list_type), pointer :: next
8 integer :: value
9 endtype list_type
10
11 interface append
12 module procedure append_scalar, append_array
13 endinterface append
14
15 interface insert
16 module procedure insert_scalar, insert_array
17 endinterface insert
18
19 interface assignment(=)
20 module procedure assign_scalar, assign_array
21 endinterface assignment(=)
22
23 public :: list_type
24 public :: new, delete, show, append, insert, remove
25 public :: assignment(=)
26
27contains
28
29 ! assignment (initialize list with a given value)
30 subroutine assign_scalar(a, b)
31 implicit none
32 type(list_type), pointer, intent(out) :: a
33 integer, intent(in) :: b
34
35 call delete(a)
36 call new(a, value=b)
37
38 endsubroutine assign_scalar
39
40 ! assignment (initialize list with a given ue)
41 subroutine assign_array(a, b)
42 implicit none
43 type(list_type), pointer, intent(out) :: a
44 integer, intent(in) :: b(:)
45
46 integer :: i
47
48 call delete(a)
49 call new(a, value=b(1))
50 do i = 2, size(b)
51 call append(a, b(i))
52 enddo
53
54 endsubroutine assign_array
55
56 ! show list contents
57 subroutine show(list)
58 implicit none
59 type(list_type), pointer, intent(in) :: list
60
61 type(list_type), pointer :: iter
62
63 write(*, fmt='("List = [")', advance='no')
64
65 if(associated(list)) then
66 ! show contents
67 iter => list
68 write(*, fmt='(i5, x)', advance='no') iter % value
69 do while(associated(iter % next))
70 iter => iter % next
71 write(*, fmt='(i5, x)', advance='no') iter % value
72 enddo
73 endif
74
75 write(*, fmt='(a)') ']'
76
77 endsubroutine show
78
79 ! create a new node (pointer must be initialized by nullify() in advance)
80 subroutine new(list, next, value)
81 implicit none
82 type(list_type), pointer, intent(out) :: list
83 type(list_type), pointer, optional, intent(in) :: next
84 integer, optional, intent(in) :: value
85
86 if(associated(list)) then
87 write(*, *) 'Error in new'
88 endif
89
90 allocate(list)
91 nullify(list % next)
92
93 if(present(next)) then
94 list % next => next
95 endif
96
97 if(present(value)) then
98 list % value = value
99 endif
100
101 endsubroutine new
102
103 ! safely delete all the list contents
104 subroutine delete(list)
105 implicit none
106 type(list_type), pointer, intent(inout) :: list
107
108 type(list_type), pointer :: iter, temp
109
110 if(.not. associated(list)) then
111 return
112 endif
113
114 iter => list
115 do while(associated(iter % next))
116 temp => iter
117 iter => iter % next
118 deallocate(temp)
119 enddo
120
121 nullify(list)
122
123 endsubroutine delete
124
125 ! return the last node
126 function tail(list) result(iter)
127 type(list_type), pointer, intent(in) :: list
128 type(list_type), pointer :: iter
129
130 iter => list
131 do while(associated(iter % next))
132 iter => iter % next
133 enddo
134
135 endfunction tail
136
137 ! append a single node at the last
138 subroutine append_scalar(list, value)
139 implicit none
140 type(list_type), pointer, intent(inout) :: list
141 integer, intent(in) :: value
142
143 type(list_type), pointer :: iter
144
145 iter => tail(list)
146 call new(iter % next, value=value)
147
148 endsubroutine append_scalar
149
150 ! append an array at the last
151 subroutine append_array(list, array)
152 implicit none
153 type(list_type), pointer, intent(inout) :: list
154 integer, intent(in) :: array(:)
155
156 integer :: i
157 type(list_type), pointer :: iter
158
159 iter => tail(list)
160 do i = 1, size(array)
161 call new(iter % next, value=array(i))
162 iter => iter % next
163 enddo
164
165 endsubroutine append_array
166
167 ! insert a node at a given index
168 subroutine insert_scalar(list, index, value)
169 implicit none
170 type(list_type), pointer, intent(inout) :: list
171 integer, intent(in) :: index
172 integer, intent(in) :: value
173
174 integer :: i
175 type(list_type), pointer :: iter, prev, node
176
177 if(index < 1) then
178 write(*, *) 'Error: no such node'
179 return
180 endif
181
182 ! find a node after which a new node is inserted
183 nullify(prev)
184 iter => list
185 do i = 1, index - 1
186 if(.not. associated(iter % next)) then
187 write(*, *) 'Error: no such node'
188 return
189 endif
190 prev => iter
191 iter => iter % next
192 enddo
193
194 ! create a new node
195 nullify(node)
196 call new(node, next=iter, value=value)
197
198 if(.not. associated(prev)) then ! first node
199 list => node
200 else
201 prev % next => node
202 endif
203
204 endsubroutine insert_scalar
205
206 ! insert an array at a given index
207 subroutine insert_array(list, index, array)
208 implicit none
209 type(list_type), pointer, intent(inout) :: list
210 integer, intent(in) :: index
211 integer, intent(in) :: array(:)
212
213 integer :: i
214 type(list_type), pointer :: iter, next, prev, temp
215
216 if(index < 1) then
217 write(*, *) 'Error: no such node'
218 return
219 endif
220
221 ! find a node after which a new node is inserted
222 nullify(prev)
223 iter => list
224 do i = 1, index - 1
225 if(.not. associated(iter % next)) then
226 write(*, *) 'Error: no such node'
227 return
228 endif
229 prev => iter
230 iter => iter % next
231 enddo
232 next => iter
233
234 ! create a new list
235 nullify(temp)
236 temp = array
237 if(.not. associated(prev)) then ! first node
238 list => temp
239 else
240 prev % next => temp
241 endif
242 iter => tail(temp)
243 iter % next => next
244
245 endsubroutine insert_array
246
247 ! remove a node at a given index
248 subroutine remove(list, index)
249 implicit none
250 type(list_type), pointer, intent(inout) :: list
251 integer, intent(in) :: index
252
253 integer :: i
254 type(list_type), pointer :: iter, prev
255
256 if(index < 1) then
257 write(*, *) 'Error: no such node'
258 endif
259
260 ! find a node to be removed
261 nullify(prev)
262 iter => list
263 do i = 1, index - 1
264 if(.not. associated(iter % next)) then
265 write(*, *) 'Error: no such node'
266 return
267 endif
268 prev => iter
269 iter => iter % next
270 enddo
271
272 if(.not. associated(prev)) then ! first node
273 list => list % next
274 else
275 prev % next => iter % next
276 endif
277
278 deallocate(iter)
279
280 endsubroutine remove
281
282endmodule mod_list
283
284program answer
285 use mod_list
286 implicit none
287
288 type(list_type), pointer :: a
289
290 nullify(a)
291
292 write(*, fmt='(a25)', advance='no') 'assignment : '
293 a = (/0, 1, 2/)
294 call show(a)
295
296 write(*, fmt='(a25)', advance='no') 'append scalar : '
297 call append(a, 3)
298 call show(a)
299
300 write(*, fmt='(a25)', advance='no') 'append array : '
301 call append(a,(/4, 5/))
302 call show(a)
303
304 write(*, fmt='(a25)', advance='no') 'insert scalar at 1 : '
305 call insert(a, 1, -1)
306 call show(a)
307
308 write(*, fmt='(a25)', advance='no') 'insert array at 1 : '
309 call insert(a, 1,(/-3, -2/))
310 call show(a)
311
312 write(*, fmt='(a25)', advance='no') 'delete : '
313 call delete(a)
314 call show(a)
315
316endprogram answer