prismtrs_set_src_epio_dble.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_src_epio_dble
!
! !INTERFACE
subroutine prismtrs_set_src_epio_dble(ida_loop, id_err)
!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMTrs_Set_src_epio_dble
!
  IMPLICIT NONE
!
! !PARAMETERS:
!
  INTEGER, DIMENSION(PSMILe_trans_Header_length), INTENT (IN) :: ida_loop
!
! ida_loop(2) : global rank of the source psmile process sending the info
! ida_loop(6) : epio id
! ida_loop(4) : source component id
! ida_loop(5) : source process id
! ida_loop(7) : source epio size 
! ida_loop(8) : size of compact lat/lon/z arrays
! 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_src_epio_dble" 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_src_epio_dble.F90 2685 2010-10-28 14:05:10Z coquart $
! $Author: coquart $
!----------------------------------------------------------------------
!
! 0. Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_set_src_epio_dble.F90 2685 2010-10-28 14:05:10Z coquart $'
!
! received in ida_loop
!
  INTEGER :: il_process_global_rank, il_epio_id, il_src_comp_id
  INTEGER :: il_src_process
  INTEGER :: il_epio_size, il_lonlatz_size
  INTEGER :: il_src_mask, il_dimtype

!
! Auxiliary variables
!
  INTEGER                            :: il_status(MPI_STATUS_SIZE)
!
  INTEGER, PARAMETER  :: nerrp = 2
  INTEGER             :: ierrp (nerrp)
  INTEGER             :: ii
  DOUBLE PRECISION           :: dbl_rad2deg
!
  CHARACTER(LEN=30)   :: name_f

!----------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | | Enter PRISMTrs_Set_src_epio_dble'
  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_src_comp_id         = ida_loop(4)
  il_src_process         = ida_loop(5)
  il_epio_size           = ida_loop(7)
  il_lonlatz_size        = ida_loop(8)
  il_dimtype             = ida_loop(9)
  il_src_mask            = ida_loop(10)
  !
#ifdef VERBOSE
  print*, '| | | Reception of source ccordinates for EPIO :',il_epio_id,&
           '| | | from global source process :',il_process_global_rank, 'size :', &
           il_epio_size
  call psmile_flushstd
#endif
!
! 0. Check if the epio structure is allocated and Set epio general information
!
! 0.1. Check allocation
  IF (Number_of_Epios_allocated == 0) THEN
      Number_of_Epios_allocated = Number_of_Epios_allocated + 8
      ALLOCATE (Drv_Epios(Number_of_Epios_allocated), STAT = id_err)
  END IF
  IF (il_epio_id > Number_of_Epios_allocated) THEN
      PRINT *, '| | | il_epio_id greater then Number_of_Epios_allocated'
      call psmile_abort 
  END IF
!
! 0.2. Set information
  Drv_Epios(il_epio_id)%epio_id = il_epio_id
  Drv_Epios(il_epio_id)%trans_rank = Appl%rank
  Drv_Epios(il_epio_id)%gaussred_stride = 0.5*il_lonlatz_size
!
! 1. Reception of the different vectors
!
#ifdef VERBOSE
  PRINT *, &
     '| | | | Reception of the EPIOS latitudes, longitudes and z'
  call psmile_flushstd
#endif

! 1.2. Reception of the lat, lon, z and mask

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

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

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

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

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

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

  ALLOCATE(Drv_Epios(il_epio_id)%src_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, 'Src_msk_pointer', &
          ierrp, 2, __FILE__, __LINE__ )
     RETURN
  ENDIF

  CALL MPI_Recv (Drv_Epios(il_epio_id)%src_lat_pointer_dble, &
     il_lonlatz_size, MPI_Double_Precision, &
     il_process_global_rank, 1, comm_drv_trans, il_status, id_err)
  Drv_Epios(il_epio_id)%src_lat_pointer_dble(:) = &
     Drv_Epios(il_epio_id)%src_lat_pointer_dble(:)*dble_deg2rad
  
  CALL MPI_Recv (Drv_Epios(il_epio_id)%src_lon_pointer_dble, &
     il_lonlatz_size, MPI_Double_Precision, &
     il_process_global_rank, 2, comm_drv_trans, il_status, id_err)
  Drv_Epios(il_epio_id)%src_lon_pointer_dble(:) = &
     Drv_Epios(il_epio_id)%src_lon_pointer_dble(:)*dble_deg2rad
  
  CALL MPI_Recv (Drv_Epios(il_epio_id)%src_z_pointer_dble,  &
     il_lonlatz_size, MPI_Double_Precision, &
     il_process_global_rank, 3, comm_drv_trans, il_status, id_err)

  IF (il_src_mask > 0) THEN
      CALL MPI_Recv (Drv_Epios(il_epio_id)%src_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)%src_mask_pointer(:) = 1
  END IF

#ifdef VERBOSE
  PRINT *, &
     '| | | | Set the EPIOS latitudes, longitudes and z'
  call psmile_flushstd
#endif
  !
#ifdef DEBUGX
  dbl_rad2deg = 360.0/6.2831853
  OPEN(unit=87, file='SOURCE_EPIO', form='formatted',position='append')
  WRITE(87,*) 'Source , epio_id, epio_size : il_lonlatz_size',il_epio_id, &
               il_epio_size, il_lonlatz_size
  WRITE(87,*) 'SOURCE LATITUDES and LONGITUDES'
  DO ii=1, il_lonlatz_size
    WRITE(87,*) ii,dbl_rad2deg*Drv_Epios(il_epio_id)%src_lat_pointer_dble(ii), &
                dbl_rad2deg*Drv_Epios(il_epio_id)%src_lon_pointer_dble(ii)
  ENDDO
  CLOSE(87)
#endif

! 3. Set the general epio information
!
  Drv_Epios(il_epio_id)%src_comp_id = il_src_comp_id
  Drv_Epios(il_epio_id)%src_process = il_src_process

!
! 4. Set the arrays information
!
  Drv_Epios(il_epio_id)%src_coord_type = PRISM_Double_Precision
  Drv_Epios(il_epio_id)%src_size = il_epio_size 
  Drv_Epios(il_epio_id)%src_lonlatz_size = il_lonlatz_size
!
#ifdef VERBOSE 
  PRINT *, '| | | Quit PRISMTrs_Set_src_epio_dble '
  call psmile_flushstd
#endif

END SUBROUTINE PRISMTrs_Set_src_epio_dble