psmile_locations_irreg2.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_irreg2
!
! !INTERFACE:

      subroutine psmile_locations_irreg2 (                   &
                      found, loc, range, control,            &
                      search, method_id, msk_required,       &
                      virtual_cell, virtual_cell_required,   &
                      dir_index, cpl_index, len_cpl, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Locations_irreg2

      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)

!     Was a grid cell found for for point (i,j,k) in range
!     (2, ndim_3d, ipart) for ipart-th partition ?
!     Only found (1:2, *) is significant.
!     found(*,i)%vector(n) = val_direct : Point was found and
!                                         has to be sent directly to target 
!                                         process.
!     found(*,i)%vector(n) = val_coupler: Point was found and
!                                         has to be sent to coupler process
!     Otherwise                           Point was not found.

      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.

      Type (integer_vector)           :: virtual_cell (search%npart)

!     Code for virtual cells if point was found in virtual cell

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

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

!     Method id of donor cells (on this process)

      Logical, Intent (In)            :: msk_required

!     Switch to determine whether an additional src location mask is required.
!
      Logical, Intent (In)            :: virtual_cell_required

!     Storage of virtual cell info required ?

! !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_irreg2;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL PARAMETERS
!
! 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
! !LOCAL VARIABLES
!
!     ... Method pointer
!
      Type (Method), Pointer          :: mp
!
!     ... for locations to be stored and transferred
!
      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_irreg2" stores the data on
! locations found for the method (grid) and the subgrid coords.
!
! Subroutine "PSMILe_Locations_irreg2" 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_irreg2.F90 2938 2011-02-03 10:23:22Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_locations_irreg2.F90 2938 2011-02-03 10:23:22Z 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 ! ipart
#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_irreg2:'
      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_irreg2: 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
!     ??? Right now data a stored row by row.
!         Clustering of Data, if possible !!!
!     ??? ratio is  weak criteria;
!
      if (max(maxval (ndir), maxval (ndirz)) > 0 .and. ratio < 0.05) then
!
!       ... The number of points which can be sent directly is not
!           "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
!       ... make vertical points for direct send also available for coupling
        ncplz = ncplz + ndirz
      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)%nrecv    = 0
        mp%send_infos_coupler(index)%num2recv = 0
!
        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

         if (virtual_cell_required) then
            Allocate (mp%send_infos_coupler(index)%virtual(1,search%npart), &
                     STAT = ierror)
               if ( ierror > 0 ) then

                  call psmile_error ( PRISM_Error_Alloc, 'mp%send_infos_coupler(index)%virtual', &
                        (/ierror, search%npart/), 2, __FILE__, __LINE__ )
                  ierror = PRISM_Error_Alloc
                  return
               endif
               ! Derefference pointer explicitly as some compilers
               ! set a reference by default
               do ipart = 1, search%npart
                  Nullify(mp%send_infos_coupler(index)%virtual(1,ipart)%vector)
               enddo
         endif
!
           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_2d (                          &
                     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
!
!          ... val_both: TODO: make vertical points for direct send
!                        also available for coupling
!
           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_both, indz, ipart, nprevi, nadd, ierror)
           if (ierror > 0) return
!
           if ( msk_required ) then
              call psmile_store_mask_locs_21d (          &
                        range   (1:2, 1:ndim_2d, ipart), &
                        control (1:2, 1:ndim_2d, ipart), &
                        found(ipart,indl)%vector,        &
                        range   (1:2,   ndim_3d, ipart), &
                        control (1:2,   ndim_3d, ipart), &
                        found(ipart,indz)%vector,        &
                        mp%send_infos_coupler(index),    &
                        ipart, ncpl(ipart), ncplz(ipart), ierror )
              if (ierror > 0) return
           endif
!
           if ( virtual_cell_required ) then
              call psmile_store_source_virt_3d (                     &
                        found(ipart,indl)%vector,                    &
                        virtual_cell(ipart)%vector,                  &
                        ibeg (ipart,indl), iend(ipart,indl),         &
                        mp%send_infos_coupler(index), ncpl(ipart),   &
                        val_cpl, indl, ipart, nprevi, ierror)
              if (ierror > 0) return
           endif

           enddo
!
        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)%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
!
        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_2d (                   &
              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_irreg2: method_id', i3, &
                    ' to ', i3, '(', i2, ')')
9980 format (1x, a, ': psmile_locations_irreg2: eof ierror =', i3, &
                    ', dir_index =', i10, ', cpl_index =', i10)

#endif /* VERBOSE */

      end subroutine PSMILe_Locations_irreg2