psmile_get_info_index.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! Copyright 2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Get_info_index
!
! !INTERFACE:

      subroutine psmile_get_info_index ( method_id, request, index, ierror )
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Get_info_index
!
      use psmile_reallocate, only : psmile_realloc
!
      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (in) :: method_id 

!     Handle to method for which an index should be returned.

      Integer, Intent (in) :: request

!     Type of index which should be returned
!     request = 1 (send_coupler_index) : Get index for send to coupler
!     request = 2 (send_direct_index)  : Get index for direct send
!     request = 3 (recv_coupler_index) : Get index for recv from coupler
!     request = 4 (recv_direct_index)  : Get index for direct recv
!     request = 5 (send_appl_index)    : Get index for send to application
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out) :: index

!     Index corresponding to request

      integer, Intent (Out) :: ierror

!     Returns the error code of PSMILe_Get_info_index;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
!
! !LOCAL PARAMETERS:
!
      Integer, Parameter :: send_coupler_index = 1
      Integer, Parameter :: send_direct_index  = 2
      Integer, Parameter :: recv_coupler_index = 3
      Integer, Parameter :: recv_direct_index  = 4
      Integer, Parameter :: send_appl_index    = 5
!
      Integer, Parameter :: new_alloc = 8
!
! !LOCAL VARIABLES
!
      Type (Method), Pointer :: mp
!
      Integer, Save :: unique_appl_msg_id = 1
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_info_index" returns an index for an 
! send or receive info within a method with method id "method_id".
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 01.12.03    H. Ritzdorf   created
! 02.12.10    M. Hanke      Introduced usage of psmile_realloc
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_get_info_index.F90 2799 2010-12-03 14:33:35Z hanke $
! $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_info_index.F90 2799 2010-12-03 14:33:35Z hanke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print 9990, trim(ch_id), method_id

      call psmile_flushstd
#endif /* VERBOSE */

!   Initialization
!
      ierror = 0
!
#ifdef PRISM_ASSERTION
      if (method_id < 1 .or. &
          method_id > Number_of_Methods_allocated ) then
         call psmile_assert ( __FILE__, __LINE__, "illegal method id" )
         return
      endif
#endif
!
      mp => Methods (method_id)
!
!     Get index depending on the request
!
      select case (request)

!-----------------------------------------------------------------------
!     Get index for send to coupler process
!-----------------------------------------------------------------------

      case (send_coupler_index)

         if (mp%n_send_info_coupler == 0) nullify (mp%send_infos_coupler)

         mp%n_send_info_coupler = mp%n_send_info_coupler + 1
         index = mp%n_send_info_coupler

         if (mp%n_send_info_coupler > mp%n_alloc_send_coupler) then

           mp%n_alloc_send_coupler = mp%n_alloc_send_coupler + new_alloc
           mp%send_infos_coupler => psmile_realloc (mp%send_infos_coupler, &
                                                    mp%n_alloc_send_coupler)
         endif

!-----------------------------------------------------------------------
!     Get index for direct send to MPI process of another application
!-----------------------------------------------------------------------

      case (send_direct_index)

         if (mp%n_send_info_direct == 0) nullify (mp%send_infos_direct)

         mp%n_send_info_direct = mp%n_send_info_direct + 1
         index = mp%n_send_info_direct

         if (mp%n_send_info_direct > mp%n_alloc_send_direct) then

            mp%n_alloc_send_direct = mp%n_alloc_send_direct + new_alloc
            mp%send_infos_direct => psmile_realloc (mp%send_infos_direct, &
                                                    mp%n_alloc_send_direct)
         endif

!-----------------------------------------------------------------------
!     Get index for receive from a coupler process
!-----------------------------------------------------------------------
!
      case (recv_coupler_index)

         if (mp%n_recv_info_coupler == 0) nullify (mp%recv_infos_coupler)

         mp%n_recv_info_coupler = mp%n_recv_info_coupler + 1
         index = mp%n_recv_info_coupler

         if (mp%n_recv_info_coupler > mp%n_alloc_recv_coupler) then

           mp%n_alloc_recv_coupler = mp%n_alloc_recv_coupler + new_alloc
           mp%recv_infos_coupler => psmile_realloc (mp%recv_infos_coupler, &
                                                    mp%n_alloc_recv_coupler)
         endif

!-----------------------------------------------------------------------
!     Get index for direct receive from MPI process of another application
!-----------------------------------------------------------------------

      case (recv_direct_index)

         if (mp%n_recv_info_direct == 0) nullify (mp%recv_infos_direct)

         mp%n_recv_info_direct = mp%n_recv_info_direct + 1
         index = mp%n_recv_info_direct

         if (mp%n_recv_info_direct > mp%n_alloc_recv_direct) then

           mp%n_alloc_recv_direct = mp%n_alloc_recv_direct + new_alloc
           mp%recv_infos_direct => psmile_realloc (mp%recv_infos_direct, &
                                                   mp%n_alloc_recv_direct)
         endif

!-----------------------------------------------------------------------
!     Get index for send to a MPI process of same application
!     (used to send data of global search)
!-----------------------------------------------------------------------

      case (send_appl_index)

         if (mp%n_send_info_appl == 0) nullify (mp%send_infos_appl)

         mp%n_send_info_appl = mp%n_send_info_appl + 1
         index = mp%n_send_info_appl

         if (mp%n_send_info_appl > mp%n_alloc_send_appl) then

           mp%n_alloc_send_appl = mp%n_send_info_appl + new_alloc
           mp%send_infos_appl => psmile_realloc (mp%send_infos_appl, &
                                                 mp%n_alloc_send_appl)
         endif

         mp%send_infos_appl(index)%msg_id = unique_appl_msg_id
         unique_appl_msg_id = unique_appl_msg_id + 1
!
!-----------------------------------------------------------------------
!     Invalid request
!-----------------------------------------------------------------------

      case DEFAULT

!        ... Error: invalid request

         ierror = PRISM_Error_Internal

         call psmile_error ( ierror, 'Invalid request', &
                             (/method_id, request/), 2, &
                             __FILE__, __LINE__ )
         return

      end select

#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, index

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

#ifdef VERBOSE

9990 format (1x, a, ': psmile_get_info_index: method_id', i3)
9980 format (1x, a, ': psmile_get_info_index: eof ierror =', i3, &
                    '; index =', i4)

#endif /* VERBOSE */
!
      end subroutine PSMILe_Get_info_index