DISPATCH
dll_mod.f90
1 !===============================================================================
2 !> Doubly linked list (DLL), carrying anything, as simply as possible
3 !===============================================================================
4 MODULE dll_mod
5  implicit none
6  private
7  type, public:: dll_node_t
8  class(dll_node_t), pointer:: prev => null()
9  class(dll_node_t), pointer:: next => null()
10  class(*), pointer:: car
11  integer:: id=0
12  end type
13  type, public:: dll_t
14  class(dll_node_t), pointer:: head => null()
15  class(dll_node_t), pointer:: tail => null()
16  integer:: n=0
17  character(len=32):: name
18  contains
19  procedure:: init
20  procedure:: append
21  procedure:: prepend
22  procedure:: find
23  procedure:: insert_before
24  procedure:: insert_after
25  procedure:: remove
26  procedure:: delete
27  procedure:: pop
28  procedure:: test
29  end type
30 CONTAINS
31 
32 !===============================================================================
33 !> Initialize a doubly-linked-list (DLL), with anonymous carry
34 !===============================================================================
35 SUBROUTINE init (self, name)
36  class(dll_t):: self
37  character(len=*), optional:: name
38  !.............................................................................
39  nullify (self%head, self%tail)
40  !$omp atomic write
41  self%n = 0
42  if (present(name)) then
43  self%name = name
44  else
45  self%name = 'dll'
46  end if
47 END SUBROUTINE init
48 
49 !===============================================================================
50 !> Add an item at the tail
51 !===============================================================================
52 SUBROUTINE append (self, new)
53  class(dll_t):: self
54  class(dll_node_t), pointer:: new
55  !.............................................................................
56  new%prev => self%tail
57  nullify(new%next)
58  if (.not.associated(self%head)) self%head => new
59  if (associated(self%tail)) self%tail%next => new
60  self%tail => new
61  !$omp atomic
62  self%n = self%n+1
63 END SUBROUTINE append
64 
65 !===============================================================================
66 !> Add an item at the head
67 !===============================================================================
68 SUBROUTINE prepend (self, new)
69  class(dll_t):: self
70  class(dll_node_t), pointer:: new
71  !.............................................................................
72  if (.not.associated(self%tail)) self%tail => new
73  new%next => self%head
74  nullify (new%prev)
75  self%head => new
76  !$omp atomic
77  self%n = self%n+1
78 END SUBROUTINE prepend
79 
80 !===============================================================================
81 !> Find an item, by matching with a known member
82 !===============================================================================
83 SUBROUTINE find (self, old, prev, next)
84  class(dll_t):: self
85  class(dll_node_t), pointer:: prev, next
86  class(*), pointer:: old
87  !.............................................................................
88  next => self%head
89  nullify (prev)
90  do while (associated(next))
91  if (associated(next%car, old)) then
92  return
93  end if
94  prev => next
95  next => next%next
96  end do
97  nullify (prev, next)
98 END SUBROUTINE find
99 
100 !===============================================================================
101 !> Insert a new item before an old one
102 !===============================================================================
103 SUBROUTINE insert_before (self, old, new)
104  class(dll_t):: self
105  class(dll_node_t), pointer:: old, new
106  !.............................................................................
107  new%prev => old%prev
108  new%next => old
109  if (associated(new%prev)) new%prev%next => new
110  if (associated(new%next)) new%next%prev => new
111  !$omp atomic
112  self%n = self%n+1
113 END SUBROUTINE insert_before
114 
115 !===============================================================================
116 !> Insert a new item after an old one
117 !===============================================================================
118 SUBROUTINE insert_after (self, old, new)
119  class(dll_t):: self
120  class(dll_node_t), pointer:: old, new
121  !.............................................................................
122  new%next => old%next
123  old%next => new
124  if (associated(new%prev)) new%prev%next => new
125  if (associated(new%next)) new%next%prev => new
126  !$omp atomic
127  self%n = self%n+1
128 END SUBROUTINE insert_after
129 
130 !===============================================================================
131 !> Remove an item from the DLL; note that the item is not deallocated!
132 !===============================================================================
133 SUBROUTINE remove (self, old)
134  class(dll_t):: self
135  class(dll_node_t), pointer:: old
136  !.............................................................................
137  if (associated(old%prev)) old%prev%next => old%next
138  if (associated(old%next)) old%next%prev => old%prev
139  if (associated(old, self%head)) then
140  self%head => old%next
141  end if
142  if (associated(old, self%tail)) then
143  self%tail => old%prev
144  end if
145  !$omp atomic
146  self%n = self%n-1
147 END SUBROUTINE remove
148 
149 !===============================================================================
150 !> Pop the last appended item off the list. The list node and its carry should
151 !> be deallocated after use.
152 !===============================================================================
153 FUNCTION pop (self)
154  class(dll_t):: self
155  class(dll_node_t), pointer:: pop
156  !.............................................................................
157  pop => self%tail
158  if (associated(pop%prev)) then
159  self%tail => pop%prev
160  nullify(self%tail%next)
161  end if
162  !$omp atomic
163  self%n = self%n-1
164 END FUNCTION pop
165 
166 !===============================================================================
167 !> Run a self test
168 !===============================================================================
169 SUBROUTINE test (self)
170  class(dll_t):: self
171  !.............................................................................
172  integer:: n
173  class(*), pointer:: car, save
174  integer, pointer:: ip
175  real, pointer:: rp
176  class(dll_node_t), pointer:: prev, next
177  integer:: i
178  !-----------------------------------------------------------------------------
179  ! Append five numbers
180  !-----------------------------------------------------------------------------
181  print *,'===================== Doubly linked list test ======================='
182  print *, 'fill:', n
183  do i=1,n
184  if (i == 2) then
185  allocate (next, ip)
186  ip = i
187  next%car => ip
188  else
189  allocate (next, rp)
190  rp = i
191  next%car => rp
192  end if
193  if (i == 3) save => next%car
194  call self%append (next)
195  end do
196  !-----------------------------------------------------------------------------
197  ! List them
198  !-----------------------------------------------------------------------------
199  print *, 'list:', self%n
200  next => self%head
201  do while (associated(next))
202  call print (next%car)
203  next => next%next
204  end do
205  !-----------------------------------------------------------------------------
206  ! Find number 3
207  !-----------------------------------------------------------------------------
208  print *, 'find:'
209  call print (save)
210  call self%find (save, prev, next)
211  call print (next%car)
212  print *, 'previous:'
213  call print (prev%car)
214 contains
215  subroutine print (car)
216  class(*), pointer:: car
217  select type (car)
218  type is (integer)
219  print *, car
220  type is (real)
221  print *, car
222  end select
223  end subroutine print
224 END SUBROUTINE test
225 
226 !===============================================================================
227 !> Delete a double-linked list, including carried content
228 !===============================================================================
229 SUBROUTINE delete (self)
230  class(dll_t):: self
231  !.............................................................................
232  class(dll_node_t), pointer:: item, next
233  !-----------------------------------------------------------------------------
234  item => self%head
235  do while (associated(item))
236  next => item%next
237  if (associated(item%car)) deallocate (item%car)
238  deallocate (item)
239  item => next
240  end do
241  nullify (self%head)
242  nullify (self%tail)
243  self%n = 0
244  call self%init
245 END SUBROUTINE delete
246 
247 END MODULE dll_mod
Doubly linked list (DLL), carrying anything, as simply as possible.
Definition: dll_mod.f90:4