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