psmile_store_dest_locs_21d.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2007-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
      subroutine psmile_store_dest_locs_21d (found, range,  control,  &
                                             foundz, &
                                             send_info, nloc, opt,           &
                                             nprev, nadd, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Store_dest_locs_21d

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)            :: range (2, ndim_3d)

!     Dimension of loc and found

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

!     Index range found

      Integer, Intent (In)            :: found  (range(1,1):range(2,1), 
                                                 range(1,2):range(2,2))
      Integer, Intent (In)            :: foundz (range(1,3):range(2,3))

!     Finest level number on which a grid cell was found for point i,j,k.
!     Level number = nlev+1: Never found (input value)
!
      Integer, Intent (In)            :: nloc
!
!     Number of locations to be stored

      Integer, Intent (In)            :: opt
!
!     Option:
!     = -1 : Store values which have to be sent to the coupler;
!            i.e. store locations with found (i,j,k) = -1
!     =  1 : Store values which have to be sent to the application process;
!            i.e. store locations with found (i,j,k) =  1
!     =  0 : Store values with abs(found (i,j,k)) = 1.
!
      Integer, Intent (In)            :: nprev
!
!     Number of locations already stored in send_info%dstijk
!
!
! !OUTPUT PARAMETERS:
!
      Type(Send_information), Intent(Inout) :: send_info
!
!     Send information to be generated
!
      Integer, Intent (Out)           :: nadd
!
!     Number of locations added in send_info%dstijk
!
      integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Store_dest_locs_21d;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer, Parameter              :: val_direct  =  1
      Integer, Parameter              :: val_coupler = -1
      Integer, Parameter              :: val_both    =  0
      Integer, Parameter              :: val_abs     =  1
!
!     ... Loop variables
!
      Integer                         :: i, j, k
!
!     ... Counters for number of points
!
      Integer                         :: n, noldk, nrep
      Logical                         :: anyk
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 2
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Store_dest_locs_21d" stores the data on the
! the subgrid coords sent by sending (destination) process which were found
! and which will be sent by the actual process.
!
! Subroutine "PSMILe_Store_dest_locs_21d" is designed for grids of
! of type "PRISM_Irrlonlat_regvrt".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_store_dest_locs_21d.F90 2687 2010-10-28 15:15:52Z coquart $
!  $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_store_dest_locs_21d.F90 2687 2010-10-28 15:15:52Z coquart $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), opt, control

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      if (nprev == 0 .and. .not. Associated (send_info%dstijk) ) then

         Allocate (send_info%dstijk(1:ndim_3d, 1:nloc), STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = nloc * ndim_3d

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'send_info%dstijk', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
      endif
!
! ... Store locations in a simple list
! ... Schoener waere eine clusterung in Regions

      n = nprev
      nrep = 0

      if (opt == val_both) then
!
!     ... Find points which have to be sent
!     ... Generate data for 2d hyperplane (first 2 indices)
!
         do j = control (1, 2), control (2, 2)
!cdir vector
            do i = control (1, 1), control (2, 1)
            if (abs(found (i,j)) == val_abs) then
               n = n + 1

               send_info%dstijk (1, n) = i
               send_info%dstijk (2, n) = j
            endif
            end do
         end do
!
         nadd = n - nprev
!
!     ... Generate data for 3rd (regular) index
!
!cdir vector
          do k = control (1, 3), control (2, 3)
            if (abs(foundz (k)) == val_abs) then
               send_info%dstijk (3, nprev+nrep*nadd+1:nprev+(nrep+1)*nadd) = k
               nrep = nrep + 1
            endif
          end do
!
!     ...  Replicate data for 2d Hyperplane; i.e.
!          copy first 2 indices for each 3rd index
!
         do i = 1, nrep-1
            send_info%dstijk (1:2, nprev+i*nadd+1:nprev+(i+1)*nadd) = &
            send_info%dstijk (1:2, nprev       +1:nprev+nadd)
         end do
!
         nadd = nadd * nrep
!
      else if (opt == val_direct) then
!
!     ... Find points which have to be sent directly to the destination process
!     ... Generate data for 2d hyperplane (first 2 indices)
!
         do j = control (1, 2), control (2, 2)
!cdir vector
            do i = control (1, 1), control (2, 1)
            if (found (i,j) == val_direct) then
               n = n + 1

               send_info%dstijk (1, n) = i
               send_info%dstijk (2, n) = j
            endif
            end do
         end do
!
         nadd = n - nprev
!
!     ... Generate data for 3rd (regular) index
!
!cdir vector
          do k = control (1, 3), control (2, 3)
            if (foundz (k) == val_direct) then
               send_info%dstijk (3, nprev+nrep*nadd+1:nprev+(nrep+1)*nadd) = k
               nrep = nrep + 1
            endif
          end do
!
!     ...  Replicate data for 2d Hyperplane; i.e.
!          copy first 2 indices for each 3rd index
!
         do i = 1, nrep-1
            send_info%dstijk (1:2, nprev+i*nadd+1:nprev+(i+1)*nadd) = &
            send_info%dstijk (1:2, nprev       +1:nprev+nadd)
         end do
!
         nadd = nadd * nrep
!
      else if (opt == val_coupler) then
!
!     ... Find points which have to be sent to the coupler
!
!cdir vector
         do k = control (1, 3), control (2, 3)
            if (abs(foundz(k)) /= val_abs) continue

            anyk = foundz(k) == val_coupler
            noldk = n
!
!     ... Generate data for 2d hyperplane (first 2 indices)
!
            do j = control (1, 2), control (2, 2)
!cdir vector
               do i = control (1, 1), control (2, 1)
                  if (found(i,j) == val_coupler .or. &
                     (anyk .and. found(i,j) == val_direct)) then
                     n = n + 1

                     send_info%dstijk (1, n) = i
                     send_info%dstijk (2, n) = j
                  endif
               end do
            end do
!
!     ... Generate data for 3rd (regular) index
!
            send_info%dstijk (3, noldk+1:n) = k
         end do
!
         nadd = n - nprev
!
      endif
!
#ifdef PRISM_ASSERTION
!
!     Control correct dimension
!
      if (nloc < nprev+nadd) then
         print *, "nloc, nctl", nloc, nprev+nadd, nrep
         call psmile_assert ( __FILE__, __LINE__, "nloc < nprev+nadd")
      endif
#endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

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

9990 format (1x, a, ': psmile_store_dest_locs_21d: opt ', i2, &
             '; control ', 6i6)
9980 format (1x, a, ': psmile_store_dest_locs_21d: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Store_dest_locs_21d