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 |
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 |
51 |
|
integer :: PropertyIncrement = 0 |
52 |
|
integer :: propertyCount = 0 |
53 |
|
|
54 |
< |
integer, pointer :: ElementData(:) |
55 |
< |
character(len=100), pointer :: PropertyDescriptions(:) |
56 |
< |
integer, pointer :: PropertyDataType(:) |
57 |
< |
real(kind = 8), pointer :: realElementProperties(:,:) |
58 |
< |
integer, pointer :: integerElementProperties(:,:) |
59 |
< |
logical, pointer :: logicalElementProperties(:,:) |
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 |
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) |
117 |
|
pn = this%PropertyDescriptions(loc) |
118 |
|
end function getPropertyNameAt |
119 |
|
|
120 |
< |
|
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=8) :: pv |
283 |
> |
real( kind = dp ) :: pv |
284 |
|
|
285 |
|
whichprop = getPropertyIndex(this, PropName) |
286 |
|
if (whichprop .eq. 0 ) then |
439 |
|
type(Vector), pointer :: this |
440 |
|
integer :: id, i |
441 |
|
character(len=*), intent(in) :: PropName |
442 |
< |
real( kind=8 ), intent(in) :: PropValue |
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 |
537 |
|
integer :: error |
538 |
|
type(Vector), pointer :: this |
539 |
|
nullify(this) |
540 |
< |
if (cap .lt. 0) then |
540 |
> |
if (cap < 0) then |
541 |
|
write(*,*) 'Bogus Capacity:', cap |
542 |
|
stop |
543 |
|
endif |
544 |
< |
if (nprop .lt. 0) then |
544 |
> |
if (nprop < 0) then |
545 |
|
write(*,*) 'Bogus Number of Properties:', nprop |
546 |
|
stop |
547 |
|
endif |
555 |
|
this%propertyIncrement = propinc |
556 |
|
|
557 |
|
allocate(this%elementData(this%initialCapacity), stat=error) |
558 |
< |
if(error .ne. 0) write(*,*) 'Could not allocate elementData!' |
558 |
> |
if(error /= 0) write(*,*) 'Could not allocate elementData!' |
559 |
|
|
560 |
|
allocate(this%PropertyDescriptions(this%initialProperties), & |
561 |
|
stat=error) |
562 |
< |
if(error .ne. 0) write(*,*) 'Could not allocate PropertyDescriptions!' |
562 |
> |
if(error /= 0) write(*,*) 'Could not allocate PropertyDescriptions!' |
563 |
|
|
564 |
|
allocate(this%integerElementProperties(this%initialCapacity, & |
565 |
|
this%initialProperties), stat=error) |
566 |
< |
if(error .ne. 0) write(*,*) 'Could not allocate integerElementProperties!' |
566 |
> |
if(error /= 0) write(*,*) 'Could not allocate integerElementProperties!' |
567 |
|
|
568 |
|
allocate(this%realElementProperties(this%initialCapacity, & |
569 |
|
this%initialProperties), stat=error) |
570 |
< |
if(error .ne. 0) write(*,*) 'Could not allocate realElementProperties!' |
570 |
> |
if(error /= 0) write(*,*) 'Could not allocate realElementProperties!' |
571 |
|
|
572 |
|
allocate(this%logicalElementProperties(this%initialCapacity, & |
573 |
|
this%initialProperties), stat=error) |