prism_def_partition.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! Copyright 2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION:
!
! The routine prism_def_partition checks the consistency of the data
! provided by the user before it is further processed.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 04.11.10    M. Hanke     created based on previous
!                          prism_def_partition (now psmile_def_partition)
!
!----------------------------------------------------------------------
!
!  $Id: prism_def_partition.F90 2769 2010-11-23 14:49:21Z hanke $
!  $Author: hanke $
!
!----------------------------------------------------------------------
subroutine prism_def_partition (grid_id, nbr_blocks, &
                                partition_array, extent_array, ierror )

   use prism_constants, only  : prism_error_arg, prism_gaussreduced_regvrt
   use psmile_common, only    : ch_id
   use psmile_user_data, only : psmile_store_data_partition, test_user_grid_id, &
                                grid_data, get_grid_type
   use psmile_geometry, only  : intersect
   use psmile_grid, only      : get_size_of_shape

   implicit none

   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

   integer :: shape_size(2)
   integer :: i, j
   integer, allocatable :: extent(:), range_a(:,:), range_b(:,:)
   logical, allocatable :: varying_dimension(:)

#ifdef VERBOSE
   print 9990, trim(ch_id)
   call psmile_flushstd
#endif /* VERBOSE */

   ierror = 0

   ! we do not like to work with negative or no blocks
   if ( nbr_blocks < 1 ) then

      ierror = PRISM_Error_Arg
      call psmile_error (ierror, 'nbr_blocks', (/grid_id, nbr_blocks/), 2, &
                         __FILE__, __LINE__ )
      return
   endif

   ! test whether the user provided a valid grid_id
   call test_user_grid_id(grid_id, ierror)

   shape_size = get_size_of_shape(get_grid_type(grid_id))

   ! if there is more than one block do some checks on the provided data
   ! I do not know how to handle certain grid types, therefore they are
   ! excluded from the following tests
   if (nbr_blocks > 1 .and. &
       has_normal_extent_array(get_grid_type(grid_id))) then

      allocate (extent(shape_size(2)), varying_dimension(shape_size(2)))

      ! get the extent of the first block
      extent = extent_array(1, 1:shape_size(2))
      varying_dimension = .false.

      do i = 2, nbr_blocks
         varying_dimension = varying_dimension .or. &
                             extent /= extent_array(i, 1:shape_size(2))
      enddo

      ! if there is more than one varying dimension
      if (count (varying_dimension) > 1) then

         ierror = prism_error_arg
         call psmile_error (ierror, "'More than one varying dimension specified'", &
                            (/grid_id, count (varying_dimension)/), 2, &
                            __FILE__, __LINE__ )
      endif

      deallocate (extent, varying_dimension)

      allocate (range_a(2, shape_size(2)), range_b(2, shape_size(2)))
      ! check whether there are intersections between the blocks in the global index space
      do i = 1, nbr_blocks - 1
         range_a (1,:) = partition_array(i,1:shape_size(2)) + 1
         range_a (2,:) = partition_array(i,1:shape_size(2)) + extent_array(i,1:shape_size(2))
         do j = i + 1, nbr_blocks
            range_b (1,:) = partition_array(j,1:shape_size(2)) + 1
            range_b (2,:) = partition_array(j,1:shape_size(2)) + extent_array(j,1:shape_size(2))

            if (intersect(range_a, range_b)) then

               ierror = prism_error_arg
               print *, "block a", range_a
               print *, "block b", range_b
               call psmile_flushstd
               call psmile_assert (__FILE__, __LINE__, &
                                   "Blocks intersect in global index space!")
            endif
         enddo
      enddo

      deallocate (range_a, range_b)
   endif

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

#ifdef VERBOSE
   print 9980, trim(ch_id), ierror
   call psmile_flushstd
#endif /* VERBOSE */

9990 format (1x, a, ': prism_def_partition: ')
9980 format (1x, a, ': prism_def_partition: eof ierror =', i5)

   contains

      function has_normal_extent_array(grid_type)
         integer, intent(in) :: grid_type
         logical :: has_normal_extent_array

         has_normal_extent_array = grid_type /= prism_gaussreduced_regvrt

      end function has_normal_extent_array

end subroutine prism_def_partition