psmile_ccompact_3d_reg_real.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_ccompact_3d_reg_real
!
! !INTERFACE:

      subroutine psmile_ccompact_3d_reg_real ( send_info,   &
               grid_valid_shape, shape, nb_corners,         &
               array_x, array_y, array_z,                   &
               extra_search, dest_size, nbr_cells_tot,      &
               source_cell_index,                           &
               neighcells, dest_x, dest_y, dest_z, ierror )
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_ccompact_3d_reg_real

      implicit none
!
! !INPUT PARAMETERS:
!
      Type (Send_information), Intent (InOut)  :: send_info
!
!     Structure containing the send information
!
      Integer, Intent (In)            :: grid_valid_shape (2, ndim_3d)

!     Specifies the valid block shape for the "ndim_3d"-dimensional block
!
      Integer, Intent (In)            :: shape (2, ndim_3d)
!
!     Shape of the array "array"
!
      Integer, Intent (In)            :: nb_corners
!
!     Number of corners in "array_x/y"
!
      Real, Intent (In)               :: array_x ( shape(1,1):shape(2,1), 
                                                   nb_corners )
      Real, Intent (In)               :: array_y ( shape(1,2):shape(2,2), 
                                                   nb_corners )
      Real, Intent (In)               :: array_z ( shape(1,3):shape(2,3) )
!
!     Arrays from which the compact list should be extracted
!
      Type (Extra_search_info), Intent (InOut) :: extra_search
!
!     Info's on global coordinates to be searched
!
      Integer, Intent (In)            :: dest_size
!
!     Size of destination arrays
!
      Integer, Intent (In)            :: nbr_cells_tot
!
!     Total number of source cells
!
      Integer, Intent (InOut)         :: source_cell_index (nbr_cells_tot)
!
!     Index of source cells
!
      Integer, Intent (InOut)         :: neighcells (nbr_cells_tot, 4)
!
!     Dimension of output vector "dest_vector"
!
! !OUTPUT PARAMETERS:
!
      Real, Intent (Out)              :: dest_x (dest_size)
      Real, Intent (Out)              :: dest_y (dest_size)
      Real, Intent (Out)              :: dest_z (dest_size)
!
!     Output vectors of compact list
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILE_ccompact_3d_reg_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for compact list
!
      Integer, Pointer                :: list_entries (:, :)
      Integer                         :: nbr_cells_loc
!
!     ... for extracting the compact list

      Integer                         :: l, n, ni, nk
      Integer                         :: nij, nij_loc
!
!     ... for globally searched data
!

      Real, Parameter                 :: tol = 1.0d-12 

      Integer                         :: i, j, k
      Integer                         :: dest_idx_off
      Integer                         :: idx1, idx2, jdx1, jdx2, stride
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_ccompact_3d_reg_real" extracts the data
! required from the 2-dimensional corner array "array" and stores the data in
! destination vector "dest_vector".
!
! Work on array_x and array_y in 1 role
! detect sense
! determine index
! we have to build two lists, one for the corners of the cells and another one for the
! cells (data) itself!!! 
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_ccompact_3d_reg_real.F90 2590 2010-09-23 15:56:33Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_ccompact_3d_reg_real.F90 2590 2010-09-23 15:56:33Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), send_info%send_entire_valid_shape

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
      if (dest_size < send_info%n_list) then
         print *, trim(ch_id), 'dest_size, n_list', dest_size, send_info%n_list
         call psmile_assert (__FILE__, __LINE__, &
                             "dest_size is not sufficient")
      endif
#endif
!
      ierror = 0

      nbr_cells_loc = nbr_cells_tot - send_info%num2recv

!------------------------------------------------------------------------
!     Store corners
!------------------------------------------------------------------------
!
!===> Get compact list
!
      ! Initialization of output variables
      dest_x = -1
      dest_y = -1
      dest_z = -1

      if ( send_info%send_entire_valid_shape ) then

         ni  =      (grid_valid_shape (2,1) - grid_valid_shape (1,1) + 1)
         nij = ni * (grid_valid_shape (2,2) - grid_valid_shape (1,2) + 1) * 4
         nk =       (grid_valid_shape (2,3) - grid_valid_shape (1,3) + 1)

#ifdef PRISM_ASSERTION
         if (dest_size < nij * nk ) then
            print *, trim(ch_id), 'dest_size, nijk', dest_size, nij*nk
            call psmile_assert ( __FILE__, __LINE__, &
                                "dest_size is not sufficient")
         endif
#endif
         n = 0

         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)
                  n = n + 1
                  dest_x(n) = min(array_x(i,1), array_x(i,2))
                  dest_y(n) = min(array_y(j,1), array_y(j,2))
                  dest_z(n) = array_z(k)
               end do
            end do
         end do

         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)
                  n = n + 1
                  dest_x(n) = max(array_x(i,1), array_x(i,2))
                  dest_y(n) = min(array_y(j,1), array_y(j,2))
                  dest_z(n) = array_z(k)
               end do
            end do
         end do

         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)
                  n = n + 1
                  dest_x(n) = max(array_x(i,1), array_x(i,2))
                  dest_y(n) = max(array_y(j,1), array_y(j,2))
                  dest_z(n) = array_z(k)
               end do
            end do
         end do

         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)
                  n = n + 1
                  dest_x(n) = min(array_x(i,1), array_x(i,2))
                  dest_y(n) = max(array_y(j,1), array_y(j,2))
                  dest_z(n) = array_z(k)
               end do
            end do
         end do

      else
!
!===> Get compact list
!
         list_entries => send_info%list_entries

         nij     = send_info%n_list
         nij_loc = nij - send_info%num2recv

#ifdef PRISM_ASSERTION
         if (.not. Associated (list_entries)) then
            call psmile_assert (__FILE__, __LINE__, &
                 "list_entries are not available")
         endif

!cdir vector
         do n = 1, nij_loc
            if ( list_entries(1, n) < grid_valid_shape (1,1) .or. &
                 list_entries(1, n) > grid_valid_shape (2,1) .or. &
                 list_entries(2, n) < grid_valid_shape (1,2) .or. &
                 list_entries(2, n) > grid_valid_shape (2,2)) exit
         end do

         if ( n < nij_loc ) then
            print *, 'n, list_entry, grid_valid_shape', n, list_entries(1, n), &
                 list_entries(2, n), grid_valid_shape
            call psmile_assert (__FILE__, __LINE__, &
                 "incorrect index in list_entries")
         endif
#endif
         do n = 1, nij_loc
            dest_x(n) = min(array_x(list_entries(1,n),1), &
                            array_x(list_entries(1,n),2))
            dest_y(n) = min(array_y(list_entries(2,n),1), &
                            array_y(list_entries(2,n),2))
            dest_z(n) = array_z(list_entries(3,n))
         end do

         do n = 1, nij_loc
            dest_x(nij+n) = max(array_x(list_entries(1,n),1), &
                                array_x(list_entries(1,n),2))
            dest_y(nij+n) = min(array_y(list_entries(2,n),1), &
                                array_y(list_entries(2,n),2))
            dest_z(nij+n) = array_z(list_entries(3,n))
         end do

         do n = 1, nij_loc
            dest_x(2*nij+n) = max(array_x(list_entries(1,n),1), &
                                  array_x(list_entries(1,n),2))
            dest_y(2*nij+n) = max(array_y(list_entries(2,n),1), &
                                  array_y(list_entries(2,n),2))
            dest_z(2*nij+n) = array_z(list_entries(3,n))

         end do

         do n = 1, nij_loc
            dest_x(3*nij+n) = min(array_x(list_entries(1,n),1), &
                                  array_x(list_entries(1,n),2))
            dest_y(3*nij+n) = max(array_y(list_entries(2,n),1), &
                                  array_y(list_entries(2,n),2))
            dest_z(3*nij+n) = array_z(list_entries(3,n))
         end do

      endif

!-----------------------------------------------------------------------
!     Create source cell index list
!-----------------------------------------------------------------------

      do n = 2, 4
         do i = 1, nbr_cells_loc
            neighcells (i,n) = neighcells (i,1) + (n-1) * nij
         enddo
      enddo

      source_cell_index(:) =  neighcells(:,1)
!
!-----------------------------------------------------------------------
!     Add cells found in global search.
!     The cells are added at the end of the buffer.
!-----------------------------------------------------------------------
!
      if ( send_info%num2recv > 0 ) then

         do n = 2, 4
            do i = 1, send_info%num2recv
               neighcells (nbr_cells_loc+i,n) = &
               neighcells (nbr_cells_loc+i,1) + (n-1) * nij
            end do
         enddo

         ! calucalate offset for dest_*
         ! we write behind the data of the local process
         dest_idx_off = nij_loc

         do l = 1, send_info%nrecv

            stride = nb_corners*send_info%len_sent(l)

            do i = 1, send_info%len_sent(l)
               idx1 = i
               idx2 = send_info%len_sent(l)+i

               jdx1 = stride + idx1
               jdx2 = stride + idx2

               n = 0
               dest_x (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(idx1)
               dest_y (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(jdx1)
               ! Rene : vertical coordinate not clean yet !!
               dest_z (n*nij+dest_idx_off+i) = array_z(1)

               n = 1
               dest_x (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(idx2)
               dest_y (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(jdx1)
               ! Rene : vertical coordinate not clean yet !!
               dest_z (n*nij+dest_idx_off+i) = array_z(1)

               n = 2
               dest_x (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(idx2)
               dest_y (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(jdx2)
               ! Rene : vertical coordinate not clean yet !!
               dest_z (n*nij+dest_idx_off+i) = array_z(1)

               n = 3
               dest_x (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(idx1)
               dest_y (n*nij+dest_idx_off+i) = extra_search%real_bufs(l)%vector(jdx2)
               ! Rene : vertical coordinate not clean yet !!
               dest_z (n*nij+dest_idx_off+i) = array_z(1)

            end do

            ! we do not want to overwrite the data just written
            dest_idx_off = dest_idx_off + send_info%len_sent(l)

            Deallocate (extra_search%real_bufs(l)%vector)

         enddo

      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_ccompact_3d_reg_real: send_entire_valid', l2)
9980 format (1x, a, ': psmile_ccompact_3d_reg_real: eof')

      end subroutine psmile_ccompact_3d_reg_real