libsim  Versione7.2.3
list_abstract.F03
1 
17 module list_abstract
18 
19  use list_link
20  use missing_values
21  implicit none
22  private
23  public :: list
24 
26  type, abstract :: list
27  private
28  class(link),pointer :: firstLink => null()
29  class(link),pointer :: lastLink => null()
30  class(link),pointer :: currLink => null()
31  integer :: index=imiss
32  contains
33  procedure, non_overridable :: append
34  procedure, non_overridable :: prepend
35  procedure, non_overridable :: insert
36  procedure, non_overridable :: rewind
37  procedure, non_overridable :: forward
38  procedure, non_overridable :: seek
39  procedure, non_overridable :: next
40  procedure, non_overridable :: prev
41  procedure, non_overridable :: currentpoli
42  procedure, non_overridable :: currentindex
43  procedure, non_overridable :: element
44  procedure, non_overridable :: delete
45  procedure, non_overridable :: countelements
46 ! procedure :: current => currentpoli !< get index of currLink
47  procedure :: display
48 ! procedure :: write_formatted
49 ! generic :: write(formatted) => write_formatted
50 ! procedure(displayValues), deferred :: display !> prints values in list
51  end type list
52 
53  abstract interface
54 
55  subroutine displayvalues(this)
56  import list
57  class(list) :: this
58  end subroutine
59  end interface
60 
61 contains
62 
63 
64 !!$SUBROUTINE write_formatted &
65 !!$(dtv, unit, iotype, v_list, iostat, iomsg)
66 !!$ INTEGER, INTENT(IN) :: unit
67 !!$ ! the derived-type value/variable
68 !!$ class(List), INTENT(IN) :: dtv
69 !!$ ! the edit descriptor string
70 !!$ CHARACTER (LEN=*), INTENT(IN) :: iotype
71 !!$ INTEGER, INTENT(IN) :: v_list(:)
72 !!$ INTEGER, INTENT(OUT) :: iostat
73 !!$ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
74 !!$ write (unit, *, IOSTAT=iostat, IOMSG=iomsg) &
75 !!$ "class(List)"
76 !!$ END SUBROUTINE
77 !!$
78 
80 subroutine display(this)
81 class(list),intent(inout) :: this
82 
83 call this%rewind()
84 do while(this%element())
85 ! print *,"index:",this%currentindex()," value:", this%currentpoli()
86  print *,"index:",this%currentindex()," value: polimorphic value (not printable)"
87  call this%next()
88 end do
89 end subroutine display
90 
91 
93 integer function countelements(this)
94 class(list),intent(inout) :: this
95 
96 if (.not.c_e(this%currentindex())) call this%rewind()
97 countelements=this%currentindex()
98 
99 do while(this%element())
100  countelements=this%currentindex()
101  call this%next()
102 end do
103 
104 if (.not. c_e(countelements)) countelements =0
105 
106 end function countelements
107 
110 subroutine append(this, value)
111 class(list),intent(inout) :: this
112 class(*),intent(in) :: value
113 class(link), pointer :: newLink
114 
115 newlink => link(value)
116 this%currLink => newlink
117 
118 if (.not. associated(this%firstLink)) then
119  this%firstLink => newlink
120  this%lastLink => newlink
121  this%index=1
122 else
123  call newlink%setPrevLink(this%lastLink)
124  call this%lastLink%setNextLink(newlink)
125 
126  this%lastLink => newlink
127  this%index=this%index+1
128 end if
129 
130 end subroutine append
131 
132 
134 subroutine prepend(this, value)
135 class(list),intent(inout) :: this
136 class(*) :: value
137 class(link), pointer :: newLink
138 
139 newlink => link(value)
140 this%currLink => newlink
141 
142 if (.not. associated(this%firstLink)) then
143  this%firstLink => newlink
144  this%lastLink => newlink
145  this%index=1
146 else
147  call newlink%setnextLink(this%firstLink)
148  call this%firstLink%setPrevLink(newlink)
149 
150  this%firstLink => newlink
151  this%index=1
152 end if
153 end subroutine prepend
154 
156 logical function insert(this, value, index)
157 class(list),intent(inout) :: this
158 class(*) :: value
159 integer :: index ! removed optional because of inconsistent behavior
160 class(link), pointer :: newlink,nextlink
161 
162 newlink => link(value)
163 
164 !if (present(index)) then
165  insert = this%seek(index)
166  if (.not. insert) return
167 !else
168 ! insert=.true.
169 !end if
170 
171 if (.not. this%element()) then
172  !insert the first one
173  this%firstLink => newlink
174  this%lastLink => newlink
175  this%index=1
176 else
177  !set prev and next in new link
178  call newlink%setPrevLink(this%currlink)
179  call newlink%setNextLink(this%currlink%nextlink())
180 
181  !break the chain and insert
182  nextlink=>this%currlink%nextlink()
183  call this%currLink%setNextLink(newlink)
184  !verify if it's last
185  if (associated(nextlink))then
186  call nextlink%setprevLink(newlink)
187  else
188  this%lastLink => newlink
189  end if
190  this%index=this%index+1
191 end if
192 
193 this%currLink => newlink
194 
195 end function insert
196 
198 integer function currentindex(this)
199 class(list),intent(in) :: this
200 currentindex=this%index
201 end function currentindex
202 
204 subroutine rewind(this)
205 class(list),intent(inout) :: this
206 this%currLink => this%firstLink
207 if (.not. associated(this%firstLink)) then
208  this%index=imiss
209 else
210  this%index=1
211 end if
212 end subroutine rewind
213 
215 subroutine forward(this)
216 class(list),intent(inout) :: this
217 this%currLink => this%lastLink
218 if (.not. associated(this%lastLink)) then
219  ! index is unknow here
220  this%index=imiss
221 end if
222 
223 end subroutine forward
224 
226 subroutine next(this)
227 class(list),intent(inout) :: this
228 
229 if (this%element()) then
230  this%currLink => this%currLink%nextLink()
231  if (this%element())then
232  if(c_e(this%index))this%index=this%index+1
233  else
234  this%index=imiss
235  end if
236 end if
237 
238 end subroutine next
239 
241 subroutine prev(this)
242 class(list),intent(inout) :: this
243 
244 if (this%element()) then
245  this%currLink => this%currLink%prevLink()
246  if (this%element())then
247  if(c_e(this%index))this%index=this%index-1
248  else
249  this%index=imiss
250  end if
251 
252 end if
253 
254 end subroutine prev
255 
256 
258 function currentpoli(this)
259 class(list),intent(in) :: this
260 class(*), pointer :: Currentpoli
261 class(*), pointer :: l_p
262 l_p => this%currLink%getValue()
263 currentpoli => l_p
264 end function currentpoli
265 
266 
268 logical function element(this)
269 class(list),intent(in) :: this
270 
271 element = associated(this%currLink)
272 end function element
273 
276 logical function seek(this, index)
277 class(list),intent(inout) :: this
278 integer :: index
279 
280 if (index == this%index) then
281  seek =.true.
282  return
283 end if
284 
285 if (index < (this%index) .or. .not. c_e(this%index)) then
286  call this%rewind()
287 end if
288 
289 do while (this%element())
290  if (index == this%index) then
291  seek =.true.
292  return
293  end if
294  call this%next()
295 end do
296 
297 seek = .false.
298 return
299 
300 end function seek
301 
304 logical function delete(this, index)
305 class(list),intent(inout) :: this
306 integer,optional :: index
307 class(link),pointer :: itemtodelete
308 
309 if (.not. associated(this%firstLink)) then
310  delete=.false.
311  return
312 else
313  if (present(index)) then
314  delete=this%seek(index)
315  if(.not. delete) return
316  call deleteitem()
317  else
318  delete=.true.
319  call this%rewind()
320  do while (this%element())
321  !save pointer to delete
322  itemtodelete=>this%currlink
323  call this%next()
324  deallocate(itemtodelete)
325  end do
326  this%firstLink => null() ! first link in list
327  this%lastLink => null() ! last link in list
328  this%currLink => null() ! list iterator
329  this%index=imiss ! index to current
330  end if
331 end if
332 
333 contains
334 
335 subroutine deleteitem()
336 
337 class(link), pointer :: prevlink,nextlink
338 
339 ! detach myitem"
340 prevlink=>this%currlink%prevlink()
341 nextlink=>this%currlink%nextlink()
342 
343 if (associated(prevlink)) then
344  call prevlink%setNextLink(nextlink)
345 else
346  this%firstLink => nextlink
347 end if
348 
349 if (associated(nextlink)) then
350  call nextlink%setPrevLink(prevlink)
351 else
352  this%lastLink => prevlink
353 end if
354 
355 deallocate(this%currlink)
356 
357 ! set current to prev
358 this%currLink => prevlink
359 
360 if (associated(this%firstLink))then
361  this%index=max(this%index-1,1)
362 else
363  this%index=imiss ! index to current
364 endif
365 
366 end subroutine deleteitem
367 end function delete
368 
369 end module list_abstract
Function to check whether a value is missing or not.
abstract class to use lists in fortran 2003.
Index method.
Abstract implementation of doubly-linked list.
Definitions of constants and functions for working with missing values.

Generated with Doxygen.