psmile_put_irr_field_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_irr_field_dble

!
! !INTERFACE:

      subroutine psmile_put_irr_field_dble (data_array, shape, nbr_fields, &
                                srcloc, npoints, srcars, nars, nloc, &
                                dest, tag, comm, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Put_irr_field_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
!
!     Total number of locations to be transferred
!     i.e. number of points in "srcloc" and "srcars" 
!
      Integer, Intent (In)             :: npoints
!
!     Number of points stored in "srcloc" to be transferred.

      Integer, Intent (In)             :: srcloc (ndim_3d, npoints)
!
!     Locations (points) to be transferred
!
      Integer, Intent (In)             :: nars
!
!     Number of clustered areas in "srcars" to be transferred
!
      Integer, Intent (In)             :: srcars (2, ndim_3d, nars)
!
!     Clustered areas 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_irr_field_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for communication
!
      Double Precision, Pointer       :: buffer (:)
!
!     ... for packing the data
!
      Integer                         :: i, n, nar, np, nprev
#define USE_PACK
#ifndef USE_PACK
      Integer                         :: j, k
#endif
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Put_irr_field_dble" sends the data (contained in
! Double Precision array "data_array") to the destination process "dest"
! using tag "tag". The data is copied out corresponding to the locations
! specified in "srcloc(*, npoints)" and "srcars(*, nars)".
!
! Subroutine "PSMILe_Put_field_3d_dble" is designed for grids of
! type "PRISM_Reglonlatvrt" or "PRISM_Gridless".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_put_irr_field_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_put_irr_field_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
!
!===> Internal control
!
      nprev = npoints
         do nar = 1, nars
         nprev = nprev + (srcars(2,1,nar)-srcars(1,1,nar)+1) * &
                         (srcars(2,2,nar)-srcars(1,2,nar)+1) * &
                         (srcars(2,3,nar)-srcars(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
!
!===> 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_irr_field_dble: unpack: nloc, nbr_fields', i7, i4)
      print 9961, shape
9961  format (1x, 'psmile_put_irr_field_dble: shape', 6i5)
#endif

         do n = 1, nbr_fields
!cdir vector
            do i = 1, npoints
            buffer ((n-1)*nloc + i) = data_array (srcloc (1, i), &
                                                  srcloc (2, i), &
                                                  srcloc (3, i), n)
            end do

         nprev = (n-1)*nloc + npoints
            do nar = 1, nars
#ifdef USE_PACK
            np = (srcars(2,1,nar)-srcars(1,1,nar)+1) * &
                 (srcars(2,2,nar)-srcars(1,2,nar)+1) * &
                 (srcars(2,3,nar)-srcars(1,3,nar)+1) 

            buffer (nprev+1:nprev+np) =                   &
            pack (data_array(srcars(1,1,nar):srcars(2,1,nar), &
                             srcars(1,2,nar):srcars(2,2,nar), &
                             srcars(1,3,nar):srcars(2,3,nar), n), .true.)
            nprev = nprev + np
#else
            np = srcars(2,1,nar)-srcars(1,1,nar)+1

               do k = srcars(1,3,nar), srcars(2,3,nar)
                  do j = srcars(1,2,nar), srcars(2,2,nar)
                  buffer (nprev+1:nprev+np) = &
                     data_array (srcars(1,1,nar):srcars(2,1,nar), j, k, n)
                  nprev = nprev + np
                  end do
               end do
#endif /* HUHU */
            end do
         end do

#ifdef PRISM_ASSERTION
      if (nloc*nbr_fields /= nprev) then
         print *, 'nloc*nbr_fields, nprev', nloc*nbr_fields, nprev
         call psmile_assert ( __FILE__, __LINE__, &
                              "Error in packing: nprev /= nloc*nbr_fields")
      endif
#endif

#ifdef DEBUG
      if (npoints > 0) then
         print 9950, srcloc (:,1), &
            data_array(srcloc (1,1), srcloc (2,1), srcloc (3,1), 1)
9950  format (1x, 'psmile_put_irr_field_dble: srcijk', 3i5, ' val', f10.5)
      endif
#endif
!
!     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_irr_field_dble: dest', i3)
9980 format (1x, a, ': psmile_put_irr_field_dble: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Put_irr_field_dble