psmile_get_face_ind_21d.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_Get_face_ind_21d
!
! !INTERFACE:

      subroutine psmile_get_face_ind_21d (search, extra_search,         &
                           send_info, len_cpl,                          &
                           send_mask, nreq, srcloc_ind, n_send,         &
                           ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Get_face_ind_21d

      Implicit none
!
! !INPUT PARAMETERS:
!
      Type (Enddef_search),     Intent (In) :: search

!     Info's on coordinates to be searched
!
      Type (Extra_search_info), Intent (In) :: extra_search
!
!     Info's on locations which 
!     (*) require global search or
!     (*) extra neighbourhood search
!
      Type (Send_information),  Intent (In) :: send_info
!
!     Send info's for sends to the coupler.
!
      Integer,                  Intent (In) :: len_cpl (search%npart)

!     Number of points to be sent to the coupler for each partition.

      Integer,                  Intent (In) :: nreq
!
!     Total number of extra points to be searched.
!     Dimension of "send_mask".
!
      Logical,                  Intent (In) :: send_mask (nreq)
!
!     Mask for the points (of "indices_req") to be sent.
!
      Integer,                  Intent (In) :: n_send
!
!     Number of extra points to be sent and 
!     number of indices to be returned.
!
! !OUTPUT PARAMETERS:
!
      Integer,                  Intent (Out) :: srcloc_ind (ndim_3d, n_send)
!
!     3d-indices of the locations to be sent.
!
      Integer,                  Intent (Out) :: ierror

!     Returns the error code of PSMILe_Get_face_ind_21d;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
! indl = Index of LonLat values in "srclocs"
! indz = Index of Vert   values in "srclocs"
!
      Integer, Parameter              :: indl = 1
      Integer, Parameter              :: indz = 2
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
      Integer                         :: i, j, n
!
!     ... for partitions
!
      Integer                         :: ipart, nextra_prev, nprev
      Integer                         :: lenij
!
      Integer, Pointer                :: indices_req (:)
      Integer, Pointer                :: len_req (:)
      Integer, Pointer                :: srcloc  (:)
      Integer, Pointer                :: srclocz (:)
!
!     ... for locations
!
      Integer                         :: ind, indk
!
!     ... for error handling
!
!     Integer, Parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_face_ind_21d" computes the 3d indices of
! the locations to be sent to a "coinciding" (neighboured)
! process of the same component.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_get_face_ind_21d.F90 2933 2011-01-31 16:42:27Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_face_ind_21d.F90 2933 2011-01-31 16:42:27Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      len_req => extra_search%len_req
!
#ifdef PRISM_ASSERTION
      if (SUM(len_req(:)) > nreq) then
         print *, 'nreq, sum(len_req)', nreq, SUM(len_req(:))
         call psmile_assert ( __FILE__, __LINE__, &
                 'nreq is too small (inconsistent data)')
      endif
!
      if (send_info%nvec /= 2) then
         print *, 'nvec', send_info%nvec
         call psmile_assert ( __FILE__, __LINE__, &
                 'Routine is designed for irregular lonlat and regular z case (2d and 1d vector)')
      endif
#endif
!
!  For all parts "ipart"
!
!  indices_req = Indices of the extra points in entire list of all points
!                to be searched (i.e. for all parts "ipart")
!
      n = 0
      nprev = 0
      nextra_prev = 0
! 
      do ipart = 1, search%npart
!
         if (len_req (ipart) > 0) then
            indices_req => extra_search%indices_req(ipart)%vector
            srcloc  => send_info%srclocs(indl,ipart)%vector
            srclocz => send_info%srclocs(indz,ipart)%vector
!
            lenij = send_info%npoints(1,ipart)
!
            do j = 1, len_req (ipart)
               if (send_mask(nextra_prev+j)) then
!
!  ... Compute index in srcloc
!      "srcloc_ij" is generated as array of dimension (ndim_2d, *)
!                  for the points in lonlat direction.
!      "srcloc_k"  is generated as 1-dimensional array
!                  for the points in z direction.
!
                  n = n + 1
!
                  i = indices_req(j) - nprev - 1
                  indk = i / lenij
                  ind  = (i - indk*lenij) * ndim_2d
!                 ind  = mod (i, lenij) * ndim_2d
!
#ifdef PRISM_ASSERTION
                  if (ind  < 0 .or. ind/ndim_2d >= send_info%npoints(1,ipart) .or. &
                      indk < 0 .or. indk >= send_info%npoints(2,ipart)) then
                     print *, "j, i, ind", j, i, ind, indk, &
                              send_info%npoints(1:2,ipart)
                     call psmile_assert (__FILE__, __LINE__, &
                        "Incorrect index generated");
                  endif
#endif
!
                  srcloc_ind (1, n) = srcloc (ind+1)
                  srcloc_ind (2, n) = srcloc (ind+2)
                  srcloc_ind (3, n) = srclocz (indk+1)
               endif
            end do ! j
!
            nextra_prev = nextra_prev + len_req (ipart)
         endif
!
         nprev = nprev + len_cpl (ipart)
      end do ! ipart
!
#ifdef PRISM_ASSERTION
      if (n /= n_send) then
         print *, 'n, n_send', n, n_send
         call psmile_assert ( __FILE__, __LINE__, &
                 'All indices were NOT generated for srcloc_ind')
      endif
#endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

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

9990 format (1x, a, ': psmile_get_face_ind_21d:')
9980 format (1x, a, ': psmile_get_face_ind_21d: eof ierror =', i3)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Get_face_ind_21d