psmile_compact_neighbors_3d.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Compact_neighbors_3d
!
! !INTERFACE:

      subroutine psmile_compact_neighbors_3d ( &
               neighbors_3d, nloc, num_neigh,  &
               grid_valid_shape, extra_search, &
               send_info, neighbors, ierror)
!
! !USES:
!
      use PRISM_constants
      use psmile_common, only : extra_search_info
      use PSMILe, dummy_interface => PSMILe_Compact_neighbors_3d

      implicit none
!
! !INPUT PARAMETERS:

      Integer, Intent (In)            :: nloc
!
!     Number of locations to be transferred
!
      Integer, Intent (In)            :: num_neigh
!
!     Last dimension of neighbors array "neighbors_3d"
!
      Integer, Intent (In)            :: neighbors_3d (ndim_3d, nloc, num_neigh)
!
!     Indices of neighbor locations (interpolation bases)
!
      Integer, Intent (In)            :: grid_valid_shape (2, ndim_3d)

!     Specifies the valid block shape for the "ndim_3d"-dimensional block

      Type(Extra_search_info), Intent(In) :: extra_search

!     Contains inforation on how to identify points/cells which are found by global search
!
! !INPUT/OUTPUT PARAMETERS:
!
      Type (Send_information), Intent (InOut)  :: send_info
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)           :: neighbors (nloc, num_neigh)
!
!     1D-Indices of neighbor locations (interpolation bases)
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILE_Compact_neighbors_3d;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for compact list
!
      Integer                         :: i, j, k, n, n_list
      Integer                         :: size (ndim_3d)
!
      Integer, Allocatable            :: indices (:, :, :)
      Integer, Pointer                :: list_entries (:, :)
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 2
      Integer                         :: ierrp (nerrp)
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Compact_neighbors_3d" transforms the 3d-indices
! stored in "neighbours_3d" into a 1D-index of a compact list of 
! the interpolation bases to be required for interpolation.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_compact_neighbors_3d.F90 2695 2010-10-29 15:48:58Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_compact_neighbors_3d.F90 2695 2010-10-29 15:48:58Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      size (:) = grid_valid_shape(2,:) - grid_valid_shape(1,:) + 1
!
!===> Generate indices within list of interpolations bases
!
      Allocate (indices (grid_valid_shape(1,1):grid_valid_shape(2,1), &
                         grid_valid_shape(1,2):grid_valid_shape(2,2), &
                         grid_valid_shape(1,3):grid_valid_shape(2,3)), &
                STAT = ierror)
!
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = PRODUCT (size)

         ierror = PRISM_Error_Alloc

         call psmile_error ( ierror, 'indices', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      indices = 0
!
!===> Generate mask of valid points
!
      do n = 1, num_neigh

!cdir vector
         do i = 1, nloc
         if (grid_valid_shape(1,1) <= neighbors_3d (1,i,n) .and. &
             grid_valid_shape(2,1) >= neighbors_3d (1,i,n) .and. &
             grid_valid_shape(1,2) <= neighbors_3d (2,i,n) .and. &
             grid_valid_shape(2,2) >= neighbors_3d (2,i,n) .and. &
             grid_valid_shape(1,3) <= neighbors_3d (3,i,n) .and. &
             grid_valid_shape(2,3) >= neighbors_3d (3,i,n)) then

            neighbors (i, n) = 1

         else
!
!           ... no interpolation base available
!
            neighbors (i, n) = 0
         endif
         end do ! i = 1, nloc
      end do ! n = 1, num_neigh
!
!===> Generate list
!
      n_list = 0

      do n = 1, num_neigh
!cdir vector
         do i = 1, nloc
         if (neighbors (i, n) > 0) then
            if (indices (neighbors_3d (1,i,n), &
                         neighbors_3d (2,i,n), &
                         neighbors_3d (3,i,n)) == 0) then
               n_list = n_list + 1
               indices (neighbors_3d (1,i,n), &
                        neighbors_3d (2,i,n), &
                        neighbors_3d (3,i,n)) = n_list
            endif
         endif
         end do ! i = 1, nloc
      end do ! n = 1, num_neigh
!
#ifdef PRISM_ASSERTION
      if (n_list > PRODUCT (size)) then
         print *, trim(ch_id), ": n_list =", n_list, nloc, size
         call psmile_assert (__FILE__, __LINE__, &
              "Invalid number of entries n_list generated")
      endif
#endif
!
!===> Special case: all points
!
#ifdef ONLY_FOR_TESTING
      print *, '#### psmile_compact_neighbors_3d: ONLY FOR TESTING ACTIVE'
      if ( .false. ) then
#else
!
! Do not jump into send_entire_valid_shape for corner neighbours
! Currently this is avieved by requiring num_neigh > 1. nneighbour
! search with only 1 neighbour required would also fall into
! this category. For the rather rare case we would also run
! into the less optimal part and establish a list.
!
      if (n_list == PRODUCT (size) .and. num_neigh > 1 ) then
#endif
         do n = 1, num_neigh
!cdir vector
            do i = 1, nloc

            neighbors (i, n) = neighbors (i, n) *                    &
           (((neighbors_3d (3,i,n)-grid_valid_shape(1,3))*size(2)  + &
             (neighbors_3d (2,i,n)-grid_valid_shape(1,2)))*size(1) + &
             (neighbors_3d (1,i,n)-grid_valid_shape(1,1)) + 1)

            end do ! i = 1, nloc
         end do ! n = 1, num_neigh
!
         Nullify (send_info%list_entries)
         send_info%send_entire_valid_shape = .true.

      else

         send_info%send_entire_valid_shape = .false.
!
         Allocate (send_info%list_entries (ndim_3d, n_list), &
                   STAT = ierror)
!
         if (ierror > 0) then
            ierrp (1) = ierror
            ierrp (2) = ndim_3d * n_list

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'send_info%list_entries', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
!
         list_entries => send_info%list_entries
!
!===> Generate compact list of entries to be sent
!
         do n = 1, num_neigh
!cdir vector
            do i = 1, nloc
            if (neighbors (i,n) > 0) then
                neighbors (i,n) = indices (neighbors_3d (1,i,n), &
                                           neighbors_3d (2,i,n), &
                                           neighbors_3d (3,i,n))
            endif
            end do ! i = 1, nloc
         end do ! n = 1, num_neigh
!
         do k = grid_valid_shape(1,3), grid_valid_shape(2,3)
            do j = grid_valid_shape(1,2), grid_valid_shape(2,2)
               do i = grid_valid_shape(1,1), grid_valid_shape(2,1)
               if (indices (i,j,k) > 0) then
                  list_entries (1, indices (i,j,k)) = i
                  list_entries (2, indices (i,j,k)) = j
                  list_entries (3, indices (i,j,k)) = k
               endif
               end do
            end do
         end do

      endif
!
      Deallocate (indices)
!
#ifdef PRISM_ASSERTION
!
!===> Control list generated
!
      do n = 1, num_neigh
         do i = 1, nloc
         if (neighbors (i, n) < 0 .or. neighbors (i, n) > n_list) exit
         end do
!
         if (i < nloc) then
             print *, trim(ch_id), i, n, neighbors (i, n), n_list
             call psmile_assert (__FILE__, __LINE__, &
                  "Invalid neighbour list generated ")
         endif
      end do
#endif
!
!-----------------------------------------------------------------------
!     Add points found in global search.
!     The points are added at the end of the buffer.
!-----------------------------------------------------------------------
!
      if ( send_info%nrecv > 0 .and. send_info%num2recv > 0 ) then
!
!
#ifdef PRISM_ASSERTION
!
!===> Control list generated
!
            do n = 1, num_neigh
               do i = 1, nloc
               if (neighbors_3d (1, i, n) == extra_search%global_marker .and. &
                  (neighbors_3d (2, i, n) < 1 .or.               &
                   neighbors_3d (2, i, n) > send_info%num2recv)) exit
               end do

               if (i < nloc) then
                   print *, trim(ch_id), ": i, n, neighbors_3d", &
                         i, n, neighbors_3d (1:ndim_3d, i, n)
                   print *, trim(ch_id), ": nrecv, num2recv", &
                         send_info%nrecv, send_info%num2recv
!
                   call psmile_assert (__FILE__, __LINE__, &
                        "Invalid index of global search ")
               endif
            end do
#endif
!
            do n = 1, num_neigh
!cdir vector
               do i = 1, nloc
               if (neighbors_3d (1, i, n) == extra_search%global_marker) then
                   neighbors (i, n) = n_list + neighbors_3d (2, i, n)
               endif
               end do ! i = 1, nloc
            end do ! n = 1, num_neigh
!
         n_list = n_list + send_info%num2recv
      endif
!
!===> All done
!
      send_info%n_list = n_list
!
#ifdef VERBOSE
      print 9980, trim(ch_id), n_list

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_compact_neighbors_3d')
9980 format (1x, a, ': psmile_compact_neighbors_3d: eof, n_list', i9)

      end subroutine psmile_compact_neighbors_3d