prismtrs_target_real.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, NEC High Performance Computing, Duesseldorf, Germany.
! Copyright 2009, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMTrs_Target_real
!
! !INTERFACE
subroutine prismtrs_target_real(id_process_global_rank,  &
                                id_transient_in_id,      &
                                id_epio_id,              &
                                id_nbr_fields,           &
                                id_err)

!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMTrs_Target_real

  IMPLICIT NONE

!
! !PARAMETERS:
!
! rank of the psmile target process sending the info
  INTEGER , INTENT (In)       :: id_process_global_rank

! id of the required field
  INTEGER, INTENT (In)        :: id_transient_in_id

! Epio index
  INTEGER, INTENT (IN)        :: id_epio_id

! nbr of bundle components
  INTEGER, INTENT (In)        :: id_nbr_fields

!
! ! RETURN VALUE
!
  INTEGER, INTENT (Out)       :: id_err   ! error value

! !DESCRIPTION
! Subroutines "PRISMTrs_Target_real" checks if the required field is ready 
! and sends it to the target model which requested it.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 28/01/2003  D. Declat    Creation
! 01/12/2003  D. Declat    Adapted to type real, dble
! 03/12/2009  M. Hanke     Simplified field handling
!
! EOP
!----------------------------------------------------------------------
! $Id: prismtrs_target_real.F90 2685 2010-10-28 14:05:10Z coquart $
! $Author: coquart $
!----------------------------------------------------------------------
!
! Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_target_real.F90 2685 2010-10-28 14:05:10Z coquart $'
!
! received field
!
  REAL, DIMENSION(:), ALLOCATABLE :: rla_field
  INTEGER :: il_field_status
!
! Auxialiary varaibles
!
  INTEGER :: il_size
!
  INTEGER :: ib
  INTEGER :: il_exchange_id

  LOGICAL :: conservation

!     ... for error handling
  LOGICAL             :: ll_found
  INTEGER, PARAMETER  :: nerrp = 2
  INTEGER             :: ierrp (nerrp)
!
! ---------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | | Enter PRISMTrs_Target_real '
  call psmile_flushstd
#endif

!
! 2. Get the exchange id
!
  ll_found = .false.
  DO ib = 1, Number_of_Exchanges
    IF (Drv_Exchanges(ib)%trans_in_id .eq. id_transient_in_id) THEN
        IF (Drv_Exchanges(ib)%epio_id .eq. id_epio_id) THEN
            il_exchange_id = ib
            ll_found = .true.
            EXIT
        END IF
    END IF
  END DO

  IF (.NOT. ll_found) THEN
      ierrp(1) = Number_of_Exchanges
      ierrp(2) = ib
      call psmile_error_common ( id_err, 'PRISMTrs_Target_real', &
         ierrp, 2, __FILE__, __LINE__ )
  END IF

  conservation = Drv_Exchanges(il_exchange_id)%conservation &
                 .ne. PSMILe_undef
!
! 3. Get the field if available
!
! 3.1. Reduce status by 1
      Drv_Exchanges(il_exchange_id)%trans_in_status =  &
         Drv_Exchanges(il_exchange_id)%trans_in_status-1
! 3.2. Check the status of the transformation:
!      if the interpolation is not completed, post a request...
  IF (Drv_Exchanges(il_exchange_id)%trans_in_status .EQ. -1) THEN

      ! store rank of process which requested the data
      ! why is this stored? the epio_id should be sufficient
      Drv_Exchanges(il_exchange_id)%trans_in_request = &
         id_process_global_rank

#ifdef VERBOSE
      PRINT *, &
         '| | | | The transient_in ', id_transient_in_id, &
         'is NOT available ! Post a request '
      call psmile_flushstd
#endif

!     if available send it !
  ELSE IF (Drv_Exchanges(il_exchange_id)%trans_in_status .GE. 0) THEN

      il_size = Drv_Exchanges(il_exchange_id)%trans_in_field_size*id_nbr_fields

#ifdef VERBOSE
      PRINT *, '| | | | Sending transient_in ', id_transient_in_id, &
         'to process ', id_process_global_rank, 'size ', &
          il_size
      call psmile_flushstd
#endif

      ! send data
      call MPI_Send(Drv_Exchanges(il_exchange_id)%trans_in_field_real(1), &
         il_size, MPI_Real,    &
         id_process_global_rank, 0177, comm_drv_trans, id_err)
      ! remove sent field from memory
      call prismtrs_dequeue_in_field_real(il_size, il_exchange_id, id_err)

      if (conservation) then
#ifdef VERBOSE
         PRINT *, '| | | | Sending global_sum ', Drv_Exchanges(il_exchange_id)%global_sum_dble, &
            conservation
         call psmile_flushstd
#endif
         ! send global sum
         call MPI_Send(Drv_Exchanges(il_exchange_id)%global_sum_dble(1), &
            id_nbr_fields, MPI_Double_Complex,    &
            id_process_global_rank, CONSERVTAG, comm_drv_trans, id_err)
         ! remove sent sum from memory
         call prismtrs_dequeue_glob_sum_dble(id_nbr_fields, il_exchange_id, id_err)
      endif

!      status is < 0, this is not allowed, because a prism_get is assumed to be blocking
  ELSE

     ierrp (1) = Drv_Exchanges(il_exchange_id)%trans_in_status

     call psmile_error_common ( PRISM_Error_Parameter, 'prismtrs_target_dble',&
          ierrp, 1, __FILE__, __LINE__ )
  ENDIF

!
#ifdef VERBOSE
  PRINT *, '| | | Quit PRISMTrs_Target_real'
  call psmile_flushstd
#endif

END SUBROUTINE PRISMTrs_Target_real