psmile_ext_compact_irreg2_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_ext_compact_irreg2_dble
!
! !INTERFACE:

      subroutine psmile_ext_compact_irreg2_dble (          &
               send_info, array, shape, grid_valid_shape,  &
               dest_vector, dest_size, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Ext_compact_irreg2_dble

      implicit none
!
! !INPUT PARAMETERS:
!
      Type (Send_information), Intent (InOut)  :: send_info
!
!     Structure containing the send information
!
      Integer, Intent (In)            :: shape (2, ndim_2d)
!
!     Shape of the array "array"
!
      Double Precision, Intent (In)   :: array (shape(1,1):shape(2,1), 
                                                shape(1,2):shape(2,2))
!
!     Array from which the compact list should be extracted
!
      Integer, Intent (In)            :: grid_valid_shape (2, ndim_3d)

!     Specifies the valid block shape for the "ndim_3d"-dimensional block
!
      Integer, Intent (In)            :: dest_size
!
!     Dimension of output vector "dest_vector"
!
! !OUTPUT PARAMETERS:
!
      Double Precision, Intent (Out)  :: dest_vector (dest_size)
!
!     Output vector of compact list
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILE_Ext_compact_irreg2_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for extracting the compact list
!
      Integer                         :: k, n, ni, nij
#ifdef DONT_USE_RESHAPE
      Integer                         :: j
#else
      Integer                         :: dest_shape (1)
#endif
      Integer, Pointer                :: list_entries (:, :)
!
!     ... for error handling
!
!     Integer, parameter              :: nerrp = 2
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Ext_compact_irreg2_dble" extracts the data
! required from the 2-dimensional array "array" and stores the data in
! destination vector "dest_vector".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_ext_compact_irreg2_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_ext_compact_irreg2_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), send_info%send_entire_valid_shape

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
      if (dest_size < send_info%n_list) then
         print *, trim(ch_id), 'dest_size, n_list', dest_size, send_info%n_list
         call psmile_assert (__FILE__, __LINE__, &
                             "dest_size is not sufficient")
      endif
#endif
!
      ierror = 0
!
!===> Special case: All points of grid shape
!
      if (send_info%send_entire_valid_shape) then
!
         ni  =       grid_valid_shape (2, 1) - grid_valid_shape (1, 1) + 1
         nij = ni * (grid_valid_shape (2, 2) - grid_valid_shape (1, 2) + 1)
!
#ifdef PRISM_ASSERTION
         if (dest_size < nij*(grid_valid_shape(2,3)-grid_valid_shape(1,3)+1)) then
            print *, trim(ch_id), 'dest_size, nijk', dest_size, &
                     nij*(grid_valid_shape(2,3)-grid_valid_shape(1,3)+1)
     
            call psmile_assert (__FILE__, __LINE__, &
                                "dest_size is not sufficient")
         endif
#endif

#ifdef DONT_USE_RESHAPE
         n = 0
!
            do j = grid_valid_shape (1, 2), grid_valid_shape (2, 2)
            dest_vector (n+1:n+ni) = &
              array (grid_valid_shape (1,1):grid_valid_shape (2,1), j)
            n = n + ni
            end do
#else
         dest_shape (1) = nij
         dest_vector (1:nij) = RESHAPE ( &
                       array(grid_valid_shape(1,1):grid_valid_shape(2,1),  &
                             grid_valid_shape(1,2):grid_valid_shape(2,2)), &
                       dest_shape)
#endif
!
!===> ... Copy values for 3rd index
!         ! Das kann man auch noch besser machen !
!
         do k = 2, grid_valid_shape (2, 3) - grid_valid_shape (1, 3) + 1
            dest_vector((k-1)*nij+1:k*nij) = dest_vector(1:nij)
         end do

      else
!
!===> Get compact list
!
         list_entries => send_info%list_entries

#ifdef PRISM_ASSERTION
!cdir vector
            do n = 1, send_info%n_list - send_info%num2recv
            if (list_entries(1, n) < shape (1,1) .or. &
                list_entries(1, n) > shape (2,1) .or. &
                list_entries(2, n) < shape (1,2) .or. &
                list_entries(2, n) > shape (2,2)) exit
            end do

         if (n < send_info%n_list - send_info%num2recv) then
            print *, 'n, list_entry, shape', n, list_entries(1, n), &
                     list_entries(2, n), shape
            call psmile_assert (__FILE__, __LINE__, &
                                "incorrect index in list_entries")
         endif
#endif

!cdir vector
            do n = 1, send_info%n_list - send_info%num2recv
            dest_vector (n) = array (list_entries(1, n), &
                                     list_entries(2, n))
            end do

      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_ext_compact_irreg2_dble: send_entire_valid', l2)
9980 format (1x, a, ': psmile_ext_compact_irreg2_dble: eof')

      end subroutine psmile_Ext_compact_irreg2_dble