psmile_get_field_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_field_handle
!
! !INTERFACE:

      subroutine psmile_get_field_handle (field_id, ierror)
!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Get_field_handle
      implicit none
!
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: field_id

!     Returns the handle to the grid function information created.

      integer, Intent (Out)               :: ierror

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

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

      type (GridFunction), Dimension(:), Pointer :: New_Fields
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_field_handle" returns a handle to a grid
! function (field).
!
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 01.12.03    H. Ritzdorf   created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_get_field_handle.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_field_handle.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

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

      call psmile_flushstd
#endif /* VERBOSE */

!
!   Initialization
!
      ierror = 0
!
!   Search for a free field index
!
      do i = 1, Number_of_Fields_allocated
         if (Fields(i)%status == PSMILe_status_free) exit
      end do
!
      if (i <= Number_of_Fields_allocated) then
         field_id = i
!        Fields(field_id)%status = PSMILe_status_defined
      else
!
!   Allocate new Fields vector and copy old vector
!
         new_dim = Number_of_Fields_allocated + 8
!
         Allocate (New_Fields (new_dim), STAT = ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            ierrp (2) = new_dim
            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'New_Fields', &
                              ierrp, 2, __FILE__, __LINE__ )
            return
         endif
!
         New_Fields (1:Number_of_Fields_allocated) = &
            Fields (1:Number_of_Fields_allocated)

         New_Fields(Number_of_Fields_allocated+1:new_dim)%status = &
            PSMILe_status_free

         do i = Number_of_Fields_allocated+1, new_dim
            Nullify ( New_Fields(i)%io_infos )
            Nullify ( New_Fields(i)%io_chan_infos )
            Nullify ( New_Fields(i)%io_task_lookup )

            Nullify ( New_Fields(i)%Taskout )

            Nullify ( New_Fields(i)%Taskin%recv_direct )
            Nullify ( New_Fields(i)%Taskin%recv_coupler )
            Nullify ( New_Fields(i)%Taskin%buffer_int )
            Nullify ( New_Fields(i)%Taskin%buffer_real )
            Nullify ( New_Fields(i)%Taskin%buffer_dble )
#if defined ( PRISM_QUAD_TYPE )
            Nullify ( New_Fields(i)%Taskin%buffer_quad )
#endif
            Nullify ( New_Fields(i)%Taskin%Judate_Axis )

            Nullify ( New_Fields(i)%Taskin%In_Channel )

            New_Fields(i)%smioc_loc = PRISM_Undefined
            New_Fields(i)%status    = PSMILe_status_free
!
!     Initialize further values of field
!
            New_Fields(i)%used_for_coupling = .false.

!     Recv info's, send infos are handled in prism_def_var

            New_Fields(i)%Taskin%n_recv_direct  = 0
            New_Fields(i)%Taskin%n_recv_coupler = 0
!
            New_Fields(i)%Taskin%n_alloc_recv_direct  = 0
            New_Fields(i)%Taskin%n_alloc_recv_coupler = 0

         enddo
!
!   De-allocate Fields vector
!
         Deallocate (Fields, STAT = ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            ierror = PRISM_Error_Dealloc

            call psmile_error ( ierror, 'Fields', &
                              ierrp, 1, __FILE__, __LINE__ )
            return
         endif
!
!   Update Number of Fields
!
         Fields => New_Fields
!
         field_id = Number_of_Fields_allocated + 1
         Number_of_Fields_allocated = new_dim

!     Fields(field_id)%status = PSMILe_status_defined
!
      endif

#ifdef VERBOSE
      print *, trim(ch_id), ': psmile_get_field_handle: eof handle, ierror =', &
               field_id, ierror

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