libsim Versione 7.1.11
arrayof_post.F90
1#ifndef ARRAYOF_TYPE
2#define ARRAYOF_TYPE arrayof_/**/ARRAYOF_ORIGTYPE
3#endif
4
5
8SUBROUTINE arrayof_type/**/_insert_array(this, content, nelem, pos)
9TYPE(ARRAYOF_TYPE) :: this
10arrayof_origtype, INTENT(in), OPTIONAL :: content(:)
11INTEGER, INTENT(in), OPTIONAL :: nelem
12INTEGER, INTENT(in), OPTIONAL :: pos
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
48SUBROUTINE arrayof_type/**/_insert(this, content, pos)
49TYPE(ARRAYOF_TYPE) :: this
50arrayof_origtype, INTENT(in) :: content
51INTEGER, INTENT(in), OPTIONAL :: pos
52
53CALL insert(this, (/content/), pos=pos)
54
55END SUBROUTINE ARRAYOF_TYPE/**/_insert
56
57
61FUNCTION arrayof_type/**/_append(this, content) RESULT(pos)
62TYPE(ARRAYOF_TYPE) :: this
63arrayof_origtype, INTENT(in) :: content
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
78SUBROUTINE arrayof_type/**/_insert_unique(this, content, pos)
79TYPE(ARRAYOF_TYPE) :: this
80arrayof_origtype, INTENT(in) :: content
81INTEGER, INTENT(in), OPTIONAL :: pos
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
98FUNCTION arrayof_type/**/_append_unique(this, content) RESULT(pos)
99TYPE(ARRAYOF_TYPE) :: this
100arrayof_origtype, INTENT(in) :: content
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
120FUNCTION arrayof_type/**/_insert_sorted(this, content, incr, back) RESULT(pos)
121TYPE(ARRAYOF_TYPE) :: this
122arrayof_origtype, INTENT(in) :: content
123LOGICAL, INTENT(in) :: incr
124LOGICAL, INTENT(in) :: back
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
159SUBROUTINE arrayof_type/**/_remove(this, nelem, pos &
160#ifdef ARRAYOF_ORIGDESTRUCTOR
161 , nodestroy &
162#endif
163)
164TYPE(ARRAYOF_TYPE) :: this
165INTEGER, INTENT(in), OPTIONAL :: nelem
166INTEGER, INTENT(in), OPTIONAL :: pos
167#ifdef ARRAYOF_ORIGDESTRUCTOR
168
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
222SUBROUTINE arrayof_type/**/_delete(this, &
223#ifdef ARRAYOF_ORIGDESTRUCTOR
224 nodestroy, &
225#endif
226 nodealloc)
227TYPE(ARRAYOF_TYPE) :: this
228#ifdef ARRAYOF_ORIGDESTRUCTOR
229
233LOGICAL, INTENT(in), OPTIONAL :: nodestroy
234#endif
235
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
288SUBROUTINE arrayof_type/**/_packarray(this)
289TYPE(ARRAYOF_TYPE) :: this
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.