psmile_locations_gauss2.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_gauss2
!
! !INTERFACE:

      subroutine psmile_locations_gauss2 (                   &
                      found,  loc,  range,  control,         &
                      search, method_id,                     &
                      dir_index, cpl_index, len_cpl, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Locations_gauss2

      implicit none
!
! !INPUT PARAMETERS:
!
      Type (Enddef_search), Intent (InOut) :: search

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

!     Dimension of loc and found
!     ??? muss range nicht shape sein ?
!
      Type (integer_vector)           :: found (search%npart, 2)

!     Finest level number on which a grid cell was found for point
!     (i,j,k) in range (2, ndim_3d, ipart) for ipart-th partition.
!     Only found (1:2, *) is significant.

      Type (integer_vector)           :: loc (search%npart, 2)
!
!     Indices of the grid cell in which the point was found.
!     Assumed input value loc(:)%vector(:, len) = 0
!     Only loc (1:2, *) is significant.

      Integer, Intent (In)            :: control (2, ndim_3d, search%npart)

!     Index range found
!
      Integer, Intent (In)            :: method_id

!     Method id
!
! !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)           :: cpl_index

!     Send index if data has to be transferred to the coupler
!     PRISM_undefined, if no data has to be sent.

      Integer, Intent (Out)           :: len_cpl (search%npart)

!     Number of points to be sent to the coupler for each partition.
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Locations_gauss2;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
! indl = Index of LonLat values in "found, loc, ibeg, iend"
! indz = Index of Vert   values in "found, loc, ibeg, iend"
!
      Integer, Parameter              :: val_direct  =  1
      Integer, Parameter              :: val_coupler = -1
      Integer, Parameter              :: val_both    =  0
!
      Integer, Parameter              :: send_coupler_index = 1
      Integer, Parameter              :: send_direct_index  = 2
!
      Integer, Parameter              :: indl = 1
      Integer, Parameter              :: indz = 2
!
!     ... Method pointer
!
      Type (Method), Pointer          :: mp
!
      Real                            :: ratio
!
      Integer                         :: ncpl_tot, ndir_tot
      Integer                         :: ncpl  (search%npart)
      Integer                         :: ndir  (search%npart)
      Integer                         :: ncplz (search%npart)
      Integer                         :: ndirz (search%npart)
      Integer                         :: index, n, val_cpl
!
!     ... for partitions
!
      Integer                         :: ipart, nadd, nprev
      Integer                         :: ibeg (search%npart, indz)
      Integer                         :: iend (search%npart, indz)
      Integer                         :: nprevi
!
!     ... for error handling
!
!     Integer, parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Locations_gauss2" stores the data on
! locations found for the method (grid) and the subgrid coords.
!
! Subroutine "PSMILe_Locations_gauss2" is designed for grids of
! of type "PRISM_Irrlonlat_regvrt".
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.04    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_locations_gauss2.F90 2966 2011-02-18 09:47:30Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_locations_gauss2.F90 2966 2011-02-18 09:47:30Z 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
      cpl_index = PRISM_undefined
      dir_index = PRISM_undefined
!
      len_cpl = 0
!
      mp => Methods(method_id)
!
#ifdef PRISM_ASSERTION
      if (search%grid_type == PRISM_Irrlonlatvrt) then
         print *, "search%grid_type = ", search%grid_type
         call psmile_assert (__FILE__, __LINE__, &
                             "This routine is not designed for this grid type")
      endif
!
      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 (control (1,1,ipart) <   range (1,1,ipart) .or. &
               range (2,1,ipart) < control (2,1,ipart) .or. &
             control (1,2,ipart) <   range (1,2,ipart) .or. &
               range (2,2,ipart) < control (2,2,ipart) .or. &
             control (1,3,ipart) <   range (1,3,ipart) .or. &
               range (2,3,ipart) < control (2,3,ipart)) then
            print *, ipart, control (:, :, ipart), range (:, :, ipart)
            call psmile_assert (__FILE__, __LINE__, "control is out of range")
         endif
      end do
#endif
!
!----------------------------------------------------------------------------
!     Determine maximal number of points to be transferred to the
!     coupler or directly to the destination process
!----------------------------------------------------------------------------
!
      ndir_tot = 0
      ncpl_tot = 0
!
      ndir(:) = 0
      ncpl(:) = 0
!
      ndirz(:) = 0
      ncplz(:) = 0
!
      ibeg (:, :) = 1
!
      do ipart = 1, search%npart
!
!===> Get number of locations to be sent directly to another process
!     ndir = Number of locations which can be sent directly
!     ncpl = Number of locations sent to the coupler
!
!     ? ibeg_dir, iend_dir, ibeg_cpl, iend_cpl berechnen ?
!
!     ibeg = (control(1,2)-range(1,2))*(range(2,1)-range(1,1)+1) &
!          + (control(1,1)-range(1,1)) + 1
!
!     iend = (control(2,2)-range(1,2))*(range(2,1)-range(1,1)+1) &
!          + (control(2,1)-range(1,1)) + 1
!
!     ... Get number of locations in 2d fields "found" and "loc"
!
         iend (ipart, indl) = (range (2,1, ipart) - range(1,1, ipart) + 1) * &
                              (range (2,2, ipart) - range(1,2, ipart) + 1)
         iend (ipart, indz) =  range (2,3, ipart) - range(1,3, ipart) + 1
!
!cdir vector
         do n = ibeg(ipart, indl), iend (ipart, indl)
            if (found(ipart,indl)%vector(n) == val_coupler) then
               ncpl(ipart) = ncpl(ipart) + 1
            else if (found(ipart,indl)%vector(n) == val_direct) then
               ndir(ipart) = ndir(ipart) + 1
            endif
         end do
!
!     ... Get number of locations in 1d fields "foundz" and "locz"
!
!cdir vector
         do n = ibeg(ipart, indz), iend (ipart, indz)
            if (found(ipart,indz)%vector(n) == val_coupler) then
               ncplz(ipart) = ncplz(ipart) + 1
            else if (found(ipart,indz)%vector(n) == val_direct) then
               ndirz(ipart) = ndirz(ipart) + 1
            endif
         end do

      end do ! ipart

#ifdef DEBUG
      print *, trim(ch_id), ': psmile_locations_gauss2:'
      print *, "range:  ", range
      print *, "control:", control
      print *, "ibeg:",    ibeg
      print *, "iend:",    iend
      print *, "ncpl   :", ncpl, ncplz
      print *, "ndir   :", ndir, ndirz

      call psmile_flushstd
#endif
!
!     ... Get total number of locations

! Was ist mit search%grid_type ?

      do ipart = 1, search%npart
         n = ndir(ipart) * ndirz(ipart)
         ndir_tot = ndir_tot + n
         ncpl_tot = ncpl_tot + ((ncpl (ipart)+ndir (ipart)) * &
                                (ncplz(ipart)+ndirz(ipart)) - n)
      end do ! ipart
!
      if (ncpl_tot + ndir_tot > 0) then
         ratio = real(ndir_tot) / (ncpl_tot+ndir_tot)
      else
         ratio = 0.0
      endif
!
#ifdef ONLY_FOR_TESTING
      print *, '######## psmile_locations_3d_reg: ratio set to 0.0'
      ratio = 0.01
#endif
#ifdef DEBUG
      print *, 'ncpl_tot, ndir_tot, ratio:', ncpl_tot, ndir_tot, ratio 
#endif
!
!===> Store locations
!     ??? Currently the data is stored cell wise.
!         Store them in clusters if possible !!!
!     ??? ratio is a weak criteria
!
      if (max(maxval (ndir), maxval (ndirz)) > 0 .and. ratio < 0.05) then
!
!       ... The number of points which can be sent directly is
!           "large" enough
!       ... Send all points to the coupler
!
        ncpl = ncpl + ndir
        ndir = 0
!
        ncplz = ncplz + ndirz
        ndirz = 0
!
        ncpl_tot = ncpl_tot + ndir_tot
        ndir_tot = 0
!
        val_cpl = val_both
      else
        val_cpl = val_coupler
      endif
!
!     Generate send areas for data send to a coupler process
!
      if (ncpl_tot > 0) then
      
        call psmile_get_info_index (method_id, send_coupler_index, index, ierror)
        
        if (ierror > 0) return

        cpl_index = index
!
!       ... generate send areas for data exchange with coupler
!
!       mp%send_infos_coupler(index)%nloc = ncpl_tot
        mp%send_infos_coupler(index)%nvec = 2
        mp%send_infos_coupler(index)%nparts = search%npart
!
        mp%send_infos_coupler(index)%remote_method_id = search%msg_intersections%first_tgt_method_id
!
!       ... Rank of coupler in communicator "comm_coupler"
!
        mp%send_infos_coupler(index)%dest = 0
!
!       ... generate send areas for data exchange with coupler
!
        call psmile_locations_alloc (mp%send_infos_coupler(index), ierror)
        if (ierror > 0) return

        nprev  = 0
        nprevi = 0
!
        do ipart = 1, search%npart
!
           call psmile_store_dest_locs_21d (                &
              found(ipart,indl)%vector, range(1:2, 1:ndim_3d, ipart), &
              control (1:2, 1:ndim_3d, ipart), found(ipart,indz)%vector, &
              mp%send_infos_coupler(index), ncpl_tot, &
              val_cpl, nprev, nadd, ierror)
           if (ierror > 0) return
!
           nprev = nprev + nadd
           len_cpl (ipart) = nadd

           call psmile_store_source_locs_1d (              &
              found(ipart,indl)%vector, loc(ipart,indl)%vector, &
              ibeg (ipart,indl),       iend(ipart,indl),   &
              mp%send_infos_coupler(index), ncpl(ipart),   &
              val_cpl, indl, ipart, nprevi, nadd, ierror)
           if (ierror > 0) return
!

           call psmile_store_source_locs_1d (             &
              found(ipart,indz)%vector, loc(ipart,indz)%vector, &
              ibeg (ipart,indz),       iend(ipart,indz),  &
              mp%send_infos_coupler(index), ncplz(ipart), &
              val_cpl, indz, ipart, nprevi, nadd, ierror)
           if (ierror > 0) return
!
        end do
!
        mp%send_infos_coupler(index)%nloc = nprev

      endif
!
!     Generate send areas for data exchange with application process
!
      if (ndir_tot > 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)%nloc = ndir_tot
!
        mp%send_infos_direct(index)%nvec      = 2
        mp%send_infos_direct(index)%nparts    = search%npart
        mp%send_infos_direct(index)%remote_method_id = search%msg_intersections%first_tgt_method_id
!
!       ... generate send areas for direct data exchange
!
        call psmile_locations_alloc (mp%send_infos_direct(index), ierror)
        if (ierror > 0) return
!
        nprev  = 0
        nprevi = 0
!
        do ipart = 1, search%npart

           call psmile_store_dest_locs_21d (                &
              found(ipart,indl)%vector, range(1:2, 1:ndim_3d, ipart), &
              control (1:2, 1:ndim_3d, ipart), found(ipart,indz)%vector, &
              mp%send_infos_direct(index), ndir_tot,        &
              val_direct, nprev, nadd, ierror)
           if (ierror > 0) return
!
           nprev = nprev + nadd

           call psmile_store_source_locs_1d (                   &
              found(ipart,indl)%vector, loc(ipart,indl)%vector, &
              ibeg (ipart,indl),       iend(ipart,indl),        &
              mp%send_infos_direct(index), ndir(ipart),         &
              val_direct, indl, ipart, nprevi, nadd, ierror)
           if (ierror > 0) return
!
           call psmile_store_source_locs_1d (                   &
              found(ipart,indz)%vector, loc(ipart,indz)%vector, &
              ibeg (ipart,indz),       iend(ipart,indz),        &
              mp%send_infos_direct(index), ndirz(ipart),        &
              val_direct, indz, ipart, nprevi, nadd, ierror)
           if (ierror > 0) return
!
        end do ! ipart
!
        mp%send_infos_direct(index)%nloc = nprev

      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, dir_index, cpl_index

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

#ifdef VERBOSE

9990 format (1x, a, ': psmile_locations_gauss2: method_id', i3, &
                    ' to ', i3, '(', i2, ')')
9980 format (1x, a, ': psmile_locations_gauss2: eof ierror =', i3, &
                    ', dir_index =', i10, ', cpl_index =', i10)

#endif /* VERBOSE */

      end subroutine PSMILe_Locations_gauss2