psmile_get_next_field.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_Get_next_field
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_get_next_field (comp_info, search, &
00012                         field_list, n_vars, n_vars_ret, var_id, ierror)
00013 !
00014 ! !USES:
00015 !
00016       use PRISM_constants
00017 !
00018       use PSMILe, dummy_interface => PSMILe_Get_next_field
00019 
00020       implicit none
00021 !
00022 ! !INPUT PARAMETERS:
00023 !
00024 !     Infos on the components (located on the actual process)
00025 !
00026       Type (Enddef_comp), Intent (In)       :: comp_info
00027 
00028 !     Info on the component in which the donor cells
00029 !     should be searched. ? Raus ?
00030 
00031       Type (Enddef_search), Intent (InOut)  :: search
00032 
00033 !     Info's on coordinates to be searched
00034 !
00035       Integer, Intent (In)                  :: n_vars
00036 !
00037 !     Number of additional fields to be searched for sending process
00038 !
00039       Integer, Intent (InOut)               :: n_vars_ret
00040 !
00041 !     Number of additional fields already returned.
00042 !
00043       Type (enddef_field_info), Intent (In) :: field_list (n_vars)
00044 !
00045 !     Info's on additional fields to be searched
00046 !
00047 ! !OUTPUT PARAMETERS:
00048 
00049       Integer, Intent (Out)                 :: var_id
00050 
00051 !     Returns the corresponding (source) field id to the target
00052 !     specified in search%msg_intersections.
00053 !
00054       Integer, Intent (Out)                 :: ierror
00055 
00056 !     Returns the error code of PSMILe_Get_next_field;
00057 !             ierror = 0 : No error
00058 !             ierror > 0 : Severe error
00059 !
00060 ! !DEFINED PARAMETERS
00061 !
00062       logical, parameter           :: new_search = .false.
00063 !
00064 ! !LOCAL VARIABLES
00065 !
00066 !  ... for intersections sent
00067 !
00068       Integer                      :: npart, n
00069 !
00070 !  ... for communication
00071 !
00072       Integer, Allocatable         :: recv_req (:)
00073       Integer                      :: save_lreq (2:3)
00074       Integer                      :: index
00075       Integer                      :: status (MPI_STATUS_SIZE)
00076 #ifndef PRISM_with_MPI2
00077       Integer, Allocatable         :: statuses (:, :)
00078 #endif
00079 !
00080 !     ... for error handling
00081 !
00082       Integer, parameter           :: nerrp = 3
00083       Integer                      :: ierrp (nerrp)
00084 !
00085 ! !DESCRIPTION:
00086 !
00087 ! Subroutine "PSMILe_Get_next_field" requests and receives the data
00088 ! on the next field from the target process. The request is fulfilled
00089 ! by the subroutine "PSMILe_Send_req_subgrid", the counterpart to this
00090 ! subroutine.
00091 !
00092 ! !REVISION HISTORY:
00093 !
00094 !   Date      Programmer   Description
00095 ! ----------  ----------   -----------
00096 ! 03.07.04    H. Ritzdorf  created
00097 !
00098 !EOP
00099 !----------------------------------------------------------------------
00100 !
00101 !  $Id: psmile_get_next_field.F90 3248 2011-06-23 13:03:19Z coquart $
00102 !  $Author: coquart $
00103 !
00104    Character(len=len_cvs_string), save :: mycvs = 
00105        '$Id: psmile_get_next_field.F90 3248 2011-06-23 13:03:19Z coquart $'
00106 !
00107 !----------------------------------------------------------------------
00108 !
00109 !  Initialization
00110 !
00111 #ifdef VERBOSE
00112       print 9990, trim(ch_id)
00113 
00114       call psmile_flushstd
00115 #endif /* VERBOSE */
00116 !
00117       ierror = 0
00118 !
00119       npart = search%search_data%npart
00120 !
00121       n_vars_ret = n_vars_ret + 1
00122 !
00123 !     Update method_id, var_id, mask_id, transient in and transient out
00124 !     TODO: Verzichte auf senden der maske, falls alte mask id == 
00125 !           Neue mask id
00126 !
00127 !     Something has to be done for Gauss-reduced here.
00128 !     search%search_data%grid_type == PRISM_Gaussreduced_regvrt
00129 !     Reduction by 1 is not sufficient!
00130 !
00131 #ifdef PRISM_ASSERTION
00132       if ( search%search_data%npart /= search%msg_intersections%num_parts ) then
00133          call psmile_assert ( __FILE__, __LINE__, &
00134                              ' search%search_data%npart /= search%msg_intersections%num_parts ')
00135       endif
00136 #endif
00137       if ( search%msg_intersections%field_info%requires_conserv_remap == PSMILe_conserv2D .and. &
00138            field_list (n_vars_ret)%requires_conserv_remap  /= PSMILe_conserv2D ) then
00139 #ifdef PRISM_ASSERTION
00140          if ( search%search_data%grid_type == PRISM_Gaussreduced_regvrt) then
00141             call psmile_assert ( __FILE__, __LINE__, &
00142               'Case is not yet supported for PRISM_Gaussreduced_regvrt.')
00143          endif
00144 #endif
00145          if ( search%search_data%grid_type /= PRISM_Gaussreduced_regvrt ) then
00146             do n = 1, npart
00147                search%msg_intersections%intersections(n)%intersection(2,1:2) = &
00148                   search%msg_intersections%intersections(n)%intersection(2,1:2) - 1
00149             enddo
00150          endif
00151 
00152       else if ( search%msg_intersections%field_info%requires_conserv_remap == PSMILe_conserv3D  .and. &
00153                 field_list (n_vars_ret)%requires_conserv_remap  /= PSMILe_conserv3D ) then
00154 #ifdef PRISM_ASSERTION
00155          if ( search%search_data%grid_type == PRISM_Gaussreduced_regvrt) then
00156             call psmile_assert ( __FILE__, __LINE__, &
00157               'Case is not yet supported for PRISM_Gaussreduced_regvrt.')
00158          endif
00159 #endif
00160          if ( search%search_data%grid_type /= PRISM_Gaussreduced_regvrt ) then
00161             do n = 1, npart
00162                search%msg_intersections%intersections(n)%intersection(2,:) = &
00163                   search%msg_intersections%intersections(n)%intersection(2,:) - 1
00164             enddo
00165          endif
00166 
00167       endif
00168 
00169       search%msg_intersections%field_info = field_list (n_vars_ret)
00170 !
00171 !===> Send request to send the data 
00172 !     Note: The destination process might be the same process
00173 !           (i.e. the send is not allowed to block).
00174 !           Todo: Optimize the special case sender == psmile_rank.
00175 !
00176       call psmile_pack_msg_intersections(search%msg_intersections, search%msgint)
00177 
00178       call psmile_bsend (search%msgint, nd_msgint, MPI_INTEGER, &
00179                          search%sender, reqtag, comm_psmile, ierror)
00180 
00181       if (ierror /= MPI_SUCCESS) then
00182          ierrp (1) = ierror
00183          ierrp (2) = search%sender
00184          ierrp (3) = reqtag
00185          ierror = PRISM_Error_Send
00186 
00187          call psmile_error (ierror, 'MPI_Send', &
00188                             ierrp, 3, __FILE__, __LINE__ )
00189          return
00190       endif
00191 !
00192 !===> Set up receive the subgrid sent by process sender
00193 !
00194       Allocate (recv_req ((ndim_3d+2)*npart), stat = ierror)
00195       if ( ierror /= 0 ) then
00196          ierrp (1) = (ndim_3d+1) * npart
00197          ierror = PRISM_Error_Alloc
00198          call psmile_error ( ierror, 'recv_req', &
00199                              ierrp, 1, __FILE__, __LINE__ )
00200          return
00201       endif
00202 !
00203       recv_req = MPI_REQUEST_NULL
00204 !
00205       call psmile_recv_req_subgrid (search%msg_intersections, &
00206                                     search%sender, grdtag, search, &
00207                                     recv_req, new_search, ierror)
00208       if (ierror > 0) return
00209 !
00210 !===> Search corresponding field with global transout id "id_transout" for
00211 !     this component "comp_id" and grid "grid_id"
00212 !
00213       call psmile_find_corr_field (comp_info, search, &
00214                                    var_id, ierror)
00215       if (ierror > 0) return
00216 !
00217 #ifdef PRISM_ASSERTION
00218       if (paction%lrequest (3) /= MPI_REQUEST_NULL) then
00219          call psmile_assert ( __FILE__, __LINE__, &
00220                              'Why is request for grid data active ?')
00221 
00222       endif
00223 #endif
00224 !
00225 !====> Control for requests
00226 !      Note: (2) Message from a partner with an intersection is disabled
00227 !                since request for grid receive (lrequest (3)) is setup
00228 !                if such a message is found.
00229 !            ??? Koennte man enablen wenn lrequest(3) == MPI_REQUEST_NULL
00230 !            (3) Old receive of grid data (paction%lrequest (3)) is disabled
00231 !
00232       save_lreq (2:3) = paction%lrequest (2:3)
00233 !
00234       paction%lrequest (2) = MPI_REQUEST_NULL
00235       paction%lrequest (3) = recv_req(1)
00236 !
00237       index = 0
00238 #ifdef DEBUGX
00239       do n = 1, paction%nreq
00240          print *, ' Request list waitany ', n, paction%lrequest(n)
00241       enddo
00242 #endif
00243          do while (index /= 3) 
00244 !
00245          call MPI_Waitany (paction%nreq, paction%lrequest, index, status, ierror)
00246 
00247          if ( ierror /= MPI_SUCCESS ) then
00248             ierrp (1) = ierror
00249             ierrp (2) = status (MPI_SOURCE)
00250             ierrp (3) = status (MPI_TAG)
00251 
00252             ierror = PRISM_Error_MPI
00253 
00254             call psmile_error ( ierror, 'MPI_Waitany', &
00255                                 ierrp, 3, __FILE__, __LINE__ )
00256             return
00257          endif
00258 
00259 #ifdef PRISM_ASSERTION
00260          if (index == MPI_UNDEFINED) then
00261             call psmile_assert ( __FILE__, __LINE__, &
00262                                  'request list is empty')
00263          endif
00264 #endif
00265 !
00266          if (index /= 3) then
00267             call psmile_enddef_action (search, index, status, ierror)
00268             if (ierror > 0) return
00269          endif
00270          end do ! while
00271 !
00272 !    ... Restore original requests (2:3)
00273 !
00274 #ifdef PRISM_ASSERTION
00275       if (paction%lrequest (2) /= MPI_REQUEST_NULL .or. &
00276           paction%lrequest (3) /= MPI_REQUEST_NULL) then
00277          print *, 'request: ', paction%lrequest (2:3)
00278          call psmile_assert ( __FILE__, __LINE__, &
00279                              'Illegal request stored')
00280 
00281       endif
00282 #endif
00283 !
00284       paction%lrequest (2:3) = save_lreq (2:3)
00285 !
00286 !===> Wait for completion
00287 !
00288 #ifdef PRISM_with_MPI2
00289       call MPI_Waitall ((ndim_3d+2)*npart-1, recv_req(2:), &
00290                         MPI_STATUSES_IGNORE, ierror)
00291 #else
00292       Allocate (statuses (MPI_STATUS_SIZE,npart*(ndim_3d+2)-1), stat = ierror)
00293       if ( ierror /= 0 ) then
00294          ierrp (1) = MPI_STATUS_SIZE * (npart*(ndim_3d+2)-1)
00295          ierror = PRISM_Error_Alloc
00296          call psmile_error ( ierror, 'statuses', &
00297                              ierrp, 1, __FILE__, __LINE__ )
00298          return
00299       endif
00300 
00301 #ifdef DEBUGX
00302       do n = 2, (ndim_3d+2)*npart
00303          print *, ' Request list waitall ', n, recv_req(n)
00304       enddo
00305 #endif
00306       call MPI_Waitall ((ndim_3d+2)*npart-1, recv_req(2:), &
00307                         statuses, ierror)
00308 #endif
00309 !
00310       if ( ierror /= MPI_SUCCESS ) then
00311          ierrp (1) = ierror
00312 
00313          ierror = PRISM_Error_MPI
00314 
00315          call psmile_error ( ierror, 'MPI_Waitall', &
00316                              ierrp, 1, __FILE__, __LINE__ )
00317          return
00318       endif
00319 !
00320 #ifndef PRISM_with_MPI2
00321       Deallocate (statuses)
00322 #endif
00323       Deallocate (recv_req)
00324 !
00325 !===> Transform locations to be searched
00326 !     Is required only once per method.
00327 !
00328       call psmile_transform_coords (comp_info, search, ierror)
00329       if (ierror > 0) return
00330 !
00331 !===> All done
00332 !
00333 #ifdef VERBOSE
00334       print 9980, trim(ch_id), ierror
00335 
00336       call psmile_flushstd
00337 #endif /* VERBOSE */
00338 !
00339 !  Formats:
00340 !
00341 #ifdef VERBOSE
00342 
00343 9990 format (1x, a, ': psmile_get_next_field:')
00344 9980 format (1x, a, ': psmile_get_next_field: eof ierror =', i3)
00345 
00346 #endif /* VERBOSE */
00347 
00348       end subroutine PSMILe_Get_next_field