psmile_store_faces_irreg2_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_Store_faces_irreg2_real
!
! !INTERFACE:

      subroutine psmile_store_faces_irreg2_real (indices_req,      &
                      required, nreq,                              &
                      tgt_coords1, tgt_coords2, tgt_coords3, ncpl, &
                      corners1, corners2, corners3,                &
                      corner_shape, nbr_corners, grid_valid_shape, &
                      send_mask, srcloc_ind,                       &
                      ibuf, len_item, ndibuf, ipia,                &
                      buf,  len_rtem, ndrbuf, ipa, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Store_faces_irreg2_real

      Implicit none
!
! !INPUT PARAMETERS:

      Integer,           Intent (In)  :: nreq
!
!     Total number of extra points to be searched for the current partition.
!     Dimension of "indices_req" and "send_mask"
!
      Integer,            Intent (In) :: indices_req (nreq)
!
!     Indices of the extra points in entire list of all points to be
!     searched (i.e. for all parts "ipart")
!
      Integer,            Intent (In) :: required    (nreq)
!
!     Code for the extra points which are additionally required.
!
      Integer,           Intent (In)  :: corner_shape (2, ndim_3d)
      
!     Specifies the dimension of arrays "corners1", "corners2" and "corners3"

      Integer,           Intent (In)  :: nbr_corners

!     Number of corners in control volume 
!     Must be 8 for a grid of type "PRISM_Reglonlatvrt".

      Integer,           Intent (In)  :: grid_valid_shape (2, ndim_3d)
      
!     Specifies the valid block shape for the "ndim_3d"-dimensional block

      Integer,           Intent (In)  :: ncpl

!     Total number of points to be transferred 
!     = Dimensions of tgt_coords1, tgt_coords2, tgt_coords3

      Real,             Intent (In)  :: tgt_coords1 (ncpl)
      Real,             Intent (In)  :: tgt_coords2 (ncpl)
      Real,             Intent (In)  :: tgt_coords3 (ncpl)

!     Coordinates of the points to be searched

      Real,             Intent (In)  ::                
         corners1 (corner_shape(1,1):corner_shape(2,1), 
                   corner_shape(1,2):corner_shape(2,2), nbr_corners/2)

      Real,             Intent (In)  ::                
         corners2 (corner_shape(1,1):corner_shape(2,1), 
                   corner_shape(1,2):corner_shape(2,2), nbr_corners/2)

      Real,             Intent (In)  ::                
         corners3 (corner_shape(1,3):corner_shape(2,3), 2)
!
!     Coordinates of corners of cell/control volume
!
      Logical,           Intent (In)  :: send_mask (nreq)
!
!     Mask for the points (of "indices_req") to be sent.
!
      Integer,           Intent (In)  :: ndibuf
!
!     Dimension of integer buffer "ibuf"
!
      Integer,           Intent (In)  :: srcloc_ind (ndim_3d, ndibuf)
!
!     Indices of points in "corners" to be sent.
!
      Integer,           Intent (In)  :: len_item
!
!     Length per data item in integer buffer "ibuf"
!        1:3: (i,j,k) index of lower left corner
!        4  : index in
!        5  : code for points required
!
      Integer,           Intent (In)  :: ndrbuf
!
!     Dimension of Real buffer "buf"
!
      Integer,           Intent (In)  :: len_rtem
!
!     Length per data item in Real buffer "buf"
!        1:3: Coordinates of the point to be searched
!        :  : Coordinates of corners of control volume/cell
!             (ndim_3d * nc_reg values)
!
! !OUTPUT PARAMETERS:
!
      Real,             Intent (InOut) :: buf (len_rtem, ndrbuf)
!
!     Buffer returning the packed Real data.
!
      Integer,           Intent (InOut) :: ipa
!
!     Number of data items stored in "buf";
!     i.e. buf(1:ipa) contains buffered data.
!
      Integer,           Intent (InOut) :: ibuf (len_item, ndibuf)
!
!     Integer buffer returning the packed integer data.
!
      Integer,           Intent (InOut) :: ipia
!
!     Number of data items stored in "ibuf";
!     i.e. ibuf(:, 1:ipia) contains buffered data.
!
      Integer,           Intent (Out)   :: ierror

!     Returns the error code of PSMILe_Store_faces_irreg2_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL PARAMETERS
!
!  NC_REG = Number of corners for regular directions
!
      Integer, Parameter              :: nc_reg = 2
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
      Integer                         :: j, n
!
      Integer                         :: nbc
!
!     ... buffer pointers
!
      Integer                         :: ip, ipb, ipi
      Integer                         :: ind (ndim_3d, ipa+1:ipa+nreq)
!
!     ... for error handling
!
!     Integer, Parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Store_faces_irreg2_real" stores the face info on
! (corner) cells to be transferred to neighbouring process for 
! global search of interpolation bases.
!
! Subroutine "PSMILe_Store_faces_irreg2_real" is designed for grids of
! type "PRISM_Irrlonlat_Regvrt"
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_store_faces_irreg2_real.F90 2082 2009-10-21 13:31:19Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_store_faces_irreg2_real.F90 2082 2009-10-21 13:31:19Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), nreq

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      nbc = nbr_corners / nc_reg
!
#ifdef PRISM_ASSERTION
         do j = 1, nreq
         if (send_mask(j)) then
            if (required(j) == 0) exit
         endif
         end do
!
      if (j < nreq) then
         print *, 'j, required', j, required (j)
         call psmile_assert (__FILE__, __LINE__, &
              "No points required")
      endif
!
      if (len_item < ndim_3d + 2) then
         print *, 'len_item', len_item, ndim_3d + 2
         call psmile_assert (__FILE__, __LINE__, &
              "len_item is insufficicent")
      endif
!
      if (len_rtem < ndim_3d + nbc*ndim_2d + ndim_2d) then
         print *, 'len_rtem', len_rtem, ndim_3d + nbc*ndim_2d + ndim_2d
         call psmile_assert (__FILE__, __LINE__, &
              "len_rtem is insufficicent")
      endif

      ip = count(send_mask)
      if (ipa+ip > ndrbuf) then
         print *, 'ndrbuf, ip, ipa, nreq', &
                   ndrbuf, ip, ipa, nreq
         call psmile_assert (__FILE__, __LINE__, &
                    "ndrbuf is not sufficient")
      endif
!
      if (ipia+ip > ndibuf) then
         print *, 'ndibuf, ip, ipia, nreq', &
                   ndibuf, ip, ipia, nreq
         call psmile_assert (__FILE__, __LINE__, &
                    "ndrbuf is not sufficient")
      endif
#endif
!
      ipi = ipia
      ip  = ipa
!
!===> Get indices of last corner cell within domain
!     Note: srcloc_ind may be indices of a virtual cell
!  HUHU  ? should be use virtual_cell info (gauss grid) instead
!  HUHU    and let srcloc_ind an index within the domain !

      do j = 1, nreq
      if (send_mask(j)) then
         ip = ip + 1
         ind (:, ip) = max (srcloc_ind(:,ip), grid_valid_shape (1,:))
         ind (:, ip) = min (ind(:, ip),       grid_valid_shape (2,:))
      endif
      end do
!
      ip = ipa
!
!===> Fill buffers
!
         do j = 1, nreq
         if (send_mask(j)) then
!
!===> ... n-th domain is a potential partner
!
!===> ... Store data in Real buffer "buf"
!
!  Storage sequence in "buf":
!  buf (:) = Coordinates of the point to be searched
!  buf (:) = Coordinates of corners of control volume/cell
!
            ip = ip + 1
!
            buf (1, ip) = tgt_coords1 (indices_req(j))
            buf (2, ip) = tgt_coords2 (indices_req(j))
            buf (3, ip) = tgt_coords3 (indices_req(j))
!
!  HUHU: Does it make really sense to transfer the box !?!
!
               do n = 1, nbc
               buf (ndim_3d+(n-1)*ndim_2d+1, ip) = &
                   corners1 (ind(1,ip), ind (2,ip), n)
               buf (ndim_3d+(n-1)*ndim_2d+2, ip) = &
                   corners2 (ind(1,ip), ind (2,ip), n)
               end do
!
            ipb = ndim_3d + nbc * ndim_2d
            buf (ipb+1, ip) = corners3 (ind(3, ip), 1)
            buf (ipb+2, ip) = corners3 (ind(3, ip), 2)
!
!===> ... Store logical coordinates of point to be searched in
!         integer buffer "ibuf"
!
!  ibuf (1:ndim_3d, :) = srcloc of extra point
!  ibuf (4,         :) = Index of the extra point to be searched
!                        This is a local index in the vectors
!                        "required" and "indices_req" of the actual
!                        partition "ipart".
!  ibuf (5,         :) = Code for interpolation bases required
!
            ipi = ipi + 1
!
            ibuf (1, ipi) = srcloc_ind (1, ip)
            ibuf (2, ipi) = srcloc_ind (2, ip)
            ibuf (3, ipi) = srcloc_ind (3, ip)
!
            ibuf (4, ipi) = j
            ibuf (5, ipi) = required (j)
!
         endif
         end do ! j
!
!===> All done; return current length
!
      ipia = ipi
      ipa  = ip
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_store_faces_irreg2_real: nreq ', i5)
9980 format (1x, a, ': psmile_store_faces_irreg2_real: eof ierror =', i3)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Store_faces_irreg2_real