libsim Versione 7.2.6
arrayof_post_nodoc.F90
1#ifndef ARRAYOF_TYPE
2#define ARRAYOF_TYPE arrayof_/**/ARRAYOF_ORIGTYPE
3#endif
4
5
6
7
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
46
47
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
58
59
60
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
76
77
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
94
95
96
97
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
117
118
119
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
158
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
168LOGICAL, INTENT(in), OPTIONAL :: nodestroy
169#endif
170
171INTEGER :: i, n, p
172#ifdef ARRAYOF_ORIGDESTRUCTOR
173LOGICAL :: destroy
174#endif
175
176IF (this%arraysize <= 0) RETURN ! nothing to do
177IF (PRESENT(nelem)) THEN ! explicit size
178 n = nelem
179 IF (n <= 0) RETURN ! nothing to do
180ELSE ! default remove one element
181 n = 1
182ENDIF
183
184IF (PRESENT(pos)) THEN ! clip p
185 p = max(1, min(pos, this%arraysize-n+1))
186ELSE ! pos not provided, cut at the end
187 p = this%arraysize - n + 1
188ENDIF
189#ifdef DEBUG
190!PRINT*,'ARRAYOF: removing ',n,' elements at position ',p
191#endif
192
193! destroy the elements if needed
194#ifdef ARRAYOF_ORIGDESTRUCTOR
195destroy = .true.
196IF (PRESENT(nodestroy)) THEN
197 destroy = .NOT.nodestroy
198ENDIF
199IF (destroy) THEN
200 DO i = p, p+n-1
201 arrayof_origdestructor(this%array(i))
202 ENDDO
203ENDIF
204#endif
205
206this%arraysize = this%arraysize - n
207DO i = p, this%arraysize ! push the elements backward starting from p
208 this%array(i) = this%array(i+n)
209ENDDO
210CALL arrayof_type/**/_alloc(this) ! release space if possible
211
212END SUBROUTINE ARRAYOF_TYPE/**/_remove
213
214
215
216
217
218SUBROUTINE arrayof_type/**/_delete(this, &
219#ifdef ARRAYOF_ORIGDESTRUCTOR
220 nodestroy, &
221#endif
222 nodealloc)
223TYPE(ARRAYOF_TYPE) :: this
224#ifdef ARRAYOF_ORIGDESTRUCTOR
225LOGICAL, INTENT(in), OPTIONAL :: nodestroy
226#endif
227LOGICAL, INTENT(in), OPTIONAL :: nodealloc
228
229TYPE(ARRAYOF_TYPE) :: empty
230
231#ifdef ARRAYOF_ORIGDESTRUCTOR
232INTEGER :: i
233LOGICAL :: destroy
234#endif
235LOGICAL :: dealloc
236
237#ifdef DEBUG
238!PRINT*,'ARRAYOF: destroying ',this%arraysize
239#endif
240IF (ASSOCIATED(this%array)) THEN
241! destroy the elements if needed
242#ifdef ARRAYOF_ORIGDESTRUCTOR
243 destroy = .true.
244 IF (PRESENT(nodestroy)) THEN
245 destroy = .NOT.nodestroy
246 ENDIF
247 IF (destroy) THEN
248 DO i = 1, this%arraysize
249 arrayof_origdestructor(this%array(i))
250 ENDDO
251 ENDIF
252#endif
253! free the space
254 dealloc = .true.
255 IF (PRESENT(nodealloc)) THEN
256 dealloc = .NOT.nodealloc
257 ENDIF
258 IF (dealloc) THEN
259 DEALLOCATE(this%array)
260 ENDIF
261ENDIF
262! give empty values
263this=empty
264
265END SUBROUTINE ARRAYOF_TYPE/**/_delete
266
267
268
269
270
271
272
273
274SUBROUTINE arrayof_type/**/_packarray(this)
275TYPE(ARRAYOF_TYPE) :: this
276
277DOUBLE PRECISION :: tmpoveralloc
278
279#ifdef DEBUG
280!PRINT*,'ARRAYOF: packing ',this%arraysize
281#endif
282tmpoveralloc = this%overalloc ! save value
283this%overalloc = 1.0d0
284CALL arrayof_type/**/_alloc(this) ! reallocate exact size
285this%overalloc = tmpoveralloc
286
287END SUBROUTINE ARRAYOF_TYPE/**/_packarray
288
289
290SUBROUTINE arrayof_type/**/_alloc(this)
291TYPE(ARRAYOF_TYPE) :: this
292
293arrayof_origtype, POINTER :: tmpptr(:)
294INTEGER :: newsize, copysize
295
296newsize = max(int(this%arraysize*this%overalloc), this%arraysize)
297
298IF (ASSOCIATED(this%array)) THEN ! array already allocated
299! space is neither too small nor too big, nothing to do
300 IF (SIZE(this%array) >= this%arraysize .AND. SIZE(this%array) <= newsize) RETURN
301! if too big, reduce
302 IF (SIZE(this%array) > newsize) newsize = this%arraysize
303#ifdef DEBUG
304! PRINT*,'ARRAYOF: requested ',this%arraysize,' elements, allocating ',newsize
305#endif
306 tmpptr => this%array ! keep a pointer to the old data
307 ALLOCATE(this%array(newsize))
308 copysize = min(this%arraysize, SIZE(tmpptr)) ! restrict to valid intervals
309 this%array(1:copysize) = tmpptr(1:copysize) ! copy the old data
310 DEALLOCATE(tmpptr) ! and destroy them
311ELSE ! need to allocate from scratch
312#ifdef DEBUG
313! PRINT*,'ARRAYOF: first time requested ',this%arraysize,' elements, allocating ',newsize
314#endif
315 ALLOCATE(this%array(newsize))
316ENDIF
317
318END SUBROUTINE ARRAYOF_TYPE/**/_alloc

Generated with Doxygen.