libsim  Versione6.3.0
arrayof_post_nodoc.F90
1 #ifndef ARRAYOF_TYPE
2 #define ARRAYOF_TYPE arrayof_/**/ARRAYOF_ORIGTYPE
3 #endif
4 
5 
6 
7 
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 
46 
47 
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 
58 
59 
60 
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 
76 
77 
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 
94 
95 
96 
97 
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 
117 
118 
119 
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 
157 
158 
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 LOGICAL, INTENT(in), OPTIONAL :: nodestroy
169 #endif
170 
171 INTEGER :: i, n, p
172 #ifdef ARRAYOF_ORIGDESTRUCTOR
173 LOGICAL :: destroy
174 #endif
175 
176 IF (this%arraysize <= 0) RETURN ! nothing to do
177 IF (PRESENT(nelem)) THEN ! explicit size
178  n = nelem
179  IF (n <= 0) RETURN ! nothing to do
180 ELSE ! default remove one element
181  n = 1
182 ENDIF
183 
184 IF (PRESENT(pos)) THEN ! clip p
185  p = max(1, min(pos, this%arraysize-n+1))
186 ELSE ! pos not provided, cut at the end
187  p = this%arraysize - n + 1
188 ENDIF
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
195 destroy = .true.
196 IF (PRESENT(nodestroy)) THEN
197  destroy = .NOT.nodestroy
198 ENDIF
199 IF (destroy) THEN
200  DO i = p, p+n-1
201  arrayof_origdestructor(this%array(i))
202  ENDDO
203 ENDIF
204 #endif
205 
206 this%arraysize = this%arraysize - n
207 DO i = p, this%arraysize ! push the elements backward starting from p
208  this%array(i) = this%array(i+n)
209 ENDDO
210 CALL arrayof_type/**/_alloc(this) ! release space if possible
211 
212 END SUBROUTINE ARRAYOF_TYPE/**/_remove
213 
214 
215 
216 
217 
218 SUBROUTINE arrayof_type/**/_delete(this, &
219 #ifdef ARRAYOF_ORIGDESTRUCTOR
220  nodestroy, &
221 #endif
222  nodealloc)
223 TYPE(ARRAYOF_TYPE) :: this
224 #ifdef ARRAYOF_ORIGDESTRUCTOR
225 LOGICAL, INTENT(in), OPTIONAL :: nodestroy
226 #endif
227 LOGICAL, INTENT(in), OPTIONAL :: nodealloc
228 
229 TYPE(ARRAYOF_TYPE) :: empty
230 
231 #ifdef ARRAYOF_ORIGDESTRUCTOR
232 INTEGER :: i
233 LOGICAL :: destroy
234 #endif
235 LOGICAL :: dealloc
236 
237 #ifdef DEBUG
238 !PRINT*,'ARRAYOF: destroying ',this%arraysize
239 #endif
240 IF (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
261 ENDIF
262 ! give empty values
263 this=empty
264 
265 END SUBROUTINE ARRAYOF_TYPE/**/_delete
266 
267 
268 
269 
270 
271 
272 
273 
274 SUBROUTINE arrayof_type/**/_packarray(this)
275 TYPE(ARRAYOF_TYPE) :: this
276 
277 DOUBLE PRECISION :: tmpoveralloc
278 
279 #ifdef DEBUG
280 !PRINT*,'ARRAYOF: packing ',this%arraysize
281 #endif
282 tmpoveralloc = this%overalloc ! save value
283 this%overalloc = 1.0d0
284 CALL arrayof_type/**/_alloc(this) ! reallocate exact size
285 this%overalloc = tmpoveralloc
286 
287 END SUBROUTINE ARRAYOF_TYPE/**/_packarray
288 
289 
290 SUBROUTINE arrayof_type/**/_alloc(this)
291 TYPE(ARRAYOF_TYPE) :: this
292 
293 arrayof_origtype, POINTER :: tmpptr(:)
294 INTEGER :: newsize, copysize
295 
296 newsize = max(int(this%arraysize*this%overalloc), this%arraysize)
297 
298 IF (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
311 ELSE ! 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))
316 ENDIF
317 
318 END SUBROUTINE ARRAYOF_TYPE/**/_alloc

Generated with Doxygen.