psmile_put_field_gauss2_dble.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
!
! !ROUTINE: PSMILe_Put_field_gauss2_dble

!
! !INTERFACE:

      subroutine psmile_put_field_gauss2_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_gauss2_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,3):shape(2,3), 
                                                      nbr_fields)
!
      Integer, Intent (In)             :: nloc
!
!     Total number of locations to be transferred
!
      Integer, Intent (In)             :: nparts
!
!     Number of partitions
!
      Integer, Intent (In)             :: npoints (2, nparts)
!
!     Number of points to be transferred
!     npoints (1) = Number of points in 2d Hyperplane
!     npoints (2) = Number of points in 3rd direction
!
!
      Type(integer_vector), Intent (In) :: srclocs (2, nparts)
!
!     srclocs (1,*)%vector = Locations of 2d hyperplane to be transferred
!     srclocs (2,*)%vector = Locations of 3rd direction 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_gauss2_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for communication
!
      Double Precision, pointer       :: buffer (:)
      Integer                         :: i, j, n
!
!     ... for partitions
!
      Integer                         :: ipart, nprev
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Put_field_gauss2_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_gauss2_dble" is designed for grids of
! type "PRISM_Irrlonlat_regvrt".
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_put_field_gauss2_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_put_field_gauss2_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
!
#ifdef PRISM_ASSERTION
      nprev = 0
         do ipart = 1, nparts
         nprev = nprev + npoints(1,ipart)*npoints (2,ipart)
         end do
!
      if (nloc /= nprev) then
         print *, "nloc, ntot, npoints", nloc, nprev, npoints
         call psmile_assert ( __FILE__, __LINE__, &
                              "nloc /= Sum(npoints(1,i)*npoints(2,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
!
#ifdef DEBUG
      print 9960, nloc, nbr_fields
9960  format (1x, 'psmile_put_field_gauss2_dble: pack: nloc, nbr_fields', i7, i4)
#endif

         do n = 1, nbr_fields
!
            nprev = (n-1)*nloc
            do ipart = 1, nparts
               do j = 1, npoints (2, ipart)
!cdir vector
                  do i = 1, npoints (1, ipart)
                  buffer (nprev+(j-1)*npoints(1,ipart)+i) = &
                          data_array (srclocs(1,ipart)%vector (i), &
                                      srclocs(2,ipart)%vector (j), n)
                  end do
               end do
!
               nprev = nprev + npoints(1,ipart)*npoints(2,ipart)
            end do
         end do

#ifdef DEBUG
      ipart = 1
      print 9950, srclocs(1,ipart)%vector(1:2), srclocs(2,ipart)%vector(1), &
            data_array(srclocs(1,ipart)%vector (1), &
                       srclocs(2,ipart)%vector (1),1)
9950  format (1x, 'psmile_put_field_gauss2_dble: srcijk', 3i5, ' val', f10.5)
#endif
!
!===> Send data
!
!     Unschoen; Alloziierte Buffer hier verwalten und mit MPI_Isend senden !!!
!
#ifdef DEBUG
     print 9970, nloc, dest, tag, comm
9970 format (1x, 'psmile_put_field_gauss2_dble: nloc', i7,  '->', i2, ', tag', i5, ', comm', i5)
#endif /* DEBUG */
!
      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_gauss2_dble: dest', i3)
9980 format (1x, a, ': psmile_put_field_gauss2_dble: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Put_field_gauss2_dble