psmile_locations_3d_mask.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_Locations_3d_mask
!
! !INTERFACE:

      subroutine psmile_locations_3d_mask (search, inter, shift, method_id, &
                                           dir_index, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Locations_3d_mask

      implicit none
!
! !INPUT PARAMETERS:

      Type (Enddef_search), Intent (InOut) :: search

!     Info's on coordinates to be searched
!
      Integer, Intent (In)            :: inter (2, ndim_3d, search%npart)

!     Common intersections found

      Integer, Intent (In)            :: shift (ndim_3d)

!     Shift to transfer local indices into local indices
!     of target grid with
!     target_grid_index (:, i) = local index (:, i) - shift (:)
!
      Integer, Intent (In)            :: method_id

!     Method id of donor cells (on this process)

! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)           :: dir_index

!     Send index if data has to be directly transferred to the
!     destination process.
!     PRISM_undefined, if no data has to be sent.
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Locations_3d_mask;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL PARAMETERS
!
      Integer, Parameter              :: send_direct_index  = 2
!
! !LOCAL VARIABLES
!
!     ... Method pointer
!
      Type (Method), Pointer          :: mp
!
!     ... for locations to be stored and transferred
!
      Integer                         :: n, nadd, ndir, nprev
      Integer                         :: index
!
!     ... for partitions
!
      Integer                         :: ipart
!
!     ... for error handling
!
!     Integer, parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Locations_3d_mask" stores the data on locations to
! be sent from the source grid to the target grid.
! Subroutine "PSMILe_Locations_3d_mask" is designed for grids of type
! PRISM_Gridless where the locations are only defined by the mask entries
! and all data is sent directly to the target process.
!
! TODO: request into send_info and free dstijk
! TODO: elimination of multiple points in dstijk and srclocs
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 11.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_locations_3d_mask.F90 2788 2010-11-30 14:34:07Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_locations_3d_mask.F90 2788 2010-11-30 14:34:07Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), method_id, search%msg_intersections%first_tgt_method_id, &
                               search%sender

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      dir_index = PRISM_undefined
!
      mp => Methods(method_id)
!
#ifdef PRISM_ASSERTION
      if ( mp%status == PSMILe_Status_free .or. &
           mp%status == PSMILe_Status_undefined ) then
         call psmile_assert (__FILE__, __LINE__, "Incorrect method")
      endif

         do ipart = 1, search%npart
         if (inter (1,1,ipart) < search%range (1,1,ipart)   .or. &
               search%range (2,1,ipart) < inter (2,1,ipart) .or. &
             inter (1,2,ipart) < search%range (1,2,ipart)   .or. &
               search%range (2,2,ipart) < inter (2,2,ipart) .or. &
             inter (1,3,ipart) < search%range (1,3,ipart)   .or. &
               search%range (2,3,ipart) < inter (2,3,ipart)) then
             print *, ipart, inter (:,:,ipart), search%range (:,:,ipart)
             call psmile_assert (__FILE__, __LINE__, "inter is out of range")
         endif
         end do ! ipart
#endif
!
!----------------------------------------------------------------------------
!     Determine maximal number of points to be transferred 
!     directly to the destination process
!----------------------------------------------------------------------------
!
      ndir = 0
!
         do ipart = 1, search%npart
         if (maxval(search%shape(:,:,ipart)-inter(:,:,ipart)) == 0) then
!
!           search%shape == inter; use intrinsic count function
!
            ndir = ndir + count (search%search_mask(ipart)%vector(:))
         else
!
!           search%shape /= inter
!
            call psmile_get_true_mask_entries (                 &
                        search%search_mask(ipart)%vector,       &
                        search%shape (:, :, ipart),             &
                        inter (:, :, ipart), n, ierror)
            if (ierror > 0) return

            ndir = ndir + n
         endif
!
         end do ! ipart
!
!----------------------------------------------------------------------------
!     Generate send areas for data exchange with application process
!     ??? Derzeit werden die Daten Zellweise abgespeichert.
!         Clustern der Daten, wenn moeglich !!!
!----------------------------------------------------------------------------
!
      if (ndir > 0) then
!
        call psmile_get_info_index (method_id, send_direct_index, index, ierror)
        if (ierror > 0) return
!
        dir_index = index
!
        mp%send_infos_direct(index)%dest   = search%sender
        mp%send_infos_direct(index)%nvec   = 1
        mp%send_infos_direct(index)%nparts = 1
!
        mp%send_infos_direct(index)%nrecv    = 0
        mp%send_infos_direct(index)%num2recv = 0
!
        mp%send_infos_direct(index)%remote_method_id = search%msg_intersections%first_tgt_method_id
!
!       ... generate send areas for direct data exchange
!       Hier nehme ich die search%search_mask statt Mask(mask_id)%mask_array
!       weil die search mask kompakter (und damit schneller) sein sollte.
!
        call psmile_locations_alloc (mp%send_infos_direct(index), ierror)
        if (ierror > 0) return
!
        nprev = 0

           do ipart = 1, search%npart
           call psmile_store_dest_locs_3d_msk (                      &
                             search%search_mask(ipart)%vector,       &
                             search%shape (:, :, ipart),             &
                             inter (:, :, ipart),                    &
                             mp%send_infos_direct(index), ndir,      &
                             nprev, nadd, ierror)
           if (ierror > 0) return

           call psmile_store_source_locs_3d_msk (                    &
                             search%search_mask(ipart)%vector,       &
                             search%shape (:, :, ipart),             &
                             inter (:, :, ipart),                    &
                             mp%send_infos_direct(index), ndir,      &
                             nprev, nadd, ierror)
           if (ierror > 0) return
!
           nprev = nprev + nadd
           end do ! ipart
!
         mp%send_infos_direct(index)%nloc = nprev
!
!===> ... Transform indices in indices of target grid
!
            do n = 1, ndim_3d
            mp%send_infos_direct(index)%dstijk (n, 1:nprev) = &
            mp%send_infos_direct(index)%dstijk (n, 1:nprev) - shift (n)
            end do
!
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, dir_index

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

#ifdef VERBOSE

9990 format (1x, a, ': psmile_locations_3d_mask: method_id', i3, &
                    ' to ', i3, '(', i2, ')')
9980 format (1x, a, ': psmile_locations_3d_mask: eof ierror =', i3, &
                    '; dir_index', i7)

#endif /* VERBOSE */

      end subroutine PSMILe_Locations_3d_mask