psmile_search_donor_extra.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_Search_
!
! !INTERFACE:

      subroutine psmile_search_donor_extra (search, tol, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Search_donor_extra

      implicit none
!
! !INPUT PARAMETERS:
!
!     Integer, Intent (In)                :: tag
!
!     Specifies the message tag used

      Double Precision, Intent (In)       :: tol

!     Absolute tolerance for search of "identical" points
!     TOL >= 0.0

!
! !INPUT/OUTPUT PARAMETERS:
!
      Type (Enddef_global_search), Intent (InOut) :: search

!     Data on the points to be searched
!
! !OUTPUT PARAMETERS:
!
      Integer,              Intent (Out)   :: ierror

!     Returns the error code of PSMILe_Search_donor_extra;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Real                         :: rtol
#if defined ( PRISM_QUAD_TYPE )
      Real (kind=PRISM_QUAD_TYPE)  :: qtol
#endif
!
!     ... for grids and components
!
! comp_id = Component Id of the component in which the donor cells
!           should be searched.
!
      Integer                      :: comp_id, grid_id
      Integer                      :: icomp
!
!     ... for fields
!
      Integer                      :: j
      Integer                      :: var_id
      Integer                      :: transi_id
      Type (Taskout_type), Pointer :: Taskout(:)
!
!     ... methods searched
!
      Integer                      :: method_id
!
!     ... for error parameters
!
      Integer, parameter           :: nerrp = 3
      Integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Search_donor_extra" perfoms the additional (global)
! search for coordinates sent by the requesting process.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 2003-07-21  H. Ritzdorf  created
! 2011-02-25  M. Hanke     cleanup of code that was
!                          supposed to be used in the future
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_search_donor_extra.F90 2993 2011-02-25 10:34:50Z hanke $
! $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_search_donor_extra.F90 2993 2011-02-25 10:34:50Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), search%msg_extra(5), search%sender

      call psmile_flushstd
#endif /* VERBOSE */

      rtol = tol

#if defined ( PRISM_QUAD_TYPE )
      qtol = tol
#endif

!     Search global comp_id in comp_infos

      do icomp = 1, n_act_comp
         if (comp_infos(icomp)%global_comp_id == search%msg_extra(5)) exit
      enddo

      if (icomp > n_act_comp) then
         ierror = PRISM_Error_internal
         ierrp (1) = search%msg_extra(5)
         ierrp (2) = n_act_comp

         call psmile_error ( ierror, &
                            'Cannot found global comp_id in active components', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif

      comp_id = comp_infos(icomp)%comp_id

#ifdef PRISM_ASSERTION
!
!===> Internal control
!
      if (comp_id < 1 .or. &
          comp_id > Number_of_Comps_allocated .or. &
          Comps(comp_id)%status /= PSMILe_status_defined) then

          print *, trim(ch_id), ": comp id =",         &
                   comp_id, Number_of_Comps_allocated, &
                   Comps(comp_id)%status
          call psmile_assert ( __FILE__, __LINE__, &
                              'invalid comp id')
      endif
#endif
!
!===> Search Field with the global var Id
!
!rr      global_var_id = search%msg_extra (6)
!rr
!rr         do var_id = 1, Number_of_Fields_allocated
!rr         if (Fields(var_id)%global_var_id == global_var_id) exit
!rr         end do
!rr
      transi_id = search%msg_extra (6)
      grid_id = search%msg_extra (17)

getv: do var_id = 1, Number_of_Fields_allocated
         if (Associated (Fields(var_id)%Taskout)) then

            if ( Methods(Fields(var_id)%method_id)%grid_id /= grid_id ) cycle
            Taskout => Fields(var_id)%Taskout

#ifdef DEBUGX
            do j = 1, size (Taskout)
               print 9960, j, &
                       Taskout(j)%origin_type, &
                       Taskout(j)%remote_transi_id, &
                       Taskout(j)%global_transi_id, &
                       Taskout(j)%remote_comp_id
            enddo
#endif

            do j = 1, size (Taskout)
               if ( Taskout(j)%global_transi_id == transi_id ) exit getv
            enddo
         endif
      enddo getv
!
      if (var_id > Number_of_Fields_allocated) then
! user Fehler ? var_id nicht definiert ?
! ist immer trans_id == global_var_id ?
         print *, 'comp_id, global var_id OUT', comp_id, transi_id
!
#ifdef DEBUG
         do var_id = 1, Number_of_Fields_allocated
            if (Associated (Fields(var_id)%Taskout)) then
               Taskout => Fields(var_id)%Taskout

               do j = 1, size (Taskout)
                  print 9960, j, &
                       Taskout(j)%origin_type, &
                       Taskout(j)%remote_transi_id, &
                       Taskout(j)%global_transi_id, &
                       Taskout(j)%remote_comp_id
               end do
            endif
         enddo
#endif
         ierror = PRISM_Error_Internal
         ierrp (1) = comp_id
         ierrp (2) = transi_id
!
         call psmile_error ( ierror, "Cannot find field on this process", &
                             ierrp, 2, __FILE__, __LINE__ )
         return
         
      endif
!
      if (Fields(var_id)%comp_id /= comp_id) then
         print *, 'comp_id, var_id', &
            comp_id, var_id, transi_id, Fields(var_id)%comp_id
         ierror = PRISM_Error_Internal
         ierrp (1) = comp_id
         ierrp (2) = transi_id
         ierrp (3) = Fields(var_id)%comp_id
         call psmile_error ( ierror, "Inconsitent components for field", &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      method_id = Fields(var_id)%method_id

#ifdef PRISM_ASSERTION
!
!===> Speziell case: Gridless grid
!
      if (Grids(grid_id)%grid_type == PRISM_Gridless) then
         print *, trim(ch_id), ": comp id, grid_id",  &
                  comp_id, grid_id
         call psmile_assert ( __FILE__, __LINE__, &
                              'Extra search not for Gridless Grids')
      endif
#endif
!
! =======================================================================
!     Are global indices available on both parts
! =======================================================================
!
      if (search%msg_extra (11) == 1 .and. &
          Associated (Grids(grid_id)%partition)) then

         call psmile_search_donor_extra_off (comp_infos(icomp), &
                     search, var_id, tol, ierror)
#ifdef VERBOSE
         print 9980, trim(ch_id), grid_id, search%sender, ierror
         call psmile_flushstd
#endif /* VERBOSE */
         return
      endif
!
! =======================================================================
!     Is this a nearest neighbour search
! =======================================================================
!
      if (search%msg_extra(1) == PSMILe_nnghbr3D) then

         call psmile_search_donor_extra_nn (comp_infos(icomp), &
                     search, var_id, tol, ierror)
#ifdef VERBOSE
         print 9980, trim(ch_id), grid_id, search%sender, ierror
         call psmile_flushstd
#endif /* VERBOSE */
         return
      endif

!
! here was a big chunk of code for a local search. I removed it, because it was not used (see r2993)
!

      ierror = PRISM_Error_Internal
      call psmile_error ( ierror, 'Global search currently support only if partition info is available', &
                        ierrp, 0, __FILE__, __LINE__ )
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), grid_id, search%sender, ierror
      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_search_donor_extra: global comp_id =', i3, &
                    '; sender =', i4)
9980 format (1x, a, ': psmile_search_donor_extra: eof grid id =', i3, &
                    '; sender =', i3, ', ierror =', i4)

#ifdef DEBUG
9960 format (1x, 'Taskout%In_channel(', i3, '): origin_type', i5, &
                 ', remote_transi_id', i4, &
                 ', global_transi_id', i4, ', remote_comp_id', i4)
#endif

      end subroutine PSMILe_Search_donor_extra