geogrid/src/queue_module.F

   1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   2 ! Module: queue_module
   3 !
   4 ! Description: This module implements a queue of user-defined data types and
   5 !   a set of routines related to the maintenance and manipulation of the queue.
   6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   7
   8 module queue_module
   9
  10    use module_debug
  11
  12    type q_data         ! The user-defined datatype to store in the queue
  13 #ifdef _GEOGRID
  14       real :: lat, lon
  15       integer :: x, y
  16       integer :: depth ! Used by 'search' interpolation method
  17 #endif
  18 #ifdef _METGRID
  19       integer :: x, y
  20       integer :: sr_x, sr_y
  21       character (len=128) :: units, description, stagger
  22       integer :: depth ! Used by 'search' interpolation method
  23 #endif
  24    end type q_data
  25
  26    type q_item         ! Wrapper for item to be stored in the queue
  27       type (q_data) :: data
  28       type (q_item), pointer :: next
  29    end type q_item
  30
  31    type queue          ! The queue object, defined by a head and tail pointer
  32       type (q_item), pointer :: head, tail
  33       integer :: length
  34    end type queue
  35
  36
  37    contains
  38
  39
  40    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41    ! Name: q_init
  42    !
  43    ! Purpose: To initialize a queue
  44    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  45    subroutine q_init(q)
  46
  47       implicit none
  48
  49       ! Arguments
  50       type (queue), intent(inout) :: q
  51
  52       nullify(q%head)
  53       nullify(q%tail)
  54       q%length = 0
  55
  56    end subroutine q_init
  57
  58
  59    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  60    ! Name: q_insert
  61    !
  62    ! Purpose: To insert an item in the tail of the queue
  63    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64    subroutine q_insert(q, qitem)
  65
  66       implicit none
  67
  68       ! Arguments
  69       type (queue), intent(inout) :: q
  70       type (q_data), intent(in) :: qitem
  71
  72       ! Local variables
  73       type (q_item), pointer :: newitem
  74
  75       allocate(newitem)
  76       newitem%data = qitem
  77       nullify(newitem%next)
  78       if (.not.associated(q%tail)) then
  79          q%head=>newitem
  80          q%tail=>newitem
  81       else
  82          q%tail%next=>newitem
  83          q%tail=>newitem
  84       end if
  85
  86       q%length = q%length + 1
  87
  88    end subroutine q_insert
  89
  90
  91    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92    ! Name: q_isdata
  93    !
  94    ! Purpose: This function returns FALSE if the queue is empty and TRUE otherwise
  95    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  96    function q_isdata(q)
  97
  98       implicit none
  99
 100       ! Arguments
 101       type (queue), intent(in) :: q
 102
 103       ! Local variables
 104       logical :: q_isdata
 105
 106       q_isdata = .false.
 107
 108       if (associated(q%head) .and. (q%length >= 1)) then
 109          q_isdata = .true.
 110       end if
 111
 112    end function q_isdata
 113
 114
 115    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 116    ! Name: q_peek
 117    !
 118    ! Purpose: To return the item in the head of the queue, without
 119    !    actually removing the item
 120    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 121    function q_peek(q)
 122
 123       implicit none
 124
 125       ! Arguments
 126       type (queue), intent(in) :: q
 127
 128       ! Local variables
 129       type (q_data) :: q_peek
 130
 131       if (associated(q%head)) then
 132          q_peek = q%head%data
 133       else
 134          call mprintf(.true.,ERROR,'q_peek(): Trying to peek at an empty queue')
 135       end if
 136
 137    end function q_peek
 138
 139
 140    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 141    ! Name: q_length
 142    !
 143    ! Purpose: To return the number of items currently in the queue
 144    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 145    function q_length(q)
 146
 147       implicit none
 148
 149       ! Arguments
 150       type (queue), intent(in) :: q
 151
 152       ! Local variables
 153   !    type (q_item), pointer :: cursor
 154       integer :: q_length
 155
 156       q_length = q%length
 157
 158   ! USE THE FOLLOWING TO COUNT THE LENGTH BY ACTUALLY TRAVERSING THE LINKED LIST
 159   ! REPRESENTATION OF THE QUEUE
 160   !    if (associated(q%head)) then
 161   !       q_length = q_length + 1
 162   !       cursor=>q%head
 163   !       do while(associated(cursor%next))
 164   !         cursor=>cursor%next
 165   !         q_length = q_length + 1
 166   !       end do
 167   !    end if
 168
 169    end function q_length
 170
 171
 172    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 173    ! Name: q_remove
 174    !
 175    ! Purpose: To return the item stored at the head of the queue
 176    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 177    function q_remove(q)
 178
 179       implicit none
 180
 181       ! Arguments
 182       type (queue), intent(inout) :: q
 183
 184       ! Local variables
 185       type (q_data) :: q_remove
 186       type (q_item), pointer :: cursor
 187
 188       if (associated(q%head)) then
 189          if (associated(q%head%next)) then
 190             cursor=>q%head%next
 191             q_remove = q%head%data
 192             deallocate(q%head)
 193             q%head=>cursor
 194          else
 195             q_remove = q%head%data
 196             deallocate(q%head)
 197             nullify(q%head)
 198             nullify(q%tail)
 199          end if
 200          q%length = q%length - 1
 201       else
 202          call mprintf(.true.,ERROR,'q_remove(): Trying to remove from an empty queue')
 203       end if
 204
 205    end function q_remove
 206
 207
 208    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 209    ! Name: q_destroy
 210    !
 211    ! Purpose: To free all memory allocated by the queue, thus destroying any
 212    !    items that have not been removed
 213    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 214    subroutine q_destroy(q)
 215
 216       implicit none
 217
 218       ! Arguments
 219       type (queue), intent(inout) :: q
 220
 221       ! Local variables
 222       type (q_item), pointer :: cursor
 223
 224       q%length = 0
 225
 226       if (associated(q%head)) then
 227          do while(associated(q%head%next))
 228             cursor=>q%head
 229             q%head=>q%head%next
 230             deallocate(cursor)
 231          end do
 232          deallocate(q%head)
 233       end if
 234
 235    end subroutine q_destroy
 236
 237 end module queue_module