psmile_get_face_ind_reg.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_reg
!
! !INTERFACE:

      subroutine psmile_get_face_ind_reg (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_reg

      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_reg;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
      Integer                         :: i, j, n
!
!     ... for partitions
!
      Integer                         :: ipart, nextra_prev, nprev
      Integer                         :: leni, lenij
!
      Integer, Pointer                :: indices_req (:)
      Integer, Pointer                :: len_req (:)
      Integer, Pointer                :: srcloc_i (:), srcloc_j (:)
      Integer, Pointer                :: srcloc_k (:)
!
!     ... for indices
!
      Integer                         :: ind (ndim_3d)
!
!     ... for error handling
!
!     Integer, Parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_face_ind_reg" 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_reg.F90 2082 2009-10-21 13:31:19Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_face_ind_reg.F90 2082 2009-10-21 13:31:19Z 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 /= ndim_3d) then
         print *, 'nvec', send_info%nvec
         call psmile_assert ( __FILE__, __LINE__, &
                 'Routine is designed for regular case (3 1d vectors)')
      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_i => send_info%srclocs(1,ipart)%vector
            srcloc_j => send_info%srclocs(2,ipart)%vector
            srcloc_k => send_info%srclocs(3,ipart)%vector
!
            leni  = send_info%npoints(1,ipart)
            lenij = send_info%npoints(2,ipart) * leni
!
               do j = 1, len_req (ipart)
               if (send_mask(nextra_prev+j)) then
!
!  ... compute 3d index out of 1-dimensional index "i"
!      (srclocs are stored as 3 1-dimensional vectors
!       regulary in lon, lat and z-direction)
!
                  n = n + 1
!
                  i = indices_req(j) - nprev - 1
!
                  ind (3) =  i / lenij
                  ind (2) = (i-ind(3)*lenij) / leni
                  ind (1) = mod (i, leni)
!
#ifdef PRISM_ASSERTION
                  if (ind(1) < 0 .or. ind(1) >= send_info%npoints(1,ipart) .or. &
                      ind(2) < 0 .or. ind(2) >= send_info%npoints(2,ipart) .or. &
                      ind(3) < 0 .or. ind(3) >= send_info%npoints(3,ipart) ) then
                     print *, "j, i, ind", j, i, ind
                     call psmile_assert (__FILE__, __LINE__, &
                        "Incorrect index generated");
                  endif
#endif
!
                  srcloc_ind (1, n) = srcloc_i(ind(1)+1)
                  srcloc_ind (2, n) = srcloc_j(ind(2)+1)
                  srcloc_ind (3, n) = srcloc_k(ind(3)+1)
print *, 'get_face_ind: n', n, srcloc_ind (:, n)
               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_reg:')
9980 format (1x, a, ': psmile_get_face_ind_reg: eof ierror =', i3)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Get_face_ind_reg