ViewVC Help
View File | Revision Log | Show Annotations | View Changeset | Root Listing
root/group/trunk/OOPSE_old/src/mdtools/libmdCode/vector_class.F90
Revision: 313
Committed: Tue Mar 11 18:51:05 2003 UTC (21 years, 4 months ago) by gezelter
File size: 17575 byte(s)
Log Message:
Did a bunch of match/find routines

File Contents

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