prismtrs_set_tgt_epio_dble.F90

Go to the documentation of this file.
00001 !------------------------------------------------------------------------
00002 ! Copyright 2006-2010, CERFACS, Toulouse, France.
00003 ! Copyright 2006-2010, NEC High Performance Computing, Duesseldorf, Germany.
00004 ! All rights reserved. Use is subject to OASIS4 license terms.
00005 !-----------------------------------------------------------------------
00006 !BOP
00007 !
00008 ! !ROUTINE: PRISMTrs_Set_tgt_epio_dble
00009 !
00010 ! !INTERFACE
00011 subroutine prismtrs_set_tgt_epio_dble(ida_loop, id_err)
00012 !
00013 ! !USES:
00014 !
00015   USE PRISMDrv, dummy_interface => PRISMTrs_Set_tgt_epio_dble
00016 !
00017   IMPLICIT NONE
00018 !
00019 ! !PARAMETERS:
00020 !
00021   INTEGER, DIMENSION(PSMILe_trans_Header_length), INTENT (IN) :: ida_loop
00022 !
00023 ! ida_loop(2) : global rank of the source psmile process sending the info
00024 ! ida_loop(6) : epio id
00025 ! ida_loop(4) : target component id
00026 ! ida_loop(5) : target process id
00027 ! ida_loop(7) : epio 3D size 
00028 ! ida_loop(8) : number of corners for target grid
00029 ! ida_loop(9) : PSMILe_3D
00030 ! ida_loop(10): indicates if the mask will be received or not
00031 !
00032 ! ! RETURN VALUE
00033 !
00034   INTEGER, INTENT (Out)               :: id_err   ! error value
00035 
00036 ! !DESCRIPTION
00037 ! Subroutine "PRISMTrs_Set_tgt_epio_dble" insures the reception of the 
00038 ! informations about the epio sent by a model through the PSMILe.
00039 !
00040 ! !REVISED HISTORY
00041 !   Date      Programmer   Description
00042 ! ----------  ----------   -----------
00043 ! 01/12/2003  D. Declat    Creation from prismdrv_trs_set_epio_info
00044 ! 05/10/2006  S. Valcke    Revised for corner reception
00045 ! EOP
00046 !----------------------------------------------------------------------
00047 ! $Id: prismtrs_set_tgt_epio_dble.F90 2685 2010-10-28 14:05:10Z coquart $
00048 ! $Author: coquart $
00049 !----------------------------------------------------------------------
00050 !
00051 ! 0. Local declarations
00052 !
00053   CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
00054      '$Id: prismtrs_set_tgt_epio_dble.F90 2685 2010-10-28 14:05:10Z coquart $'
00055 !
00056 ! received in ida_loop
00057 !
00058   INTEGER :: il_process_global_rank, il_epio_id, il_tgt_comp_id
00059   INTEGER :: il_tgt_process
00060   INTEGER :: il_epio_size, il_nbr_corner
00061   INTEGER :: il_tgt_mask, il_dimtype, il_unit
00062 !
00063 ! Auxiliary variables
00064 !
00065   INTEGER                            :: il_status(MPI_STATUS_SIZE)
00066 !
00067   INTEGER, PARAMETER  :: nerrp = 2
00068   INTEGER             :: ierrp (nerrp)
00069   INTEGER             :: il_recv_size
00070 #ifdef DEBUGX
00071   INTEGER             :: ii 
00072   DOUBLE PRECISION           :: dbl_rad2deg
00073 #endif
00074 !
00075 !----------------------------------------------------------------------
00076 !
00077 #ifdef VERBOSE
00078   PRINT *, '| | | Enter PRISMTrs_Set_tgt_epio_dble'
00079   call psmile_flushstd
00080 #endif
00081 !
00082 ! Put received argument in local integer variables
00083   il_process_global_rank = ida_loop(2)
00084   il_epio_id             = ida_loop(6)
00085   il_tgt_comp_id         = ida_loop(4)
00086   il_tgt_process         = ida_loop(5)
00087   il_epio_size           = ida_loop(7)
00088   il_nbr_corner          = ida_loop(8)
00089   il_dimtype             = ida_loop(9)
00090   il_tgt_mask            = ida_loop(10) 
00091 !
00092 ! 1. Reception of the different vectors
00093 !
00094 #ifdef VERBOSE
00095   PRINT *, &
00096      '| | | | Reception of the EPIOS latitudes, longitudes and z'
00097   PRINT *, &
00098      '| | | | |  Epio :',il_epio_id ,'Size :',il_epio_size
00099   call psmile_flushstd
00100 #endif
00101 
00102   il_recv_size    = il_epio_size*il_nbr_corner
00103 
00104 ! 1.2. Reception of the lat, lon, z and mask
00105 !
00106   ALLOCATE(Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(1:il_recv_size), &
00107        stat = id_err)
00108   IF (id_err > 0) THEN
00109      ierrp (1) = id_err
00110      ierrp (2) = il_recv_size
00111      id_err = PRISM_Error_Alloc
00112 
00113      call psmile_error_common ( id_err, 'Tgt_lat_pointer_dble', &
00114           ierrp, 2, __FILE__, __LINE__ )
00115      RETURN
00116   ENDIF
00117 
00118   ALLOCATE(Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(1:il_recv_size), &
00119        stat = id_err)
00120   IF (id_err > 0) THEN
00121      ierrp (1) = id_err
00122      ierrp (2) = il_recv_size
00123      id_err = PRISM_Error_Alloc
00124 
00125      call psmile_error_common ( id_err, 'Tgt_lon_pointer_dble', &
00126           ierrp, 2, __FILE__, __LINE__ )
00127      RETURN
00128   ENDIF
00129 
00130   ALLOCATE(Drv_Epios(il_epio_id)%tgt_z_pointer_dble(1:il_recv_size), &
00131        stat = id_err)
00132   IF (id_err > 0) THEN
00133      ierrp (1) = id_err
00134      ierrp (2) = il_recv_size
00135      id_err = PRISM_Error_Alloc
00136 
00137      call psmile_error_common ( id_err, 'Tgt_z_pointer_dble', &
00138           ierrp, 2, __FILE__, __LINE__ )
00139      RETURN
00140   ENDIF
00141 
00142   ALLOCATE(Drv_Epios(il_epio_id)%tgt_mask_pointer(1:il_epio_size), &
00143      stat = id_err)
00144   IF (id_err > 0) THEN
00145       ierrp (1) = id_err
00146       ierrp (2) = il_epio_size
00147       id_err = PRISM_Error_Alloc
00148 
00149       call psmile_error_common ( id_err, 'Tgt_msk_pointer', &
00150          ierrp, 2, __FILE__, __LINE__ )
00151       RETURN
00152   ENDIF
00153 
00154   CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_lat_pointer_dble, &
00155      il_recv_size, MPI_Double_Precision, &
00156      il_process_global_rank, 1, comm_drv_trans, il_status, id_err)
00157   Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(:) = &
00158      Drv_Epios(il_epio_id)%tgt_lat_pointer_dble*dble_deg2rad
00159   
00160   CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_lon_pointer_dble, &
00161      il_recv_size, MPI_Double_Precision, &
00162      il_process_global_rank, 2, comm_drv_trans, il_status, id_err)
00163   Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(:) = &
00164      Drv_Epios(il_epio_id)%tgt_lon_pointer_dble*dble_deg2rad
00165 
00166 #ifdef DEBUGX
00167   il_unit=94+il_epio_id
00168   dbl_rad2deg = 360.0/6.2831853
00169   OPEN(unit=il_unit, file='TARGET_EPIO', form='formatted',position='append')
00170   WRITE(il_unit,*) 'TGT LATITUDES and LONGITUDE, epio_id, epio_size : ',il_epio_id,il_epio_size
00171   IF (il_nbr_corner .GT. 1) THEN
00172       DO ii=1, il_epio_size
00173         WRITE(il_unit,*) 'TARGET EPIO number', ii
00174         WRITE(il_unit,119) &
00175            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(ii), &
00176            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(ii+il_epio_size), &
00177            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(ii+2*il_epio_size), &
00178            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(ii+3*il_epio_size)
00179         WRITE(il_unit,118) & 
00180            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(ii), &
00181            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(ii+il_epio_size), &
00182            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(ii+2*il_epio_size), &
00183            dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(ii+3*il_epio_size) 
00184       ENDDO
00185   ELSE
00186       DO ii=1, il_recv_size
00187         WRITE(il_unit,*) ii,dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lat_pointer_dble(ii), &
00188                             dbl_rad2deg*Drv_Epios(il_epio_id)%tgt_lon_pointer_dble(ii)
00189       ENDDO
00190   ENDIF
00191   CLOSE(il_unit)
00192 #endif
00193 
00194   CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_z_pointer_dble, &
00195      il_recv_size, MPI_Double_Precision, &
00196      il_process_global_rank, 3, comm_drv_trans, il_status, id_err)
00197 
00198   IF (il_tgt_mask > 0 ) THEN
00199       CALL MPI_Recv (Drv_Epios(il_epio_id)%tgt_mask_pointer, &
00200          il_epio_size, MPI_Integer, &
00201          il_process_global_rank, 4, comm_drv_trans, il_status, id_err)
00202   ELSE
00203       Drv_Epios(il_epio_id)%tgt_mask_pointer(:) = 1
00204   END IF
00205 #ifdef DEBUGX
00206   il_unit=il_unit+il_epio_id
00207   OPEN(unit=il_unit, file='TARGET_EPIO_MSK', form='formatted',position='append')
00208   WRITE(il_unit,*) 'TGT MASK, epio_id, epio_size : ',il_epio_id,il_epio_size 
00209   WRITE(il_unit,*) Drv_Epios(il_epio_id)%tgt_mask_pointer(:)
00210   CLOSE(il_unit) 
00211 #endif
00212 
00213 #ifdef VERBOSE
00214   PRINT *, &
00215      '| | | | Set the EPIOS latitudes, longitudes and z'
00216   call psmile_flushstd
00217 #endif  
00218   
00219 !
00220 ! 3. Set the general epio information
00221 !
00222   Drv_Epios(il_epio_id)%tgt_comp_id = il_tgt_comp_id
00223   Drv_Epios(il_epio_id)%tgt_process = il_tgt_process
00224 !
00225 ! 4. Set the arrays information
00226 !
00227   Drv_Epios(il_epio_id)%tgt_coord_type = PRISM_Double_Precision
00228   Drv_Epios(il_epio_id)%tgt_size = il_epio_size 
00229   Drv_Epios(il_epio_id)%tgt_nbr_corner = il_nbr_corner
00230 !
00231 118        FORMAT ('LON =', 2X, F12.4, 3X, F12.4,3X, F12.4, 3X, F12.4)
00232 119        FORMAT ('LAT =', 2X, F12.4, 3X, F12.4,3X, F12.4, 3X, F12.4)
00233 #ifdef VERBOSE  
00234   PRINT *, '| | | Quit PRISMTrs_Set_tgt_epio_dble '
00235   call psmile_flushstd
00236 #endif
00237 
00238 END SUBROUTINE PRISMTrs_Set_tgt_epio_dble