psmile_search_donor_cells.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_Search_donor_cells
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_search_donor_cells (search, tol, ierror)
00012 !
00013 ! !USES:
00014 !
00015       use PRISM_constants
00016       use PSMILe, dummy_interface => PSMILe_Search_donor_cells
00017 #ifdef DEBUG_TRACE
00018       use psmile_debug_trace
00019 #endif
00020 
00021       implicit none
00022 !
00023 ! !INPUT PARAMETERS:
00024 !
00025 !     Integer, Intent (In)                :: tag
00026 !
00027 !     Specifies the message tag used
00028 
00029       Double Precision, Intent (In)       :: tol
00030 
00031 !     Absolute tolerance for search of "identical" points
00032 !     TOL >= 0.0
00033 
00034 !
00035 ! !INPUT/OUTPUT PARAMETERS:
00036 !
00037       Type (Enddef_search), Intent (InOut) :: search
00038 
00039 !     Data on the points to be searched
00040 !
00041 ! !OUTPUT PARAMETERS:
00042 !
00043       Integer,              Intent (Out)   :: ierror
00044 
00045 !     Returns the error code of PSMILe_Search_donor_cells;
00046 !             ierror = 0 : No error
00047 !             ierror > 0 : Severe error
00048 !
00049 ! !LOCAL VARIABLES
00050 !
00051       Integer                      :: i
00052       Real                         :: rtol
00053 #if defined ( PRISM_QUAD_TYPE )
00054       Real (kind=PRISM_QUAD_TYPE)  :: qtol
00055 #endif
00056 !
00057 !     ... for grids and components
00058 !
00059 ! comp_id = Component Id of the component in which the donor cells
00060 !           should be searched.
00061 !
00062       Integer                      :: comp_id
00063       Integer                      :: grid_id
00064       Integer                      :: icomp, nlev1
00065       Integer                      :: datatype
00066 !
00067 !     ... for fields
00068 !
00069       Integer                      :: var_id, n_vars
00070 !
00071       Integer, Allocatable         :: field_list (:, :)
00072 !
00073 !     ... methods searched
00074 !
00075       Integer                      :: method_id
00076 !
00077 !     ... for intersections
00078 !
00079       Integer                      :: ipart, npart
00080       Integer                      :: len  (search%npart, ndim_3d)
00081 !
00082 !     ... locations searched
00083 !
00084       Integer                      :: save_range(2, ndim_3d, search%npart)
00085       Integer                      :: save_shape(2, ndim_3d, search%npart)
00086 
00087       Integer                      :: n_vec
00088       Type (integer_vector)        :: found     (search%npart, ndim_3d)
00089       Type (integer_vector)        :: locations (search%npart, ndim_3d)
00090 !
00091 !     ... for communication
00092 !
00093       Integer                      :: status (MPI_STATUS_SIZE)
00094 !
00095 !     ... for error parameters
00096 !
00097       Integer, parameter           :: nerrp = 2
00098       Integer                      :: ierrp (nerrp)
00099 !
00100 #ifdef TIMING
00101 !  ... for timing prism_enddef
00102 !      
00103       DOUBLE PRECISION            :: tic, toc 
00104 #endif                        
00105 !
00106 ! !DESCRIPTION:
00107 !
00108 ! Subroutine "PSMILe_Search_donor_cells" searches the donor cells
00109 ! for the subgrid sent by the sending process.
00110 !
00111 !
00112 ! !REVISION HISTORY:
00113 !
00114 !   Date      Programmer   Description
00115 ! ----------  ----------   -----------
00116 ! 03.07.21    H. Ritzdorf  created
00117 !
00118 !EOP
00119 !----------------------------------------------------------------------
00120 !
00121 ! $Id: psmile_search_donor_cells.F90 2936 2011-02-03 09:36:47Z hanke $
00122 ! $Author: hanke $
00123 !
00124    Character(len=len_cvs_string), save :: mycvs = 
00125        '$Id: psmile_search_donor_cells.F90 2936 2011-02-03 09:36:47Z hanke $'
00126 !
00127 !----------------------------------------------------------------------
00128 !
00129 !  Initialization
00130 !
00131       comp_id = search%msg_intersections%src_comp_id
00132 #ifdef VERBOSE
00133       print 9990, trim(ch_id), comp_id, search%sender
00134 
00135       call psmile_flushstd
00136 #endif /* VERBOSE */
00137 
00138       rtol = tol
00139 
00140 #if defined ( PRISM_QUAD_TYPE )
00141       qtol = tol
00142 #endif
00143 
00144 #ifdef DEBUG_TRACE
00145 !     Target index of the point to be searched which should be traced
00146       ictl_ind (:) =  (/48, 6, 1/)
00147 #endif
00148 
00149 #ifdef PRISM_ASSERTION
00150 !
00151 !===> Internal control
00152 !
00153       if (comp_id < 1 .or. &
00154           comp_id > Number_of_Comps_allocated .or. &
00155           Comps(comp_id)%status /= PSMILe_status_defined) then
00156 
00157           print *, trim(ch_id), "comp id =",           &
00158                    comp_id, Number_of_Comps_allocated, &
00159                    Comps(comp_id)%status
00160           call psmile_assert ( __FILE__, __LINE__, &
00161                               'invalid comp id')
00162       endif
00163 #endif
00164 
00165 !     Search comp_id in comp_infos
00166 
00167       do icomp = 1, n_act_comp
00168          if (comp_infos(icomp)%comp_id == comp_id) exit
00169       enddo
00170 
00171       if (icomp > n_act_comp) then
00172          ierror = PRISM_Error_internal
00173          ierrp (1) = comp_id
00174          ierrp (2) = n_act_comp
00175 
00176          call psmile_error ( ierror, &
00177                             'Cannot found comp_id in active components', &
00178                              ierrp, 2, __FILE__, __LINE__ )
00179          return
00180       endif
00181 !
00182 !===> Receive info on additional fields if necessary
00183 !
00184       n_vars = search%msg_intersections%num_vars - 1
00185 !
00186       if (n_vars > 0) then
00187          Allocate (field_list (nd_field_list, n_vars), STAT = ierror)
00188          if ( ierror > 0 ) then
00189             ierrp (1) = ierror
00190             ierrp (2) = nd_field_list * n_vars
00191             ierror = PRISM_Error_Alloc
00192             call psmile_error ( ierror, 'field_list', &
00193                                 ierrp, 2, __FILE__, __LINE__ )
00194             return
00195          endif
00196 !
00197 !        print *, 'n_vars', n_vars, nd_field_list*n_vars
00198 !
00199          call MPI_Recv (field_list, nd_field_list*n_vars, MPI_INTEGER,  &
00200                         search%sender, vartag, comm_psmile, &
00201                         status, ierror)
00202          if ( ierror /= MPI_SUCCESS ) then
00203             ierrp (1) = ierror
00204             ierror = PRISM_Error_MPI
00205 
00206             call psmile_error ( ierror, 'MPI_Recv', &
00207                                 ierrp, 1, __FILE__, __LINE__ )
00208             return
00209          endif
00210 
00211       else  ! no additional field, but dummy allocation for argument list in
00212             ! calling subroutines (avoid to pass a non-allocated array)
00213          Allocate (field_list (1,1), STAT = ierror)
00214 
00215       endif
00216 !
00217 !===> Search corresponding field with global transout id "id_transout" for
00218 !     this component "comp_id" and grid "grid_id"
00219 !
00220       call psmile_find_corr_field (comp_infos(icomp), search, &
00221                                    var_id, ierror)
00222       if (ierror > 0) return
00223 !
00224 !===> Special case: Gridless grid
00225 !
00226       method_id = Fields(var_id)%method_id
00227       grid_id = Methods(method_id)%grid_id
00228 !
00229       if (Grids(grid_id)%grid_type == PRISM_Gridless) then
00230          call psmile_search_donor_gridless (comp_infos(icomp), search, &
00231                                     field_list, n_vars,                &
00232                                     grid_id, method_id, var_id, ierror)
00233 #ifdef VERBOSE
00234          print 9970, trim(ch_id), grid_id, search%sender, ierror
00235 
00236          call psmile_flushstd
00237 #endif /* VERBOSE */
00238 
00239          Deallocate (field_list)    ! always allocated
00240          return
00241 
00242       endif
00243 !
00244 !===> Transform locations to be searched
00245 !     Is required only once per method.
00246 !
00247       call psmile_transform_coords (comp_infos(icomp), search, ierror)
00248       if (ierror > 0) return
00249 !
00250 ! =======================================================================
00251 !     Search locations
00252 !     (i)  Allocate and initalize found and locations vectors
00253 !     (ii) Search with specific routine
00254 ! =======================================================================
00255 !
00256       datatype  = Grids(grid_id)%corner_pointer%corner_datatype
00257 !
00258       npart = search%npart
00259       nlev1 = - (Grids(grid_id)%nlev + 1) ! Outside
00260 !
00261       select case ( Grids(grid_id)%grid_type )
00262 
00263 ! -----------------------------------------------------------------------
00264 !      Regular in all directions
00265 ! -----------------------------------------------------------------------
00266 !    len (ipart, i) = Length of last dimension of vectors
00267 !                     found (ipart,i) and locations (ipart,i)
00268 !                   = Number of coordinates to be searched in each direction
00269 !
00270       case (PRISM_Reglonlatvrt)
00271 !
00272 !     Allocate found and location array and initialize arrays
00273 !     1 vector for each direction of the source grid
00274 !
00275          n_vec = ndim_3d
00276 !
00277          if (search%grid_type == PRISM_Irrlonlatvrt) then
00278                do ipart = 1, npart
00279                len (ipart,1) = (search%range (2,1,ipart) -      &
00280                                 search%range (1,1,ipart) + 1) * &
00281                                (search%range (2,2,ipart) -      &
00282                                 search%range (1,2,ipart) + 1) * &
00283                                (search%range (2,3,ipart) -      &
00284                                 search%range (1,3,ipart) + 1)
00285                end do
00286 !
00287             len(:,2) = len (:, 1)
00288             len(:,3) = len (:, 1)
00289 !
00290          else if (search%grid_type == PRISM_Irrlonlat_Regvrt) then
00291                do ipart = 1, npart
00292                len(ipart,1) = (search%range (2,1,ipart) -      &
00293                                search%range (1,1,ipart) + 1) * &
00294                               (search%range (2,2,ipart) -      &
00295                                search%range (1,2,ipart) + 1)
00296                len(ipart,3) = (search%range (2,3,ipart) -      &
00297                                search%range (1,3,ipart) + 1)
00298                end do
00299 !
00300             len(:,2) = len(:, 1)
00301 !
00302          else if (search%grid_type == PRISM_Reglonlatvrt) then
00303                do ipart = 1, npart
00304                len(ipart,1) = (search%range (2,1,ipart) -      &
00305                                search%range (1,1,ipart) + 1)
00306                len(ipart,2) = (search%range (2,2,ipart) -      &
00307                                search%range (1,2,ipart) + 1)
00308                len(ipart,3) = (search%range (2,3,ipart) -      &
00309                                search%range (1,3,ipart) + 1)
00310                end do
00311 
00312          else if (search%grid_type == PRISM_Gaussreduced_regvrt) then
00313                do ipart = 1, npart
00314                len(ipart,1) = (search%range (2,1,ipart) -      &
00315                                search%range (1,1,ipart) + 1) * &
00316                               (search%range (2,2,ipart) -      &
00317                                search%range (1,2,ipart) + 1)
00318                len(ipart,3) = (search%range (2,3,ipart) -      &
00319                                search%range (1,3,ipart) + 1)
00320                end do
00321 
00322                if ( search%msg_intersections%requires_conserv_remap == PSMILe_conserv2D ) &
00323                   len(:,1) = 2 * len(:,1)
00324 
00325 
00326             len(:,2) = len(:,1)
00327 !
00328          else
00329 !
00330             ierrp (1) = Grids(grid_id)%grid_type
00331             ierror = PRISM_Error_Internal
00332 
00333             call psmile_error ( ierror, 'unsupported grid generation type', &
00334                                 ierrp, 1, __FILE__, __LINE__ )
00335          endif
00336 !
00337             do ipart = 1, npart
00338 
00339                do i = 1, n_vec
00340                Allocate (found(ipart,i)%vector(len(ipart,i)), STAT = ierror)
00341                if ( ierror > 0 ) then
00342                   ierrp (1) = ierror
00343                   ierrp (2) = len (ipart, i)
00344                   ierror = PRISM_Error_Alloc
00345                   call psmile_error ( ierror, 'found(ipart,i)%vector', &
00346                                       ierrp, 2, __FILE__, __LINE__ )
00347                   return
00348                endif
00349 
00350                Allocate (locations(ipart,i)%vector(len(ipart,i)), &
00351                          STAT = ierror)
00352                if ( ierror > 0 ) then
00353                   ierrp (1) = ierror
00354                   ierrp (2) = len (ipart, i)
00355                   ierror = PRISM_Error_Alloc
00356                   call psmile_error ( ierror, 'locations(ipart,i)%vector', &
00357                                       ierrp, 2, __FILE__, __LINE__ )
00358                   return
00359                endif
00360                end do
00361 
00362             end do ! ipart
00363 
00364             do ipart = 1, npart
00365                do i = 1, n_vec
00366                found    (ipart,i)%vector (:) = nlev1
00367                locations(ipart,i)%vector (:) = 0
00368                end do
00369             end do ! ipart
00370 !
00371 !===> Search locations separately in all 3 directions
00372 !
00373          if (datatype == MPI_REAL) then
00374 
00375             do ipart = 1, npart
00376                do i = 1, ndim_3d
00377                call psmile_search_donor_1d_real (grid_id, i,    &
00378                            found(ipart,i)%vector,               &
00379                            locations(ipart,i)%vector,           &
00380                            search%search_real(i, ipart)%vector, &
00381                            search%dims(i, ipart), rtol, ierror)
00382                if (ierror > 0) return
00383                end do
00384             end do ! ipart
00385 
00386             call psmile_search_donor_3d_reg_real (comp_infos(icomp),       &
00387                         found, locations, len, search, field_list, n_vars, &
00388                         grid_id, method_id, var_id, rtol, ierror)
00389             if (ierror > 0) return
00390 
00391          else if (datatype == MPI_DOUBLE_PRECISION) then
00392 
00393             do ipart = 1, npart
00394                do i = 1, ndim_3d
00395                call psmile_search_donor_1d_dble (grid_id, i,    &
00396                            found(ipart,i)%vector,               &
00397                            locations(ipart,i)%vector,           &
00398                            search%search_dble(i, ipart)%vector, &
00399                            search%dims(i, ipart), tol, ierror)
00400                if (ierror > 0) return
00401                end do
00402             end do ! ipart
00403 
00404             call psmile_search_donor_3d_reg_dble (comp_infos(icomp),       &
00405                         found, locations, len, search, field_list, n_vars, &
00406                         grid_id, method_id, var_id, tol, ierror)
00407             if (ierror > 0) return
00408 
00409 #if defined ( PRISM_QUAD_TYPE )
00410          else if (datatype == MPI_REAL16) then
00411 
00412             do ipart = 1, npart
00413                do i = 1, ndim_3d
00414                call psmile_search_donor_1d_quad (grid_id, i,    &
00415                            found(ipart,i)%vector,               &
00416                            locations(ipart,i)%vector,           &
00417                            search%search_quad(i, ipart)%vector, &
00418                            search%dims(i, ipart), qtol, ierror)
00419                if (ierror > 0) return
00420                end do
00421             end do ! ipart
00422 
00423             call psmile_search_donor_3d_reg_quad (comp_infos(icomp),       &
00424                         found, locations, len, search, field_list, n_vars, &
00425                         grid_id, method_id, var_id, qtol, ierror)
00426             if (ierror > 0) return
00427 #endif
00428          endif
00429 !
00430 ! -----------------------------------------------------------------------
00431 !    Irregular in lonlat   direction
00432 !      Regular in vertical direction
00433 ! -----------------------------------------------------------------------
00434 !    len (ipart, i) = Length of last dimension of vectors
00435 !                     found (ipart,i) and locations (ipart,i)
00436 !                   = Number of coordinates to be searched with
00437 !                     len (ipart, 1) = Number in lonlat direction
00438 !                     len (ipart, 2) = Number in z      direction
00439 !
00440       case (PRISM_Irrlonlat_regvrt)
00441 !
00442 !     Allocate found and location array and initialize arrays
00443 !     2 vectors for lonlat and z direction of the source grid
00444 
00445          n_vec = 2
00446 !
00447          if (search%grid_type == PRISM_Irrlonlatvrt) then
00448                do ipart = 1, npart
00449                len (ipart,1) = (search%range (2,1,ipart) -      &
00450                                 search%range (1,1,ipart) + 1) * &
00451                                (search%range (2,2,ipart) -      &
00452                                 search%range (1,2,ipart) + 1) * &
00453                                (search%range (2,3,ipart) -      &
00454                                 search%range (1,3,ipart) + 1)
00455                end do
00456 !
00457             len(:,2) = len (:, 1)
00458 
00459          else if (search%grid_type == PRISM_Gaussreduced_regvrt) then
00460 
00461 ! For Gauss grids the search range needs to be extended so that we also
00462 ! get locations for the maximum corners.
00463 
00464             do ipart = 1, npart
00465                len(ipart,1) = (search%range (2,1,ipart) -      &
00466                                search%range (1,1,ipart) + 1) * &
00467                               (search%range (2,2,ipart) -      &
00468                                search%range (1,2,ipart) + 1)
00469                len(ipart,2) = (search%range (2,3,ipart) -      &
00470                                search%range (1,3,ipart) + 1)
00471             end do
00472 
00473             if ( search%msg_intersections%requires_conserv_remap == PSMILe_conserv2D ) &
00474                len(:,1) = 2 * len(:,1)
00475 !
00476 ! For parallel search for Gauss-red target grids we reset
00477 ! to the original shape and range to continue with point
00478 ! based search.
00479 !
00480             if ( search%msg_intersections%requires_conserv_remap == PSMILe_conserv2D .or. &
00481                  search%msg_intersections%requires_conserv_remap == PSMILe_conserv3D ) then
00482 
00483                save_range = search%range
00484                save_shape = search%shape
00485 
00486                search%range(2, 1, 1:npart) = save_range (1, 1, 1:npart) + &
00487                                        2 * ( save_range (2, 1, 1:npart)   &
00488                                            - save_range (1, 1, 1:npart) + 1 ) - 1
00489 
00490                search%shape(2, 1, 1:npart) = save_shape (1, 1, 1:npart) + &
00491                                        2 * ( save_shape (2, 1, 1:npart)   &
00492                                            - save_shape (1, 1, 1:npart) + 1 ) - 1
00493             endif
00494 
00495          else
00496                do ipart = 1, npart
00497                len(ipart,1) = (search%range (2,1,ipart) -      &
00498                                search%range (1,1,ipart) + 1) * &
00499                               (search%range (2,2,ipart) -      &
00500                                search%range (1,2,ipart) + 1)
00501                len(ipart,2) = (search%range (2,3,ipart) -      &
00502                                search%range (1,3,ipart) + 1)
00503                end do
00504          endif
00505 !
00506             do ipart = 1, npart
00507             Allocate (found(ipart,1)%vector(len(ipart,1)), STAT = ierror)
00508             if ( ierror > 0 ) then
00509                ierrp (1) = ierror
00510                ierrp (2) = len(ipart, 1)
00511                ierror = PRISM_Error_Alloc
00512                call psmile_error ( ierror, 'found(ipart,1)%vector', &
00513                                    ierrp, 2, __FILE__, __LINE__ )
00514                return
00515             endif
00516 
00517             Allocate (locations(ipart,1)%vector(ndim_2d*len(ipart,1)), &
00518                       STAT = ierror)
00519             if ( ierror > 0 ) then
00520                ierrp (1) = ierror
00521                ierrp (2) = ndim_2d * len(ipart,1)
00522                ierror = PRISM_Error_Alloc
00523                call psmile_error ( ierror, 'locations(ipart,1)%vector', &
00524                                    ierrp, 2, __FILE__, __LINE__ )
00525                return
00526             endif
00527 
00528             Allocate (found(ipart,2)%vector(len(ipart,2)), STAT = ierror)
00529             if ( ierror > 0 ) then
00530                ierrp (1) = ierror
00531                ierrp (2) = len (ipart,2)
00532                ierror = PRISM_Error_Alloc
00533                call psmile_error ( ierror, 'found(ipart,2)%vector', &
00534                                    ierrp, 2, __FILE__, __LINE__ )
00535                return
00536             endif
00537 
00538             Allocate (locations(ipart,2)%vector(len(ipart,2)), STAT = ierror)
00539             if ( ierror > 0 ) then
00540                ierrp (1) = ierror
00541                ierrp (2) = len (ipart,2)
00542                ierror = PRISM_Error_Alloc
00543                call psmile_error ( ierror, 'locations(ipart,2)%vector', &
00544                                    ierrp, 2, __FILE__, __LINE__ )
00545                return
00546             endif
00547             end do ! ipart
00548 
00549             do ipart = 1, npart
00550             found    (ipart,1)%vector (:) = nlev1
00551             found    (ipart,2)%vector (:) = nlev1
00552 !
00553             locations(ipart,1)%vector (:) = 0
00554             locations(ipart,2)%vector (:) = 0
00555             end do ! ipart
00556 !
00557 !
00558 !
00559          if (datatype == MPI_REAL) then
00560 
00561             do ipart = 1, npart
00562             call psmile_search_donor_2d_real (                    &
00563                         found    (ipart,1)%vector,                &
00564                         locations(ipart,1)%vector,                &
00565                         len      (ipart,1), search, ipart,        &
00566                         grid_id, method_id, var_id, rtol, ierror)
00567             if (ierror > 0) return
00568 
00569             call psmile_search_donor_1d_real (grid_id, 3,    &
00570                         found    (ipart,2)%vector,           &
00571                         locations(ipart,2)%vector,           &
00572                         search%search_real(3, ipart)%vector, &
00573                         search%dims(3, ipart), rtol, ierror)
00574             if (ierror > 0) return
00575             end do
00576 
00577             call psmile_search_donor_irreg2_real (comp_infos(icomp),   &
00578                         found(:, 1:n_vec), locations(:, 1:n_vec),      &
00579                         len  (:, 1:n_vec),                             &
00580                         search, field_list, n_vars,                    &
00581                         grid_id, method_id, var_id, rtol, ierror)
00582             if (ierror > 0) return
00583 
00584          else if (datatype == MPI_DOUBLE_PRECISION) then
00585 
00586             do ipart = 1, npart
00587             call psmile_search_donor_2d_dble (                            &
00588                         found(ipart,1)%vector, locations(ipart,1)%vector, &
00589                         len  (ipart,1), search, ipart,                    &
00590                         grid_id, method_id, var_id, tol, ierror)
00591             if (ierror > 0) return
00592 
00593             call psmile_search_donor_1d_dble (grid_id, 3,                 &
00594                         found(ipart,2)%vector, locations(ipart,2)%vector, &
00595                         search%search_dble(3, ipart)%vector,              &
00596                         search%dims(3, ipart), tol, ierror)
00597             if (ierror > 0) return
00598             end do
00599 
00600             call psmile_search_donor_irreg2_dble (comp_infos(icomp),   &
00601                         found(:, 1:n_vec), locations(:, 1:n_vec),      &
00602                         len  (:, 1:n_vec),                             &
00603                         search, field_list, n_vars, &
00604                         grid_id, method_id, var_id, tol, ierror)
00605             if (ierror > 0) return
00606 
00607 #if defined ( PRISM_QUAD_TYPE )
00608          else if (datatype == MPI_REAL16) then
00609 
00610             do ipart = 1, npart
00611             call psmile_search_donor_2d_quad (                            &
00612                         found(ipart,1)%vector, locations(ipart,1)%vector, &
00613                         len  (ipart,1), search,                           &
00614                         grid_id, method_id, var_id, qtol, ierror)
00615             if (ierror > 0) return
00616 
00617             call psmile_search_donor_1d_quad (grid_id, 3,                 &
00618                         found(ipart,2)%vector, locations(ipart,2)%vector, &
00619                         search%search_dble(3)%vector,                     &
00620                         search%dims(3, ipart), qtol, ierror)
00621             if (ierror > 0) return
00622             end do
00623 
00624             call psmile_search_donor_irreg2_quad (comp_infos(icomp),   &
00625                         found(:, 1:n_vec), locations(:, 1:n_vec),      &
00626                         len  (:, 1:n_vec),                             &
00627                         search, field_list, n_vars, &
00628                         grid_id, method_id, var_id, qtol, ierror)
00629             if (ierror > 0) return
00630 #endif
00631          endif
00632 !
00633 ! For parallel search for Gauss-red target grids we need to store
00634 ! the original range and shape. The shape and range is extended
00635 ! (doubled) to be able to store also locations on the maximum corners.
00636 ! The origianl shape and range cannot be reconstructed otherwise.
00637 !
00638          if ( search%msg_intersections%requires_conserv_remap == PSMILe_conserv2D .or. &
00639               search%msg_intersections%requires_conserv_remap == PSMILe_conserv3D ) then
00640 
00641              search%range = save_range
00642              search%shape = save_shape
00643 
00644          endif
00645 !
00646 ! -----------------------------------------------------------------------
00647 !       Irregular in lonlat   and vertical direction
00648 ! -----------------------------------------------------------------------
00649 !    len (ipart, i) = Length of last dimension of vectors
00650 !                     found (ipart,i) and locations (ipart,i)
00651 !                   = Number of coordinates to be searched
00652 !
00653       case (PRISM_Irrlonlatvrt)
00654 
00655 !     Allocate found and location array and initialize arrays
00656 !     1 vector for all directions
00657 !
00658          n_vec = 1
00659 
00660             do ipart = 1, npart
00661             len(ipart,1) = (search%range (2,1,ipart) -      &
00662                             search%range (1,1,ipart) + 1) * &
00663                            (search%range (2,2,ipart) -      &
00664                             search%range (1,2,ipart) + 1) * &
00665                            (search%range (2,3,ipart) -      &
00666                             search%range (1,3,ipart) + 1)
00667             end do
00668 
00669             do ipart = 1, npart
00670             Allocate (found(ipart,1)%vector(len(ipart,1)), STAT = ierror)
00671             if ( ierror > 0 ) then
00672                ierrp (1) = ierror
00673                ierrp (2) = len (ipart,1)
00674                ierror = PRISM_Error_Alloc
00675                call psmile_error ( ierror, 'found(ipart,1)%vector', &
00676                                    ierrp, 2, __FILE__, __LINE__ )
00677                return
00678             endif
00679 
00680             Allocate (locations(ipart,1)%vector(ndim_3d*len(ipart,1)), &
00681                       STAT = ierror)
00682             if ( ierror > 0 ) then
00683                ierrp (1) = ierror
00684                ierrp (2) = ndim_3d*len(ipart,1)
00685                ierror = PRISM_Error_Alloc
00686                call psmile_error ( ierror, 'found(ipart,1)%vector', &
00687                                    ierrp, 2, __FILE__, __LINE__ )
00688                return
00689             endif
00690             end do ! ipart
00691 
00692             do ipart = 1, npart
00693             found    (ipart,1)%vector (:) = nlev1
00694             locations(ipart,1)%vector (:) = 0
00695             end do ! ipart
00696 !
00697 !
00698 !
00699          if (datatype == MPI_REAL) then
00700 
00701             call psmile_search_donor_3d_real (comp_infos(icomp), &
00702                         found(:, 1), locations (:, 1),           &
00703                         len  (:, 1), search, field_list, n_vars, &
00704                         grid_id, method_id, var_id, rtol, ierror)
00705             if (ierror > 0) return
00706 
00707          else if (datatype == MPI_DOUBLE_PRECISION) then
00708 
00709             call psmile_search_donor_3d_dble (comp_infos(icomp),   &
00710                         found(:, 1), locations (:, 1),             &
00711                         len  (:, 1), search, field_list, n_vars,   &
00712                         grid_id, method_id, var_id, tol, ierror)
00713             if (ierror > 0) return
00714 
00715 #if defined ( PRISM_QUAD_TYPE )
00716          else if (datatype == MPI_REAL16) then
00717 
00718             call psmile_search_donor_3d_quad (comp_infos(icomp), &
00719                         found(:, 1), locations (:, 1),           &
00720                         len  (:, 1), search, field_list, n_vars, &
00721                         grid_id, method_id, var_id, qtol, ierror)
00722             if (ierror > 0) return
00723 #endif
00724          endif
00725 !
00726 ! -----------------------------------------------------------------------
00727 !    Gauss reduced in lonlat direction
00728 !      Regular in vertical direction
00729 ! -----------------------------------------------------------------------
00730 !    len (ipart, i) = Length of last dimension of vectors
00731 !                     found (ipart,i) and locations (ipart,i)
00732 !                   = Number of coordinates to be searched with
00733 !                     len (ipart, 1) = Number in lonlat direction
00734 !                     len (ipart, 2) = Number in z      direction
00735 !
00736       case (PRISM_Gaussreduced_regvrt)
00737 !
00738 !     Allocate found and location array and initialize arrays
00739 !     2 vectors for lonlat and z direction of the source grid
00740 
00741          n_vec = ndim_3d
00742 !
00743          if (search%grid_type == PRISM_Irrlonlatvrt) then
00744 !
00745                do ipart = 1, npart
00746                len (ipart,1) = (search%range (2,1,ipart) -      &
00747                                 search%range (1,1,ipart) + 1) * &
00748                                (search%range (2,2,ipart) -      &
00749                                 search%range (1,2,ipart) + 1) * &
00750                                (search%range (2,3,ipart) -      &
00751                                 search%range (1,3,ipart) + 1)
00752                end do
00753 !
00754             len(:,2) = len (:, 1)
00755             len(:,3) = len (:, 1)
00756 !
00757          else if (search%grid_type == PRISM_Irrlonlat_Regvrt) then
00758 !
00759                do ipart = 1, npart
00760                len(ipart,1) = (search%range (2,1,ipart) -      &
00761                                search%range (1,1,ipart) + 1) * &
00762                               (search%range (2,2,ipart) -      &
00763                                search%range (1,2,ipart) + 1)
00764                len(ipart,3) = (search%range (2,3,ipart) -      &
00765                                search%range (1,3,ipart) + 1)
00766                end do
00767 !
00768             len(:,2) = len(:, 1)
00769 !
00770          else if (search%grid_type == PRISM_Reglonlatvrt) then
00771 !
00772                do ipart = 1, npart
00773                len(ipart,1) = (search%range (2,1,ipart) -      &
00774                                search%range (1,1,ipart) + 1)
00775                len(ipart,2) = (search%range (2,2,ipart) -      &
00776                                search%range (1,2,ipart) + 1)
00777                len(ipart,3) = (search%range (2,3,ipart) -      &
00778                                search%range (1,3,ipart) + 1)
00779                end do
00780 
00781          else if (search%grid_type == PRISM_Gaussreduced_regvrt) then
00782 !
00783                do ipart = 1, npart
00784                len(ipart,1) = (search%range (2,1,ipart) -      &
00785                                search%range (1,1,ipart) + 1) * &
00786                               (search%range (2,2,ipart) -      &
00787                                search%range (1,2,ipart) + 1)
00788                len(ipart,3) = (search%range (2,3,ipart) -      &
00789                                search%range (1,3,ipart) + 1)
00790                end do
00791 
00792             len(:,2) = len(:, 1)
00793 !
00794          else
00795 !
00796             ierrp (1) = Grids(grid_id)%grid_type
00797             ierror = PRISM_Error_Internal
00798 
00799             call psmile_error ( ierror, 'unsupported grid generation type', &
00800                                 ierrp, 1, __FILE__, __LINE__ )
00801          endif
00802 !
00803             do ipart = 1, npart
00804 
00805                do i = 1, n_vec
00806                Allocate (found(ipart,i)%vector(len(ipart,i)), STAT = ierror)
00807                if ( ierror > 0 ) then
00808                   ierrp (1) = ierror
00809                   ierrp (2) = len (ipart, i)
00810                   ierror = PRISM_Error_Alloc
00811                   call psmile_error ( ierror, 'found(ipart,i)%vector', &
00812                                       ierrp, 2, __FILE__, __LINE__ )
00813                   return
00814                endif
00815 
00816                Allocate (locations(ipart,i)%vector(len(ipart,i)), &
00817                          STAT = ierror)
00818                if ( ierror > 0 ) then
00819                   ierrp (1) = ierror
00820                   ierrp (2) = len (ipart, i)
00821                   ierror = PRISM_Error_Alloc
00822                   call psmile_error ( ierror, 'locations(ipart,i)%vector', &
00823                                       ierrp, 2, __FILE__, __LINE__ )
00824                   return
00825                endif
00826                end do
00827 
00828             end do ! ipart
00829 
00830             do ipart = 1, npart
00831                do i = 1, n_vec
00832                found    (ipart,i)%vector (:) = nlev1
00833                locations(ipart,i)%vector (:) = 0
00834                end do
00835             end do ! ipart
00836 !
00837 !===> Search locations separately in all 3 directions
00838 !
00839          if (datatype == MPI_REAL) then
00840 
00841             do ipart = 1, npart
00842                do i = 1, ndim_3d
00843                call psmile_search_donor_1d_real (grid_id, i,    &
00844                            found(ipart,i)%vector,               &
00845                            locations(ipart,i)%vector,           &
00846                            search%search_real(i, ipart)%vector, &
00847                            search%dims(i, ipart), rtol, ierror)
00848                if (ierror > 0) return
00849                end do
00850             end do ! ipart
00851 
00852             call psmile_search_donor_gauss2_real (comp_infos(icomp),       &
00853                         found, locations, len, search, field_list, n_vars, &
00854                         grid_id, method_id, var_id, rtol, ierror)
00855             if (ierror > 0) return
00856 
00857          else if (datatype == MPI_DOUBLE_PRECISION) then
00858 
00859 #ifdef TIMING
00860             tic=MPI_Wtime()
00861 #endif             
00862             do ipart = 1, npart
00863 
00864                do i = 1, ndim_3d
00865                call psmile_search_donor_1d_dble (grid_id, i,    &
00866                            found(ipart,i)%vector,               &
00867                            locations(ipart,i)%vector,           &
00868                            search%search_dble(i, ipart)%vector, &
00869                            search%dims(i, ipart), tol, ierror)
00870 
00871                call psmile_flushstd
00872                if (ierror > 0) return
00873                end do
00874             end do ! ipart
00875 #ifdef TIMING
00876             toc=MPI_Wtime()
00877             print *, trim(ch_id), 'Time PSMILE_search_donor_1d_dble ', toc-tic
00878 #endif
00879 
00880 #ifdef TIMING
00881             tic=MPI_Wtime()
00882 #endif 
00883             call psmile_search_donor_gauss2_dble (comp_infos(icomp),       &
00884                         found, locations, len, search, field_list, n_vars, &
00885                         grid_id, method_id, var_id, tol, ierror)
00886             if (ierror > 0) return
00887 
00888 #ifdef TIMING
00889             toc=MPI_Wtime()
00890             print *, trim(ch_id), 'Time PSMILE_search_donor_gauss2_dble ', toc-tic
00891 #endif
00892 
00893 #if defined ( PRISM_QUAD_TYPE )
00894          else if (datatype == MPI_REAL16) then
00895 
00896             do ipart = 1, npart
00897                do i = 1, ndim_3d
00898                call psmile_search_donor_1d_quad (grid_id, i,          &
00899                            found(ipart,i)%vector,                     &
00900                            locations(ipart,i)%vector,                 &
00901                            search%search_quad(i, ipart)%vector,       &
00902                            search%dims(i, ipart), qtol, ierror)
00903                if (ierror > 0) return
00904                end do
00905             end do !ipart
00906 
00907             call psmile_search_donor_gauss2_quad (comp_infos(icomp),  &
00908                         found, locations, len, search, field_list, n_vars, &
00909                         grid_id, method_id, var_id, tol, ierror)
00910             if (ierror > 0) return
00911 #endif
00912          endif
00913 !
00914 ! -----------------------------------------------------------------------
00915 !        Error: unsupported grid type
00916 ! -----------------------------------------------------------------------
00917 !
00918       case DEFAULT
00919 !
00920           ierrp (1) = Grids(grid_id)%grid_type
00921           ierror = PRISM_Error_Internal
00922 
00923           call psmile_error ( ierror, 'unsupported grid generation type', &
00924                               ierrp, 1, __FILE__, __LINE__ )
00925       end select
00926 !
00927 !===> Free memory allocated
00928 !
00929          do ipart = 1, npart
00930             do i = 1, n_vec
00931             Deallocate (locations(ipart,i)%vector)
00932             Deallocate (found    (ipart,i)%vector)
00933             end do
00934          end do
00935 !
00936          Deallocate (field_list)
00937 !
00938 !===> All done
00939 !
00940 #ifdef VERBOSE
00941       print 9980, trim(ch_id), grid_id, search%sender, ierror
00942 
00943       call psmile_flushstd
00944 #endif /* VERBOSE */
00945 !
00946       return
00947 !
00948 !  Formats:
00949 !
00950 9990 format (1x, a, ': psmile_search_donor_cells: comp_id =', i3, &
00951                     '; sender =', i4)
00952 9980 format (1x, a, ': psmile_search_donor_cells: comp_id =', i3, &
00953                     '; eof sender =', i3, ', ierror =', i4)
00954 9970 format (1x, a, ': psmile_search_donor_cells: eof comp_id =', i3, &
00955                     '; intended return after call to gridless, sender =', i3, &
00956                     ', ierror =', i4)
00957 
00958       end subroutine PSMILe_Search_donor_cells