1 |
! vector_class.F90 |
2 |
!! Module Vector_class |
3 |
!! Fortran 95 Vector class module. Similar to java.util vector class. |
4 |
!! |
5 |
!! The Vector class implements a growable array of objects. Like an array, |
6 |
!! it contains components that can be accessed using an integer index. However, |
7 |
!! the size of a Vector can grow as needed to accommodate |
8 |
!! adding and removing items after the Vector has been created. |
9 |
!! Each vector tries to optimize storage management by maintaining a capacity and a |
10 |
!! capacityIncrement. The capacity is always at least as large as the vector size; |
11 |
!! it is usually larger because as components are added to the vector, |
12 |
!! the vector's storage increases in chunks the size of capacityIncrement. |
13 |
!! An application can increase the capacity of a vector before inserting a large number |
14 |
!! of components; this reduces the amount of incremental reallocation. |
15 |
!! |
16 |
!! |
17 |
!! @author J. Daniel Gezelter |
18 |
!! @author Charles F. Vardeman II |
19 |
!! @author Matthew Meineke |
20 |
!! @version $Id: vector_class.F90,v 1.4 2003-03-11 20:15:18 chuckv Exp $, $Date: 2003-03-11 20:15:18 $, $Name: not supported by cvs2svn $, $Revision: 1.4 $ |
21 |
|
22 |
module Vector_class |
23 |
|
24 |
implicit NONE |
25 |
PRIVATE |
26 |
|
27 |
public :: initialize |
28 |
public :: getSize |
29 |
public :: getElementAt |
30 |
public :: getPropertyListSize |
31 |
public :: getPropertyNameAt |
32 |
public :: addElement |
33 |
public :: setElementProperty |
34 |
public :: getElementProperty |
35 |
public :: getMatchingElementList |
36 |
public :: getFirstMatchingElement |
37 |
|
38 |
integer, parameter :: logical_data_type = 1 |
39 |
integer, parameter :: integer_data_type = 2 |
40 |
integer, parameter :: real_data_type = 3 |
41 |
|
42 |
integer :: dp = selected_real_kind(8) |
43 |
!! |
44 |
type, public :: Vector |
45 |
PRIVATE |
46 |
integer :: initialCapacity = 10 |
47 |
integer :: capacityIncrement = 0 |
48 |
integer :: elementCount = 0 |
49 |
|
50 |
integer :: initialProperties = 5 |
51 |
integer :: PropertyIncrement = 0 |
52 |
integer :: propertyCount = 0 |
53 |
|
54 |
integer, pointer :: ElementData(:) => null() |
55 |
character(len=100), pointer :: PropertyDescriptions(:) => null() |
56 |
integer, pointer :: PropertyDataType(:) => null() |
57 |
real(kind = dp), pointer :: realElementProperties(:,:) => null() |
58 |
integer, pointer :: integerElementProperties(:,:) => null() |
59 |
logical, pointer :: logicalElementProperties(:,:) => null() |
60 |
end type Vector |
61 |
|
62 |
!! Initialize vector |
63 |
interface initialize |
64 |
module procedure initialize_0i |
65 |
module procedure initialize_1i |
66 |
module procedure initialize_2i |
67 |
module procedure initialize_3i |
68 |
module procedure initialize_4i |
69 |
end interface |
70 |
|
71 |
interface setElementProperty |
72 |
module procedure setElementPropertyReal |
73 |
module procedure setElementPropertyInt |
74 |
module procedure setElementPropertyLogical |
75 |
end interface |
76 |
|
77 |
interface getElementProperty |
78 |
module procedure getElementPropertyReal |
79 |
module procedure getElementPropertyInt |
80 |
module procedure getElementPropertyLogical |
81 |
end interface |
82 |
|
83 |
interface getMatchingElementList |
84 |
module procedure getMatchingElementList1i |
85 |
module procedure getMatchingElementList2i |
86 |
end interface |
87 |
|
88 |
interface getFirstMatchingElement |
89 |
module procedure getFirstMatchingElement1i |
90 |
module procedure getFirstMatchingElement2i |
91 |
end interface |
92 |
contains |
93 |
|
94 |
function getSize(this) result (ne) |
95 |
type(Vector), pointer :: this |
96 |
integer :: ne |
97 |
ne = this%elementCount |
98 |
end function getSize |
99 |
|
100 |
function getElementAt(this, loc) result (id) |
101 |
type(Vector), pointer :: this |
102 |
integer, intent(in) :: loc |
103 |
integer :: id |
104 |
id = this%ElementData(loc) |
105 |
end function getElementAt |
106 |
|
107 |
function getPropertyListSize(this) result (np) |
108 |
type(Vector), pointer :: this |
109 |
integer :: np |
110 |
np = this%propertyCount |
111 |
end function getPropertyListSize |
112 |
|
113 |
function getPropertyNameAt(this, loc) result (pn) |
114 |
type(Vector), pointer :: this |
115 |
integer, intent(in) :: loc |
116 |
character(len=len(this%PropertyDescriptions)) :: pn |
117 |
pn = this%PropertyDescriptions(loc) |
118 |
end function getPropertyNameAt |
119 |
|
120 |
function getFirstMatchingElement1i(this, MatchName, MatchValue) result (id) |
121 |
type(Vector), pointer :: this |
122 |
character(len=*), intent(in) :: MatchName |
123 |
integer, intent(in) :: MatchValue |
124 |
integer :: id |
125 |
integer :: i, j |
126 |
|
127 |
id = 0 |
128 |
|
129 |
do i = 1, this%propertyCount |
130 |
if (this%PropertyDescriptions(i) == MatchName) then |
131 |
do j = 1, this%elementCount |
132 |
if (this%integerElementProperties(j, i) == MatchValue) then |
133 |
id = j |
134 |
return |
135 |
endif |
136 |
enddo |
137 |
endif |
138 |
enddo |
139 |
return |
140 |
end function getFirstMatchingElement1i |
141 |
|
142 |
function getFirstMatchingElement2i(this, MatchName1, MatchValue1, & |
143 |
MatchName2, MatchValue2) result (id) |
144 |
type(Vector), pointer :: this |
145 |
character(len=*), intent(in) :: MatchName1, MatchName2 |
146 |
integer, intent(in) :: MatchValue1, MatchValue2 |
147 |
integer :: id |
148 |
integer :: i, j, MatchID1, MatchID2 |
149 |
logical :: found1 = .false. |
150 |
logical :: found2 = .false. |
151 |
|
152 |
id = 0 |
153 |
! first figure out which properties we are using to do the match: |
154 |
|
155 |
do i = 1, this%propertyCount |
156 |
if (this%PropertyDescriptions(i) == MatchName1) then |
157 |
MatchID1 = i |
158 |
found1 = .true. |
159 |
endif |
160 |
if (this%PropertyDescriptions(i) == MatchName2) then |
161 |
MatchID2 = i |
162 |
found2 = .true. |
163 |
endif |
164 |
|
165 |
if (found1.and.found2) then |
166 |
do j = 1, this%elementCount |
167 |
if ((this%integerElementProperties(j, MatchID1) == MatchValue1) & |
168 |
.and. & |
169 |
(this%integerElementProperties(j, MatchID2) ==MatchValue2)) & |
170 |
then |
171 |
id = j |
172 |
return |
173 |
endif |
174 |
enddo |
175 |
endif |
176 |
end do |
177 |
|
178 |
return |
179 |
end function getFirstMatchingElement2i |
180 |
|
181 |
|
182 |
subroutine getMatchingElementList1i(this, MatchName, MatchValue, & |
183 |
nMatches, MatchList) |
184 |
type(Vector), pointer :: this |
185 |
character(len=*), intent(in) :: MatchName |
186 |
integer, intent(in) :: MatchValue |
187 |
integer, intent(out) :: nMatches |
188 |
integer, pointer :: MatchList |
189 |
integer :: i |
190 |
|
191 |
! first figure out which property we are using to do the match: |
192 |
|
193 |
do i = 1, this%propertyCount |
194 |
if (this%PropertyDescriptions(i) == MatchName) then |
195 |
call getMatches1(this, i, MatchValue, MatchList) |
196 |
return |
197 |
endif |
198 |
enddo |
199 |
return |
200 |
end subroutine getMatchingElementList1i |
201 |
|
202 |
subroutine getMatchingElementList2i(this, MatchName1, MatchValue1, & |
203 |
MatchName2, MatchValue2, nMatches, MatchList) |
204 |
type(Vector), pointer :: this |
205 |
character(len=*), intent(in) :: MatchName1, MatchName2 |
206 |
integer, intent(in) :: MatchValue1, MatchValue2 |
207 |
integer, intent(out) :: nMatches |
208 |
integer, pointer :: MatchList(:) |
209 |
integer :: i, MatchID1, MatchID2 |
210 |
logical :: found1 = .false. |
211 |
logical :: found2 = .false. |
212 |
|
213 |
! first figure out which properties we are using to do the match: |
214 |
|
215 |
do i = 1, this%propertyCount |
216 |
if (this%PropertyDescriptions(i) == MatchName1) then |
217 |
MatchID1 = i |
218 |
found1 = .true. |
219 |
endif |
220 |
if (this%PropertyDescriptions(i) == MatchName2) then |
221 |
MatchID2 = i |
222 |
found2 = .true. |
223 |
endif |
224 |
|
225 |
if (found1.and.found2) then |
226 |
call getAllMatches2i(this, MatchID1, MatchValue1, & |
227 |
MatchID2, MatchValue2, nMatches, MatchList) |
228 |
return |
229 |
endif |
230 |
enddo |
231 |
return |
232 |
end subroutine getMatchingElementList2i |
233 |
|
234 |
subroutine getAllMatches1i(this, MatchID, MatchValue, nMatches, MatchList) |
235 |
type(Vector), pointer :: this |
236 |
integer, intent(in) :: MatchID |
237 |
integer, intent(in) :: MatchValue |
238 |
integer, pointer :: MatchList(:) |
239 |
integer, intent(out) :: nMatches |
240 |
integer :: error, i |
241 |
|
242 |
allocate(MatchList(this%elementCount), stat=error) |
243 |
if(error .ne. 0) write(*,*) 'Could not allocate MatchList!' |
244 |
|
245 |
nMatches = 0 |
246 |
|
247 |
do i = 1, this%elementCount |
248 |
if (this%integerElementProperties(i, MatchID) == MatchValue) then |
249 |
nMatches = nMatches + 1 |
250 |
MatchList(nMatches) = i |
251 |
endif |
252 |
enddo |
253 |
end subroutine getAllMatches1i |
254 |
|
255 |
subroutine getAllMatches2i(this, MatchID1, MatchValue1, & |
256 |
MatchID2, MatchValue2, nMatches, MatchList) |
257 |
type(Vector), pointer :: this |
258 |
integer, intent(in) :: MatchID1, MatchID2 |
259 |
integer, intent(in) :: MatchValue1, MatchValue2 |
260 |
integer, pointer :: MatchList(:) |
261 |
integer, intent(out) :: nMatches |
262 |
integer :: error, i |
263 |
|
264 |
allocate(MatchList(this%elementCount), stat=error) |
265 |
if(error .ne. 0) write(*,*) 'Could not allocate MatchList!' |
266 |
|
267 |
nMatches = 0 |
268 |
|
269 |
do i = 1, this%elementCount |
270 |
if ((this%integerElementProperties(i, MatchID1) == MatchValue1) .and. & |
271 |
(this%integerElementProperties(i, MatchID2) == MatchValue2)) then |
272 |
nMatches = nMatches + 1 |
273 |
MatchList(nMatches) = i |
274 |
endif |
275 |
enddo |
276 |
end subroutine getAllMatches2i |
277 |
|
278 |
|
279 |
subroutine getElementPropertyReal(this, id, PropName, pv) |
280 |
type(Vector), pointer :: this |
281 |
integer :: id, whichprop |
282 |
character(len=*) :: PropName |
283 |
real( kind = dp ) :: pv |
284 |
|
285 |
whichprop = getPropertyIndex(this, PropName) |
286 |
if (whichprop .eq. 0 ) then |
287 |
write(*,*) 'unknown property!' |
288 |
pv = 0.0 |
289 |
else |
290 |
if (this%PropertyDataType(whichprop) .ne. real_data_type) then |
291 |
write(*,*) 'wrong data type for this property!' |
292 |
pv = 0.0 |
293 |
else |
294 |
pv = this%realElementProperties(id, whichprop) |
295 |
endif |
296 |
endif |
297 |
end subroutine getElementPropertyReal |
298 |
|
299 |
subroutine getElementPropertyInt(this, id, PropName, pv) |
300 |
type(Vector), pointer :: this |
301 |
integer :: id, whichprop |
302 |
character(len=*) :: PropName |
303 |
integer :: pv |
304 |
|
305 |
whichprop = getPropertyIndex(this, PropName) |
306 |
if (whichprop .eq. 0 ) then |
307 |
write(*,*) 'unknown property!' |
308 |
pv = 0 |
309 |
else |
310 |
if (this%PropertyDataType(whichprop) .ne. integer_data_type) then |
311 |
write(*,*) 'wrong data type for this property!' |
312 |
pv = 0 |
313 |
else |
314 |
pv = this%integerElementProperties(id, whichprop) |
315 |
endif |
316 |
endif |
317 |
end subroutine getElementPropertyInt |
318 |
|
319 |
subroutine getElementPropertyLogical(this, id, PropName, pv) |
320 |
type(Vector), pointer :: this |
321 |
integer :: id, whichprop |
322 |
character(len=*) :: PropName |
323 |
logical :: pv |
324 |
|
325 |
whichprop = getPropertyIndex(this, PropName) |
326 |
if (whichprop .eq. 0 ) then |
327 |
write(*,*) 'unknown property!' |
328 |
pv = .false. |
329 |
else |
330 |
if (this%PropertyDataType(whichprop) .ne. logical_data_type) then |
331 |
write(*,*) 'wrong data type for this property!' |
332 |
pv = .false. |
333 |
else |
334 |
pv = this%logicalElementProperties(id, whichprop) |
335 |
endif |
336 |
endif |
337 |
end subroutine getElementPropertyLogical |
338 |
|
339 |
function getPropertyIndex(this, PropName) result (id) |
340 |
type(Vector), pointer :: this |
341 |
integer :: id, i |
342 |
character(len=*) :: PropName |
343 |
|
344 |
do i = 1, this%propertyCount |
345 |
if (this%PropertyDescriptions(i) == PropName) then |
346 |
id = i |
347 |
return |
348 |
endif |
349 |
enddo |
350 |
id = 0 |
351 |
end function getPropertyIndex |
352 |
|
353 |
subroutine ensureCapacityHelper(this, minCapacity, minPropCap) |
354 |
type(Vector), pointer :: this, that |
355 |
integer, intent(in) :: minCapacity, minPropCap |
356 |
integer :: oldCapacity, oldPropCap |
357 |
integer :: newCapacity, newPropCap |
358 |
logical :: resizeFlag = .false. |
359 |
|
360 |
oldCapacity = size(this%ElementData) |
361 |
oldPropCap = size(this%PropertyDescriptions) |
362 |
|
363 |
if (minCapacity > oldCapacity) then |
364 |
if (this%capacityIncrement .gt. 0) then |
365 |
newCapacity = oldCapacity + this%capacityIncrement |
366 |
else |
367 |
newCapacity = oldCapacity * 2 |
368 |
endif |
369 |
if (newCapacity .lt. minCapacity) then |
370 |
newCapacity = minCapacity |
371 |
endif |
372 |
resizeFlag = .true. |
373 |
endif |
374 |
|
375 |
if (minPropCap > oldPropCap) then |
376 |
if (this%PropertyIncrement .gt. 0) then |
377 |
newPropCap = oldPropCap + this%PropertyIncrement |
378 |
else |
379 |
newPropCap = oldPropCap * 2 |
380 |
endif |
381 |
if (newPropCap .lt. minPropCap) then |
382 |
newPropCap = minPropCap |
383 |
endif |
384 |
resizeFlag = .true. |
385 |
endif |
386 |
|
387 |
if (resizeFlag) then |
388 |
that = initialize(newCapacity, newPropCap, & |
389 |
this%capacityIncrement, this%PropertyIncrement) |
390 |
call copyAllData(this, that) |
391 |
deallocate(this) |
392 |
this => that |
393 |
endif |
394 |
end subroutine ensureCapacityHelper |
395 |
|
396 |
subroutine copyAllData(v1, v2) |
397 |
type(Vector), pointer :: v1 |
398 |
type(Vector), pointer :: v2 |
399 |
integer :: i, j |
400 |
|
401 |
do i = 1, v1%elementCount |
402 |
v2%elementData(i) = v1%elementData(i) |
403 |
do j = 1, v1%propertyCount |
404 |
|
405 |
if (v1%PropertyDataType(j) .eq. integer_data_type) & |
406 |
v2%integerElementProperties(i,j) = & |
407 |
v1%integerElementProperties(i,j) |
408 |
|
409 |
if (v1%PropertyDataType(j) .eq. real_data_type) & |
410 |
v2%realElementProperties(i,j) = v1%realElementProperties(i,j) |
411 |
|
412 |
if (v1%PropertyDataType(j) .eq. logical_data_type) & |
413 |
v2%logicalElementProperties(i,j) = & |
414 |
v1%logicalElementProperties(i,j) |
415 |
enddo |
416 |
enddo |
417 |
|
418 |
do j = 1, v1%propertyCount |
419 |
v2%PropertyDescriptions(j) = v1%PropertyDescriptions(j) |
420 |
v2%PropertyDataType(j) = v1%PropertyDataType(j) |
421 |
enddo |
422 |
|
423 |
v2%elementCount = v1%elementCount |
424 |
v2%propertyCount = v1%propertyCount |
425 |
|
426 |
return |
427 |
end subroutine copyAllData |
428 |
|
429 |
function addElement(this) result (id) |
430 |
type(Vector), pointer :: this |
431 |
integer :: id |
432 |
call ensureCapacityHelper(this, this%elementCount + 1, this%PropertyCount) |
433 |
this%elementCount = this%elementCount + 1 |
434 |
this%elementData = this%elementCount |
435 |
id = this%elementCount |
436 |
end function addElement |
437 |
|
438 |
recursive subroutine setElementPropertyReal(this, id, PropName, PropValue) |
439 |
type(Vector), pointer :: this |
440 |
integer :: id, i |
441 |
character(len=*), intent(in) :: PropName |
442 |
real( kind = dp ), intent(in) :: PropValue |
443 |
logical :: foundit = .false. |
444 |
! first make sure that the PropName isn't in the list of known properties: |
445 |
do i = 1, this%propertyCount |
446 |
if (PropName == this%PropertyDescriptions(i)) then |
447 |
foundit = .true. |
448 |
this%realElementProperties(id,i) = PropValue |
449 |
endif |
450 |
enddo |
451 |
|
452 |
if (.not.foundit) then |
453 |
call addPropertyToVector(this, PropName, real_data_type) |
454 |
call setElementPropertyReal(this, id, PropName, PropValue) |
455 |
endif |
456 |
end subroutine setElementPropertyReal |
457 |
|
458 |
recursive subroutine setElementPropertyInt(this, id, PropName, PropValue) |
459 |
type(Vector), pointer :: this |
460 |
integer :: id, i |
461 |
character(len=*), intent(in) :: PropName |
462 |
integer, intent(in) :: PropValue |
463 |
logical :: foundit = .false. |
464 |
! first make sure that the PropName isn't in the list of known properties: |
465 |
do i = 1, this%propertyCount |
466 |
if (PropName == this%PropertyDescriptions(i)) then |
467 |
foundit = .true. |
468 |
this%integerElementProperties(id,i) = PropValue |
469 |
endif |
470 |
enddo |
471 |
|
472 |
if (.not.foundit) then |
473 |
call addPropertyToVector(this, PropName, integer_data_type) |
474 |
call setElementPropertyInt(this, id, PropName, PropValue) |
475 |
endif |
476 |
end subroutine setElementPropertyInt |
477 |
|
478 |
recursive subroutine setElementPropertyLogical(this, id, PropName, PropValue) |
479 |
type(Vector), pointer :: this |
480 |
integer :: id, i |
481 |
character(len=*), intent(in) :: PropName |
482 |
logical, intent(in) :: PropValue |
483 |
logical :: foundit = .false. |
484 |
! first make sure that the PropName isn't in the list of known properties: |
485 |
do i = 1, this%propertyCount |
486 |
if (PropName == this%PropertyDescriptions(i)) then |
487 |
foundit = .true. |
488 |
this%logicalElementProperties(id,i) = PropValue |
489 |
endif |
490 |
enddo |
491 |
|
492 |
if (.not.foundit) then |
493 |
call addPropertyToVector(this, PropName, logical_data_type) |
494 |
call setElementPropertyLogical(this, id, PropName, PropValue) |
495 |
endif |
496 |
end subroutine setElementPropertyLogical |
497 |
|
498 |
subroutine addPropertyToVector(this, PropName, data_type) |
499 |
type(Vector), pointer :: this |
500 |
character(len=*), intent(in) :: PropName |
501 |
integer data_type |
502 |
call ensureCapacityHelper(this, this%elementCount, this%propertyCount + 1) |
503 |
this%propertyCount = this%propertyCount + 1 |
504 |
this%PropertyDescriptions(this%propertyCount) = PropName |
505 |
this%PropertyDataType(this%propertyCount) = data_type |
506 |
end subroutine addPropertyToVector |
507 |
|
508 |
function initialize_0i() result(this) |
509 |
type(Vector), pointer :: this |
510 |
nullify(this) |
511 |
this = initialize_2i(10, 5) |
512 |
end function initialize_0i |
513 |
|
514 |
function initialize_1i(nprop) result(this) |
515 |
integer, intent(in) :: nprop |
516 |
type(Vector), pointer :: this |
517 |
nullify(this) |
518 |
this = initialize_2i(10, nprop) |
519 |
end function initialize_1i |
520 |
|
521 |
function initialize_2i(cap, nprop) result(this) |
522 |
integer, intent(in) :: cap, nprop |
523 |
type(Vector), pointer :: this |
524 |
nullify(this) |
525 |
this = initialize_4i(cap, nprop, 0, 0) |
526 |
end function initialize_2i |
527 |
|
528 |
function initialize_3i(cap, nprop, capinc) result(this) |
529 |
integer, intent(in) :: cap, nprop, capinc |
530 |
type(Vector), pointer :: this |
531 |
nullify(this) |
532 |
this = initialize_4i(cap, nprop, capinc, 0) |
533 |
end function initialize_3i |
534 |
|
535 |
function initialize_4i(cap, nprop, capinc, propinc) result(this) |
536 |
integer, intent(in) :: cap, nprop, capinc, propinc |
537 |
integer :: error |
538 |
type(Vector), pointer :: this |
539 |
nullify(this) |
540 |
if (cap < 0) then |
541 |
write(*,*) 'Bogus Capacity:', cap |
542 |
stop |
543 |
endif |
544 |
if (nprop < 0) then |
545 |
write(*,*) 'Bogus Number of Properties:', nprop |
546 |
stop |
547 |
endif |
548 |
|
549 |
allocate(this, stat=error) |
550 |
if(error .ne. 0) write(*,*) 'Could not allocate Vector!' |
551 |
|
552 |
this%initialCapacity = cap |
553 |
this%initialProperties = nprop |
554 |
this%capacityIncrement = capinc |
555 |
this%propertyIncrement = propinc |
556 |
|
557 |
allocate(this%elementData(this%initialCapacity), stat=error) |
558 |
if(error /= 0) write(*,*) 'Could not allocate elementData!' |
559 |
|
560 |
allocate(this%PropertyDescriptions(this%initialProperties), & |
561 |
stat=error) |
562 |
if(error /= 0) write(*,*) 'Could not allocate PropertyDescriptions!' |
563 |
|
564 |
allocate(this%integerElementProperties(this%initialCapacity, & |
565 |
this%initialProperties), stat=error) |
566 |
if(error /= 0) write(*,*) 'Could not allocate integerElementProperties!' |
567 |
|
568 |
allocate(this%realElementProperties(this%initialCapacity, & |
569 |
this%initialProperties), stat=error) |
570 |
if(error /= 0) write(*,*) 'Could not allocate realElementProperties!' |
571 |
|
572 |
allocate(this%logicalElementProperties(this%initialCapacity, & |
573 |
this%initialProperties), stat=error) |
574 |
if(error .ne. 0) write(*,*) 'Could not allocate logicalElementProperties!' |
575 |
end function initialize_4i |
576 |
|
577 |
|
578 |
|
579 |
|
580 |
|
581 |
|
582 |
end module Vector_class |