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 assignment(=)
12 module procedure assign
13 endinterface assignment(=)
14
15 public :: list_type
16 public :: new, delete, show, append, insert, remove
17 public :: assignment(=)
18
19contains
20
21 ! assignment (initialize list with a given value)
22 subroutine assign(a, b)
23 implicit none
24 type(list_type), pointer, intent(out) :: a
25 integer, intent(in) :: b
26
27 call delete(a)
28 call new(a, value=b)
29
30 endsubroutine assign
31
32 ! show list contents
33 subroutine show(list)
34 implicit none
35 type(list_type), pointer, intent(in) :: list
36
37 type(list_type), pointer :: iter
38
39 write(*, fmt='("List = [")', advance='no')
40
41 if(associated(list)) then
42 ! show contents
43 iter => list
44 write(*, fmt='(i5, x)', advance='no') iter % value
45 do while(associated(iter % next))
46 iter => iter % next
47 write(*, fmt='(i5, x)', advance='no') iter % value
48 enddo
49 endif
50
51 write(*, fmt='(a)') ']'
52
53 endsubroutine show
54
55 ! create a new node (pointer must be initialized by nullify() in advance)
56 subroutine new(list, next, value)
57 implicit none
58 type(list_type), pointer, intent(out) :: list
59 type(list_type), pointer, optional, intent(in) :: next
60 integer, optional, intent(in) :: value
61
62 if(associated(list)) then
63 write(*, *) 'Error in new'
64 endif
65
66 allocate(list)
67 nullify(list % next)
68
69 if(present(next)) then
70 list % next => next
71 endif
72
73 if(present(value)) then
74 list % value = value
75 endif
76
77 endsubroutine new
78
79 ! safely delete all the list contents
80 subroutine delete(list)
81 implicit none
82 type(list_type), pointer, intent(inout) :: list
83
84 type(list_type), pointer :: iter, temp
85
86 if(.not. associated(list)) then
87 return
88 endif
89
90 iter => list
91 do while(associated(iter % next))
92 temp => iter
93 iter => iter % next
94 deallocate(temp)
95 enddo
96
97 nullify(list)
98
99 endsubroutine delete
100
101 ! return the last node
102 function tail(list) result(iter)
103 type(list_type), pointer, intent(in) :: list
104 type(list_type), pointer :: iter
105
106 iter => list
107 do while(associated(iter % next))
108 iter => iter % next
109 enddo
110
111 endfunction tail
112
113 ! append a single node at the last
114 subroutine append(list, value)
115 implicit none
116 type(list_type), pointer, intent(in) :: list
117 integer, intent(in) :: value
118
119 type(list_type), pointer :: iter
120
121 iter => tail(list)
122 call new(iter % next, value=value)
123
124 endsubroutine append
125
126 ! insert a node at a given index
127 subroutine insert(list, index, value)
128 implicit none
129 type(list_type), pointer, intent(inout) :: list
130 integer, intent(in) :: index
131 integer, intent(in) :: value
132
133 integer :: i
134 type(list_type), pointer :: iter, prev, node
135
136 if(index < 1) then
137 write(*, *) 'Error: no such node'
138 return
139 endif
140
141 ! find a node after which a new node is inserted
142 nullify(prev)
143 iter => list
144 do i = 1, index - 1
145 if(.not. associated(iter % next)) then
146 write(*, *) 'Error: no such node'
147 return
148 endif
149 prev => iter
150 iter => iter % next
151 enddo
152
153 ! create a new node
154 nullify(node)
155 call new(node, next=iter, value=value)
156
157 if(.not. associated(prev)) then ! first node
158 list => node
159 else
160 prev % next => node
161 endif
162
163 endsubroutine insert
164
165 ! remove a node at a given index
166 subroutine remove(list, index)
167 implicit none
168 type(list_type), pointer, intent(inout) :: list
169 integer, intent(in) :: index
170
171 integer :: i
172 type(list_type), pointer :: iter, prev
173
174 if(index < 1) then
175 write(*, *) 'Error: no such node'
176 endif
177
178 ! find a node to be removed
179 nullify(prev)
180 iter => list
181 do i = 1, index - 1
182 if(.not. associated(iter % next)) then
183 write(*, *) 'Error: no such node'
184 return
185 endif
186 prev => iter
187 iter => iter % next
188 enddo
189
190 if(.not. associated(prev)) then ! first node
191 list => list % next
192 else
193 prev % next => iter % next
194 endif
195
196 deallocate(iter)
197
198 endsubroutine remove
199
200endmodule mod_list