| 1 |
!! 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 |
|
| 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 |
|
| 83 |
else if ( list_size > size(identPtrList)) then |
| 84 |
!! We've already allocated this list and need to make it bigger |
| 85 |
|
| 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 |
|
| 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 |
write(*,*) "Could not find an atype for ident ", this_ident |
| 108 |
return |
| 109 |
end if |
| 110 |
!! Assign temp pointer to pointer list |
| 111 |
identPtrList(i)%this => tmpPtr |
| 112 |
end do |
| 113 |
|
| 114 |
end subroutine create_identPtrList |
| 115 |
|
| 116 |
function getListLen(this_list) result(listLen) |
| 117 |
type( generic_atype ), pointer :: this_list |
| 118 |
type( generic_atype ), pointer :: tmpPtr |
| 119 |
|
| 120 |
integer :: listLen |
| 121 |
|
| 122 |
listLen = 0 |
| 123 |
|
| 124 |
tmpPtr => this_list |
| 125 |
do while (associated(tmpPtr)) |
| 126 |
listLen = listLen + 1 |
| 127 |
tmpPtr => tmpPtr%next |
| 128 |
end do |
| 129 |
|
| 130 |
end function getListLen |
| 131 |
|
| 132 |
subroutine print_list(head) |
| 133 |
type( generic_atype ), pointer :: head |
| 134 |
type( generic_atype ), pointer :: tmpLstPointer |
| 135 |
|
| 136 |
write(*,*) " Printing atype_list" |
| 137 |
if (.not. associated(head)) then |
| 138 |
|
| 139 |
write(*,*) "ERROR: list is not associated" |
| 140 |
return |
| 141 |
end if |
| 142 |
tmpLstPointer => head |
| 143 |
do while(associated(tmpLstPointer)) |
| 144 |
write(*,*) "Found ident: ", tmpLstPointer%atype_ident |
| 145 |
tmpLstPointer => tmpLstPointer%next |
| 146 |
|
| 147 |
end do |
| 148 |
|
| 149 |
|
| 150 |
end subroutine print_list |
