psmile_search_donor_cells.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! Copyright 2011, DKRZ, Hamburg, Germany.
00004 ! All rights reserved. Use is subject to OASIS4 license terms.
00005 !-----------------------------------------------------------------------
00006 !BOP
00007 !
00008 ! !ROUTINE: PSMILe_Search_donor_cells
00009 !
00010 ! !INTERFACE:
00011 
00012       subroutine psmile_search_donor_cells (search, tol, ierror)
00013 !
00014 ! !USES:
00015 !
00016       use PRISM_constants
00017       use PSMILe, dummy_interface => PSMILe_Search_donor_cells
00018       use psmile_grid, only : get_num_independent_dims
00019 #ifdef DEBUG_TRACE
00020       use psmile_debug_trace
00021 #endif
00022 
00023       implicit none
00024 !
00025 ! !INPUT PARAMETERS:
00026 !
00027 !     Integer, Intent (In)                :: tag
00028 !
00029 !     Specifies the message tag used
00030 
00031       Double Precision, Intent (In)       :: tol
00032 
00033 !     Absolute tolerance for search of "identical" points
00034 !     TOL >= 0.0
00035 
00036 !
00037 ! !INPUT/OUTPUT PARAMETERS:
00038 !
00039       Type (Enddef_search), Intent (InOut) :: search
00040 
00041 !     Data on the points to be searched
00042 !
00043 ! !OUTPUT PARAMETERS:
00044 !
00045       Integer,              Intent (Out)   :: ierror
00046 
00047 !     Returns the error code of PSMILe_Search_donor_cells;
00048 !             ierror = 0 : No error
00049 !             ierror > 0 : Severe error
00050 !
00051 ! !LOCAL VARIABLES
00052 !
00053       Integer                               :: i
00054       Real                                  :: rtol
00055 #if defined ( PRISM_QUAD_TYPE )
00056       Real (kind=PRISM_QUAD_TYPE)           :: qtol
00057 #endif
00058 !
00059 !     ... for grids and components
00060 !
00061 ! comp_id = Component Id of the component in which the donor cells
00062 !           should be searched.
00063 !
00064       Integer                               :: comp_id
00065       Integer                               :: grid_id
00066       Integer                               :: icomp
00067       Integer                               :: datatype
00068 !
00069 !     ... for fields
00070 !
00071       Integer                               :: var_id, n_vars
00072 !
00073       Integer, Allocatable                  :: field_list_buf (:, :)
00074       Type (Enddef_field_info), Allocatable :: field_list (:)
00075 !
00076 !     ... methods searched
00077 !
00078       Integer                               :: method_id
00079 !
00080 !     ... for intersections
00081 !
00082       Integer                               :: ipart
00083       Integer                               :: len  (search%search_data%npart, ndim_3d)
00084 !
00085 !     ... locations searched
00086 !
00087       Type (integer_vector)                 :: found     (search%search_data%npart, ndim_3d)
00088       Type (integer_vector)                 :: locations (search%search_data%npart, ndim_3d)
00089 !
00090 !     ... for communication
00091 !
00092       Integer                               :: status (MPI_STATUS_SIZE)
00093 !
00094 !     ... for error parameters
00095 !
00096       Integer, parameter                    :: nerrp = 2
00097       Integer                               :: ierrp (nerrp)
00098 !
00099 ! !DESCRIPTION:
00100 !
00101 ! Subroutine "PSMILe_Search_donor_cells" searches the donor cells
00102 ! for the subgrid sent by the sending process.
00103 !
00104 !
00105 ! !REVISION HISTORY:
00106 !
00107 !   Date      Programmer   Description
00108 ! ----------  ----------   -----------
00109 ! 03.07.21    H. Ritzdorf  created
00110 ! 03.05.2011  M. Hanke     moved mg search and initalisation of found
00111 !                          and locations to new routine psmile_mg_search
00112 !
00113 !EOP
00114 !----------------------------------------------------------------------
00115 !
00116 ! $Id: psmile_search_donor_cells.F90 3248 2011-06-23 13:03:19Z coquart $
00117 ! $Author: coquart $
00118 !
00119    Character(len=len_cvs_string), save :: mycvs = 
00120        '$Id: psmile_search_donor_cells.F90 3248 2011-06-23 13:03:19Z coquart $'
00121 !
00122 !----------------------------------------------------------------------
00123 !
00124 !  Initialization
00125 !
00126       comp_id = search%msg_intersections%src_comp_id
00127 #ifdef VERBOSE
00128       print 9990, trim(ch_id), comp_id, search%sender
00129 
00130       call psmile_flushstd
00131 #endif /* VERBOSE */
00132 
00133       rtol = tol
00134 
00135 #if defined ( PRISM_QUAD_TYPE )
00136       qtol = tol
00137 #endif
00138 
00139 #ifdef DEBUG_TRACE
00140 !     Target index of the point to be searched which should be traced
00141       ictl_ind (:) =  (/48, 6, 1/)
00142 #endif
00143 
00144 #ifdef PRISM_ASSERTION
00145 !
00146 !===> Internal control
00147 !
00148       if (comp_id < 1 .or. &
00149           comp_id > Number_of_Comps_allocated .or. &
00150           Comps(comp_id)%status /= PSMILe_status_defined) then
00151 
00152           print *, trim(ch_id), "comp id =",           &
00153                    comp_id, Number_of_Comps_allocated, &
00154                    Comps(comp_id)%status
00155           call psmile_assert ( __FILE__, __LINE__, &
00156                               'invalid comp id')
00157       endif
00158 #endif
00159 
00160 !     Search comp_id in comp_infos
00161 
00162       do icomp = 1, n_act_comp
00163          if (comp_infos(icomp)%comp_id == comp_id) exit
00164       enddo
00165 
00166       if (icomp > n_act_comp) then
00167          ierror = PRISM_Error_internal
00168          ierrp (1) = comp_id
00169          ierrp (2) = n_act_comp
00170 
00171          call psmile_error ( ierror, &
00172                             'Cannot found comp_id in active components', &
00173                              ierrp, 2, __FILE__, __LINE__ )
00174          return
00175       endif
00176 !
00177 !===> Receive info on additional fields if necessary
00178 !
00179       n_vars = search%msg_intersections%num_vars - 1
00180 !
00181       if (n_vars > 0) then
00182          Allocate (field_list_buf (nd_field_list, n_vars), &
00183                    field_list (n_vars), STAT = ierror)
00184          if ( ierror > 0 ) then
00185             ierrp (1) = ierror
00186             ierrp (2) = 2 * nd_field_list * n_vars
00187             ierror = PRISM_Error_Alloc
00188             call psmile_error ( ierror, 'field_list', &
00189                                 ierrp, 2, __FILE__, __LINE__ )
00190             return
00191          endif
00192 !
00193 !        print *, 'n_vars', n_vars, nd_field_list*n_vars
00194 !
00195          call MPI_Recv (field_list_buf, nd_field_list*n_vars, MPI_INTEGER,  &
00196                         search%sender, vartag, comm_psmile, status, ierror)
00197          if ( ierror /= MPI_SUCCESS ) then
00198             ierrp (1) = ierror
00199             ierror = PRISM_Error_MPI
00200 
00201             call psmile_error ( ierror, 'MPI_Recv', &
00202                                 ierrp, 1, __FILE__, __LINE__ )
00203             return
00204          endif
00205 
00206          call psmile_unpack_field_info (field_list, field_list_buf, n_vars)
00207 
00208          Deallocate(field_list_buf)
00209       else  ! no additional field, but dummy allocation for argument list in
00210             ! calling subroutines (avoid to pass a non-allocated array)
00211          Allocate (field_list (1), STAT = ierror)
00212 
00213       endif
00214 !
00215 !===> Search corresponding field with global transout id "id_transout" for
00216 !     this component "comp_id" and grid "grid_id"
00217 !
00218       call psmile_find_corr_field (comp_infos(icomp), search, &
00219                                    var_id, ierror)
00220       if (ierror > 0) return
00221 !
00222 !===> Special case: Gridless grid
00223 !
00224       method_id = Fields(var_id)%method_id
00225       grid_id = Methods(method_id)%grid_id
00226 !
00227       if (Grids(grid_id)%grid_type == PRISM_Gridless) then
00228          call psmile_search_donor_gridless (comp_infos(icomp), search, &
00229                                     field_list, n_vars,                &
00230                                     grid_id, method_id, var_id, ierror)
00231 #ifdef VERBOSE
00232          print 9970, trim(ch_id), grid_id, search%sender, ierror
00233 
00234          call psmile_flushstd
00235 #endif /* VERBOSE */
00236 
00237          Deallocate (field_list)    ! always allocated
00238          return
00239 
00240       endif
00241 !
00242 !===> Transform locations to be searched
00243 !     Is required only once per method.
00244 !
00245       call psmile_transform_coords (comp_infos(icomp), search, ierror)
00246       if (ierror > 0) return
00247 !
00248 ! =======================================================================
00249 !     Search locations
00250 !     (i)  Allocate and initalize found and locations vectors
00251 !     (ii) Search with specific routine
00252 ! =======================================================================
00253 !
00254       call psmile_mg_search (comp_infos(icomp), grid_id, search%search_data,                  &
00255          (search%msg_intersections%field_info%requires_conserv_remap == PSMILe_conserv2D .or. &
00256           search%msg_intersections%field_info%requires_conserv_remap == PSMILe_conserv3D),    &
00257          found, locations, len, tol, ierror)
00258 
00259 ! -----------------------------------------------------------------------
00260 !      Do the actual search + everything else there is to do
00261 ! -----------------------------------------------------------------------
00262 
00263       datatype  = Grids(grid_id)%corner_pointer%corner_datatype
00264 
00265       select case ( get_num_independent_dims(Grids(grid_id)%grid_type) )
00266 
00267       case (ndim_3d) ! 3 independent dimension
00268                      ! regular in all 3 directions
00269 
00270          ! Search locations separately in all 3 directions
00271          if (datatype == MPI_REAL) then
00272 
00273             call psmile_search_donor_3d_reg_real (comp_infos(icomp),       &
00274                         found, locations, len, search, field_list, n_vars, &
00275                         grid_id, method_id, var_id, rtol, ierror)
00276             if (ierror > 0) return
00277 
00278          else if (datatype == MPI_DOUBLE_PRECISION) then
00279 
00280 
00281             call psmile_search_donor_3d_reg_dble (comp_infos(icomp),       &
00282                         found, locations, len, search, field_list, n_vars, &
00283                         grid_id, method_id, var_id, tol, ierror)
00284             if (ierror > 0) return
00285 
00286 #if defined ( PRISM_QUAD_TYPE )
00287          else if (datatype == MPI_REAL16) then
00288 
00289             call psmile_search_donor_3d_reg_quad (comp_infos(icomp),       &
00290                         found, locations, len, search, field_list, n_vars, &
00291                         grid_id, method_id, var_id, qtol, ierror)
00292             if (ierror > 0) return
00293 #endif
00294          endif
00295 
00296       case (ndim_2d) !    2 independent dimesions
00297                      !    Irregular in lonlat   direction
00298                      !    Regular   in vertical direction
00299 
00300          if (datatype == MPI_REAL) then
00301 
00302             if (Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt) then
00303                call psmile_search_donor_gauss2_real (comp_infos(icomp),       &
00304                            found, locations, len, search, field_list, n_vars, &
00305                            grid_id, method_id, var_id, rtol, ierror)
00306             else
00307                call psmile_search_donor_irreg2_real (comp_infos(icomp),  &
00308                            found(:, 1:ndim_2d), locations(:, 1:ndim_2d), &
00309                            len  (:, 1:ndim_2d),                          &
00310                            search, field_list, n_vars,                   &
00311                            grid_id, method_id, var_id, rtol, ierror)
00312             endif
00313             if (ierror > 0) return
00314 
00315          else if (datatype == MPI_DOUBLE_PRECISION) then
00316 
00317             if (Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt) then
00318                call psmile_search_donor_gauss2_dble (comp_infos(icomp),       &
00319                            found, locations, len, search, field_list, n_vars, &
00320                            grid_id, method_id, var_id, tol, ierror)
00321             else
00322                call psmile_search_donor_irreg2_dble (comp_infos(icomp),  &
00323                            found(:, 1:ndim_2d), locations(:, 1:ndim_2d), &
00324                            len  (:, 1:ndim_2d),                          &
00325                            search, field_list, n_vars, &
00326                            grid_id, method_id, var_id, tol, ierror)
00327             endif
00328             if (ierror > 0) return
00329 
00330 #if defined ( PRISM_QUAD_TYPE )
00331          else if (datatype == MPI_REAL16) then
00332 
00333             if (Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt) then
00334                call psmile_search_donor_gauss2_quad (comp_infos(icomp),  &
00335                            found, locations, len, search, field_list, n_vars, &
00336                            grid_id, method_id, var_id, tol, ierror)
00337             else
00338                call psmile_search_donor_irreg2_quad (comp_infos(icomp),  &
00339                            found(:, 1:ndim_2d), locations(:, 1:ndim_2d), &
00340                            len  (:, 1:ndim_2d),                          &
00341                            search, field_list, n_vars, &
00342                            grid_id, method_id, var_id, qtol, ierror)
00343             endif
00344             if (ierror > 0) return
00345 #endif
00346          endif
00347 
00348       case (ndim_1d) ! 1 independent dimension
00349                      ! Irregular in lonlat   and vertical direction
00350 
00351          if (datatype == MPI_REAL) then
00352 
00353             call psmile_search_donor_irreg3_real (comp_infos(icomp), &
00354                         found(:, 1), locations (:, 1),           &
00355                         len  (:, 1), search, field_list, n_vars, &
00356                         grid_id, method_id, var_id, rtol, ierror)
00357             if (ierror > 0) return
00358 
00359          else if (datatype == MPI_DOUBLE_PRECISION) then
00360 
00361             call psmile_search_donor_irreg3_dble (comp_infos(icomp),   &
00362                         found(:, 1), locations (:, 1),             &
00363                         len  (:, 1), search, field_list, n_vars,   &
00364                         grid_id, method_id, var_id, tol, ierror)
00365             if (ierror > 0) return
00366 
00367 #if defined ( PRISM_QUAD_TYPE )
00368          else if (datatype == MPI_REAL16) then
00369 
00370             call psmile_search_donor_irreg3_quad (comp_infos(icomp), &
00371                         found(:, 1), locations (:, 1),           &
00372                         len  (:, 1), search, field_list, n_vars, &
00373                         grid_id, method_id, var_id, qtol, ierror)
00374             if (ierror > 0) return
00375 #endif
00376          endif
00377 
00378       end select ! get_num_independent_dims(Grids(grid_id)%grid_type)
00379 !
00380 !===> Free memory allocated
00381 !
00382       do ipart = 1, search%search_data%npart
00383          do i = 1, ndim_3d
00384             if (associated(locations(ipart,i)%vector)) &
00385                Deallocate (locations(ipart,i)%vector)
00386             if (associated(found    (ipart,i)%vector)) &
00387                Deallocate (found    (ipart,i)%vector)
00388          end do
00389       end do
00390 !
00391       Deallocate (field_list)
00392 !
00393 !===> All done
00394 !
00395 #ifdef VERBOSE
00396       print 9980, trim(ch_id), grid_id, search%sender, ierror
00397 
00398       call psmile_flushstd
00399 #endif /* VERBOSE */
00400 !
00401       return
00402 !
00403 !  Formats:
00404 !
00405 9990 format (1x, a, ': psmile_search_donor_cells: comp_id =', i3, &
00406                     '; sender =', i4)
00407 9980 format (1x, a, ': psmile_search_donor_cells: comp_id =', i3, &
00408                     '; eof sender =', i3, ', ierror =', i4)
00409 9970 format (1x, a, ': psmile_search_donor_cells: eof comp_id =', i3, &
00410                     '; intended return after call to gridless, sender =', i3, &
00411                     ', ierror =', i4)
00412 
00413       end subroutine PSMILe_Search_donor_cells