psmile_mg_method_1d_dble.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_MG_method_1d_dble
!
! !INTERFACE:

      subroutine psmile_mg_method_1d_dble (                &
                           comp_info, nlev,                &
                           found, loc, range,              &
                           coords1,                        &
                           shape, control,                 &
                           method_id,                      &
                           x_coords,                       &
                           coords_shape,                   &
                           grid_valid_shape, cyclic,       &
                           chmin, chmax,                   &
                           tol, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_mg_method_1d_dble

      implicit none
!
! !INPUT PARAMETERS:
!
      Type (Enddef_comp), Intent (In) :: comp_info

!     Info on the component in which the donor
!     should be searched.

      Integer, Intent (In)            :: nlev

!     Total number of levels

      Integer, Intent (In)            :: range (2, ndim_3d)

!     Dimension of loc and found

      Integer, Intent (In)            :: shape (2, ndim_3d)

!     Dimension of coordinate arrays

      Integer, Intent (InOut)         :: found (range(1,1):range(2,1), 
                                                range(1,2):range(2,2), 
                                                range(1,3):range(2,3))

!     Finest level number on which a grid cell was found for point i,j,k.
!     Input :
!     Level number < -1: Point was not found and
!                        and last level number was (-found(i,j,k))
!     Level number = -(nlev+1): Never found
!     Output :
!     found(i,j,k) = +1: Point (i,j,k) is located on a point
!                        of the method grid.
!     found(i,j,k) = -1: Point (i,j,k) is located in a cell
!                        of the method grid.
!     Otherwise, not contained in the method grid.

      Integer, Intent (InOut)         :: loc   (range(1,1):range(2,1), 
                                                range(1,2):range(2,2), 
                                                range(1,3):range(2,3))

!     Indices of the grid cell in which the point was found.
!     The indices are relative to "shape".

      Double Precision, Intent (In)   :: coords1 (shape(1,1):shape(2,1), 
                                                  shape(1,2):shape(2,2), 
                                                  shape(1,3):shape(2,3))

!     Coordinates to be searched

      Integer, Intent (In)            :: control (2, ndim_3d)

!     Input  value: index range in "coords" to be searched
!     Output value: index range in "coords" for which a cell was found

      Integer, Intent (In)            :: method_id

!     Method id

      Integer, Intent (In)            :: coords_shape (2)

!     Dimension of coordinates (method) x_coords, ...

      Double Precision, Intent (In)   :: x_coords(coords_shape(1):coords_shape(2))

!     Coordinates of the method

      Integer,          Intent (In)   :: grid_valid_shape (2)

!     Specifies the valid block shape for the "1d"-dimensional block
!     Dimension of chmin, chmax and midp

      Logical,          Intent (In)   :: cyclic

!     Is this a (locally) cyclic coordinate

      Double Precision, Intent (In)   :: chmin (grid_valid_shape(1)-1:
                                                grid_valid_shape(2))
!
!     Minimum value of bounding box of coordinate.
! chmin (grid_valid_shape(1)+i) contains the minimal value of bounding box of
!                   cell (x_coords(grid_valid_shape(1)+i)  :
!                         x_coords(grid_valid_shape(1)+i+1))
!
! The first box
! chmin (grid_valid_shape(1)-1) contains the minimal value of
!                                        the bounding box from
!                    the virtual cell (x_coords(grid_valid_shape(1)):
!                                               bounding box of
!                                               corner control volume)
! The last box
! chmin (grid_valid_shape(2)) contains the minimal value of
!                                      the bounding box from
!                    the virtual cell (x_coords(grid_valid_shape(2)):
!                                               bounding box of
!                                               corner control volume)
!
      Double Precision, Intent (In)   :: chmax (grid_valid_shape(1)-1:
                                                grid_valid_shape(2))
!
!     Maximum value of bounding box of coordinate.
!
      Double Precision, Intent (In)   :: tol
!
!     Absolute tolerance for search of "identical" points
!     TOL >= 0.0
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILE_mg_method_1d_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
!  NREFD = Number of method coordinates to be controlled.
!  val_direct  = Code for locations which should to be directly transferred
!                to the destination process.
!  val_coupler = Code for locations which should to be transferred
!                to the coupler process.

      Integer, Parameter              :: nrefd = 3
!
      Integer, Parameter              :: val_direct  =  1
      Integer, Parameter              :: val_coupler = -1
!
!     ... for levels
!
      Integer, Parameter              :: lev = 1
!
! !LOCAL VARIABLES
!
!     ... for locations searched
!
      Integer                         :: i, j, k
      Integer                         :: ibegl, iendl, jpart, n
      Integer                         :: ic
!
!     ... For locations controlled
!
      Double Precision                :: dist (nrefd)
      Integer                         :: irange (2)
!
      Integer                         :: nref
      Integer                         :: nmin (1)
!
!     ... for search
!
      Integer                         :: ii
!
#ifdef DEBUG
!     ... for locations searched
!
      Integer                         :: nfnd (0:3)
#endif /* DEBUG */
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_mg_method_1d_dble" searches the corresponding points
! of the method (grid) for the subgrid coords by the sending process.
!
! TODO: Besser machen !!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_method_1d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_method_1d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!----------------------------------------------------------------------
!
!  Initialization
!
      ierror = 0

#ifdef VERBOSE
      print 9990, trim(ch_id), lev, control

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
      if (tol < 0.0) then
         call psmile_assert (__FILE__, __LINE__, &
                             "tol must be >= 0.0")
      endif

#ifdef FOO
!     Control range and shape

      if (range(1) < shape (1) .or. shape (2) < range (2)) then
         print *, "range", range
         print *, "shape", shape
         call psmile_assert (__FILE__, __LINE__, &
                             "range must be within shape")
      endif

!     Control control and range

      if (control(1) < range (1) .or. range (2) < control (2)) then
         print *, "control", control
         print *, "range  ", range
         call psmile_assert (__FILE__, __LINE__, &
                             "control must be within range")
      endif
#endif /* FOO */
#endif
!
! temporaeren speicherbereich (control (2,1)-control(1,1)+1)*ndtry anlegen
! und do n =1,nref vor i-loop ziehen ?!?
!
! ? statt immer alle nref zu kontrollieren, einmal location in der
! Zelle bestimmen ?
!
! ? ein-dimensionaler Loop statt i,j loop
!
#ifdef DEBUG
      nfnd (:) = 0
#endif /* DEBUG */

#ifdef DEBUGX
      print *, 'begin ---'
        do k = control (1, 3), control (2,3)   
            do j = control(1,2), control (2,2) 
               do i = control(1,1), control (2,1) 
               print *, 'i,j,k,coord, loc, found', i,j,k, coords1 (i,j,k), &
                        loc(i,j,k), found (i,j,k)
               end do
            end do
        end do
#endif
!
!===>
!
        do k = control (1, 3), control (2,3)   
            do j = control(1,2), control (2,2) 
!
!-----------------------------------------------------------------------
!             Look in the fine parts of the coarse grid cell
!             loc(i)
!
!  Besser ein gatter/Scatter hier einbauen
!-----------------------------------------------------------------------
!
            ibegl = control (1, 1)
!
!===> ... Look for the next cells to be controlled
!
            do while (ibegl <= control(2,1))
!cdir vector
                  do i = ibegl, control(2,1)
                  if (found(i, j, k) == lev) exit
                  end do
!
            if (i > control(2,1)) exit
            ibegl = i
!
!cdir vector
               do i = ibegl, control(2,1)
               if (found(i, j, k) /= lev) exit
               end do
!
            iendl = i - 1
!
!===> ... Look in the real cell (ic)
!
#ifdef PRISM_ASSERTION
            do i = ibegl, iendl
            if (loc (i,j,k) < coords_shape(1) .or. &
                loc (i,j,k) > coords_shape(2)) exit
            end do

            if (i <= iendl) then
               print *, "i,j,k, ic, coords_shape", &
                        i,j,k, loc (i,j,k), coords_shape
print *, 'control', control
print *, 'range  ', range
               call psmile_assert (__FILE__, __LINE__, &
                                   'wrong index')
            endif
#endif
!
            do jpart = 0, (iendl-ibegl)/5000
!cdir vector loopcnt=5000
            do i = ibegl+jpart*5000, min (iendl, ibegl+(jpart+1)*5000 - 1)
!
            ic = loc (i,j,k)
!
            irange (1) = max (ic-1, grid_valid_shape (1))
            irange (2) = min (ic+1, grid_valid_shape (2))
!
!===> ... Compute distance to points
!
               do n = irange(1), irange (2)
               dist (n-irange(1)+1) = abs (x_coords (n)-coords1(i,j,k))
               end do
!
!===> ... Look for the minimum distance
!
            nref = irange (2) - irange (1) + 1
#ifdef PRISM_ASSERTION
            if (nref <= 0) then
               call psmile_assert (__FILE__, __LINE__, &
                                   'nref <= 0')
            endif
#endif
            nmin = MINLOC (dist(1:nref))
#ifdef MINLOCFIX
            if (nmin(1).eq.0) nmin=1
#endif /* MINLOCFIX */
!
            loc (i,j,k) = irange (1) + nmin(1) - 1
!
#ifdef DEBUG2
   print *, "psmile_mg_method_1d_dble: i, j, k --- ", i,j,k
   print *, "psmile_mg_method_1d_dble loc   ", loc(i,j,k), nmin(1), dist(nmin(1))
   print *, "psmile_mg_method_1d_dble ic    ", ic
   print *, "psmile_mg_method_1d_dble irange", irange
   print *, "psmile_mg_method_1d_dble search", coords1(i,j,k)
   print *, "psmile_mg_method_1d_dble source", x_coords (irange(1):irange(2))
#endif
!
            if (dist(nmin(1)) .lt. tol) then
!
!===> ...... Point is located on the grid point of the method.
!            Mark point by negative level number
!
!              found (i,j,k) = val_direct ! == lev == 1
!
#ifdef DEBUG
               nfnd (1) = nfnd (1) + 1
#endif /* DEBUG */
            else
               found (i,j,k) = val_coupler
#ifdef DEBUG
               nfnd (2) = nfnd (2) + 1
#endif /* DEBUG */

               if (coords1(i,j,k) < chmin (loc(i,j,k)) .or. &
                   coords1(i,j,k) > chmax (loc(i,j,k))) then

                  irange (1) = max (ic-1, grid_valid_shape (1)-1)

                  do ii = irange (1), irange (2)
                  if (chmin(ii) <= coords1(i,j,k) .and. &
                      chmax(ii) >= coords1(i,j,k)) exit
                  end do
!
                  if (ii <= irange(2)) then
!
                     loc (i,j,k) = ii
                  else
!                    Point as not found in the method grid;
!                    mark point as 0
#ifdef DEBUG
                     nfnd (3) = nfnd (3) + 1
                     nfnd (2) = nfnd (2) - 1
#endif /* DEBUG */
!Todo                found (i,j,k) = 0
 
                  endif
               endif
            endif
!
            end do ! i
            end do ! jpart
!
!===> ... Is there an cyclic index
!
            if (cyclic) then
!
!              This is an cyclic index;
!              Move points, which are located in virtual cell 0
!              into cell "grid_valid_shape(2)"
!
!cdir vector
                  do i = ibegl, iendl
                  if (loc (i,j,k) < grid_valid_shape (1)) then
                      loc (i,j,k) = grid_valid_shape (2)
                  endif
                  enddo
#ifdef REMOVED
            else
!
!              Move points located in virtual cell 0 into
!              cell 1; wird derzeit nur gemacht, um Probleme
!              in anderen Routinen zu verhindern
!              spaeter: diese indices in extra_search aufnehmen
!              oder nearest neighbour
!cdir vector
                  do i = ibegl, iendl
                  loc (i,j,k) = max (loc(i,j,k), grid_valid_shape (1))
                  enddo
#endif
!
            endif
!
!===> ... Start index of the next search
!
            ibegl = iendl + 2
            end do ! while
!
            end do ! j
         end do ! k
!
!===> All done
!
#ifdef DEBUGX
      print *, 'end ---'
        do k = control (1, 3), control (2,3)   
            do j = control(1,2), control (2,2) 
               do i = control(1,1), control (2,1) 
               print *, 'i,j,k,coord, loc, found', i,j,k, coords1 (i,j,k), &
                        loc(i,j,k), found (i,j,k)
               end do
            end do
        end do
#endif

#ifdef DEBUG
      print 9970, trim(ch_id), lev, nfnd
9970  format (1x, a, ': psmile_mg_method_1d_dble: lev =', i3, &
              ': not :', i5, ', dir: ', i6, ', fnd :', i6, i5)
#endif /* DEBUG */

#ifdef VERBOSE
      print 9980, trim(ch_id), lev

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

9990 format (1x, a, ': psmile_mg_method_1d_dble: level', i3, &
                    ', control', 6i6)
9980 format (1x, a, ': psmile_mg_method_1d_dble: eof, level', i3)

      end subroutine psmile_mg_method_1d_dble