psmile_multimap_routines.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION:
!
! Implementation of subroutines and functions of psmile_multimap. This
! is extracted from psmile_multimap.F90 in order to avoid circular
! dependencies with psmile_reallocate.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 18.11.10    M. Hanke     extracted from psmile_multimap.F90
!
!----------------------------------------------------------------------
!
!  $Id: psmile_multimap_routines.F90 2751 2010-11-19 13:53:28Z hanke $
!  $Author: hanke $
!
!----------------------------------------------------------------------

   subroutine init_multimap (this)
      use psmile_multimap, only : multimap

      implicit none

      type(multimap), intent(inout) :: this

      nullify (this%keys)
   end subroutine init_multimap

   subroutine free_multimap (this)
      use psmile_multimap, only : multimap

      implicit none

      type(multimap), intent(inout) :: this
      integer :: i

      if (associated (this%keys)) then
         do i = lbound(this%keys,1), ubound (this%keys,1)
            if (associated (this%keys(i)%values)) &
               deallocate (this%keys(i)%values)
         enddo
         deallocate (this%keys)
      endif
   end subroutine free_multimap

   subroutine add_pair (this, key, value)
      use psmile_multimap, only : multimap, key_type, init_keys
      use psmile_reallocate

      implicit none

      type(multimap), intent(inout) :: this
      integer, intent(in) :: key, value
      type(key_type), pointer :: temp_keys(:)

      if (.not. associated (this%keys)) then
         allocate (this%keys(key:key))
         call init_keys(this%keys(key:key))
      else if (lbound (this%keys,1) > key .or. key > ubound (this%keys,1)) then
         allocate (temp_keys(min(lbound (this%keys,1),key):max(ubound (this%keys,1),key)))
         temp_keys(lbound (this%keys,1):ubound (this%keys,1)) = this%keys
         call init_keys(temp_keys(min(key,ubound (this%keys,1)+1):max(key,lbound (this%keys,1)-1)))
         deallocate (this%keys)
         this%keys => temp_keys
         nullify (temp_keys)
      endif

      if (.not. associated (this%keys(key)%values)) then
         allocate (this%keys(key)%values(1))
         this%keys(key)%values(1) = value
      else if (.not. any (this%keys(key)%values == value)) then
         this%keys(key)%values => psmile_realloc(this%keys(key)%values, &
                                                 size (this%keys(key)%values) + 1)
         this%keys(key)%values(size (this%keys(key)%values)) = value
      endif
   end subroutine add_pair

   function get_num_values (this, key)
      use psmile_multimap, only : multimap, is_valid_key

      implicit none

      type(multimap), intent(inout) :: this
      integer, intent(in) :: key

      integer :: get_num_values

      if (.not. is_valid_key(this, key)) then
         get_num_values = 0
      else
         get_num_values = size (this%keys(key)%values)
      endif
   end function get_num_values

   function get_values(this, key, num_values)
      use psmile_multimap, only : multimap, is_valid_key

      implicit none

      type(multimap), intent(inout) :: this
      integer, intent(in) :: key, num_values

      integer :: get_values(num_values)

      if (.not. is_valid_key(this, key)) then
         continue
      else if (size (this%keys(key)%values) >= num_values) then
         get_values = this%keys(key)%values(1:num_values)
         return
      endif

      get_values = 0
   end function get_values

   function get_value(this, key, value_idx)
      use psmile_multimap, only : multimap, is_valid_key

      implicit none

      type(multimap), intent(inout) :: this
      integer, intent(in) :: key, value_idx

      integer :: get_value

      if (.not. is_valid_key(this, key)) then
         continue
      else if (size (this%keys(key)%values) >= value_idx) then
         get_value = this%keys(key)%values(value_idx)
         return
      endif

      get_value = 0
   end function

   subroutine init_keys (keys)
      use psmile_multimap, only : key_type

      implicit none

      type(key_type), intent(inout) :: keys(:)

      integer :: i

      do i = lbound(keys,1), ubound (keys,1)
         nullify (keys(i)%values)
      enddo
   end subroutine

   subroutine rm_key (this, key)
      use psmile_multimap, only : multimap, is_valid_key

      implicit none

      type(multimap), intent(inout) :: this
      integer, intent(in) :: key

      if (is_valid_key(this, key)) then
         deallocate (this%keys(key)%values)
         nullify (this%keys(key)%values)
      endif

   end subroutine

   function is_valid_key(this, key)
      use psmile_multimap, only : multimap

      implicit none

      type(multimap), intent(in) :: this
      integer, intent(in) :: key

      logical :: is_valid_key

      if (.not. associated (this%keys)) then
         continue
      else if (lbound (this%keys,1) > key .or. key > ubound (this%keys,1)) then
         continue
      else if (.not. associated (this%keys(key)%values)) then
         continue
      else
         is_valid_key = .true.
         return
      endif

      is_valid_key = .false.

   end function

   integer function get_num_valid_keys (this)
      use psmile_multimap, only : multimap

      implicit none

      type(multimap), intent(in) :: this

      integer :: i

         get_num_valid_keys = 0

      ! if there is at least one key
      if (associated (this%keys)) then

         ! for all keys
         do i = lbound (this%keys,1), ubound (this%keys,1)

            ! if the current keys has at least one associated value
            if (associated (this%keys(i)%values)) &
               get_num_valid_keys = get_num_valid_keys + 1

         enddo ! i
      endif
   end function get_num_valid_keys