prismtrs_set_triple_links.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, NEC High Performance Computing, Duesseldorf, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMTrs_Set_triple_links
!
! !INTERFACE
subroutine prismtrs_set_triple_links(id_transient_out_id,     &
                                     id_transient_in_id,      &
                                     id_epio_id,              &
                                     id_err)

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

  IMPLICIT NONE

!
! !PARAMETERS:
!
! id of the transient out
  INTEGER, INTENT (In)        :: id_transient_out_id

! id of the transient in
  INTEGER, INTENT (In)        :: id_transient_in_id

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

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

! !DESCRIPTION
! Subroutines "PRISMTrs_Set_triple_links" set the epio_id in the exchange
! structure for a couple (trans_in, trans_out)
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03/12/2003  D. Declat    Creation
!
! EOP
!----------------------------------------------------------------------
! $Id: prismtrs_set_triple_links.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!----------------------------------------------------------------------
!
! Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_set_triple_links.F90 2325 2010-04-21 15:00:07Z valcke $'

  INTEGER :: ib

!     ... for error handling
  LOGICAL             :: ll_found
  INTEGER             :: il_found
  INTEGER, PARAMETER  :: nerrp = 2
  INTEGER             :: ierrp (nerrp)
  TYPE (Drv_Exchange),Dimension(:), POINTER :: temp_Drv_Exchanges
!
! ---------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | | Enter PRISMTrs_Set_triple_links'
  call psmile_flushstd
#endif

  id_err = 0
!
! 1. Find a place where to put the epio_id
!
  il_found = -1
  ll_found = .false.
  DO ib = 1, Number_of_Exchanges
    IF (Drv_Exchanges(ib)%trans_out_id .eq. id_transient_out_id) THEN
        IF (Drv_Exchanges(ib)%trans_in_id .eq. id_transient_in_id) THEN
            il_found = ib
            IF (Drv_Exchanges(ib)%epio_id .eq. PSMILe_trans_unset) THEN
                ll_found = .true.
                EXIT
            END IF
        END IF
    END IF
  END DO

  IF ((.NOT. ll_found) .AND. (il_found .eq. -1)) THEN
      ierrp(1) = Number_of_Exchanges
      ierrp(2) = ib
      call psmile_error_common ( id_err, 'PRISMTrs_Set_triple_links', &
         ierrp, 2, __FILE__, __LINE__ )
  END IF
!
! 2. Create additional Drv_Exchange instance if necessary
!
  IF (.NOT. ll_found) THEN ! can happen if one process 
                           ! processes multiple parts of one field
      ALLOCATE(temp_Drv_Exchanges(Number_of_Exchanges+1), stat = id_err)
      IF (id_err > 0) THEN
         ierrp (1) = id_err
         ierrp (2) = Number_of_Exchanges
         id_err = 13
         call psmile_error_common ( id_err, 'Drv_Exchanges', &
            ierrp, 2, __FILE__, __LINE__ )
         RETURN
      ENDIF

      temp_Drv_Exchanges(1:Number_of_Exchanges) = Drv_Exchanges
      temp_Drv_Exchanges(Number_of_Exchanges+1) = Drv_Exchanges(il_found)
      DEALLOCATE(Drv_Exchanges)
      Drv_Exchanges => temp_Drv_Exchanges
      CALL prismdrv_init_Drv_Exchange(Number_of_Exchanges+1)
      il_found = Number_of_Exchanges + 1
      Number_of_Exchanges = Number_of_Exchanges + 1
  END IF
!
! 3. Set the trans_in_field_size and epio_id
!
  Drv_Exchanges(il_found)%epio_id = id_epio_id
  Drv_Exchanges(il_found)%trans_in_field_size = Drv_Epios(id_epio_id)%tgt_size
!
#ifdef VERBOSE
  PRINT *, '| | | Quit PRISMTrs_Set_triple_links'
  call psmile_flushstd
#endif

END SUBROUTINE PRISMTrs_Set_triple_links