psmile_get_faces_irreg2_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_faces_irreg2_real
!
! !INTERFACE:

      subroutine psmile_get_faces_irreg2_real (search, extra_search,    &
                           corners1, corners2, corners3,                &
                           corner_shape, nbr_corners, grid_valid_shape, &
                           neighbors_3d, nloc, num_neigh,               &
                           faces, n_faces, nreq, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Get_faces_irreg2_real

      Implicit none
!
! !INPUT PARAMETERS:
!
      Type (Enddef_search),     Intent (In) :: search

!     Info's on coordinates to be searched
!
      Type (Extra_search_info), Intent (In) :: extra_search
!
!     Number of locations where
!       (*) required mask values were not true
!
      Integer,            Intent (In) :: corner_shape (2, ndim_3d)
      
!     Specifies the dimension of arrays "corners1", "corners2" and "corners3"

      Integer,            Intent (In) :: nbr_corners

!     Number of corners in control volume 
!     Must be 8 for a grid of type "PRISM_Reglonlatvrt".

      Integer,            Intent (In) :: grid_valid_shape (2, ndim_3d)
      
!     Specifies the valid block shape for the "ndim_3d"-dimensional block

      Real,   Intent (In)             :: corners1 (                          
                                         corner_shape(1,1):corner_shape(2,1),
                                         corner_shape(1,2):corner_shape(2,2),
                                         nbr_corners/2)

      Real,   Intent (In)             :: corners2 (                          
                                         corner_shape(1,1):corner_shape(2,1),
                                         corner_shape(1,2):corner_shape(2,2),
                                         nbr_corners/2)

      Real,   Intent (In)             :: corners3 (                          
                                         corner_shape(1,3):corner_shape(2,3),
                                         2)
!
!     Coordinates of corners of cell/control volume
!     Note: This is a grid of type PRISM_Reglonlatvrt, i.e. 
!           2 corner coordinates per regular direction
!
      Integer,            Intent (In)    :: nloc
!
!     Total  Number of locations to be transferred
!
!     Last dimension of neighbors array "neighbors_3d" and
!     number of neighbors to be searched.

      Integer,            Intent (In)    :: num_neigh
!
!     Last dimension of neighbors array "neighbors_3d" and
!     number of neighbors to be searched.

      Integer,            Intent (In)    :: neighbors_3d (ndim_3d, nloc, 
                                                          num_neigh)

!     Indices of neighbor locations (interpolation bases)
!
      Integer,            Intent (In) :: nreq
!
!     Total number of extra points to be searched.
!     Dimension of "faces" and "nfaces".
!
! !OUTPUT PARAMETERS:
!
      Real,             Intent (Out) :: faces (2, ndim_3d, nreq)
!     
!
      Integer,           Intent (Out) :: n_faces (nreq)

!     Number of block faces which cell "i" is coinciding
!
      Integer,           Intent (Out) :: ierror

!     Returns the error code of PSMILe_Get_faces_irreg2_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
      Integer                         :: i, j, n
!
!     ... for partitions
!
      Integer                         :: ipart, nprev
!
      Integer, Pointer                :: indices_req (:)
      Integer, Pointer                :: required (:)
      Integer, Pointer                :: len_req (:)
!
!     ... locations controlled
!
      Integer                         :: code
!
      Integer                         :: ind (ndim_3d)
      Real                            :: box (2, ndim_3d)
!
!     ... for error handling
!
!     Integer, Parameter              :: nerrp = 3
!     Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_faces_irreg2_real" computes
!
! Subroutine "PSMILe_Get_faces_irreg2_real" is designed for grids of
! type "PRISM_Irrlonlat_Regvrt"
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_get_faces_irreg2_real.F90 2082 2009-10-21 13:31:19Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_faces_irreg2_real.F90 2082 2009-10-21 13:31:19Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
#endif
!
      ierror = 0
!
      len_req => extra_search%len_req
!
!     n_faces (:) = 0 ! wieder raus
      n_faces (:) = 1 ! wieder raus
!
      faces (1, 1, :) = 1.0
      faces (2, 1, :) = 0.0
!
!  For all part "ipart"
!
!  indices_req = Indices of the extra points in entire list of all points
!                to be searched (i.e. for all parts "ipart")
!  required    = Code for the extra points which are additionally required.

      nprev = 0
         do ipart = 1, search%npart
         if (len_req (ipart) > 0) then
            indices_req => extra_search%indices_req(ipart)%vector
            required    => extra_search%required(ipart)%vector
!
! ? HR: better use bbcells instead of corners ?
!
            code = 1
!
               do n = 1, num_neigh

                  do j = 1, len_req(ipart)
                  if (IAND (required (j), code) == 0) cycle

                  i = indices_req (j)

                  if (neighbors_3d (1,i,n) < grid_valid_shape(1,1)) then
                     ind (1) = grid_valid_shape(1,1)
                  else 
                     ind (1) = min (grid_valid_shape(2,1), neighbors_3d (1,i,n))
                  endif

                  if (neighbors_3d (2,i,n) < grid_valid_shape(1,2)) then
                     ind (2) = grid_valid_shape (1,2)
                  else 
                     ind (2) = min (grid_valid_shape(2,2), neighbors_3d (2,i,n))
                  endif

                  if (neighbors_3d (3,i,n) < grid_valid_shape(1,3)) then
                     ind (3) = grid_valid_shape (1,3)
                  else 
                     ind (3) = min (grid_valid_shape(2,3), neighbors_3d (3,i,n))
                  endif

!               HR: This was already calculated. This is the finest multi-grid.

                  box (1, 1) = minval(corners1 (ind (1), ind(2), :))
                  box (2, 1) = maxval(corners1 (ind (1), ind(2), :))

                  box (1, 2) = minval(corners2 (ind (1), ind(2), :))
                  box (2, 2) = maxval(corners2 (ind (1), ind(2), :))

                  box (1, 3) = minval(corners3 (ind (3), :))
                  box (2, 3) = maxval(corners3 (ind (3), :))

                  if (faces (1, 1, nprev+j) > faces (2, 1, nprev+j)) then

!                    ... first entry

                     faces (:, :, nprev+j) = box (:, :)

                  else

                     faces (1,1, nprev+j) = min (faces (1,1, nprev+j), box (1,1))
                     faces (2,1, nprev+j) = max (faces (2,1, nprev+j), box (2,1))
                     faces (1,2, nprev+j) = min (faces (1,2, nprev+j), box (1,2))
                     faces (2,2, nprev+j) = max (faces (2,2, nprev+j), box (2,2))
                     faces (1,3, nprev+j) = min (faces (1,3, nprev+j), box (1,3))
                     faces (2,3, nprev+j) = max (faces (2,3, nprev+j), box (2,3))

                  endif

                  end do ! j

               code = code * 2
               end do ! n
            nprev = nprev + len_req (ipart)
         endif
         end do ! ipart
!
#ifdef PRISM_ASSERTION
         do j = 1, nreq
         if (faces (1,1,j) > faces (2,1,j)) exit
         end do
!
      if (j < nreq) then
         nprev = 0
            do ipart = 1, search%npart
            if (nprev + len_req(ipart) >= j) exit
            nprev = nprev + len_req(ipart)
            end do 
         
         indices_req => extra_search%indices_req(ipart)%vector
         i = indices_req (j)
         print *, 'j, nreq', j, nreq, grid_valid_shape
            do n = 1, num_neigh
            print *, 'n, ng', n, &
                              neighbors_3d (1,j,n), &
                              neighbors_3d (2,j,n), &
                              neighbors_3d (3,j,n)
            end do

         call psmile_assert (__FILE__, __LINE__, &
              "neighbour info is not consistent")
      endif
#endif
!
! Hier muss ich noch die faces auf -180:180, .... mappen
! oder 
!!
!!
!
!===> Muss ich hier nicht die Faces mit der cyclic behandeln
!     Oder mache ich das wieder dort, wo die Punkte gesucht werden.
!
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!

#ifdef VERBOSE

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

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Get_faces_irreg2_real