libsim Versione 7.2.6
arrayof_post.F90
1#ifndef ARRAYOF_TYPE
2#define ARRAYOF_TYPE arrayof_/**/ARRAYOF_ORIGTYPE
3#endif
4
5
6!> Method for inserting a number of elements of the array at a desired position.
7!! If necessary, the array is reallocated to accomodate the new elements.
8SUBROUTINE arrayof_type/**/_insert_array(this, content, nelem, pos)
9TYPE(ARRAYOF_TYPE) :: this !< array object to extend
10arrayof_origtype, INTENT(in), OPTIONAL :: content(:) !< object of \a TYPE ARRAYOF_ORIGTYPE to insert, if not provided, space is reserved but not initialized
11INTEGER, INTENT(in), OPTIONAL :: nelem !< number of elements to add, mutually exclusive with the previous parameter, if both are not provided, a single element is added without initialization
12INTEGER, INTENT(in), OPTIONAL :: pos !< position where to insert, if it is out of range, it is clipped, if it is not provided, the object is appended
13
14INTEGER :: i, n, p
15
16IF (PRESENT(content)) THEN ! size of data
17 n = SIZE(content)
18ELSE IF (PRESENT(nelem)) THEN ! explicit size
19 n = nelem
20ELSE ! default add one element
21 n = 1
22ENDIF
23IF (n <= 0) RETURN ! nothing to do
24
25IF (PRESENT(pos)) THEN ! clip p
26 p = max(1, min(pos, this%arraysize+1))
27ELSE ! pos not provided, append
28 p = this%arraysize + 1
29ENDIF
30this%arraysize = this%arraysize + n
31#ifdef DEBUG
32!PRINT*,'ARRAYOF: inserting ',n,' elements at position ',p
33#endif
34
35CALL arrayof_type/**/_alloc(this) ! ensure to have space
36DO i = this%arraysize, p+n, -1 ! push the elements forward starting from p
37 this%array(i) = this%array(i-n)
38ENDDO
39IF (PRESENT(content)) THEN
40 this%array(p:p+n-1) = content(:)
41ENDIF
42
43END SUBROUTINE ARRAYOF_TYPE/**/_insert_array
44
45
46!> Method for inserting an element of the array at a desired position.
47!! If necessary, the array is reallocated to accomodate the new element.
48SUBROUTINE arrayof_type/**/_insert(this, content, pos)
49TYPE(ARRAYOF_TYPE) :: this !< array object to extend
50arrayof_origtype, INTENT(in) :: content !< object of \a TYPE ARRAYOF_ORIGTYPE to insert
51INTEGER, INTENT(in), OPTIONAL :: pos !< position where to insert, if it is out of range, it is clipped, if it is not provided, the object is appended
52
53CALL insert(this, (/content/), pos=pos)
54
55END SUBROUTINE ARRAYOF_TYPE/**/_insert
56
57
58!> Quick method to append an element to the array.
59!! The return value is the position at which the element has been
60!! appended.
61FUNCTION arrayof_type/**/_append(this, content) RESULT(pos)
62TYPE(ARRAYOF_TYPE) :: this !< array object to extend
63arrayof_origtype, INTENT(in) :: content !< object of \a TYPE ARRAYOF_ORIGTYPE to append
64INTEGER :: pos
65
66this%arraysize = this%arraysize + 1
67pos = this%arraysize
68CALL arrayof_type/**/_alloc(this)
69this%array(this%arraysize) = content
70
71END FUNCTION ARRAYOF_TYPE/**/_append
72
73
74#ifdef ARRAYOF_ORIGEQ
75!> Method for inserting an element of the array at a desired position
76!! only if it is not present in the array yet.
77!! If necessary, the array is reallocated to accomodate the new element.
78SUBROUTINE arrayof_type/**/_insert_unique(this, content, pos)
79TYPE(ARRAYOF_TYPE) :: this !< array object to extend
80arrayof_origtype, INTENT(in) :: content !< object of \a TYPE ARRAYOF_ORIGTYPE to insert
81INTEGER, INTENT(in), OPTIONAL :: pos !< position where to insert, if it is out of range, it is clipped, if it is not provided, the object is appended
82
83INTEGER :: i
84
85DO i = 1, this%arraysize
86 IF (this%array(i) == content) RETURN
87ENDDO
88
89CALL insert(this, (/content/), pos=pos)
90
91END SUBROUTINE ARRAYOF_TYPE/**/_insert_unique
92
93
94!> Quick function to append an element to the array
95!! only if it is not present in the array yet. The return value is
96!! the position at which the element has been appended or at which it
97!! has been found.
98FUNCTION arrayof_type/**/_append_unique(this, content) RESULT(pos)
99TYPE(ARRAYOF_TYPE) :: this !< array object to extend
100arrayof_origtype, INTENT(in) :: content !< object of \a TYPE ARRAYOF_ORIGTYPE to append
101INTEGER :: pos
102
103DO pos = 1, this%arraysize
104 IF (this%array(pos) == content) RETURN
105ENDDO
106
107this%arraysize = this%arraysize + 1
108pos = this%arraysize
109CALL arrayof_type/**/_alloc(this)
110this%array(this%arraysize) = content
111
112END FUNCTION ARRAYOF_TYPE/**/_append_unique
113
114
115#ifdef ARRAYOF_ORIGGT
116!> Method for inserting an element of the array in a sorted manner.
117!! If necessary, the array is reallocated to accomodate the new element.
118!! It works under the assumption that the current content of the array
119!! is already sorted in the desired order.
120FUNCTION arrayof_type/**/_insert_sorted(this, content, incr, back) RESULT(pos)
121TYPE(ARRAYOF_TYPE) :: this !< array object to extend
122arrayof_origtype, INTENT(in) :: content !< object of \a TYPE ARRAYOF_ORIGTYPE to insert
123LOGICAL, INTENT(in) :: incr !< insert in increasing order
124LOGICAL, INTENT(in) :: back !< search position starting from end of array (optimization)
125
126INTEGER :: pos
127
128IF (incr) THEN
129 IF (back) THEN
130 DO pos = this%arraysize+1, 2, -1
131 IF (this%array(pos-1) < content) EXIT
132 ENDDO
133 ELSE
134 DO pos = 1, this%arraysize
135 IF (this%array(pos) > content) EXIT
136 ENDDO
137 ENDIF
138ELSE
139 IF (back) THEN
140 DO pos = this%arraysize+1, 2, -1
141 IF (this%array(pos-1) > content) EXIT
142 ENDDO
143 ELSE
144 DO pos = 1, this%arraysize
145 IF (this%array(pos) < content) EXIT
146 ENDDO
147 ENDIF
148ENDIF
149
150CALL insert(this, (/content/), pos=pos)
151
152END FUNCTION ARRAYOF_TYPE/**/_insert_sorted
153#endif
154#endif
155
156
157!> Method for removing elements of the array at a desired position.
158!! If necessary, the array is reallocated to reduce space.
159SUBROUTINE arrayof_type/**/_remove(this, nelem, pos &
160#ifdef ARRAYOF_ORIGDESTRUCTOR
161 , nodestroy &
162#endif
163)
164TYPE(ARRAYOF_TYPE) :: this !< array object in which an element has to be removed
165INTEGER, INTENT(in), OPTIONAL :: nelem !< number of elements to remove, if not provided, a single element is removed
166INTEGER, INTENT(in), OPTIONAL :: pos !< position of the element to be removed, if it is out of range, it is clipped, if it is not provided, objects are removed at the end
167#ifdef ARRAYOF_ORIGDESTRUCTOR
168!< if provided and \c .TRUE. , the destructor possibily defined for
169!!the ARRAYOF_ORIGTYPE is not called for every deleted object, may be
170!!useful if the objects to be deleted have been copied to another
171!!instance of ARRAYOF_TYPE and continue their life there
172LOGICAL, INTENT(in), OPTIONAL :: nodestroy
173#endif
174
175INTEGER :: i, n, p
176#ifdef ARRAYOF_ORIGDESTRUCTOR
177LOGICAL :: destroy
178#endif
179
180IF (this%arraysize <= 0) RETURN ! nothing to do
181IF (PRESENT(nelem)) THEN ! explicit size
182 n = nelem
183 IF (n <= 0) RETURN ! nothing to do
184ELSE ! default remove one element
185 n = 1
186ENDIF
187
188IF (PRESENT(pos)) THEN ! clip p
189 p = max(1, min(pos, this%arraysize-n+1))
190ELSE ! pos not provided, cut at the end
191 p = this%arraysize - n + 1
192ENDIF
193#ifdef DEBUG
194!PRINT*,'ARRAYOF: removing ',n,' elements at position ',p
195#endif
196
197! destroy the elements if needed
198#ifdef ARRAYOF_ORIGDESTRUCTOR
199destroy = .true.
200IF (PRESENT(nodestroy)) THEN
201 destroy = .NOT.nodestroy
202ENDIF
203IF (destroy) THEN
204 DO i = p, p+n-1
205 arrayof_origdestructor(this%array(i))
206 ENDDO
207ENDIF
208#endif
209
210this%arraysize = this%arraysize - n
211DO i = p, this%arraysize ! push the elements backward starting from p
212 this%array(i) = this%array(i+n)
213ENDDO
214CALL arrayof_type/**/_alloc(this) ! release space if possible
215
216END SUBROUTINE ARRAYOF_TYPE/**/_remove
217
218
219!> Destructor for finalizing an array object. If defined, calls the
220!! destructor for every element of the array object;
221!! finally it deallocates all the space occupied.
222SUBROUTINE arrayof_type/**/_delete(this, &
223#ifdef ARRAYOF_ORIGDESTRUCTOR
224 nodestroy, &
225#endif
226 nodealloc)
227TYPE(ARRAYOF_TYPE) :: this !< array object to be destroyed
228#ifdef ARRAYOF_ORIGDESTRUCTOR
229!< if provided and \c .TRUE. , the destructor possibily defined for
230!!the ARRAYOF_ORIGTYPE is not called for every deleted object, may be
231!!useful if the objects to be deleted have been copied to another
232!!instance of ARRAYOF_TYPE and continue their life there
233LOGICAL, INTENT(in), OPTIONAL :: nodestroy
234#endif
235
236!> if provided and \c .TRUE. , the space reserved for the array is not
237!! deallocated, thus the values are retained, while the array pointer
238!! is nullified, this means that the caller must have previously assigned
239!! the pointer contents this%array to another pointer to prevent memory
240!! leaks
241LOGICAL, INTENT(in), OPTIONAL :: nodealloc
242
243TYPE(ARRAYOF_TYPE) :: empty
244
245#ifdef ARRAYOF_ORIGDESTRUCTOR
246INTEGER :: i
247LOGICAL :: destroy
248#endif
249LOGICAL :: dealloc
250
251#ifdef DEBUG
252!PRINT*,'ARRAYOF: destroying ',this%arraysize
253#endif
254IF (ASSOCIATED(this%array)) THEN
255! destroy the elements if needed
256#ifdef ARRAYOF_ORIGDESTRUCTOR
257 destroy = .true.
258 IF (PRESENT(nodestroy)) THEN
259 destroy = .NOT.nodestroy
260 ENDIF
261 IF (destroy) THEN
262 DO i = 1, this%arraysize
263 arrayof_origdestructor(this%array(i))
264 ENDDO
265 ENDIF
266#endif
267! free the space
268 dealloc = .true.
269 IF (PRESENT(nodealloc)) THEN
270 dealloc = .NOT.nodealloc
271 ENDIF
272 IF (dealloc) THEN
273 DEALLOCATE(this%array)
274 ENDIF
275ENDIF
276! give empty values
277this=empty
278
279END SUBROUTINE ARRAYOF_TYPE/**/_delete
280
281
282!> Method for packing the array object reducing at a minimum
283!! the memory occupation, without destroying its contents.
284!! The value of this::overalloc remains unchanged.
285!! After the call to the method, the object can continue to be used,
286!! extended and shortened as before. If the object is empty the array
287!! is allocated to zero length.
288SUBROUTINE arrayof_type/**/_packarray(this)
289TYPE(ARRAYOF_TYPE) :: this !< object to be packed
290
291DOUBLE PRECISION :: tmpoveralloc
292
293#ifdef DEBUG
294!PRINT*,'ARRAYOF: packing ',this%arraysize
295#endif
296tmpoveralloc = this%overalloc ! save value
297this%overalloc = 1.0d0
298CALL arrayof_type/**/_alloc(this) ! reallocate exact size
299this%overalloc = tmpoveralloc
300
301END SUBROUTINE ARRAYOF_TYPE/**/_packarray
302
303
304SUBROUTINE arrayof_type/**/_alloc(this)
305TYPE(ARRAYOF_TYPE) :: this
306
307arrayof_origtype, POINTER :: tmpptr(:)
308INTEGER :: newsize, copysize
309
310newsize = max(int(this%arraysize*this%overalloc), this%arraysize)
311
312IF (ASSOCIATED(this%array)) THEN ! array already allocated
313! space is neither too small nor too big, nothing to do
314 IF (SIZE(this%array) >= this%arraysize .AND. SIZE(this%array) <= newsize) RETURN
315! if too big, reduce
316 IF (SIZE(this%array) > newsize) newsize = this%arraysize
317#ifdef DEBUG
318! PRINT*,'ARRAYOF: requested ',this%arraysize,' elements, allocating ',newsize
319#endif
320 tmpptr => this%array ! keep a pointer to the old data
321 ALLOCATE(this%array(newsize))
322 copysize = min(this%arraysize, SIZE(tmpptr)) ! restrict to valid intervals
323 this%array(1:copysize) = tmpptr(1:copysize) ! copy the old data
324 DEALLOCATE(tmpptr) ! and destroy them
325ELSE ! need to allocate from scratch
326#ifdef DEBUG
327! PRINT*,'ARRAYOF: first time requested ',this%arraysize,' elements, allocating ',newsize
328#endif
329 ALLOCATE(this%array(newsize))
330ENDIF
331
332END SUBROUTINE ARRAYOF_TYPE/**/_alloc

Generated with Doxygen.