psmile_put_field_3d_dble.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_Put_field_3d_dble

!
! !INTERFACE:

      subroutine psmile_put_field_3d_dble (data_array, shape, nbr_fields,  &
                                           srclocs, nparts, nloc, npoints, &
                                           dest, tag, comm, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Put_field_3d_dble

      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

      Double Precision, Intent (In)    :: data_array (shape(1,1):shape(2,1), 
                                                      shape(1,2):shape(2,2), 
                                                      shape(1,3):shape(2,3), 
                                                      nbr_fields)
!
      Integer, Intent (In)             :: nloc
!
!     Number of locations to be transferred

      Integer, Intent (In)             :: nparts
!
!     Number of partitions
!
      Integer, Intent (In)             :: npoints (ndim_3d, nparts)
!
!     Number of points to be transferred
!     npoints (1,*) = Number of points in 1st 1d Hyperplane
!     npoints (2,*) = Number of points in 2nd 1d Hyperplane
!     npoints (3,*) = Number of points in 3rd 1d Hyperplane
!
      Type (integer_vector), Intent (In) :: srclocs (ndim_3d, nparts)
!
!     Locations of 1d hyperplanes to be transferred
!
      Integer, Intent (In)             :: dest
!
!     Rank of destination process in communicator "comm"
!
      Integer, Intent (In)             :: tag
!
!     Message tag to be used
!
      Integer, Intent (In)             :: comm
!
!     Communicator 
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)            :: ierror

!     Returns the error code of PSMILe_Put_field_3d_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for communication
!
      Double Precision, Pointer       :: buffer (:)
      Integer                         :: i, j, k, n
      Integer                         :: ijinc (nparts)
!
!     ... for partitions
!
      Integer                         :: ipart, nprev
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Put_field_3d_dble" sends the data (contained in
! Double Precision "data_array") to the destination process "dest" using
! tag "tag". The data is copied out corresponding to the locations
! specified in 
!
! Subroutine "PSMILe_Put_field_3d_dble" is designed for grids of
! type "PRISM_Reglonlatvrt".
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_put_field_3d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_put_field_3d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), dest

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
      ijinc (:) = npoints(1, :) * npoints (2, :)
!
#ifdef PRISM_ASSERTION
      nprev = 0
         do ipart = 1, nparts
         nprev = nprev + npoints(1,ipart)*npoints(2,ipart)*npoints(3,ipart)
         end do
!
      if (nloc /= nprev) then
         print *, "nloc, nprev, npoints", nloc, npoints
         call psmile_assert ( __FILE__, __LINE__, &
              "nloc /= Sum(npoints(1,i)*npoints(2,i)*npoints(3,i))")
      endif
#endif
!
!===> Allocate array to pack the data
!     Alternative ! Create datatype
!
      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 
!
!===> Pack data into the buffer
!
         do n = 1, nbr_fields
            nprev = (n-1)*nloc
!
            do ipart = 1, nparts
               do k = 1, npoints (3, ipart)
                  do j = 1, npoints (2, ipart)
!cdir vector
                     do i = 1, npoints (1, ipart)
                     buffer (nprev+(k-1)*ijinc(ipart)+(j-1)*npoints(1,ipart)+i) = &
                             data_array (srclocs(1,ipart)%vector(i), &
                                         srclocs(2,ipart)%vector(j), &
                                         srclocs(3,ipart)%vector(k), n)
                     end do
                  end do
               end do
!
               nprev = nprev + &
                       npoints(1,ipart)*npoints(2,ipart)*npoints(3,ipart)
            end do
         end do
!
!===> Send data
!
!     Unschoen; Alloziierte Buffer hier verwalten und mit MPI_Isend senden !!!
!
      call psmile_bsend (buffer, nloc*nbr_fields, MPI_DOUBLE_PRECISION, &
                         dest, tag, comm, ierror)
!
      if (ierror /= MPI_SUCCESS) then
         ierrp (1) = ierror
         ierrp (2) = dest
         ierrp (3) = tag

         ierror = PRISM_Error_Send

         call psmile_error (ierror, 'psmile_bsend', &
                            ierrp, 3, __FILE__, __LINE__ )
         return
      endif
!
!===> Deallocate buffers locally allocated
!
      Deallocate (buffer)
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */

!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_put_field_3d_dble: dest', i3)
9980 format (1x, a, ': psmile_put_field_3d_dble: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Put_field_3d_dble