psmile_send_req_subgrid.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Send_req_subgrid
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_send_req_subgrid (msg_intersections, &
00012                                           dest, tag, ierror)
00013 !
00014 ! !USES:
00015 !
00016       use PRISM_constants
00017 !
00018       use PSMILe, dummy_interface => PSMILe_Send_req_subgrid
00019 
00020       implicit none
00021 !
00022 ! !INPUT PARAMETERS:
00023 !
00024       Type (enddef_msg_intersections), Intent (In) :: msg_intersections
00025 
00026 !     Contains the request for a subgrid.
00027 
00028       Integer, Intent (In)                         :: dest
00029 
00030 !     Specifies the sender of the request and the destination
00031 !     of the subgrid to be sent.
00032 
00033       Integer, Intent (In)                         :: tag
00034 !
00035 !     Specifies the message tag used
00036 !
00037 ! !OUTPUT PARAMETERS:
00038 !
00039       integer, Intent (Out)                        :: ierror
00040 
00041 !     Returns the error code of PSMILe_Send_req_subgrid;
00042 !             ierror = 0 : No error
00043 !             ierror > 0 : Severe error
00044 !
00045 ! !LOCAL VARIABLES
00046 !
00047 !     ... for the grid information
00048 !
00049       integer                      :: grid_id
00050 !
00051 !     ... for the point information
00052 !
00053       integer                      :: sendreq (nd_msgint)
00054       integer                      :: method_id, method_type
00055       Type (Coords_Block), Pointer :: coords_pointer
00056 !
00057 !     ... for the corner information (conservative remapping)
00058 !
00059       Type (Corner_Block), Pointer :: corner_pointer
00060 !
00061 !
00062 !     ... for error parameters
00063 !
00064       integer, parameter           :: nerrp = 1
00065       integer                      :: ierrp (nerrp)
00066 !
00067 !
00068 ! !DESCRIPTION:
00069 !
00070 ! Subroutine "PSMILe_Send_req_subgrid" sends the subgrid requested to
00071 ! the destination process. The subgrid is sent after the corresponding
00072 ! request was received by routine "PSMILe_Get_intersect".
00073 !
00074 !
00075 ! !REVISION HISTORY:
00076 !
00077 !   Date      Programmer   Description
00078 ! ----------  ----------   -----------
00079 ! 03.07.10    H. Ritzdorf  created
00080 !
00081 !EOP
00082 !----------------------------------------------------------------------
00083 !
00084 ! $Id: psmile_send_req_subgrid.F90 2787 2010-11-29 16:51:32Z hanke $
00085 ! $Author: hanke $
00086 !
00087    Character(len=len_cvs_string), save :: mycvs = 
00088        '$Id: psmile_send_req_subgrid.F90 2787 2010-11-29 16:51:32Z hanke $'
00089 !
00090 !----------------------------------------------------------------------
00091 !
00092 !  Initialization
00093 !
00094       grid_id = msg_intersections%tgt_grid_id
00095       method_id = msg_intersections%first_tgt_method_id
00096 
00097 #ifdef VERBOSE
00098       print 9990, trim(ch_id), grid_id, method_id, dest
00099 
00100       call psmile_flushstd
00101 #endif /* VERBOSE */
00102 
00103 #ifdef PRISM_ASSERTION
00104 !
00105 !     ... Consistency check
00106 !
00107       if (method_id < 1 .or. method_id > Number_of_Methods_allocated) then
00108          print *, trim(ch_id), "method id =", method_id, Number_of_Methods_allocated
00109          call psmile_assert ( __FILE__, __LINE__, &
00110                              "invalid method id")
00111       endif
00112 !
00113       if (grid_id /= Methods(method_id)%grid_id) then
00114          call psmile_assert ( __FILE__, __LINE__, &
00115                              "inconsistent grid id's")
00116       endif
00117 #endif
00118 !
00119       method_type = Methods(method_id)%method_type
00120 !
00121       if (Grids(grid_id)%grid_type == PRISM_Gridless) then
00122 !
00123 !----------------------------------------------------------------------
00124 !     Gridless Grid (send only mask if required)
00125 !----------------------------------------------------------------------
00126 !
00127          call psmile_send_req_mask (msg_intersections, &
00128                                     dest, tag, ierror)
00129 !
00130 !----------------------------------------------------------------------
00131 !     Conservative Remapping
00132 !----------------------------------------------------------------------
00133 !
00134       else if ( msg_intersections%requires_conserv_remap == PSMILe_conserv2D .or. &
00135                 msg_intersections%requires_conserv_remap == PSMILe_conserv3D ) then
00136 
00137          corner_pointer => Grids(grid_id)%corner_pointer
00138 !
00139          if (corner_pointer%corner_datatype == MPI_REAL) then
00140 
00141 !        ... Real datatype
00142 
00143             call psmile_send_req_corners_real (msg_intersections, &
00144                                                dest, tag, ierror)
00145 
00146          else if (corner_pointer%corner_datatype == MPI_DOUBLE_PRECISION) then
00147 
00148 !        ... Double datatype
00149 
00150             call psmile_send_req_corners_dble (msg_intersections, &
00151                                                dest, tag, ierror)
00152 
00153 #if defined ( PRISM_QUAD_TYPE )
00154          else if (corner_pointer%corner_datatype == MPI_REAL16) then
00155 
00156 !        ... Quadruple  datatype
00157 
00158             call psmile_send_req_corner_quad (msg_intersections, &
00159                                               dest, tag, ierror)
00160 #endif
00161 
00162          else
00163 !
00164 !           Unknown data type
00165 !
00166             ierrp (1) = corner_pointer%corner_datatype
00167             ierror = PRISM_Error_Internal
00168             call psmile_error ( ierror, 'unsupported data type', &
00169                                 ierrp, 1, __FILE__, __LINE__ )
00170          endif
00171 !
00172 !----------------------------------------------------------------------
00173 !     Point Method
00174 !----------------------------------------------------------------------
00175 !
00176       else if (method_type == PSMILe_PointMethod) then
00177 
00178          coords_pointer => Methods(method_id)%coords_pointer
00179 !
00180          if (coords_pointer%coords_datatype == MPI_REAL) then
00181 
00182 !        ... Real datatype
00183 
00184             call psmile_send_req_coords_real (msg_intersections, &
00185                                               dest, tag, ierror)
00186 
00187          else if (coords_pointer%coords_datatype == MPI_DOUBLE_PRECISION) then
00188 
00189 !        ... Double datatype
00190 
00191             call psmile_send_req_coords_dble (msg_intersections, &
00192                                               dest, tag, ierror)
00193 
00194 #if defined ( PRISM_QUAD_TYPE )
00195          else if (coords_pointer%coords_datatype == MPI_REAL16) then
00196 
00197 !        ... Quadruple  datatype
00198 
00199             call psmile_send_req_coords_quad (msg_intersections, &
00200                                               dest, tag, ierror)
00201 
00202 #endif
00203 
00204          else
00205 !
00206 !           Unknown data type
00207 !
00208             ierrp (1) = coords_pointer%coords_datatype
00209             ierror = PRISM_Error_Internal
00210             call psmile_error ( ierror, 'unsupported data type', &
00211                                 ierrp, 1, __FILE__, __LINE__ )
00212          endif
00213 !
00214 !----------------------------------------------------------------------
00215 !     Vector method
00216 !----------------------------------------------------------------------
00217 !
00218       else if (method_type == PSMILe_VectorPointMethod) then
00219 
00220          ierrp (1) = method_type
00221          ierror = PRISM_Error_Internal
00222          call psmile_error ( ierror, 'Vector Method is currently not supported', &
00223                              ierrp, 1, __FILE__, __LINE__ )
00224 !
00225 !----------------------------------------------------------------------
00226 !     Subgrid method
00227 !----------------------------------------------------------------------
00228 !
00229       else if (method_type == PSMILe_SubgridMethod) then
00230 
00231          ierrp (1) = method_type
00232          ierror = PRISM_Error_Internal
00233          call psmile_error ( ierror, 'Subgrid Method is currently not supported', &
00234                              ierrp, 1, __FILE__, __LINE__ )
00235 !
00236 !----------------------------------------------------------------------
00237 !     Unknown method
00238 !----------------------------------------------------------------------
00239 !
00240       else
00241 
00242          ierrp (1) = method_type
00243          ierror = PRISM_Error_Internal
00244          call psmile_error ( ierror, 'unsupported method type', &
00245                              ierrp, 1, __FILE__, __LINE__ )
00246       endif
00247 !
00248 !===> All done
00249 !
00250 #ifdef VERBOSE
00251       print 9980, trim(ch_id), grid_id, dest, ierror
00252 
00253       call psmile_flushstd
00254 #endif /* VERBOSE */
00255 !
00256 !  Formats:
00257 !
00258 9990 format (1x, a, ': psmile_send_req_subgrid: grid_id =', i3, &
00259                     '; method id =', i4, '; dest =', i4)
00260 9980 format (1x, a, ': psmile_send_req_subgrid: grid_id =', i3, &
00261                     '; eof dest =', i3, ', ierror =', i4)
00262 
00263       end subroutine PSMILe_Send_req_subgrid

Generated on 18 Mar 2011 for Oasis4 by  doxygen 1.6.1