| 1 |
chuckv |
247 |
!! include file for adding generic linked list routines for atype list |
| 2 |
|
|
|
| 3 |
|
|
|
| 4 |
|
|
|
| 5 |
|
|
!! generic routine to add an atype to a list |
| 6 |
|
|
subroutine add_atype(this_node,head,tail,status) |
| 7 |
|
|
!! atype node to be added to a list |
| 8 |
|
|
type (generic_atype), pointer :: this_node |
| 9 |
|
|
!! list to which atype is added, if null, we allocate a new list |
| 10 |
|
|
type (generic_atype), pointer :: head |
| 11 |
|
|
type (generic_atype), pointer :: tail |
| 12 |
|
|
|
| 13 |
|
|
!! status 0 = success, -1 = failure |
| 14 |
|
|
integer, intent(out) :: status |
| 15 |
|
|
|
| 16 |
|
|
type (generic_atype), pointer :: current => null() |
| 17 |
|
|
|
| 18 |
|
|
status = 0 |
| 19 |
|
|
|
| 20 |
|
|
!! We need to allocate and set this node before calling add_list |
| 21 |
|
|
if (.not. associated(this_node)) then |
| 22 |
|
|
status = -1 |
| 23 |
|
|
return |
| 24 |
|
|
endif |
| 25 |
|
|
|
| 26 |
|
|
!! if list is not associated, we are the first node on the list |
| 27 |
|
|
if (.not. associated(head)) then |
| 28 |
|
|
head => this_node |
| 29 |
|
|
tail => this_node |
| 30 |
|
|
else |
| 31 |
|
|
this_node%prev => tail |
| 32 |
|
|
tail%next => this_node |
| 33 |
|
|
tail => this_node |
| 34 |
|
|
|
| 35 |
|
|
endif |
| 36 |
|
|
end subroutine add_atype |
| 37 |
|
|
|
| 38 |
|
|
subroutine find_atype(ident,this_list, atype) |
| 39 |
|
|
integer, intent(in) :: ident |
| 40 |
|
|
type (generic_atype), pointer :: this_list |
| 41 |
|
|
type (generic_atype), pointer :: atype |
| 42 |
|
|
|
| 43 |
|
|
type (generic_atype), pointer :: temp |
| 44 |
|
|
|
| 45 |
|
|
atype => null() |
| 46 |
|
|
if (.not. associated(this_list)) return |
| 47 |
|
|
|
| 48 |
|
|
temp => this_list |
| 49 |
|
|
|
| 50 |
|
|
do while (associated(temp)) |
| 51 |
|
|
if (temp%atype_ident == ident) then |
| 52 |
|
|
atype => temp |
| 53 |
|
|
exit |
| 54 |
|
|
endif |
| 55 |
|
|
temp => temp%next |
| 56 |
|
|
end do |
| 57 |
|
|
|
| 58 |
|
|
end subroutine find_atype |
| 59 |
|
|
|
| 60 |
|
|
subroutine create_identPtrList(ident,this_list,identPtrList,status) |
| 61 |
|
|
integer, dimension(:) :: ident |
| 62 |
|
|
type(generic_atype), pointer :: this_list |
| 63 |
|
|
type(generic_atype), pointer :: tmpPtr |
| 64 |
|
|
type(generic_identPtrList), dimension(:),pointer :: identPtrList |
| 65 |
|
|
integer, intent(out), optional :: status |
| 66 |
|
|
|
| 67 |
|
|
integer :: list_size |
| 68 |
|
|
integer :: i |
| 69 |
|
|
integer :: this_ident |
| 70 |
|
|
integer :: alloc_stat |
| 71 |
|
|
|
| 72 |
|
|
status = 0 |
| 73 |
|
|
list_size = size(ident) |
| 74 |
|
|
write(*,*) "Creating identPtrList for size: ", list_size |
| 75 |
|
|
!! Allocate space for pointer list. |
| 76 |
|
|
if (.not. associated(identPtrList)) then |
| 77 |
|
|
allocate(identPtrList(list_size),stat=alloc_stat) |
| 78 |
|
|
if (alloc_stat /= 0) then |
| 79 |
|
|
status = -1 |
| 80 |
|
|
return |
| 81 |
|
|
end if |
| 82 |
|
|
write(*,*) "Successfully allocated new list" |
| 83 |
|
|
else if ( list_size > size(identPtrList)) then |
| 84 |
|
|
!! We've already allocated this list and need to make it bigger |
| 85 |
|
|
write(*,*) "Warning reallocating identPointerList" |
| 86 |
|
|
deallocate(identPtrList) |
| 87 |
|
|
allocate(identPtrList(list_size),stat=alloc_stat) |
| 88 |
|
|
if (alloc_stat /= 0) then |
| 89 |
|
|
status = -1 |
| 90 |
|
|
return |
| 91 |
|
|
end if |
| 92 |
|
|
else |
| 93 |
|
|
!! nullify entire list.... |
| 94 |
|
|
do i = 1, list_size |
| 95 |
|
|
identPtrList(i)%this => null() |
| 96 |
|
|
end do |
| 97 |
|
|
end if |
| 98 |
|
|
|
| 99 |
|
|
|
| 100 |
|
|
do i = 1, list_size |
| 101 |
|
|
this_ident = ident(i) |
| 102 |
|
|
write(*,*) "Finding atype for ident ", this_ident |
| 103 |
|
|
call find_atype(this_ident,this_list,tmpPtr) |
| 104 |
|
|
!! If we can't find the atype corresponding to the ident, return w/ error. |
| 105 |
|
|
if (.not. associated(tmpPtr)) then |
| 106 |
|
|
status = -1 |
| 107 |
|
|
|
| 108 |
|
|
write(*,*) "Could not find an atype for ident ", this_ident |
| 109 |
|
|
return |
| 110 |
|
|
end if |
| 111 |
|
|
!! Assign temp pointer to pointer list |
| 112 |
|
|
identPtrList(i)%this => tmpPtr |
| 113 |
|
|
end do |
| 114 |
|
|
|
| 115 |
|
|
end subroutine create_identPtrList |
| 116 |
|
|
|
| 117 |
|
|
function getListLen(this_list) result(listLen) |
| 118 |
|
|
type( generic_atype ), pointer :: this_list |
| 119 |
|
|
type( generic_atype ), pointer :: tmpPtr |
| 120 |
|
|
|
| 121 |
|
|
integer :: listLen |
| 122 |
|
|
|
| 123 |
|
|
listLen = 0 |
| 124 |
|
|
|
| 125 |
|
|
tmpPtr => this_list |
| 126 |
|
|
do while (associated(tmpPtr)) |
| 127 |
|
|
listLen = listLen + 1 |
| 128 |
|
|
tmpPtr => tmpPtr%next |
| 129 |
|
|
end do |
| 130 |
|
|
|
| 131 |
|
|
end function getListLen |
| 132 |
|
|
|
| 133 |
|
|
subroutine print_list(head) |
| 134 |
|
|
type( generic_atype ), pointer :: head |
| 135 |
|
|
type( generic_atype ), pointer :: tmpLstPointer |
| 136 |
|
|
|
| 137 |
|
|
write(*,*) " Printing atype_list" |
| 138 |
|
|
if (.not. associated(head)) then |
| 139 |
|
|
|
| 140 |
|
|
write(*,*) "ERROR: list is not associated" |
| 141 |
|
|
return |
| 142 |
|
|
end if |
| 143 |
|
|
tmpLstPointer => head |
| 144 |
|
|
do while(associated(tmpLstPointer)) |
| 145 |
|
|
write(*,*) "Found ident: ", tmpLstPointer%atype_ident |
| 146 |
|
|
tmpLstPointer => tmpLstPointer%next |
| 147 |
|
|
|
| 148 |
|
|
end do |
| 149 |
|
|
|
| 150 |
|
|
|
| 151 |
|
|
end subroutine print_list |
