WPS/geogrid/src/queue_module.F90

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