60 |
|
!! @author J. Daniel Gezelter |
61 |
|
!! @author Charles F. Vardeman II |
62 |
|
!! @author Matthew Meineke |
63 |
< |
!! @version $Id: vector_class.F90,v 1.6 2005-04-12 21:28:07 gezelter Exp $, $Date: 2005-04-12 21:28:07 $, $Name: not supported by cvs2svn $, $Revision: 1.6 $ |
63 |
> |
!! @version $Id: vector_class.F90,v 1.7 2005-04-15 22:03:59 gezelter Exp $, $Date: 2005-04-15 22:03:59 $, $Name: not supported by cvs2svn $, $Revision: 1.7 $ |
64 |
|
|
65 |
|
module Vector_class |
66 |
< |
|
66 |
> |
|
67 |
|
implicit NONE |
68 |
|
PRIVATE |
69 |
< |
|
69 |
> |
|
70 |
|
public :: initialize |
71 |
|
public :: destroy |
72 |
|
public :: getSize |
78 |
|
public :: getElementProperty |
79 |
|
public :: getMatchingElementList |
80 |
|
public :: getFirstMatchingElement |
81 |
– |
|
81 |
|
|
82 |
+ |
|
83 |
|
integer, parameter :: logical_data_type = 1 |
84 |
|
integer, parameter :: integer_data_type = 2 |
85 |
|
integer, parameter :: real_data_type = 3 |
86 |
|
|
87 |
< |
!! |
87 |
> |
!! |
88 |
|
type, public :: Vector |
89 |
|
PRIVATE |
90 |
|
integer :: initialCapacity = 10 |
91 |
|
integer :: capacityIncrement = 0 |
92 |
|
integer :: elementCount = 0 |
93 |
< |
|
93 |
> |
|
94 |
|
integer :: initialProperties = 5 |
95 |
|
integer :: PropertyIncrement = 0 |
96 |
|
integer :: propertyCount = 0 |
97 |
< |
|
97 |
> |
|
98 |
|
integer, pointer :: ElementData(:) => null() |
99 |
|
character(len=100), pointer :: PropertyDescriptions(:) => null() |
100 |
|
integer, pointer :: PropertyDataType(:) => null() |
103 |
|
logical, pointer :: logicalElementProperties(:,:) => null() |
104 |
|
end type Vector |
105 |
|
|
106 |
< |
!! Initialize vector |
106 |
> |
!! Initialize vector |
107 |
|
interface initialize |
108 |
|
module procedure initialize_0i |
109 |
|
module procedure initialize_1i |
171 |
|
integer, intent(in) :: MatchValue |
172 |
|
integer :: id |
173 |
|
integer :: i, j |
174 |
< |
|
174 |
> |
|
175 |
|
id = 0 |
176 |
< |
|
176 |
> |
|
177 |
|
do i = 1, this%propertyCount |
178 |
|
if (this%PropertyDescriptions(i) == MatchName) then |
179 |
|
do j = 1, this%elementCount |
222 |
|
enddo |
223 |
|
endif |
224 |
|
end do |
225 |
< |
|
225 |
> |
|
226 |
|
return |
227 |
|
end function getFirstMatchingElement2i |
228 |
|
|
232 |
|
logical, intent(in) :: MatchValue |
233 |
|
integer :: id |
234 |
|
integer :: i, j |
235 |
< |
|
235 |
> |
|
236 |
|
id = 0 |
237 |
|
|
238 |
|
do i = 1, this%propertyCount |
283 |
|
enddo |
284 |
|
endif |
285 |
|
end do |
286 |
< |
|
286 |
> |
|
287 |
|
return |
288 |
|
end function getFirstMatchingElement2l |
289 |
|
|
317 |
|
integer :: i, MatchID1, MatchID2 |
318 |
|
logical :: found1 = .false. |
319 |
|
logical :: found2 = .false. |
320 |
< |
|
320 |
> |
|
321 |
|
! first figure out which properties we are using to do the match: |
322 |
< |
|
322 |
> |
|
323 |
|
do i = 1, this%propertyCount |
324 |
|
if (this%PropertyDescriptions(i) == MatchName1) then |
325 |
|
MatchID1 = i |
329 |
|
MatchID2 = i |
330 |
|
found2 = .true. |
331 |
|
endif |
332 |
< |
|
332 |
> |
|
333 |
|
if (found1.and.found2) then |
334 |
|
call getAllMatches2i(this, MatchID1, MatchValue1, & |
335 |
|
MatchID2, MatchValue2, nMatches, MatchList) |
369 |
|
integer :: i, MatchID1, MatchID2 |
370 |
|
logical :: found1 = .false. |
371 |
|
logical :: found2 = .false. |
372 |
< |
|
372 |
> |
|
373 |
|
! first figure out which properties we are using to do the match: |
374 |
< |
|
374 |
> |
|
375 |
|
do i = 1, this%propertyCount |
376 |
|
if (this%PropertyDescriptions(i) == MatchName1) then |
377 |
|
MatchID1 = i |
381 |
|
MatchID2 = i |
382 |
|
found2 = .true. |
383 |
|
endif |
384 |
< |
|
384 |
> |
|
385 |
|
if (found1.and.found2) then |
386 |
|
call getAllMatches2l(this, MatchID1, MatchValue1, & |
387 |
|
MatchID2, MatchValue2, nMatches, MatchList) |
390 |
|
enddo |
391 |
|
return |
392 |
|
end subroutine getMatchingElementList2l |
393 |
< |
|
393 |
> |
|
394 |
|
subroutine getAllMatches1i(this, MatchID, MatchValue, nMatches, MatchList) |
395 |
|
type(Vector), pointer :: this |
396 |
|
integer, intent(in) :: MatchID |
399 |
|
integer, allocatable :: MatchListTemp(:) |
400 |
|
integer, intent(out) :: nMatches |
401 |
|
integer :: error, i |
402 |
< |
|
402 |
> |
|
403 |
|
if(associated(MatchList)) deallocate(MatchList) |
404 |
|
MatchList => null() |
405 |
|
|
406 |
|
allocate(MatchListTemp(this%elementCount), stat=error) |
407 |
|
if(error .ne. 0) write(*,*) 'Could not allocate MatchListTemp!' |
408 |
< |
|
408 |
> |
|
409 |
|
nMatches = 0 |
410 |
< |
|
410 |
> |
|
411 |
|
do i = 1, this%elementCount |
412 |
|
if (this%integerElementProperties(i, MatchID) == MatchValue) then |
413 |
|
nMatches = nMatches + 1 |
414 |
|
MatchListTemp(nMatches) = i |
415 |
|
endif |
416 |
|
enddo |
417 |
< |
|
418 |
< |
|
417 |
> |
|
418 |
> |
|
419 |
|
if (nMatches .ne. 0) then |
420 |
|
allocate(MatchList(nMatches), stat=error) |
421 |
|
if (error.ne.0) write(*, *) 'Could not allocate MatchList!' |
423 |
|
MatchList(i) = MatchListTemp(i) |
424 |
|
enddo |
425 |
|
endif |
426 |
< |
|
426 |
> |
|
427 |
|
deallocate(MatchListTemp) |
428 |
– |
|
428 |
|
|
429 |
+ |
|
430 |
|
end subroutine getAllMatches1i |
431 |
|
|
432 |
|
subroutine getAllMatches2i(this, MatchID1, MatchValue1, & |
438 |
|
integer, allocatable :: MatchListTemp(:) |
439 |
|
integer, intent(out) :: nMatches |
440 |
|
integer :: error, i |
441 |
< |
|
441 |
> |
|
442 |
|
if(associated(MatchList)) deallocate(MatchList) |
443 |
|
MatchList => null() |
444 |
|
|
445 |
|
allocate(MatchListTemp(this%elementCount), stat=error) |
446 |
|
if(error .ne. 0) write(*,*) 'Could not allocate MatchListTemp!' |
447 |
< |
|
447 |
> |
|
448 |
|
nMatches = 0 |
449 |
< |
|
449 |
> |
|
450 |
|
do i = 1, this%elementCount |
451 |
|
if ((this%integerElementProperties(i, MatchID1) == MatchValue1) .and. & |
452 |
|
(this%integerElementProperties(i, MatchID2) == MatchValue2)) then |
462 |
|
MatchList(i) = MatchListTemp(i) |
463 |
|
enddo |
464 |
|
endif |
465 |
< |
|
465 |
> |
|
466 |
|
deallocate(MatchListTemp) |
467 |
|
|
468 |
|
end subroutine getAllMatches2i |
475 |
|
integer, allocatable :: MatchListTemp(:) |
476 |
|
integer, intent(out) :: nMatches |
477 |
|
integer :: error, i |
478 |
< |
|
478 |
> |
|
479 |
|
if(associated(MatchList)) deallocate(MatchList) |
480 |
|
MatchList => null() |
481 |
|
|
482 |
|
allocate(MatchListTemp(this%elementCount), stat=error) |
483 |
|
if(error .ne. 0) write(*,*) 'Could not allocate MatchListTemp!' |
484 |
< |
|
484 |
> |
|
485 |
|
nMatches = 0 |
486 |
< |
|
486 |
> |
|
487 |
|
do i = 1, this%elementCount |
488 |
|
if (this%logicalElementProperties(i, MatchID).eqv.MatchValue) then |
489 |
|
nMatches = nMatches + 1 |
498 |
|
MatchList(i) = MatchListTemp(i) |
499 |
|
enddo |
500 |
|
endif |
501 |
< |
|
501 |
> |
|
502 |
|
deallocate(MatchListTemp) |
503 |
|
|
504 |
|
end subroutine getAllMatches1l |
512 |
|
integer, allocatable :: MatchListTemp(:) |
513 |
|
integer, intent(out) :: nMatches |
514 |
|
integer :: error, i |
515 |
< |
|
515 |
> |
|
516 |
|
if(associated(MatchList)) deallocate(MatchList) |
517 |
|
MatchList => null() |
518 |
|
|
519 |
|
allocate(MatchListTemp(this%elementCount), stat=error) |
520 |
|
if(error .ne. 0) write(*,*) 'Could not allocate MatchListTemp!' |
521 |
< |
|
521 |
> |
|
522 |
|
nMatches = 0 |
523 |
< |
|
523 |
> |
|
524 |
|
do i = 1, this%elementCount |
525 |
|
if ((this%logicalElementProperties(i, MatchID1).eqv.MatchValue1) .and. & |
526 |
|
(this%logicalElementProperties(i, MatchID2).eqv.MatchValue2)) then |
536 |
|
MatchList(i) = MatchListTemp(i) |
537 |
|
enddo |
538 |
|
endif |
539 |
< |
|
539 |
> |
|
540 |
|
deallocate(MatchListTemp) |
541 |
|
|
542 |
|
end subroutine getAllMatches2l |
543 |
< |
|
544 |
< |
|
543 |
> |
|
544 |
> |
|
545 |
|
subroutine getElementPropertyReal(this, id, PropName, pv) |
546 |
|
type(Vector), pointer :: this |
547 |
|
integer :: id, whichprop |
548 |
|
character(len=*) :: PropName |
549 |
|
real( kind = 8 ) :: pv |
550 |
< |
|
550 |
> |
|
551 |
|
whichprop = getPropertyIndex(this, PropName) |
552 |
|
if (whichprop .eq. 0 ) then |
553 |
|
write(*,*) 'unknown property: ', PropName |
567 |
|
integer :: id, whichprop |
568 |
|
character(len=*) :: PropName |
569 |
|
integer :: pv |
570 |
< |
|
570 |
> |
|
571 |
|
whichprop = getPropertyIndex(this, PropName) |
572 |
|
if (whichprop .eq. 0 ) then |
573 |
|
write(*,*) 'unknown property! ', PropName |
587 |
|
integer :: id, whichprop |
588 |
|
character(len=*) :: PropName |
589 |
|
logical :: pv |
590 |
< |
|
590 |
> |
|
591 |
|
whichprop = getPropertyIndex(this, PropName) |
592 |
|
if (whichprop .eq. 0 ) then |
593 |
|
write(*,*) 'unknown property! ', PropName |
612 |
|
id = i |
613 |
|
return |
614 |
|
endif |
615 |
< |
enddo |
615 |
> |
enddo |
616 |
|
id = 0 |
617 |
|
end function getPropertyIndex |
618 |
|
|
625 |
|
|
626 |
|
resizeFlag = .false. |
627 |
|
|
628 |
< |
! first time: allocate a new vector with default size |
628 |
> |
! first time: allocate a new vector with default size |
629 |
|
|
630 |
|
if (.not. associated(this)) then |
631 |
|
this => initialize() |
633 |
|
|
634 |
|
oldCapacity = size(this%ElementData) |
635 |
|
oldPropCap = size(this%PropertyDescriptions) |
636 |
< |
|
636 |
> |
|
637 |
|
if (minCapacity > oldCapacity) then |
638 |
|
if (this%capacityIncrement .gt. 0) then |
639 |
|
newCapacity = oldCapacity + this%capacityIncrement |
647 |
|
else |
648 |
|
newCapacity = oldCapacity |
649 |
|
endif |
650 |
< |
|
650 |
> |
|
651 |
|
!!! newCapacity is not set..... |
652 |
|
if (minPropCap > oldPropCap) then |
653 |
|
if (this%PropertyIncrement .gt. 0) then |
662 |
|
else |
663 |
|
newPropCap = oldPropCap |
664 |
|
endif |
665 |
< |
|
665 |
> |
|
666 |
|
if (resizeFlag) then |
667 |
|
that => initialize(newCapacity, newPropCap, & |
668 |
|
this%capacityIncrement, this%PropertyIncrement) |
671 |
|
this => that |
672 |
|
endif |
673 |
|
end subroutine ensureCapacityHelper |
674 |
< |
|
674 |
> |
|
675 |
|
subroutine copyAllData(v1, v2) |
676 |
|
type(Vector), pointer :: v1 |
677 |
|
type(Vector), pointer :: v2 |
678 |
|
integer :: i, j |
679 |
< |
|
679 |
> |
|
680 |
|
do i = 1, v1%elementCount |
681 |
|
v2%elementData(i) = v1%elementData(i) |
682 |
|
do j = 1, v1%propertyCount |
693 |
|
v1%logicalElementProperties(i,j) |
694 |
|
enddo |
695 |
|
enddo |
696 |
< |
|
696 |
> |
|
697 |
|
do j = 1, v1%propertyCount |
698 |
|
v2%PropertyDescriptions(j) = v1%PropertyDescriptions(j) |
699 |
|
v2%PropertyDataType(j) = v1%PropertyDataType(j) |
700 |
|
enddo |
701 |
< |
|
701 |
> |
|
702 |
|
v2%elementCount = v1%elementCount |
703 |
|
v2%propertyCount = v1%propertyCount |
704 |
< |
|
704 |
> |
|
705 |
|
return |
706 |
|
end subroutine copyAllData |
707 |
|
|
709 |
|
type(Vector), pointer :: this |
710 |
|
integer :: id |
711 |
|
integer :: error |
712 |
< |
|
712 |
> |
|
713 |
|
if (.not. associated(this)) then |
714 |
|
call ensureCapacityHelper(this,1,0) |
715 |
|
else |
716 |
|
call ensureCapacityHelper(this, this%elementCount + 1, this%PropertyCount) |
717 |
|
end if |
718 |
< |
|
718 |
> |
|
719 |
|
this%elementCount = this%elementCount + 1 |
720 |
< |
|
720 |
> |
|
721 |
|
!! We never use this and we set the entire array to the same value |
722 |
|
this%elementData = this%elementCount |
723 |
|
id = this%elementCount |
729 |
|
character(len=*), intent(in) :: PropName |
730 |
|
real( kind = 8 ), intent(in) :: PropValue |
731 |
|
logical :: foundit |
732 |
< |
|
732 |
> |
|
733 |
|
foundit = .false. |
734 |
|
|
735 |
|
! first make sure that the PropName isn't in the list of known properties: |
742 |
|
enddo |
743 |
|
|
744 |
|
if (.not.foundit) then |
745 |
< |
call addPropertyToVector(this, PropName, real_data_type) |
746 |
< |
call setElementPropertyReal(this, id, PropName, PropValue) |
745 |
> |
call addPropertyToVector(this, PropName, real_data_type) |
746 |
> |
call setElementPropertyReal(this, id, PropName, PropValue) |
747 |
|
endif |
748 |
|
end subroutine setElementPropertyReal |
749 |
|
|
762 |
|
this%integerElementProperties(id,i) = PropValue |
763 |
|
endif |
764 |
|
enddo |
765 |
< |
|
765 |
> |
|
766 |
|
if (.not.foundit) then |
767 |
|
call addPropertyToVector(this, PropName, integer_data_type) |
768 |
|
call setElementPropertyInt(this, id, PropName, PropValue) |
784 |
|
this%logicalElementProperties(id,i) = PropValue |
785 |
|
endif |
786 |
|
enddo |
787 |
< |
|
787 |
> |
|
788 |
|
if (.not.foundit) then |
789 |
|
call addPropertyToVector(this, PropName, logical_data_type) |
790 |
|
call setElementPropertyLogical(this, id, PropName, PropValue) |
795 |
|
type(Vector), pointer :: this |
796 |
|
character(len=*), intent(in) :: PropName |
797 |
|
integer data_type |
798 |
< |
|
799 |
< |
call ensureCapacityHelper(this, this%elementCount, this%propertyCount + 1) |
800 |
< |
this%propertyCount = this%propertyCount + 1 |
801 |
< |
this%PropertyDescriptions(this%propertyCount) = PropName |
802 |
< |
this%PropertyDataType(this%propertyCount) = data_type |
803 |
< |
end subroutine addPropertyToVector |
804 |
< |
|
798 |
> |
|
799 |
> |
call ensureCapacityHelper(this, this%elementCount, this%propertyCount + 1) |
800 |
> |
this%propertyCount = this%propertyCount + 1 |
801 |
> |
this%PropertyDescriptions(this%propertyCount) = PropName |
802 |
> |
this%PropertyDataType(this%propertyCount) = data_type |
803 |
> |
end subroutine addPropertyToVector |
804 |
> |
|
805 |
|
function initialize_0i() result(this) |
806 |
|
type(Vector), pointer :: this |
807 |
|
this => initialize_2i(10, 5) |
826 |
|
end function initialize_3i |
827 |
|
|
828 |
|
function initialize_4i(cap, nprop, capinc, propinc) result(this) |
829 |
< |
integer, intent(in) :: cap, nprop, capinc, propinc |
829 |
> |
integer, intent(in) :: cap, nprop, capinc, propinc |
830 |
|
integer :: error |
831 |
|
type(Vector), pointer :: this |
832 |
|
|
833 |
|
nullify(this) |
834 |
|
|
835 |
< |
if (cap < 0) then |
835 |
> |
if (cap < 0) then |
836 |
|
write(*,*) 'Bogus Capacity:', cap |
837 |
|
return |
838 |
|
endif |
840 |
|
write(*,*) 'Bogus Number of Properties:', nprop |
841 |
|
return |
842 |
|
endif |
843 |
< |
|
843 |
> |
|
844 |
|
allocate(this,stat=error) |
845 |
|
if ( error /= 0 ) then |
846 |
|
write(*,*) 'Could not allocate Vector!' |
851 |
|
this%initialProperties = nprop |
852 |
|
this%capacityIncrement = capinc |
853 |
|
this%propertyIncrement = propinc |
854 |
< |
|
854 |
> |
|
855 |
|
allocate(this%elementData(this%initialCapacity), stat=error) |
856 |
|
if(error /= 0) write(*,*) 'Could not allocate elementData!' |
857 |
– |
|
857 |
|
|
858 |
+ |
|
859 |
|
allocate(this%PropertyDescriptions(this%initialProperties), & |
860 |
|
stat=error) |
861 |
|
if(error /= 0) write(*,*) 'Could not allocate PropertyDescriptions!' |
863 |
|
allocate(this%PropertyDataType(this%initialProperties), & |
864 |
|
stat=error) |
865 |
|
if(error /= 0) write(*,*) 'Could not allocate PropertyDataType!' |
866 |
< |
|
866 |
> |
|
867 |
|
allocate(this%integerElementProperties(this%initialCapacity, & |
868 |
|
this%initialProperties), stat=error) |
869 |
|
if(error /= 0) write(*,*) 'Could not allocate integerElementProperties!' |
878 |
|
|
879 |
|
end function initialize_4i |
880 |
|
|
881 |
< |
!! This function destroys the vector components.... |
881 |
> |
!! This function destroys the vector components.... |
882 |
|
function destroy(this) result(null_this) |
883 |
|
logical :: done |
884 |
|
type(Vector), pointer :: this |
888 |
|
null_this => null() |
889 |
|
return |
890 |
|
end if |
891 |
< |
|
892 |
< |
!! Walk down the list and deallocate each of the vector component |
893 |
< |
if(associated(this%logicalElementProperties)) then |
894 |
< |
deallocate(this%logicalElementProperties) |
895 |
< |
this%logicalElementProperties=>null() |
896 |
< |
endif |
897 |
< |
if(associated(this%realElementProperties)) then |
898 |
< |
deallocate(this%realElementProperties) |
899 |
< |
this%realElementProperties=>null() |
900 |
< |
endif |
901 |
< |
if(associated(this%integerElementProperties)) then |
902 |
< |
deallocate(this%integerElementProperties) |
903 |
< |
this%integerElementProperties=>null() |
904 |
< |
endif |
905 |
< |
if(associated(this%PropertyDataType)) then |
906 |
< |
deallocate(this%PropertyDataType) |
907 |
< |
this%PropertyDataType=>null() |
908 |
< |
endif |
909 |
< |
if(associated(this%PropertyDescriptions)) then |
910 |
< |
deallocate(this%PropertyDescriptions) |
911 |
< |
this%PropertyDescriptions=>null() |
912 |
< |
endif |
913 |
< |
if(associated(this%elementData)) then |
914 |
< |
deallocate(this%elementData) |
915 |
< |
this%elementData=>null() |
916 |
< |
endif |
917 |
< |
deallocate(this) |
918 |
< |
this => null() |
919 |
< |
null_this => null() |
891 |
> |
|
892 |
> |
!! Walk down the list and deallocate each of the vector component |
893 |
> |
if(associated(this%logicalElementProperties)) then |
894 |
> |
deallocate(this%logicalElementProperties) |
895 |
> |
this%logicalElementProperties=>null() |
896 |
> |
endif |
897 |
> |
if(associated(this%realElementProperties)) then |
898 |
> |
deallocate(this%realElementProperties) |
899 |
> |
this%realElementProperties=>null() |
900 |
> |
endif |
901 |
> |
if(associated(this%integerElementProperties)) then |
902 |
> |
deallocate(this%integerElementProperties) |
903 |
> |
this%integerElementProperties=>null() |
904 |
> |
endif |
905 |
> |
if(associated(this%PropertyDataType)) then |
906 |
> |
deallocate(this%PropertyDataType) |
907 |
> |
this%PropertyDataType=>null() |
908 |
> |
endif |
909 |
> |
if(associated(this%PropertyDescriptions)) then |
910 |
> |
deallocate(this%PropertyDescriptions) |
911 |
> |
this%PropertyDescriptions=>null() |
912 |
> |
endif |
913 |
> |
if(associated(this%elementData)) then |
914 |
> |
deallocate(this%elementData) |
915 |
> |
this%elementData=>null() |
916 |
> |
endif |
917 |
> |
deallocate(this) |
918 |
> |
this => null() |
919 |
> |
null_this => null() |
920 |
|
end function destroy |
921 |
< |
|
921 |
> |
|
922 |
|
end module Vector_class |