geogrid/src/list_module.F

   1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   2 ! MODULE LIST_MODULE
   3 !
   4 ! Purpose: This module implements a list with insert, search, and
   5 !   remove routines.
   6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   7 module list_module
   8
   9    use module_debug
  10
  11    type list_item
  12       integer :: ikey, ivalue
  13       character (len=128) :: ckey, cvalue
  14       type (list_item), pointer :: next, prev
  15    end type list_item
  16
  17    type list
  18       integer :: l_len
  19       type (list_item), pointer :: head, tail
  20    end type list
  21
  22    contains
  23
  24    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  25    ! Name: list_init
  26    !
  27    ! Purpose: To initialize a list type
  28    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  29    subroutine list_init(l)
  30
  31       implicit none
  32
  33       ! Arguments
  34       type (list), intent(inout) :: l
  35
  36       nullify(l%head)
  37       nullify(l%tail)
  38       l%l_len = 0
  39
  40    end subroutine list_init
  41
  42
  43    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44    ! Name: list_insert
  45    !
  46    ! Purpose: Given a list l, a key, and a value to be stored with that key,
  47    !   this routine adds (key, value) to the table.
  48    !
  49    ! NOTE: If the key already exists in the list, a second copy of a list item
  50    !   with that key is added, possibly with a different associated value.
  51    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52    subroutine list_insert(l, ikey, ivalue, ckey, cvalue)
  53
  54       implicit none
  55
  56       ! Arguments
  57       integer, intent(in), optional :: ikey, ivalue
  58       character (len=128), intent(in), optional :: ckey, cvalue
  59       type (list), intent(inout) :: l
  60
  61       ! Local variables
  62       type (list_item), pointer :: lp
  63
  64       allocate(lp)
  65       nullify(lp%prev)
  66       nullify(lp%next)
  67       if (present(ikey) .and. present(ivalue)) then
  68          lp%ikey   = ikey
  69          lp%ivalue = ivalue
  70       else if (present(ckey) .and. present(cvalue)) then
  71          lp%ckey   = ckey
  72          lp%cvalue = cvalue
  73       else
  74          call mprintf(.true.,ERROR,'list_insert() called without proper arguments.')
  75       end if
  76
  77       if (associated(l%tail)) then
  78          l%tail%next => lp
  79          lp%prev => l%tail
  80          l%tail => lp
  81       else
  82          l%tail => lp
  83          l%head => lp
  84       end if
  85
  86       l%l_len = l%l_len + 1
  87
  88    end subroutine list_insert
  89
  90
  91    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92    ! Name: list_get_keys
  93    !
  94    ! Purpose:
  95    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  96    function list_get_keys(l)
  97
  98       implicit none
  99
 100       ! Arguments
 101       type (list), intent(in) :: l
 102
 103       ! Return value
 104       type (list_item), pointer, dimension(:) :: list_get_keys
 105
 106       ! Local variables
 107       integer :: i
 108       type (list_item), pointer :: lp
 109
 110       allocate(list_get_keys(l%l_len))
 111
 112       lp => l%head
 113
 114       i = 1
 115       do while (associated(lp))
 116          list_get_keys(i)%ikey   = lp%ikey
 117          list_get_keys(i)%ivalue = lp%ivalue
 118          list_get_keys(i)%ckey   = lp%ckey
 119          list_get_keys(i)%cvalue = lp%cvalue
 120          lp => lp%next
 121          i = i + 1
 122       end do
 123
 124       return
 125
 126    end function list_get_keys
 127
 128
 129    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 130    ! Name: list_search
 131    !
 132    ! Purpose: If key k is found in the list, this function returns TRUE and sets
 133    !   value equal to the value stored with k. If the k is not found, this
 134    !   function returns FALSE, and value is undefined.
 135    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 136    function list_search(l, ikey, ivalue, ckey, cvalue)
 137
 138       implicit none
 139
 140       ! Arguments
 141       integer, intent(in), optional :: ikey
 142       integer, intent(out), optional :: ivalue
 143       character (len=128), intent(in), optional :: ckey
 144       character (len=128), intent(out), optional :: cvalue
 145       type (list), intent(inout) :: l
 146
 147       ! Return value
 148       logical :: list_search
 149
 150       ! Local variables
 151       type (list_item), pointer :: lp
 152
 153       list_search = .false.
 154
 155       lp => l%head
 156
 157       do while (associated(lp))
 158          if (present(ikey) .and. present(ivalue)) then
 159             if (lp%ikey == ikey) then
 160                list_search = .true.
 161                ivalue = lp%ivalue
 162                exit
 163             end if
 164          else if (present(ckey) .and. present(cvalue)) then
 165             if (lp%ckey == ckey) then
 166                list_search = .true.
 167                cvalue = lp%cvalue
 168                exit
 169             end if
 170          else
 171             call mprintf(.true.,ERROR,'list_search() called without proper arguments.')
 172          end if
 173          lp => lp%next
 174       end do
 175
 176    end function list_search
 177
 178
 179    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 180    ! Name: list_get_first_item
 181    !
 182    ! Purpose: Sets k and v equal to the key and value, respectively, of the
 183    !   first item in the list. The list should be thought of as a queue, so that
 184    !   the first item refers to the least recently inserted item that has not yet
 185    !   been removed or retrieved. This item is also removed from the list before
 186    !   the subroutine returns.
 187    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 188    subroutine list_get_first_item(l, ikey, ivalue, ckey, cvalue)
 189
 190       implicit none
 191
 192       ! Arguments
 193       integer, intent(out), optional :: ikey, ivalue
 194       character (len=128), intent(out), optional :: ckey, cvalue
 195       type (list), intent(inout) :: l
 196
 197       ! Local variables
 198       type (list_item), pointer :: lp
 199
 200       lp => l%head
 201
 202       if (associated(lp)) then
 203          if (present(ikey) .and. present(ivalue)) then
 204             ikey = lp%ikey
 205             ivalue = lp%ivalue
 206          else if (present(ckey) .and. present(cvalue)) then
 207             ckey = lp%ckey
 208             cvalue = lp%cvalue
 209          else
 210             call mprintf(.true.,ERROR,'list_get_first_item() called without proper arguments.')
 211          end if
 212          l%head => lp%next
 213          if (associated(lp%next)) nullify(lp%next%prev)
 214          deallocate(lp)
 215          l%l_len = l%l_len - 1
 216       end if
 217
 218    end subroutine list_get_first_item
 219
 220
 221    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 222    ! Name: list_remove
 223    !
 224    ! Purpose: Deletes the entry with key k from the list. If multiple entries
 225    !   have the specified key, only the first encountered entry is deleted.
 226    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 227    subroutine list_remove(l, ikey, ckey)
 228
 229       implicit none
 230
 231       ! Arguments
 232       integer, intent(in), optional :: ikey
 233       character (len=128), intent(in), optional :: ckey
 234       type (list), intent(inout) :: l
 235
 236       ! Local variables
 237       type (list_item), pointer :: lp
 238
 239       lp => l%head
 240
 241       do while (associated(lp))
 242          if (present(ikey)) then
 243             if (lp%ikey == ikey) then
 244
 245                if (.not. associated(lp%prev)) then
 246                   l%head => lp%next
 247                   if (.not. associated(l%head)) nullify(l%tail)
 248                   if (associated(lp%next)) nullify(lp%next%prev)
 249                   deallocate(lp)
 250                else if (.not. associated(lp%next)) then
 251                   l%tail => lp%prev
 252                   if (.not. associated(l%tail)) nullify(l%head)
 253                   if (associated(lp%prev)) nullify(lp%prev%next)
 254                   deallocate(lp)
 255                else
 256                   lp%prev%next => lp%next
 257                   lp%next%prev => lp%prev
 258                   deallocate(lp)
 259                end if
 260                l%l_len = l%l_len - 1
 261
 262                exit
 263
 264             end if
 265
 266          else if (present(ckey)) then
 267
 268             if (lp%ckey == ckey) then
 269
 270                if (.not. associated(lp%prev)) then
 271                   l%head => lp%next
 272                   if (.not. associated(l%head)) nullify(l%tail)
 273                   if (associated(lp%next)) nullify(lp%next%prev)
 274                   deallocate(lp)
 275                else if (.not. associated(lp%next)) then
 276                   l%tail => lp%prev
 277                   if (.not. associated(l%tail)) nullify(l%head)
 278                   if (associated(lp%prev)) nullify(lp%prev%next)
 279                   deallocate(lp)
 280                else
 281                   lp%prev%next => lp%next
 282                   lp%next%prev => lp%prev
 283                   deallocate(lp)
 284                end if
 285                l%l_len = l%l_len - 1
 286
 287                exit
 288
 289             end if
 290          else
 291             call mprintf(.true.,ERROR,'list_remove() called without proper arguments.')
 292          end if
 293
 294          lp => lp%next
 295       end do
 296
 297    end subroutine list_remove
 298
 299
 300    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 301    ! Name: list_length
 302    !
 303    ! Purpose: Returns the number of items in the list l.
 304    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 305    function list_length(l)
 306
 307       implicit none
 308
 309       ! Arguments
 310       type (list), intent(in) :: l
 311
 312       ! Return value
 313       integer :: list_length
 314
 315       list_length = l%l_len
 316
 317       return
 318
 319    end function list_length
 320
 321
 322    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 323    ! Name: list_destroy
 324    !
 325    ! Purpose: Frees all memory associated with list l. This routine may be
 326    !   used to remove all entries from a list.
 327    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 328    subroutine list_destroy(l)
 329
 330       implicit none
 331
 332       ! Arguments
 333       type (list), intent(inout) :: l
 334
 335       ! Local variables
 336       type (list_item), pointer :: lp
 337
 338       lp => l%head
 339
 340       do while (associated(lp))
 341          l%head => lp%next
 342          deallocate(lp)
 343          lp => l%head
 344       end do
 345
 346       l%l_len = 0
 347       nullify(l%head)
 348       nullify(l%tail)
 349
 350    end subroutine list_destroy
 351
 352 end module list_module