psmile_get_method_handle.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_method_handle
!
! !INTERFACE:

      subroutine psmile_get_method_handle ( grid_id, method_id, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Get_method_handle
!
      implicit none
!
! !INPUT PARAMETERS:
!
      integer, Intent (In)  :: grid_id

!     Handle to the grid for which grid point information is created.

!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out) :: method_id

!     Returns the handle to the grid point information created.

      integer, Intent (Out) :: ierror

!     Returns the error code of PSMILe_Get_method_handle;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
!
! !LOCAL VARIABLES
!
      integer             :: i, new_dim

      integer, parameter  :: nerrp = 2
      integer             :: ierrp (nerrp)

      type (Method), Dimension(:), Pointer :: New_Methods
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_method_handle" returns a handle to
!                                  a PointSet (method_id).
!
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 01.12.03    H. Ritzdorf   created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_get_method_handle.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_method_handle.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Get_method_handle: start'

      call psmile_flushstd
#endif /* VERBOSE */

!   Initialization
!
      ierror = 0
!
!   Search for a free grid index
!
      do i = 1, Number_of_Methods_allocated
         if (Methods(i)%status == PSMILe_status_free) exit
      end do
!
      if (i <= Number_of_Methods_allocated) then

         method_id = i

      else
!
!   ... Allocate new Methods vector, initialise and copy old vector
!
         new_dim = Number_of_Methods_allocated + 8
!
         Allocate (New_Methods (new_dim), STAT = ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            ierrp (2) = new_dim
            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'New_Methods', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
!
         New_Methods (1:Number_of_Methods_allocated) = &
             Methods (1:Number_of_Methods_allocated)

         New_Methods(Number_of_Methods_allocated+1:new_dim)%status = &
             PSMILe_status_free

         Nullify ( New_Methods(method_id)%halo_pointer )

         do i = Number_of_Methods_allocated+1, new_dim
            Nullify ( New_Methods(i)%send_infos_direct )
            Nullify ( New_Methods(i)%send_infos_coupler )
            Nullify ( New_Methods(i)%recv_infos_direct )
            Nullify ( New_Methods(i)%recv_infos_coupler )
            Nullify ( New_Methods(i)%coords_pointer )
            Nullify ( New_Methods(i)%subgrid_pointer )
            Nullify ( New_Methods(i)%vector_pointer )
            Nullify ( New_Methods(i)%gauss2_real(1)%vector)
            Nullify ( New_Methods(i)%gauss2_real(2)%vector)
            Nullify ( New_Methods(i)%gauss2_dble(1)%vector)
            Nullify ( New_Methods(i)%gauss2_dble(2)%vector)
#if defined ( PRISM_QUAD_TYPE )
            Nullify ( New_Methods(i)%gauss2_quad(1)%vector)
            Nullify ( New_Methods(i)%gauss2_quad(2)%vector)
#endif
         enddo
!
!   ... De-allocate Methods vector
!
         Deallocate (Methods, STAT = ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            ierror = PRISM_Error_Dealloc

            call psmile_error ( ierror, 'Methods', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif
!
!   ... Update Number of Methods
!
         Methods => New_Methods
!
         method_id = Number_of_Methods_allocated + 1
!
         Number_of_Methods_allocated = new_dim
      endif

!     Link methods of a grid into a linked list
!
      Methods(method_id)%next_method_in_grid = PRISM_UNDEFINED

      do i = 1, Number_of_Methods_allocated
         if (Methods(i)%grid_id == grid_id .and. &
             Methods(i)%next_method_in_grid == PRISM_UNDEFINED .and. &
             Methods(i)%status  /= PSMILe_status_free) exit
      end do

      if (i > Number_of_Methods_allocated) then

!        ... first method for this grid

         Methods(method_id)%previous_method_in_grid = PRISM_UNDEFINED
      else

!        ... last method found

         Methods(i)%next_method_in_grid = method_id
      endif

!     Initialize values of the new method 

      Methods(method_id)%status  = PSMILe_status_defined
      Methods(method_id)%grid_id = grid_id
!
!     Initialize further values of method
!
      Methods(method_id)%used_for_coupling = .false.

!     Send and recv info's

      Methods(method_id)%n_send_info_direct  = 0
      Methods(method_id)%n_send_info_coupler = 0
      Methods(method_id)%n_recv_info_direct  = 0
      Methods(method_id)%n_recv_info_coupler = 0
      Methods(method_id)%n_send_info_appl    = 0

      Methods(method_id)%n_alloc_send_direct  = 0
      Methods(method_id)%n_alloc_send_coupler = 0
      Methods(method_id)%n_alloc_recv_direct  = 0
      Methods(method_id)%n_alloc_recv_coupler = 0
      Methods(method_id)%n_alloc_send_appl    = 0
!
#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Get_method_handle: eof handle, ierror =', &
               method_id, ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
      end subroutine PSMILe_Get_method_handle