prismtrs_set_tgt_epio_real.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_tgt_epio_real
!
! !INTERFACE
subroutine prismtrs_set_tgt_epio_real(ida_loop, id_err)
!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMTrs_Set_tgt_epio_real
!
  IMPLICIT NONE
!
! !PARAMETERS:
!
  INTEGER, DIMENSION(PSMILe_trans_Header_length), INTENT (IN) :: ida_loop
!
! ida_loop(2) : global rank of the psmile process sending the info
! ida_loop(6) : epio id
! ida_loop(4) : target component id
! ida_loop(5) : target process id
! ida_loop(7) : epio 3D size 
! ida_loop(8) : number of corners for target grid
! ida_loop(9) : PSMILe_3D
! ida_loop(10): indicates if the mask will be received or not
!
! ! RETURN VALUE
!
  INTEGER, INTENT (Out)               :: id_err   ! error value

! !DESCRIPTION
! Subroutine "PRISMTrs_Set_tgt_epio_real" insures the reception of the 
! informations about the epio sent by a model through the PSMILe.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01/12/2003  D. Declat    Creation from prismdrv_trs_set_epio_info
! 05/10/2006  S. Valcke    Revised for corner reception
! EOP
!----------------------------------------------------------------------
! $Id: prismtrs_set_tgt_epio_real.F90 2685 2010-10-28 14:05:10Z coquart $
! $Author: coquart $
!----------------------------------------------------------------------
!
! 0. Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_set_tgt_epio_real.F90 2685 2010-10-28 14:05:10Z coquart $'
!
! received in ida_loop
!
  INTEGER :: il_process_global_rank, il_epio_id, il_tgt_comp_id
  INTEGER :: il_tgt_process
  INTEGER :: il_epio_size, il_nbr_corner
  INTEGER :: il_tgt_mask, il_dimtype
!
! Auxiliary variables
!
  INTEGER                            :: il_status(MPI_STATUS_SIZE)
!
  INTEGER, PARAMETER  :: nerrp = 2
  INTEGER             :: ierrp (nerrp)
  INTEGER             :: il_recv_size
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | | Enter PRISMTrs_Set_tgt_epio_real'
  call psmile_flushstd
#endif
!
! Put received argument in local integer variables
  il_process_global_rank = ida_loop(2)
  il_epio_id             = ida_loop(6)
  il_tgt_comp_id         = ida_loop(4)
  il_tgt_process         = ida_loop(5)
  il_epio_size           = ida_loop(7)
  il_nbr_corner          = ida_loop(8)
  il_dimtype             = ida_loop(9)
  il_tgt_mask            = ida_loop(10)  
!
! 1. Reception of the different vectors
!
#ifdef VERBOSE
  PRINT *, &
     '| | | | Reception of the EPIOS latitudes, longitudes and z'
  call psmile_flushstd
#endif

  il_recv_size    = il_epio_size*il_nbr_corner

! 1.2. Reception of the lat, lon, z and mask
!
  ALLOCATE(Drv_Epios(il_epio_id)%tgt_lat_pointer_real(1:il_recv_size), &
       stat = id_err)
  IF (id_err > 0) THEN
     ierrp (1) = id_err
     ierrp (2) = il_recv_size
     id_err = PRISM_Error_Alloc

     call psmile_error_common ( id_err, 'Tgt_lat_pointer_real', &
          ierrp, 2, __FILE__, __LINE__ )
     RETURN
  ENDIF

  ALLOCATE(Drv_Epios(il_epio_id)%tgt_lon_pointer_real(1:il_recv_size), &
       stat = id_err)
  IF (id_err > 0) THEN
     ierrp (1) = id_err
     ierrp (2) = il_recv_size
     id_err = PRISM_Error_Alloc

     call psmile_error_common ( id_err, 'Tgt_lon_pointer_real', &
          ierrp, 2, __FILE__, __LINE__ )
     RETURN
  ENDIF

  ALLOCATE(Drv_Epios(il_epio_id)%tgt_z_pointer_real(1:il_recv_size), &
       stat = id_err)
  IF (id_err > 0) THEN
     ierrp (1) = id_err
     ierrp (2) = il_recv_size
     id_err = PRISM_Error_Alloc

     call psmile_error_common ( id_err, 'Tgt_z_pointer_real', &
          ierrp, 2, __FILE__, __LINE__ )
     RETURN
  ENDIF

  ALLOCATE(Drv_Epios(il_epio_id)%tgt_mask_pointer(1:il_epio_size), &
     stat = id_err)
  IF (id_err > 0) THEN
      ierrp (1) = id_err
      ierrp (2) = il_epio_size
      id_err = PRISM_Error_Alloc
      
      call psmile_error_common ( id_err, 'Tgt_msk_pointer', &
         ierrp, 2, __FILE__, __LINE__ )
      RETURN
  ENDIF

  CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_lat_pointer_real, &
     il_recv_size, MPI_Real, &
     il_process_global_rank, 1, comm_drv_trans, il_status, id_err)
  Drv_Epios(il_epio_id)%tgt_lat_pointer_real(:) = &
     Drv_Epios(il_epio_id)%tgt_lat_pointer_real(:)*real_deg2rad

  CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_lon_pointer_real, &
     il_recv_size, MPI_Real, &
     il_process_global_rank, 2, comm_drv_trans, il_status, id_err)
  Drv_Epios(il_epio_id)%tgt_lon_pointer_real(:) = &
     Drv_Epios(il_epio_id)%tgt_lon_pointer_real(:)*real_deg2rad

  CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_z_pointer_real, &
     il_recv_size, MPI_Real, &
     il_process_global_rank, 3, comm_drv_trans, il_status, id_err)

  IF (il_tgt_mask > 0 ) THEN
      CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_mask_pointer, &
         il_epio_size, MPI_Integer, &
         il_process_global_rank, 4, comm_drv_trans, il_status, id_err)
  ELSE
      Drv_Epios(il_epio_id)%tgt_mask_pointer(:) = 1
  END IF

#ifdef VERBOSE
  PRINT *, &
     '| | | | Set the EPIOS latitudes, longitudes and z'
  PRINT *, &
     '| | | | | Epio :',il_epio_id ,'Size :',il_epio_size
  call psmile_flushstd
#endif  
  
!
! 3. Set the general epio information
!
  Drv_Epios(il_epio_id)%tgt_comp_id = il_tgt_comp_id
  Drv_Epios(il_epio_id)%tgt_process = il_tgt_process

!
! 4. Set the arrays information
!
  Drv_Epios(il_epio_id)%tgt_coord_type = PRISM_Real
  Drv_Epios(il_epio_id)%tgt_size = il_epio_size 
  Drv_Epios(il_epio_id)%tgt_nbr_corner = il_nbr_corner
  !  
#ifdef VERBOSE
  PRINT *, '| | | Quit PRISMTrs_Set_tgt_epio_real '
  call psmile_flushstd
#endif
  
END SUBROUTINE PRISMTrs_Set_tgt_epio_real