psmile_get_irr_field_real.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_Get_irr_field_real

!
! !INTERFACE:

      subroutine psmile_get_irr_field_real (data_array, shape, nbr_fields,   &
                                            dstijk, npoints, dstars, nars, nloc, &
                                            sender, tag, comm, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Get_irr_field_real

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

!     Dimension of the data array "data_array"

      Integer, Intent (In)             :: nbr_fields

!     Number of fields to be sent
!
      Integer, Intent (In)             :: nloc
!
!     Total number of locations to be received
!     i.e. number of points in "dstijk" and "dstars"
!
      Integer, Intent (In)             :: npoints
!
!     Number of points stored in "dstijk" to be transferred.
!
      Integer, Intent (In)             :: dstijk (ndim_3d, npoints)
!
!     Locations (points) to be received
!
      Integer, Intent (In)             :: nars
!
!     Number of clustered areas in "dstars" to be received
!
      Integer, Intent (In)             :: dstars (2, ndim_3d, nars)
!
!     Clustered areas to be received
!
      Integer, Intent (In)             :: sender
!
!     Rank of source process in communicator "comm"
!
      Integer, Intent (In)             :: tag
!
!     Message tag to be used
!
      Integer, Intent (In)             :: comm
!
!     Communicator 
!
! !INPUT/OUTPUT PARAMETERS:
!
      Real, Intent (InOut)             :: data_array (shape(1,1):shape(2,1), 
                                                      shape(1,2):shape(2,2), 
                                                      shape(1,3):shape(2,3), 
                                                      nbr_fields)
!
!     Field data
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)            :: ierror

!     Returns the error code of PSMILe_Get_irr_field_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for communication
!
      Integer                         :: status (MPI_STATUS_SIZE)
!
      Real, Pointer                   :: buffer (:)
      Integer                         :: i, j, k, n
!
      Integer                         :: nar, np, nprev 
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_irr_field_real" receives the data (contained in
! Real array "data_array") from the source process "sender" using
! tag "tag". The data is copied out corresponding to the locations
! specified in "dstijk" and "dstars".
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_get_irr_field_real.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_irr_field_real.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), sender

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
!
!===> Internal control
!
!     Besser waere eine kontrolle auf den range
!cdir vector
         do i = 1, npoints
         if (dstijk (1,i) < shape(1,1) .or. shape (2,1) < dstijk (1,i) .or. &
             dstijk (2,i) < shape(1,2) .or. shape (2,2) < dstijk (2,i) .or. &
             dstijk (3,i) < shape(1,3) .or. shape (2,3) < dstijk (3,i) ) exit
         end do

      if (i <= npoints) then
         print *, 'i, dstijk, shape', i, dstijk (1:ndim_3d,i), shape
         call psmile_assert ( __FILE__, __LINE__, &
                              "invalid destination index")
      endif

         do nar = 1, nars
         if (dstars (1,1,nar) < shape(1,1) .or. shape (2,1) < dstars (2,1,nar) .or. &
             dstars (1,2,nar) < shape(1,2) .or. shape (2,2) < dstars (2,2,nar) .or. &
             dstars (1,3,nar) < shape(1,3) .or. shape (2,3) < dstars (2,3,nar) ) exit
         end do

      if (nar <= nars) then
         print *, 'nar, dstars, shape', nar, dstars (1:2, 1:ndim_3d,nar), shape
         call psmile_assert ( __FILE__, __LINE__, &
                              "invalid destination area")
      endif

     nprev = npoints
         do nar = 1, nars
         nprev = nprev + (dstars(2,1,nar)-dstars(1,1,nar)+1) * &
                         (dstars(2,2,nar)-dstars(1,2,nar)+1) * &
                         (dstars(2,3,nar)-dstars(1,3,nar)+1)
         enddo
!
      if (nloc /= nprev) then
         print *, 'nloc, nprev, npoints, nars', nloc, nprev, npoints, nars
         call psmile_assert ( __FILE__, __LINE__, &
                              "nloc /= npoints + SUM(points in ars)")
      endif
#endif
!
      ierror = 0
!
!===> Allocate array to pack the data
!     Alternative ! Create datatype, aber was ist mit der Maske ?
!
      Allocate (buffer(nloc*nbr_fields), STAT = ierror)
      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = nloc * nbr_fields

         ierror = PRISM_Error_Alloc

         call psmile_error ( ierror, 'buffer', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif 
!
!===> Receive data
!
#ifdef DEBUG
      print 9970, nloc, sender, tag, comm
9970  format (1x, 'psmile_get_irr_field_real: nloc', i7, ', from', i2, &
              ', tag', i5, '; comm', i5)
#endif
      call MPI_Recv (buffer, nloc*nbr_fields, MPI_REAL, &
                     sender, tag, comm, status, ierror)
!
      if (ierror /= MPI_SUCCESS) then
         ierrp (1) = ierror
         ierrp (2) = sender
         ierrp (3) = tag

         ierror = PRISM_Error_Recv

         call psmile_error (ierror, 'MPI_Recv', &
                            ierrp, 3, __FILE__, __LINE__ )
         return
      endif
!
#ifdef PRISM_ASSERTION
      call MPI_Get_count (status, MPI_REAL, n, ierror)
      if (n /= nloc*nbr_fields) then
         print *, 'count, nloc, nbr_fields', n, nloc, nbr_fields
         call psmile_assert ( __FILE__, __LINE__, &
                              "count != nloc*nbr_fields")
      endif
#endif
!
#ifdef DEBUG
      print 9960, nloc, nbr_fields
9960  format (1x, 'psmile_get_irr_field_real: unpack: nloc, nbr_fields', i7, i4)
#endif
!
         do n = 1, nbr_fields
!cdir vector
            do i = 1, npoints
            data_array (dstijk (1,i), dstijk (2,i), dstijk (3,i), n) = &
               buffer ((n-1)*nloc + i)
            end do

         nprev = (n-1)*nloc + npoints
            do nar = 1, nars
            np = dstars(2,1,nar)-dstars(1,1,nar)+1

               do k = dstars(1,3,nar), dstars(2,3,nar)
                  do j = dstars(1,2,nar), dstars(2,2,nar)
                  data_array (dstars(1,1,nar):dstars(2,1,nar), j, k, n) = &
                     buffer (nprev+1:nprev+np)
                  nprev = nprev + np
                  end do
               end do

            end do

         end do

#ifdef DEBUG
      if (npoints > 0) then
         print 9950, dstijk (:,1), &
               data_array(dstijk (1,1), dstijk (2,1), dstijk (3,1), 1)
9950  format (1x, 'psmile_get_irr_field_real: dstijk', 3i5, ' val', f10.5)
      endif
#endif
!
!===> All done
!
      Deallocate (buffer)

#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */

!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_get_irr_field_real: source', i3)
9980 format (1x, a, ': psmile_get_irr_field_real: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Get_irr_field_real