psmile_user_data.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION:
!
! Module psmile_user_data stores the information provided by the user
! (e.g. grid, corners, masks). This data is then preprocessed before
! psmile internal data structures (e.g. Fields, Grids) are generated
! from this.
! The preprocessing is required in order to avoid problems that
! occurred when multiple blocks per partition were defined.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 22.10.10    M. Hanke     created
!
!----------------------------------------------------------------------
!
!  $Id: psmile_user_data.F90 2769 2010-11-23 14:49:21Z hanke $
!  $Author: hanke $
!
!----------------------------------------------------------------------

module psmile_user_data

   use psmile_common, only : max_name
   use psmile_multimap, only : multimap, init_multimap

   implicit none

   type user_coordinate_data
      integer, pointer :: actual_shape(:,:)
      double precision, pointer :: st_array_dble(:) ! first
      double precision, pointer :: nd_array_dble(:) ! second
      double precision, pointer :: rd_array_dble(:) ! third
      real, pointer :: st_array_real(:) ! first
      real, pointer :: nd_array_real(:) ! second
      real, pointer :: rd_array_real(:) ! third
   end type user_coordinate_data

   type user_grid_data
      character(len=max_name) :: grid_name
      integer :: comp_id
      integer, pointer :: grid_valid_shape(:,:)
      integer :: grid_type

      integer :: nbr_corners
      type(user_coordinate_data) :: corners

      integer, pointer :: nbr_points_per_lat(:)

      integer, pointer :: partition_array(:,:)
      integer, pointer :: extent_array(:,:)
   end type user_grid_data

   type user_point_data
      integer :: grid_id
      type(user_coordinate_data) :: points
      character(len=max_name) :: name
   end type user_point_data

   type user_mask_data
      integer :: grid_id
      integer, pointer :: mask_actual_shape(:,:)
      logical, pointer :: mask(:)
   end type user_mask_data

   type user_var_data
      character(len=max_name) :: var_name
      integer :: point_id
      integer :: mask_id
      integer, pointer :: var_actual_shape(:,:)
      integer :: var_type
   end type user_var_data

   type(user_grid_data), pointer  :: grid_data(:)
   type(user_point_data), pointer :: point_data(:)
   type(user_mask_data), pointer  :: mask_data(:)
   type(user_var_data), pointer   :: var_data(:)

   type(multimap) :: grid_id_map
   type(multimap) :: mask_id_map
   type(multimap) :: point_id_map
   type(multimap) :: var_id_map

   interface
      subroutine psmile_store_data_grid (grid_id, grid_name,        &
                                         comp_id, grid_valid_shape, &
                                         grid_type, ierror)

         integer, intent(out)         :: grid_id
         character(len=*), intent(in) :: grid_name
         integer, intent(in)          :: comp_id
         integer, intent(in)          :: grid_valid_shape (2, *)
         integer, intent(in)          :: grid_type
         integer, intent(out)         :: ierror
      end subroutine psmile_store_data_grid

      subroutine psmile_store_data_partition (grid_id, nbr_blocks, &
                                              partition_array,     &
                                              extent_array, ierror)

         integer, intent (in)  :: grid_id
         integer, intent (in)  :: nbr_blocks
         integer, intent (in)  :: partition_array(1:nbr_blocks,*)
         integer, intent (in)  :: extent_array(1:nbr_blocks,*)
         integer, intent (out) :: ierror
      end subroutine psmile_store_data_partition

      subroutine psmile_store_data_reducedgrid (grid_id, nbr_latitudes, &
                                                nbr_points_per_lat, ierror)

         integer, intent (in)                :: grid_id
         integer, intent (in)                :: nbr_latitudes
         integer, intent (in)                :: nbr_points_per_lat(nbr_latitudes)
         integer, intent (out)               :: ierror
      end subroutine psmile_store_data_reducedgrid

      subroutine psmile_store_data_corner_3d_db (       &
            grid_id, nbr_corners, corners_actual_shape, &
            corners_1st_array,corners_2nd_array,        &
            corners_3rd_array, array_size, ierror)

         integer, intent (in)          :: grid_id
         integer, intent (in)          :: nbr_corners
         double precision, intent (in) :: corners_1st_array (*)
         double precision, intent (in) :: corners_2nd_array (*)
         double precision, intent (in) :: corners_3rd_array (*)
         integer, intent (in)          :: array_size (3)
         integer, intent (in)          :: corners_actual_shape (1:2, *)
         integer, intent(out)          :: ierror
      end subroutine psmile_store_data_corner_3d_db

      subroutine psmile_store_data_corner_3d_re (       &
            grid_id, nbr_corners, corners_actual_shape, &
            corners_1st_array,corners_2nd_array,        &
            corners_3rd_array, array_size, ierror)

         integer, intent (in) :: grid_id
         integer, intent (in) :: nbr_corners
         real, intent (in)    :: corners_1st_array (*)
         real, intent (in)    :: corners_2nd_array (*)
         real, intent (in)    :: corners_3rd_array (*)
         integer, intent (in) :: array_size (3)
         integer, intent (in) :: corners_actual_shape (1:2, *)
         integer, intent(out) :: ierror
      end subroutine psmile_store_data_corner_3d_re

      subroutine psmile_store_data_points_3d_db(point_id, point_name, grid_id,         &
                                                points_actual_shape, points_1st_array, &
                                                points_2nd_array, points_3rd_array,    &
                                                array_size, new_points, ierror)
         character (len=*), intent(in)                :: point_name
         integer,           intent(in)                :: grid_id
         integer,           intent(inout)             :: point_id
         double precision,  intent(in), dimension (*) :: points_1st_array, points_2nd_array, points_3rd_array
         integer,           intent(in)                :: points_actual_shape (2, *)
         integer,           intent(in)                :: array_size(3)
         logical,           intent(in)                :: new_points
         integer,           intent(out)               :: ierror
      end subroutine psmile_store_data_points_3d_db

      subroutine psmile_store_data_points_3d_re(point_id, point_name, grid_id,         &
                                                points_actual_shape, points_1st_array, &
                                                points_2nd_array, points_3rd_array,    &
                                                array_size, new_points, ierror)
         character (len=*), intent(in)    :: point_name
         integer,           intent(in)    :: grid_id
         integer,           intent(inout) :: point_id
         real,  intent(in), dimension (*) :: points_1st_array, points_2nd_array, points_3rd_array
         integer,           intent(in)    :: points_actual_shape (2, *)
         integer,           intent(in)    :: array_size(3)
         logical,           intent(in)    :: new_points
         integer,           intent(out)   :: ierror
      end subroutine psmile_store_data_points_3d_re

      subroutine psmile_store_data_points_grless(point_id, point_name, grid_id, &
                                                   new_points, ierror)
         integer,           intent(inout) :: point_id
         character (len=*), intent(in)    :: point_name
         integer,           intent(in)    :: grid_id
         logical,           intent(in)    :: new_points
         integer,           intent(out)   :: ierror
      end subroutine psmile_store_data_points_grless

      subroutine psmile_store_data_mask (mask_id, grid_id, mask_actual_shape, &
                                          mask_array, new_mask, ierror)
            integer, intent(inout)       :: mask_id
            integer, intent(in)          :: grid_id
            integer, intent(in)          :: mask_actual_shape(2, *)
            logical, intent(in)          :: mask_array (*)
            logical, intent(in)          :: new_mask
            integer, intent(out)         :: ierror
      end subroutine psmile_store_data_mask

      subroutine psmile_store_data_rm_mask (mask_id, ierror)
         integer, intent(in)  :: mask_id
         integer, intent(out) :: ierror
      end subroutine psmile_store_data_rm_mask

      subroutine psmile_store_data_var (var_id, name, grid_id, point_id, mask_id, &
                              var_nodims, var_actual_shape, var_type, ierror )
         integer, intent(out)          :: var_id
         character (len=*), intent(in) :: name
         integer, intent(in)           :: grid_id
         integer, intent(in)           :: point_id
         integer, intent(in)           :: mask_id
         integer, intent(in)           :: var_nodims(2)
         integer, intent(in)           :: var_actual_shape(1:2, 1:var_nodims(1)+var_nodims(2))
         integer, intent(in)           :: var_type
         integer, intent(out)          :: ierror
      end subroutine psmile_store_data_var

      subroutine psmile_apply_user_data(ierror)
         integer, intent (out) :: ierror
      end subroutine psmile_apply_user_data

      subroutine psmile_merge_fields(ierror)
         integer, intent (out) :: ierror
      end subroutine psmile_merge_fields

      subroutine psmile_store_data_intern_field(psmile_var_id)
         integer, intent (in) :: psmile_var_id
      end subroutine psmile_store_data_intern_field

      subroutine psmile_store_data_intern_points(psmile_point_id)
         integer, intent (in) :: psmile_point_id
      end subroutine psmile_store_data_intern_points

   end interface

   contains

   function get_grid_type (grid_id)

      integer, intent (in) :: grid_id
      integer :: get_grid_type

      get_grid_type = grid_data(grid_id)%grid_type
   end function get_grid_type

   function get_grid_id (point_id)

      integer, intent (in) :: point_id
      integer :: get_grid_id

      get_grid_id = point_data(point_id)%grid_id
   end function get_grid_id

   function get_comp_id (grid_id)

      integer, intent (in) :: grid_id
      integer :: get_comp_id

      get_comp_id = grid_data(grid_id)%comp_id
   end function get_comp_id

   function get_grid_valid_shape(grid_id, size_of_valid_shape)

      integer, intent(in) :: grid_id, size_of_valid_shape(2)
      integer :: get_grid_valid_shape (size_of_valid_shape(1), 
                                       size_of_valid_shape(2))

      get_grid_valid_shape = grid_data(grid_id)%grid_valid_shape
   end function get_grid_valid_shape

   subroutine test_user_grid_id(user_grid_id, ierror)
      use prism_constants, only : PRISM_Error_Arg

      integer, intent(in)  :: user_grid_id
      integer, intent(out) :: ierror

      ierror = 0

      if (.not. associated (grid_data)) ierror = PRISM_Error_Arg
      if (ierror == 0 ) then
         if (user_grid_id > size(grid_data)) ierror = PRISM_Error_Arg
      endif

      if (ierror /= 0) then
         ierror = PRISM_Error_Arg
         call psmile_error ( PRISM_Error_Arg, 'grid_id', &
                           (/user_grid_id/), 1, __FILE__, __LINE__ )
         return
      endif
   end subroutine test_user_grid_id

   subroutine test_user_mask_id(user_mask_id, ierror)
      use prism_constants, only : PRISM_Error_Arg

      integer, intent(in)  :: user_mask_id
      integer, intent(out) :: ierror

      if (.not. associated (mask_data)) then
         continue
      else if (user_mask_id > size(mask_data))then
         continue
      else if (.not. associated (mask_data(user_mask_id)%mask_actual_shape) .or. &
               .not. associated (mask_data(user_mask_id)%mask)) then
         continue
      else
         ierror = 0
         return
      endif

      ierror = PRISM_Error_Arg
      call psmile_error ( PRISM_Error_Arg, 'mask_id', &
                        (/user_mask_id/), 1, __FILE__, __LINE__ )
   end subroutine test_user_mask_id

   subroutine test_user_point_id(user_point_id, ierror)
      use prism_constants, only : PRISM_Error_Arg

      integer, intent(in)  :: user_point_id
      integer, intent(out) :: ierror

      if (.not. associated (point_data)) then
         continue
      else if (user_point_id > size(point_data)) then
         continue
      else
         ierror = 0
         return
      endif

      ierror = PRISM_Error_Arg
      call psmile_error ( PRISM_Error_Arg, 'point_id', &
                        (/user_point_id/), 1, __FILE__, __LINE__ )
   end subroutine test_user_point_id

   subroutine init_user_coordinate_data(data)

      type (user_coordinate_data), intent(inout) :: data

      nullify (data%actual_shape)
      nullify (data%st_array_dble)
      nullify (data%nd_array_dble)
      nullify (data%rd_array_dble)
      nullify (data%st_array_real)
      nullify (data%nd_array_real)
      nullify (data%rd_array_real)

   end subroutine init_user_coordinate_data

   subroutine free_user_coordinate_data (data, ierror)

      type (user_coordinate_data), intent(inout) :: data
      integer, intent(out) :: ierror

      if (associated (data%actual_shape)) deallocate (data%actual_shape)
      if (associated (data%st_array_dble)) deallocate (data%st_array_dble)
      if (associated (data%nd_array_dble)) deallocate (data%nd_array_dble)
      if (associated (data%rd_array_dble)) deallocate (data%rd_array_dble)
      if (associated (data%st_array_real)) deallocate (data%st_array_real)
      if (associated (data%nd_array_real)) deallocate (data%nd_array_real)
      if (associated (data%rd_array_real)) deallocate (data%rd_array_real)

   end subroutine free_user_coordinate_data

   function partition_data_available (grid_id)
      integer, intent (in) :: grid_id
      logical :: partition_data_available

      integer :: ierror

      call test_user_grid_id (grid_id, ierror)

      partition_data_available = associated (grid_data(grid_id)%partition_array) .and. &
                                 associated (grid_data(grid_id)%extent_array)
   end function partition_data_available

   function reducedgrid_map_available (grid_id)
      integer, intent (in) :: grid_id
      logical :: reducedgrid_map_available

      integer :: ierror

      call test_user_grid_id (grid_id, ierror)

      reducedgrid_map_available = associated (grid_data(grid_id)%nbr_points_per_lat)
   end function reducedgrid_map_available

   subroutine generate_partition_data (grid_id)

      use psmile_grid, only : get_size_of_shape

      integer, intent (in) :: grid_id

      integer :: shape_size(2)
      integer :: ierror

      call test_user_grid_id (grid_id, ierror)

      if (.not. partition_data_available(grid_id)) then

         shape_size = get_size_of_shape(grid_data(grid_id)%grid_type)

         allocate (grid_data(grid_id)%partition_array(1,1:shape_size(2)), &
                   grid_data(grid_id)%extent_array(1,1:shape_size(2)))

         grid_data(grid_id)%partition_array(1, 1:shape_size(2)) = &
            grid_data(grid_id)%grid_valid_shape(1,1:shape_size(2)) - 1
         grid_data(grid_id)%extent_array(1, 1:shape_size(2)) = &
            grid_data(grid_id)%grid_valid_shape(2,1:shape_size(2)) - &
            grid_data(grid_id)%grid_valid_shape(1,1:shape_size(2)) + 1
      endif
   end subroutine generate_partition_data

   subroutine psmile_user_data_init()
      ! initialise internal data structures
      nullify (grid_data, point_data, mask_data, var_data)
      ! initialise the map structures
      call init_multimap(grid_id_map)
      call init_multimap(mask_id_map)
      call init_multimap(point_id_map)
      call init_multimap(var_id_map)
   end subroutine

end module psmile_user_data