psmile_get_faces_virtual_ind.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_faces_virtual_ind
!
! !INTERFACE:

      subroutine psmile_get_faces_virtual_ind (search, extra_search, &
                      send_info, len_cpl,                            &
                      send_mask, nreq, virtual_ind, n_send,          &
                      ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Get_faces_virtual_ind

      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) :: virtual_ind (n_send)
!
!     Codes of the virtual cell info's sent
!
      Integer,                  Intent (Out) :: ierror

!     Returns the error code of PSMILe_Get_faces_virtual_ind;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
      Integer                         :: j, n
!
!     ... for partitions
!
      Integer                         :: ipart, nextra_prev, nprev
      Integer                         :: nvec
!
      Integer, Pointer                :: indices_req (:)
      Integer, Pointer                :: len_req (:)
      Integer, Pointer                :: virtual (:)
!
!     ... for locations
!
#ifdef PRISM_ASSERTION
      Integer                         :: nlast, ispart
#endif
!
!     ... for error handling
!
!     Integer, Parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_faces_virtual_ind" stores the code of virtual cell
! info for 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_faces_virtual_ind.F90 2897 2011-01-19 15:42:53Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_faces_virtual_ind.F90 2897 2011-01-19 15:42:53Z 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
#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
!
      nvec = send_info%nvec
      if (nvec == 1) then
!        Virtual cell info is store in single vector
!        independent on number of parts
         virtual => send_info%virtual(1, 1)%vector
      endif
! 
      do ipart = 1, search%npart
!
         if (len_req (ipart) > 0) then
            indices_req => extra_search%indices_req(ipart)%vector
            if (nvec > 1) virtual => send_info%virtual(1, ipart)%vector
!
#ifdef PRISM_ASSERTION
            nlast = n
            ispart = min (ipart, nvec)
#endif
!
!cdir vector
            do j = 1, len_req (ipart)
               if (send_mask(nextra_prev+j)) then
!
!  ... Compute index in virtual
!
                  n = n + 1
!
                  virtual_ind (n) = virtual (indices_req(j) - nprev)
               endif
            end do ! j
!
#ifdef PRISM_ASSERTION
            do j = nlast+1, n
               if (virtual_ind (j) < 0 .or. &
                   virtual_ind (j) >= send_info%npoints(1,ispart)) exit
            end do 
!
            if (j <= n) then
               print *, "j, ind", j, virtual_ind (j), &
                        send_info%npoints(1,ispart)
               call psmile_assert (__FILE__, __LINE__, &
                     "Incorrect index generated");
            endif
#endif
!
            nextra_prev = nextra_prev + len_req (ipart)
         endif
!
         if (nvec > 1) 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 virtual_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_faces_virtual_ind:')
9980 format (1x, a, ': psmile_get_faces_virtual_ind: eof ierror =', i3)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Get_faces_virtual_ind