psmile_store_source_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_source_locs_3d (found, loc, ibeg, len, &
                      send_info, nloc, opt,                          &
                      nprev, nadd, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_store_source_locs_3d

      Implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)            :: ibeg
!
!     Start of search
!
      Integer, Intent (In)            :: len
!
!     Dimension of vectors found and loc
!
      Integer, Intent (In)            :: found (len)

!     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, len)

!     Locations found for coordinates to be searched

      Integer, Intent (In)            :: nloc
!
!     Total 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%srclocs(ialloc, ipart)%vector
!
! !INPUT/OUTPUT PARAMETERS:
!
      Type(Send_information), Intent(InOut) :: send_info
!
!     Send information to be generated
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)           :: nadd
!
!     Number of locations added in send_info%srclocs(ialloc, ipart)%vector
!
      integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Store_source_locs_3d;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer, Parameter              :: ialloc = 1
      Integer, Parameter              :: ipart  = 1
!
      Integer                         :: i, n
!
      Integer, Pointer                :: srcloc (:)
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 2
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_store_source_locs_3d" stores the data on the
! source locations found for the method (grid) and the
! subgrid coords sent by sending (destination) process.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.03    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_store_source_locs_3d.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_store_source_locs_3d.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), opt, nloc, ibeg, len, nprev

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      if (nprev == 0 .and. &
          .not. Associated (send_info%srclocs(ialloc, ipart)%vector) ) then

!        Allocate (send_info%srcloc(1:ndim_3d, 1:nloc), STAT = ierror)
         Allocate (send_info%srclocs(ialloc, ipart)%vector(ndim_3d*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%srclocs(1)%vector', &
                                ierrp, 2, __FILE__, __LINE__ )
            return

         endif
!
!        Allocate dummy array (for 1 dummy area) in order to avoid
!        problems with some run-time systems.
!
         Allocate (send_info%srcars(ialloc, ipart)%vector(ndim_3d*2), &
                   STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = ndim_3d * 2

            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'send_info%srcars(1)%vector', &
                                ierrp, 2, __FILE__, __LINE__ )
            return

         endif

!
! ... Store locations in a simple list
!     ??? Schoener waere eine clusterung in Regions
!     ??? Dann muessen aber die Destionations mit den geclusterten
!         Daten erzeugt werden, um Problem in der Reihenfolge zu verhindern.
!
         send_info%npoints(ialloc, ipart) = 0
         send_info%nars   (ialloc, ipart) = 0
      end if
!
      srcloc => send_info%srclocs(ialloc, ipart)%vector
!
      n = nprev * ndim_3d

      if (opt == 0) then
!cdir vector
          do i = ibeg, len
          if (abs(found (i)) == 1) then

             srcloc (n+1) = loc (1, i)
             srcloc (n+2) = loc (2, i)
             srcloc (n+3) = loc (3, i)

             n = n + ndim_3d

#ifdef DEBUGX
             if (n/ndim_3d == 1) then
                print *, 'store_source_locs_3d: n, i, srcloc', &
                         n/ndim_3d, i, srcloc (n-2:n), loc (:, i), found (i)
             endif
#endif
          endif
          end do
!
      else
!
!cdir vector
          do i = ibeg, len
          if (found (i) == opt) then
             srcloc (n+1) = loc (1, i)
             srcloc (n+2) = loc (2, i)
             srcloc (n+3) = loc (3, i)

             n = n + ndim_3d

#ifdef DEBUGX
             if (n/ndim_3d == 3441) then
                print *, 'store_source_locs_3d: n',  n/ndim_3d, ', i', i, &
                         'srcloc', srcloc (n-2:n), &
                         'loc', loc (:, i), ', found', found (i)
             endif
#endif
          endif
          end do
      endif

#ifdef PRISM_ASSERTION
      if (nloc*ndim_3d < n) then
         print *, "nloc, n", nloc, n/ndim_3d
         call psmile_assert ( __FILE__, __LINE__, "nloc < n")
      endif
#endif
!
!===> All done
!
      nadd = n/ndim_3d - nprev
!
      send_info%npoints(ialloc, ipart) = send_info%npoints(ialloc, ipart) + nadd
!     send_info%nars   (ialloc, ipart) = send_info%nars   (ialloc, ipart) +
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

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

9990 format (1x, a, ': psmile_store_source_locs_3d: opt ', i2, &
             '; nloc, ibeg, len, nprev ', 4i8)
9980 format (1x, a, ': psmile_store_source_locs_3d: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_store_source_locs_3d