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

Generated with Doxygen.