libsim  Versione7.2.1
arrayof_post.F90
1 #ifndef ARRAYOF_TYPE
2 #define ARRAYOF_TYPE arrayof_/**/ARRAYOF_ORIGTYPE
3 #endif
4 
5 
8 SUBROUTINE arrayof_type/**/_insert_array(this, content, nelem, pos)
9 TYPE(ARRAYOF_TYPE) :: this
10 arrayof_origtype, INTENT(in), OPTIONAL :: content(:)
11 INTEGER, INTENT(in), OPTIONAL :: nelem
12 INTEGER, INTENT(in), OPTIONAL :: pos
13 
14 INTEGER :: i, n, p
15 
16 IF (PRESENT(content)) THEN ! size of data
17  n = SIZE(content)
18 ELSE IF (PRESENT(nelem)) THEN ! explicit size
19  n = nelem
20 ELSE ! default add one element
21  n = 1
22 ENDIF
23 IF (n <= 0) RETURN ! nothing to do
24 
25 IF (PRESENT(pos)) THEN ! clip p
26  p = max(1, min(pos, this%arraysize+1))
27 ELSE ! pos not provided, append
28  p = this%arraysize + 1
29 ENDIF
30 this%arraysize = this%arraysize + n
31 #ifdef DEBUG
32 !PRINT*,'ARRAYOF: inserting ',n,' elements at position ',p
33 #endif
34 
35 CALL arrayof_type/**/_alloc(this) ! ensure to have space
36 DO i = this%arraysize, p+n, -1 ! push the elements forward starting from p
37  this%array(i) = this%array(i-n)
38 ENDDO
39 IF (PRESENT(content)) THEN
40  this%array(p:p+n-1) = content(:)
41 ENDIF
42 
43 END SUBROUTINE ARRAYOF_TYPE/**/_insert_array
44 
45 
48 SUBROUTINE arrayof_type/**/_insert(this, content, pos)
49 TYPE(ARRAYOF_TYPE) :: this
50 arrayof_origtype, INTENT(in) :: content
51 INTEGER, INTENT(in), OPTIONAL :: pos
52 
53 CALL insert(this, (/content/), pos=pos)
54 
55 END SUBROUTINE ARRAYOF_TYPE/**/_insert
56 
57 
61 FUNCTION arrayof_type/**/_append(this, content) RESULT(pos)
62 TYPE(ARRAYOF_TYPE) :: this
63 arrayof_origtype, INTENT(in) :: content
64 INTEGER :: pos
65 
66 this%arraysize = this%arraysize + 1
67 pos = this%arraysize
68 CALL arrayof_type/**/_alloc(this)
69 this%array(this%arraysize) = content
70 
71 END FUNCTION ARRAYOF_TYPE/**/_append
72 
73 
74 #ifdef ARRAYOF_ORIGEQ
75 
78 SUBROUTINE arrayof_type/**/_insert_unique(this, content, pos)
79 TYPE(ARRAYOF_TYPE) :: this
80 arrayof_origtype, INTENT(in) :: content
81 INTEGER, INTENT(in), OPTIONAL :: pos
82 
83 INTEGER :: i
84 
85 DO i = 1, this%arraysize
86  IF (this%array(i) == content) RETURN
87 ENDDO
88 
89 CALL insert(this, (/content/), pos=pos)
90 
91 END SUBROUTINE ARRAYOF_TYPE/**/_insert_unique
92 
93 
98 FUNCTION arrayof_type/**/_append_unique(this, content) RESULT(pos)
99 TYPE(ARRAYOF_TYPE) :: this
100 arrayof_origtype, INTENT(in) :: content
101 INTEGER :: pos
102 
103 DO pos = 1, this%arraysize
104  IF (this%array(pos) == content) RETURN
105 ENDDO
106 
107 this%arraysize = this%arraysize + 1
108 pos = this%arraysize
109 CALL arrayof_type/**/_alloc(this)
110 this%array(this%arraysize) = content
111 
112 END FUNCTION ARRAYOF_TYPE/**/_append_unique
113 
114 
115 #ifdef ARRAYOF_ORIGGT
116 
120 FUNCTION arrayof_type/**/_insert_sorted(this, content, incr, back) RESULT(pos)
121 TYPE(ARRAYOF_TYPE) :: this
122 arrayof_origtype, INTENT(in) :: content
123 LOGICAL, INTENT(in) :: incr
124 LOGICAL, INTENT(in) :: back
125 
126 INTEGER :: pos
127 
128 IF (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
138 ELSE
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
148 ENDIF
149 
150 CALL insert(this, (/content/), pos=pos)
151 
152 END FUNCTION ARRAYOF_TYPE/**/_insert_sorted
153 #endif
154 #endif
155 
156 
159 SUBROUTINE arrayof_type/**/_remove(this, nelem, pos &
160 #ifdef ARRAYOF_ORIGDESTRUCTOR
161  , nodestroy &
162 #endif
163 )
164 TYPE(ARRAYOF_TYPE) :: this
165 INTEGER, INTENT(in), OPTIONAL :: nelem
166 INTEGER, INTENT(in), OPTIONAL :: pos
167 #ifdef ARRAYOF_ORIGDESTRUCTOR
168 
172 LOGICAL, INTENT(in), OPTIONAL :: nodestroy
173 #endif
174 
175 INTEGER :: i, n, p
176 #ifdef ARRAYOF_ORIGDESTRUCTOR
177 LOGICAL :: destroy
178 #endif
179 
180 IF (this%arraysize <= 0) RETURN ! nothing to do
181 IF (PRESENT(nelem)) THEN ! explicit size
182  n = nelem
183  IF (n <= 0) RETURN ! nothing to do
184 ELSE ! default remove one element
185  n = 1
186 ENDIF
187 
188 IF (PRESENT(pos)) THEN ! clip p
189  p = max(1, min(pos, this%arraysize-n+1))
190 ELSE ! pos not provided, cut at the end
191  p = this%arraysize - n + 1
192 ENDIF
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
199 destroy = .true.
200 IF (PRESENT(nodestroy)) THEN
201  destroy = .NOT.nodestroy
202 ENDIF
203 IF (destroy) THEN
204  DO i = p, p+n-1
205  arrayof_origdestructor(this%array(i))
206  ENDDO
207 ENDIF
208 #endif
209 
210 this%arraysize = this%arraysize - n
211 DO i = p, this%arraysize ! push the elements backward starting from p
212  this%array(i) = this%array(i+n)
213 ENDDO
214 CALL arrayof_type/**/_alloc(this) ! release space if possible
215 
216 END SUBROUTINE ARRAYOF_TYPE/**/_remove
217 
218 
222 SUBROUTINE arrayof_type/**/_delete(this, &
223 #ifdef ARRAYOF_ORIGDESTRUCTOR
224  nodestroy, &
225 #endif
226  nodealloc)
227 TYPE(ARRAYOF_TYPE) :: this
228 #ifdef ARRAYOF_ORIGDESTRUCTOR
229 
233 LOGICAL, INTENT(in), OPTIONAL :: nodestroy
234 #endif
235 
241 LOGICAL, INTENT(in), OPTIONAL :: nodealloc
242 
243 TYPE(ARRAYOF_TYPE) :: empty
244 
245 #ifdef ARRAYOF_ORIGDESTRUCTOR
246 INTEGER :: i
247 LOGICAL :: destroy
248 #endif
249 LOGICAL :: dealloc
250 
251 #ifdef DEBUG
252 !PRINT*,'ARRAYOF: destroying ',this%arraysize
253 #endif
254 IF (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
275 ENDIF
276 ! give empty values
277 this=empty
278 
279 END SUBROUTINE ARRAYOF_TYPE/**/_delete
280 
281 
288 SUBROUTINE arrayof_type/**/_packarray(this)
289 TYPE(ARRAYOF_TYPE) :: this
290 
291 DOUBLE PRECISION :: tmpoveralloc
292 
293 #ifdef DEBUG
294 !PRINT*,'ARRAYOF: packing ',this%arraysize
295 #endif
296 tmpoveralloc = this%overalloc ! save value
297 this%overalloc = 1.0d0
298 CALL arrayof_type/**/_alloc(this) ! reallocate exact size
299 this%overalloc = tmpoveralloc
300 
301 END SUBROUTINE ARRAYOF_TYPE/**/_packarray
302 
303 
304 SUBROUTINE arrayof_type/**/_alloc(this)
305 TYPE(ARRAYOF_TYPE) :: this
306 
307 arrayof_origtype, POINTER :: tmpptr(:)
308 INTEGER :: newsize, copysize
309 
310 newsize = max(int(this%arraysize*this%overalloc), this%arraysize)
311 
312 IF (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
325 ELSE ! 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))
330 ENDIF
331 
332 END SUBROUTINE ARRAYOF_TYPE/**/_alloc

Generated with Doxygen.