psmile_locations_direct.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_direct
!
! !INTERFACE:

      subroutine psmile_locations_direct (control, global, search, method_id, &
                                          dir_index, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Locations_direct

      implicit none
!
! !INPUT PARAMETERS:

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

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

!     Local Index range found
!
      Integer,              Intent (In)    :: global (2, ndim_3d, search%npart)

!     Global Index range found
!
      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_direct;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL PARAMETERS
!
! val_direct  = Code for locations which should to be directly transferred
!               to the destination process.
!
      Integer, Parameter              :: val_direct  =  1
!
      Integer, Parameter              :: send_direct_index  = 2
!
! !LOCAL VARIABLES
!
!     ... Method pointer
!
      Type (Method), Pointer          :: mp
       
!
!     ... for locations to be stored and transferred
!
      Type(Send_information), Pointer :: send_info
!
      Integer                         :: ndir, index
!
!     ... for partitions
!
      Integer                         :: ipart, i0
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 2
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Locations_direct" stores the data on locations
! to be sent and received (on target process) for grids of type
! "PRISM_Gridless". Grids of type "PRISM_Gridless" are transferring the
! data always directly between the MPI processes.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_locations_direct.F90 2788 2010-11-30 14:34:07Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_locations_direct.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
#endif
#ifdef PRISM_ASSERTION_WRONG
         !
         ! This search%range contains local indices and is not
         ! what is contained in search%msg_intersections, from where
         ! psmile_search_donor_gridless extracts the data
         ! to fill in the inter(section) array.
         ! In contrast, the search%range is filled in
         ! psmile_recv_req_subgrid.
         !
         do ipart = 1, search%npart
         if (global (1,1,ipart) < search%range (1,1,ipart) .or. &
             global (2,1,ipart) > search%range (2,1,ipart) .or. &
             global (1,2,ipart) < search%range (1,2,ipart) .or. &
             global (2,2,ipart) > search%range (2,2,ipart) .or. &
             global (1,3,ipart) < search%range (1,3,ipart) .or. &
             global (2,3,ipart) > search%range (2,3,ipart) ) then
             print *, ' ipart ', ipart
             print *, ' globl ', global (:,:,ipart)
             print *, ' range ', search%range (:,:,ipart)
             print *, ' contl ', control (:,:,ipart)
             call psmile_assert (__FILE__, __LINE__, "control is out of range")
         endif
         end do ! ipart
#endif
!
      ndir = 0
         do ipart = 1, search%npart
         ndir = ndir +                                    &
                (control(2,1,ipart)-control(1,1,ipart)+1) &
              * (control(2,2,ipart)-control(1,2,ipart)+1) &
              * (control(2,3,ipart)-control(1,3,ipart)+1)
         end do
!
!----------------------------------------------------------------------------
!     Generate send areas for data exchange with application process
!----------------------------------------------------------------------------
!
      if (ndir > 0) then
!
        call psmile_get_info_index (method_id, send_direct_index, index, ierror)
        if (ierror > 0) return
!
        dir_index = index
        send_info => mp%send_infos_direct(index)
!
        send_info%dest   = search%sender
        send_info%nvec   = 1
        send_info%nparts = 1
        send_info%nloc   = ndir ! total number of locations
!
        send_info%nrecv    = 0
        send_info%num2recv = 0
!
        send_info%remote_method_id = search%msg_intersections%first_tgt_method_id
!
!       ... generate send areas for direct data exchange
!
        call psmile_locations_alloc (send_info, ierror)
        if (ierror > 0) return
!
!       Allocate dummy "srcloc" vector (for a single point) in order
!       to avoid problems with some runtime systems/compilers
!
        Allocate (send_info%srclocs(1,1)%vector(ndim_3d), &
                  STAT = ierror)
        if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = ndim_3d

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'send_info%srclocs(1,1)%vector', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
        endif
!
!       Store all "search%nparts" partitions as "search%nparts" areas
!
        Allocate (send_info%srcars(1,1)%vector(2*ndim_3d*search%npart), &
                  send_info%dstars(2,ndim_3d,search%npart), &
                  STAT = ierror)
        if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = 2*ndim_3d * search%npart

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'send_info%srcars(1,1)%vector', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
        endif
!
!       ... Store data for sending process
!
        send_info%nars(1, 1) = search%npart
!
           do ipart = 1, search%npart
           i0 = (ipart-1)*2*ndim_3d
!
           send_info%srcars(1,1)%vector(i0+1) = control (1, 1, ipart)
           send_info%srcars(1,1)%vector(i0+2) = control (2, 1, ipart)
           send_info%srcars(1,1)%vector(i0+3) = control (1, 2, ipart)
           send_info%srcars(1,1)%vector(i0+4) = control (2, 2, ipart)
           send_info%srcars(1,1)%vector(i0+5) = control (1, 3, ipart)
           send_info%srcars(1,1)%vector(i0+6) = control (2, 3, ipart)
!
           end do ! ipart
!
!       ... Store areas in GLOBAL indices of destination process
!           Note: Has to be transferred in local indices in target process.
!
        send_info%dstars (:, :, :) = global (: , :, :)
!
      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_direct: method_id', i3, &
                    ' to ', i3, '(', i2, ')')
9980 format (1x, a, ': psmile_locations_direct: eof ierror =', i3, &
                    '; dir_index', i7)

#endif /* VERBOSE */

      end subroutine PSMILe_Locations_direct