libsim Versione 7.2.4
list_abstractforchar.F03
1
8
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
51contains
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!!$
70subroutine display(this)
71class(list) :: this
73call this%rewind()
74do 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()
78end do
79end subroutine display
80
81
83integer function countelements(this)
84class(list) :: this
85
86if (.not.c_e(this%currentindex())) call this%rewind()
87countelements=this%currentindex()
88
89do while(this%element())
90 countelements=this%currentindex()
91 call this%next()
92end do
93
94if (.not. c_e(countelements)) countelements =0
95
96end function countelements
97
98
100subroutine append(this, value)
101class(list) :: this
102character(len=*) :: value
103class(link), pointer :: newLink
104
105newlink => link(value)
106this%currLink => newlink
107
108if (.not. associated(this%firstLink)) then
109 this%firstLink => newlink
110 this%lastLink => newlink
111 this%index=1
112else
113 call newlink%setPrevLink(this%lastLink)
114 call this%lastLink%setNextLink(newlink)
115
116 this%lastLink => newlink
117 this%index=this%index+1
118end if
119
120end subroutine append
121
122
124subroutine prepend(this, value)
125class(list) :: this
126character(len=*) :: value
127class(link), pointer :: newlink
128
129newlink => link(value)
130this%currLink => newlink
131
132if (.not. associated(this%firstLink)) then
133 this%firstLink => newlink
134 this%lastLink => newlink
135 this%index=1
136else
137 call newlink%setnextLink(this%firstLink)
138 call this%firstLink%setNextLink(newlink)
139
140 this%firstLink => newlink
141 this%index=this%index+1
142end if
143end subroutine prepend
144
146logical function insert(this, value, index)
147class(list) :: this
148character(len=*) :: value
149integer,optional :: index
150class(link), pointer :: newLink,nextlink
151
152newlink => link(value)
153
154if (present(index)) then
155 insert = this%seek(index)
156 if (.not. insert) return
157else
158 insert=.true.
159end if
160
161if (.not. associated(this%currLink)) then
162 !insert the first one
163 this%firstLink => newlink
164 this%lastLink => newlink
165 this%index=1
166else
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
181end if
182
183this%currLink => newlink
184
185end function insert
186
188integer function currentindex(this)
189class(list) :: this
190currentindex=this%index
191end function currentindex
192
194subroutine rewind(this)
195class(list) :: this
196this%currLink => this%firstLink
197if (.not. associated(this%firstLink)) then
198 this%index=imiss
199else
200 this%index=1
201end if
202end subroutine rewind
203
205subroutine forward(this)
206class(list) :: this
207this%currLink => this%lastLink
208if (.not. associated(this%lastLink)) then
209 ! index is unknow here
210 this%index=imiss
211end if
212
213end subroutine forward
214
216subroutine next(this)
217class(list) :: this
218
219if (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
226end if
227
228end subroutine next
231subroutine prev(this)
232class(list) :: this
233
234if (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
242end if
243
244end subroutine prev
245
248function currentpoli(this)
249class(list) :: this
250character(len=listcharmaxlen) :: Currentpoli
251currentpoli = this%currLink%getValue()
252end function currentpoli
253
254
256logical function element(this)
257class(list) :: this
258
259element = associated(this%currLink)
260end function element
261
264logical function seek(this, index)
265class(list) :: this
266integer :: index
267
268if (index == this%index) then
269 seek =.true.
270 return
271end if
273if (index < (this%index) .or. .not. c_e(this%index)) then
274 call this%rewind()
275end if
276
277do while (this%element())
278 if (index == this%index) then
279 seek =.true.
280 return
281 end if
282 call this%next()
283end do
284
285seek = .false.
286return
287
288end function seek
292logical function delete(this, index)
293class(list) :: this
294integer,optional :: index
295class(link),pointer :: itemtodelete
296
297if (.not. associated(this%firstLink)) then
298 delete=.false.
299 return
300else
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
319end if
320
321contains
322
323subroutine deleteitem()
324
325class(link), pointer :: prevlink,nextlink
326
327! detach myitem"
328prevlink=>this%currlink%prevlink()
329nextlink=>this%currlink%nextlink()
330
331if (associated(prevlink)) then
332 call prevlink%setNextLink(nextlink)
333else
334 this%firstLink => nextlink
335end if
336
337if (associated(nextlink)) then
338 call nextlink%setPrevLink(prevlink)
339else
340 this%lastLink => prevlink
341end if
342
343deallocate(this%currlink)
344
345! set current to prev
346this%currLink => prevlink
347
348if (associated(this%firstLink))then
349 this%index=max(this%index-1,1)
350else
351 this%index=imiss ! index to current
352endif
353
354end subroutine deleteitem
355end function delete
356
357end module list_abstractforchar
Index method.
Function to check whether a value is missing or not.
like abstract class to use character lists in fortran 2003 (gnu gcc 4.8 do not work with character(le...
class to manage links for lists in fortran 2003.
Definitions of constants and functions for working with missing values.
Abstract implementation of doubly-linked list.

Generated with Doxygen.