psmile_store_send_info.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_store_send_info
!
! !INTERFACE:

      subroutine psmile_store_send_info (var_id, id_trans_out, dir_index, &
                                         cpl_index, appl_index, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_store_send_info

      implicit none
!
! !INPUT PARAMETERS:

      Integer, Intent (In)              :: var_id
!
!     Field id of the field for which the send info is stored.

      Integer, Intent (In)              :: id_trans_out
!
!     Transient id

      Integer, Intent (In)              :: cpl_index

!     Index of coupler send information
!     cpl_index = PRISM_UNDEFINED if no data from coupler is transferred

      Integer, Intent (In)              :: dir_index

!     Index of direct send information
!     dir_index = PRISM_UNDEFINED if no data is directly transferred

      Integer, Intent (In)              :: appl_index

!     Index of send information to an application process
!     (global search)
!     appl_index = PRISM_UNDEFINED if no data is directly transferred

! !OUTPUT PARAMETERS:

      integer, Intent (Out)             :: ierror

!     Returns the error code of PSMILe_store_send_info;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer, Parameter                :: send_coupler_index = 1
      Integer, Parameter                :: send_direct_index  = 2
      Integer, Parameter                :: send_appl_index    = 5
!
!     ... field and Taskout pointer
!
      Type (GridFunction), Pointer      :: field
      Type (Taskout_type), Pointer      :: fieldout

      Integer                           :: s_index
!
      Integer                           :: task_id
!
!     ... for error handling
!
      Integer, parameter                :: nerrp = 1
      Integer                           :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_store_send_info" stores the information for
! the puts of the field with id "var_id" and tranosint out id "id_trans_out".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_store_send_info.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_store_send_info.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), var_id

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      field => Fields(var_id)
!
#ifdef PRISM_ASSERTION
!
!===> Control Assertions
!
      if (var_id < 1 .or. var_id > Number_of_Fields_allocated) then
         print *, 'var_id', var_id
         call psmile_assert (__FILE__, __LINE__, "Incorrect var_id")
      endif

      if ( field%status == PSMILe_Status_free .or. &
           field%status == PSMILe_Status_undefined ) then
         call psmile_assert (__FILE__, __LINE__, "Incorrect field")
      endif
#endif
!
!   Find correct task_id
!
      do task_id = 1, size(Fields(var_id)%Taskout)
        if ( Fields(var_id)%Taskout(task_id)%global_transi_id == id_trans_out ) exit
      enddo

      if ( task_id > size(Fields(var_id)%Taskout) ) then
         ierror = PRISM_Error_Internal
         ierrp(1) = id_trans_out
         call psmile_error ( PRISM_Error_Arglist, &
              'No matching id was found id_trans_out ', &
              ierrp, 1, __FILE__, __LINE__ )
         return
      endif

      fieldout => Fields(var_id)%Taskout(task_id)
!
!   Store send info for field
!
      if (cpl_index /= PRISM_UNDEFINED) then
         call psmile_get_exch_index (var_id, task_id, send_coupler_index, &
                                     s_index, ierror)
         if (ierror > 0) return
!
         fieldout%send_coupler(s_index)%trans_out_id    = id_trans_out
         fieldout%send_coupler(s_index)%send_info_index = cpl_index
      endif
!
      if (dir_index /= PRISM_UNDEFINED) then
         call psmile_get_exch_index (var_id, task_id, send_direct_index, &
                                     s_index, ierror)
         if (ierror > 0) return
!
         fieldout%send_direct(s_index)%trans_out_id    = id_trans_out
         fieldout%send_direct(s_index)%send_info_index = dir_index
      endif
!
      if (appl_index /= PRISM_UNDEFINED) then
         call psmile_get_exch_index (var_id, task_id, send_appl_index, &
                                     s_index, ierror)
         if (ierror > 0) return
!
         fieldout%send_appl(s_index)%trans_out_id    = id_trans_out
         fieldout%send_appl(s_index)%send_info_index = appl_index
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

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

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

#endif /* VERBOSE */

      end subroutine PSMILe_store_send_info