psmile_store_faces_gauss2_dble.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_gauss2_dble
!
! !INTERFACE:

      subroutine psmile_store_faces_gauss2_dble (indices_req,      &
                      required, nreq,                              &
                      tgt_coords1, tgt_coords2, tgt_coords3, ncpl, &
                      corners1, corners2, corners3, corner_shape,  &
                      nbr_corners, grid_id, grid_valid_shape,      &
                      send_mask, srcloc_ind,                       &
                      virtual_ind, virtual_cell_available,         &
                      ibuf, len_item, ndibuf, ipia,                &
                      buf,  len_rtem, ndrbuf, ipa, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Store_faces_gauss2_dble
#ifdef DEBUG_TRACE
      use psmile_debug_trace
#endif

      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_id

!     Grid Id of the source grid (grid on which the points are searched)


      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

      Double Precision,  Intent (In)  :: tgt_coords1 (ncpl)
      Double Precision,  Intent (In)  :: tgt_coords2 (ncpl)
      Double Precision,  Intent (In)  :: tgt_coords3 (ncpl)

!     Coordinates of the points to be searched

      Double Precision,   Intent (In) :: 
         corners1 ( corner_shape(1,1):corner_shape(2,1), 2)
!        corners1 ( corner_shape(1,1):corner_shape(2,1), nbr_corners/2)

      Double Precision,   Intent (In) :: 
         corners2 ( corner_shape(1,1):corner_shape(2,1), 2)
!        corners2 ( corner_shape(1,1):corner_shape(2,1), nbr_corners/2)

      Double Precision,   Intent (In) :: 
         corners3 ( corner_shape(1,3):corner_shape(2,3), 2)
!
!     Coordinates of corners of cell/control volume.
!     Note: This is a grid of type PRISM_Gaussreduced_Regvrt, i.e. 
!           2 corner coordinates per regular direction
!
      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.
!     The indices are indices in the GaussReduced Grid
!     (Not in the auxiliary lonlat grid).
!
      Integer,           Intent (In)  :: virtual_ind (ndibuf)
!
!     Virtual cell info
!
      Logical,           Intent (In)  :: virtual_cell_available
!
!     Is virtual cell info available and should the info be stored ?
!
      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 Double Precision buffer "buf"
!
      Integer,           Intent (In)  :: len_rtem
!
!     Length per data item in Double Precision 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:
!
      Double Precision,  Intent (InOut) :: buf (len_rtem, ndrbuf)
!
!     Buffer returning the packed Double Precision 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_gauss2_dble;
!             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
!
!     ... for gaussian reduced grids
!
      Integer                         :: nbr_lats
      Logical                         :: store_virtual
!  
      Type (Grid), Pointer            :: gp
      Integer, Pointer                :: points_per_lat (:,:)

!
!     ... buffer pointers
!
      Integer                         :: ip, ipi
!
!     ... for error handling
!
!     Integer, Parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Store_faces_gauss2_dble" computes
!
! Subroutine "PSMILe_Store_faces_gauss2_dble" is designed for grids of
! type "PRISM_Gaussreduced_Regvrt"
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_store_faces_gauss2_dble.F90 2966 2011-02-18 09:47:30Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_store_faces_gauss2_dble.F90 2966 2011-02-18 09:47:30Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), nreq

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0

!     nbc = nbr_corners/nc_reg
      nbc = 2
!
#ifdef PRISM_ASSERTION
!
      if (grid_valid_shape (1,2) /= 1 .or. &
          grid_valid_shape (2,2) /= 1) then
         call psmile_assert (__FILE__, __LINE__, &
              "Internal definition of GaussReduced grid not correct")
      endif
!
      if (grid_valid_shape (1,1) /= corner_shape(1,1) .or. &
          grid_valid_shape (2,1) /= corner_shape(2,1) .or. &
          grid_valid_shape (1,2) /= corner_shape(1,2) .or. &
          grid_valid_shape (2,2) /= corner_shape(2,2)) then
!
         print *, 'corner_shape    ', corner_shape
         print *, 'grid_valid_shape', grid_valid_shape
!
         call psmile_assert (__FILE__, __LINE__, &
              "corner_shape /= grid_valid_shape; don't know to address")
      endif
!
         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
!
!===> Get number of points per lat for Gaussian Reduce grid
!
      gp => Grids(grid_id)
      points_per_lat => gp%extent
!
      nbr_lats = size(gp%extent(:,1))
!
      ipi = ipia
      ip  = ipa
!
      store_virtual = virtual_cell_available ! Help the compiler
!
!===> Fill buffers
!
!cdir vector
      do j = 1, nreq
         if (send_mask(j)) then
!
!===> ... n-th domain is a potential partner
!
!===> ... Store data in Double Precision 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))
!
! das ist unsinn
! box
            do n = 1, nbc
               buf (n*ndim_3d+1, ip) = corners1 (srcloc_ind(1,ip), n)
               buf (n*ndim_3d+2, ip) = corners2 (srcloc_ind(1,ip), n)
               buf (n*ndim_3d+3, ip) = corners3 (srcloc_ind(3,ip), n)
            end do
!
!===> ... 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
!  ibuf (6,         :) = virtual_cell info
!
            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)
            if (store_virtual) ibuf (6, ipi) = virtual_ind (ip)
!
#ifdef DEBUG_TRACE
            if (indices_req (j) == ictl) then
            print *, "psmile_store_faces_gauss2_dble: indices_req(j)", &
                     indices_req (j), ", ipi", ipi
            print *, 'required: j, ind, required', &
                     j, ibuf (1, ipi), ibuf (2, ipi), ibuf (3, ipi), &
                     required (j), 'virtual', ibuf (6, ipi)
            endif
#endif
!
#ifdef DEBUGX
            print *, 'required: j, ind, required', &
                     j, ibuf (1, ipi), ibuf (2, ipi), ibuf (3, ipi), &
                     required (j), 'virtual', ibuf (6, ipi)
#endif
!
         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_gauss2_dble: nreq ', i5)
9980 format (1x, a, ': psmile_store_faces_gauss2_dble: eof ierror =', i3)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Store_faces_gauss2_dble