psmile_store_dest_locs_3d.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
      subroutine psmile_store_dest_locs_3d (found, loc, range, control,  &
                                            send_info, nloc, opt,        &
                                            nprev, nadd, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Store_dest_locs_3d
#ifdef DEBUG_TRACE
      use psmile_debug_trace
#endif

      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), 
                                                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)            :: loc   (ndim_3d,               
                                                range(1,1):range(2,1), 
                                                range(1,2):range(2,2), 
                                                range(1,3):range(2,3))
!
!     Locations found for coordinates to be searched

      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_3d;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer, Parameter              :: val_both    =  0
      Integer, Parameter              :: val_abs     =  1
!
      Integer                         :: i, j, k, n
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 2
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Store_dest_locs_3d" 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.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_store_dest_locs_3d.F90 2927 2011-01-28 14:04:12Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_store_dest_locs_3d.F90 2927 2011-01-28 14:04:12Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), opt, control

      call psmile_flushstd
#endif /* VERBOSE */

#ifdef DEBUG_TRACE
      if (range(1,1) <= ictl_ind(1) .and. ictl_ind(1) <= range(2,1) .and. &
          range(1,2) <= ictl_ind(2) .and. ictl_ind(2) <= range(2,2) .and. &
          range(1,3) <= ictl_ind(3) .and. ictl_ind(3) <= range(2,3)) then
         print *, '### prepared to store dest: ictl_ind found, loc', &
                  found(   ictl_ind(1),ictl_ind(2),ictl_ind(3)), &
                    loc(:, ictl_ind(1),ictl_ind(2),ictl_ind(3))
      endif
#endif
!
      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

#ifdef DEBUG
!Rene Initialisation
         send_info%dstijk = PSMILe_Undef
#endif
      endif
!
! ... Store locations in a simple list
! ... TODO: Schoener waere eine clusterung in Regions

      n = nprev

         if (opt == val_both) then
            do k = control (1, 3), control (2, 3)
               do j = control (1, 2), control (2, 2)
!cdir vector
                  do i = control (1, 1), control (2, 1)
                     if (abs(found (i,j,k)) == val_abs) then
                        n = n + 1
#ifdef DEBUG_TRACE
                        if ( i == ictl_ind(1) .and. j == ictl_ind(2) .and. k == ictl_ind(3) ) then
                           print *, '### store dest a): ictl_ind found, loc', n, &
                                found( ictl_ind(1),ictl_ind(2),ictl_ind(3)), &
                                loc(:, ictl_ind(1),ictl_ind(2),ictl_ind(3))
                        endif
#endif
                        send_info%dstijk (1, n) = i
                        send_info%dstijk (2, n) = j
                        send_info%dstijk (3, n) = k
                     endif
                  end do
               end do
            end do
!
         else
!
            do k = control (1, 3), control (2, 3)
               do j = control (1, 2), control (2, 2)
!cdir vector
                  do i = control (1, 1), control (2, 1)
                     if (found (i,j,k) == opt) then
                        n = n + 1
#ifdef DEBUG_TRACE
                        if ( i == ictl_ind(1) .and. j == ictl_ind(2) .and. k == ictl_ind(3) ) then
                           print *, '### store dest b): ictl_ind found, loc', n, &
                                found( ictl_ind(1),ictl_ind(2),ictl_ind(3)),  &
                                loc(:, ictl_ind(1),ictl_ind(2),ictl_ind(3))
                        endif
#endif
                        send_info%dstijk (1, n) = i
                        send_info%dstijk (2, n) = j
                        send_info%dstijk (3, n) = k
                     endif
                  end do
               end do
            end do
         endif

#ifdef PRISM_ASSERTION
      if (nloc < n) then
         print *, "nloc, n", nloc, n
         call psmile_assert ( __FILE__, __LINE__, "nloc < n")
      endif
#endif
!
!===> All done
!
      nadd = n - nprev
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, nadd

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

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

#endif /* VERBOSE */

      end subroutine PSMILe_Store_dest_locs_3d