psmile_get_locations_3d.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_locations_3d
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_get_locations_3d (msg_locations, ierror)
00012 !
00013 ! !USES:
00014 !
00015       use PRISM_constants
00016 !
00017       use PSMILe, dummy_interface => PSMILe_Get_locations_3d
00018 
00019       implicit none
00020 !
00021 ! !INPUT PARAMETERS:
00022 !
00023       Type (enddef_msg_locations), Intent (In) :: msg_locations
00024 
00025 !    Contains basic information required to receive the locations
00026 !
00027 ! !OUTPUT PARAMETERS:
00028 !
00029       integer, Intent (Out)           :: ierror
00030 
00031 !     Returns the error code of PSMILe_Get_locations_3d;
00032 !             ierror = 0 : No error
00033 !             ierror > 0 : Severe error
00034 !
00035 ! !LOCAL VARIABLES
00036 !
00037       Integer, Parameter              :: recv_coupler_index = 3
00038       Integer, Parameter              :: recv_direct_index  = 4
00039 !
00040 !     ... Field Id and Pointer
00041 !
00042       Integer                         :: var_id, recv_index
00043       Type (GridFunction), Pointer    :: field
00044 !
00045 !     ... Grid Id and description of local grid
00046 !
00047       Type (Grid), Pointer            :: gp
00048       Integer                         :: grid_id
00049       Integer                         :: i, n, nb, nar
00050       Integer                         :: nbr_blocks
00051       Integer                         :: extent(ndim_3d)
00052       Integer                         :: offset(ndim_3d)
00053       Integer                         :: addoffset(ndim_3d)
00054       Integer                         :: idim(ndim_3d)
00055 !
00056 !     ... Method Id and pointer
00057 !
00058       Integer                         :: method_id
00059       Type (Method), Pointer          :: mp
00060 !
00061       Integer                         :: nardir, ncpl, ndir, npoints
00062       Integer                         :: index
00063       Integer                         :: task_id
00064 !
00065 !     ... for communication
00066 !
00067       Integer                         :: status (MPI_STATUS_SIZE)
00068 !
00069 !     ... for error handling
00070 !
00071       Integer, parameter              :: nerrp = 2
00072       Integer                         :: ierrp (nerrp)
00073 !
00074 ! !DESCRIPTION:
00075 !
00076 ! Subroutine "PSMILe_Get_locations_3d" returns the data on locations found
00077 ! for the method (grid) and the subgrid coords by process "msg_locations%src_rank".
00078 ! The data is sent by routine "PSMILe_Return_locations_3d" in the process
00079 ! which has searched the data.
00080 !
00081 !
00082 ! !REVISION HISTORY:
00083 !
00084 !   Date      Programmer   Description
00085 ! ----------  ----------   -----------
00086 ! 03.07.21    H. Ritzdorf  created
00087 !
00088 !EOP
00089 !----------------------------------------------------------------------
00090 !
00091 !  $Id: psmile_get_locations_3d.F90 2887 2011-01-14 09:25:49Z redler $
00092 !  $Author: redler $
00093 !
00094    Character(len=len_cvs_string), save :: mycvs = 
00095        '$Id: psmile_get_locations_3d.F90 2887 2011-01-14 09:25:49Z redler $'
00096 !
00097 !----------------------------------------------------------------------
00098 !
00099 !  Initialization
00100 !
00101 #ifdef VERBOSE
00102       print 9990, trim(ch_id), msg_locations%src_rank
00103 
00104       call psmile_flushstd
00105 #endif /* VERBOSE */
00106 !
00107       ierror = 0
00108       task_id = 0
00109 !
00110 !===> Get number of locations to be sent directly to another process
00111 !     ndir   = Number of locations which can be sent directly
00112 !     ncpl   = Number of locations sent to the coupler
00113 !     nardir = Number of clustered areas which can be sent directly
00114 !
00115       ncpl   = msg_locations%num_locs_coupler
00116       ndir   = msg_locations%num_locs_direct
00117       npoints= msg_locations%num_points_direct
00118       nardir = msg_locations%num_areas_direct
00119 !
00120       method_id = msg_locations%tgt_method_id
00121       var_id    = msg_locations%tgt_var_id
00122 !
00123 !
00124       mp => Methods(method_id)
00125       grid_id = mp%grid_id
00126 
00127       gp => Grids(grid_id)
00128 
00129       field => Fields (var_id)
00130 !
00131 #ifdef PRISM_ASSERTION
00132       if ( mp%status == PSMILe_Status_free .or. &
00133            mp%status == PSMILe_Status_undefined ) then
00134          call psmile_assert (__FILE__, __LINE__, "Incorrect method")
00135       endif
00136 !
00137       if ( field%status == PSMILe_Status_free .or. &
00138            field%status == PSMILe_Status_undefined ) then
00139          call psmile_assert (__FILE__, __LINE__, "Incorrect field")
00140       endif
00141 #endif
00142 !
00143 !===> Store data for receiver from coupler process
00144 !     ??? For now data are store line by line.
00145 !         Clustering of Data, if possibe !!!
00146 !
00147       if (ncpl > 0) then
00148 !
00149 !       ... generate receive areas for data exchange with coupler
00150 !
00151         call psmile_get_info_index (method_id, recv_coupler_index, index, ierror)
00152         if (ierror > 0) return
00153 !
00154         mp%recv_infos_coupler(index)%nloc        = ncpl
00155         mp%recv_infos_coupler(index)%npoints     = ncpl
00156         mp%recv_infos_coupler(index)%epio_id     = msg_locations%epio_id
00157         mp%recv_infos_coupler(index)%trs_rank    = msg_locations%trs_rank
00158 !
00159 !       ... Rank of coupler in communicator "comm_coupler"
00160 !
00161         mp%recv_infos_coupler(index)%source = 0
00162 !
00163 !       ... Store data for each receive of the field
00164 !
00165         call psmile_get_exch_index (var_id, task_id, recv_coupler_index, &
00166                                     recv_index, ierror)
00167         if (ierror > 0) return
00168 !
00169         field%Taskin%recv_coupler(recv_index)%trans_in_id     = msg_locations%transi_in_id
00170         field%Taskin%recv_coupler(recv_index)%recv_info_index = index
00171 !
00172 !       Allocate and receive destinations of points sent
00173 !
00174         Allocate (mp%recv_infos_coupler(index)%dstijk(1:ndim_3d, 1:ncpl), &
00175                   STAT = ierror)
00176         if ( ierror > 0 ) then
00177            ierrp (1) = ierror
00178            ierrp (2) = ncpl * ndim_3d
00179 
00180            ierror = PRISM_Error_Alloc
00181 
00182            call psmile_error ( ierror, 'send_info%dstijk', &
00183                                ierrp, 2, __FILE__, __LINE__ )
00184            return
00185         endif 
00186 
00187 #ifdef DEBUGX
00188         print *, ' Receiving locations from', msg_locations%src_rank, &
00189                  ' with tag ', loctag+msg_locations%relative_msg_tag, &
00190                  ' size ', ncpl*ndim_3d
00191 #endif /* DEBUGX */
00192 
00193         call MPI_Recv (mp%recv_infos_coupler(index)%dstijk, ncpl*ndim_3d,  &
00194                        MPI_INTEGER, msg_locations%src_rank,                &
00195                        loctag+msg_locations%relative_msg_tag, comm_psmile, &
00196                        status, ierror)
00197 
00198          if ( ierror /= MPI_SUCCESS ) then
00199             ierrp (1) = ierror
00200             ierror = PRISM_Error_MPI
00201 
00202             call psmile_error ( ierror, 'MPI_Recv', &
00203                                 ierrp, 1, __FILE__, __LINE__ )
00204             return
00205          endif
00206 
00207       endif
00208 !
00209 !     Generate receive areas for data exchange with application process
00210 !
00211       if (ndir > 0) then
00212 !
00213         call psmile_get_info_index (method_id, recv_direct_index, index, ierror)
00214         if (ierror > 0) return
00215 !
00216         mp%recv_infos_direct(index)%nloc    = ndir
00217         mp%recv_infos_direct(index)%npoints = npoints
00218         mp%recv_infos_direct(index)%source  = msg_locations%src_rank
00219         mp%recv_infos_direct(index)%nar     = nardir
00220 !
00221 !       ... Store data for each receive of the field
00222 !
00223         call psmile_get_exch_index (var_id, task_id, recv_direct_index, &
00224                                     recv_index, ierror)
00225         if (ierror > 0) return
00226 !
00227         field%Taskin%recv_direct(recv_index)%trans_in_id     = msg_locations%transi_in_id
00228         field%Taskin%recv_direct(recv_index)%recv_info_index = index
00229 !
00230 !       Allocate and receive destinations of points sent
00231 !       Note: It is at least one (dummy) area allocated in order
00232 !             to avoid problem in passing "dstijk" to routines
00233 !
00234         Allocate (mp%recv_infos_direct(index)%dstijk(1:ndim_3d, 1:max(npoints,1)), &
00235                   STAT = ierror)
00236         if ( ierror > 0 ) then
00237            ierrp (1) = ierror
00238            ierrp (2) = max(1, npoints) * ndim_3d
00239 
00240            ierror = PRISM_Error_Alloc
00241 
00242            call psmile_error ( ierror, 'send_info%dstijk', &
00243                                ierrp, 2, __FILE__, __LINE__ )
00244            return
00245         endif 
00246 
00247         if (npoints > 0) then
00248 #ifdef DEBUGX
00249            print *, ' Receiving locations from', msg_locations%src_rank, &
00250                     ' with tag ', loctag+msg_locations%relative_msg_tag, &
00251                     ' size ', npoints*ndim_3d
00252 #endif /* DEBUGX */
00253            call MPI_Recv (mp%recv_infos_direct(index)%dstijk, npoints*ndim_3d, &
00254                           MPI_INTEGER, msg_locations%src_rank,                 &
00255                           loctag+msg_locations%relative_msg_tag, comm_psmile,  &
00256                           status, ierror)
00257 
00258             if ( ierror /= MPI_SUCCESS ) then
00259                ierrp (1) = ierror
00260                ierror = PRISM_Error_MPI
00261 
00262                call psmile_error ( ierror, 'MPI_Recv', &
00263                                    ierrp, 1, __FILE__, __LINE__ )
00264                return
00265             endif
00266          endif
00267 !
00268 !       Allocate and receive clustered areas
00269 !       Note: It is at least one (dummy) area allocated in order
00270 !             to avoid problem in passing "dstars" to routines
00271 !
00272         Allocate (mp%recv_infos_direct(index)%dstars(1:2, 1:ndim_3d, 1:max(nardir,1)), &
00273                   STAT = ierror)
00274         if ( ierror > 0 ) then
00275            ierrp (1) = ierror
00276            ierrp (2) = max(nardir,1) * 2 * ndim_3d
00277 
00278            ierror = PRISM_Error_Alloc
00279 
00280            call psmile_error ( ierror, 'send_info%dstars', &
00281                                ierrp, 2, __FILE__, __LINE__ )
00282            return
00283         endif 
00284 
00285         if (nardir > 0) then
00286 #ifdef DEBUGX
00287            print *, ' Receiving locations from', msg_locations%src_rank, &
00288                     ' with tag ', loctag+msg_locations%relative_msg_tag, &
00289                     ' size ', nardir*2*ndim_3d
00290 #endif /* DEBUGX */
00291            call MPI_Recv (mp%recv_infos_direct(index)%dstars, nardir*2*ndim_3d, &
00292                           MPI_INTEGER, msg_locations%src_rank,                  &
00293                           loctag+msg_locations%relative_msg_tag, comm_psmile,   &
00294                           status, ierror)
00295 
00296            if ( ierror /= MPI_SUCCESS ) then
00297                ierrp (1) = ierror
00298                ierror = PRISM_Error_MPI
00299 
00300                call psmile_error ( ierror, 'MPI_Recv', &
00301                                    ierrp, 1, __FILE__, __LINE__ )
00302                return
00303            endif
00304 
00305 !          For PRISM_Gridless convert into local indices
00306 !
00307 !          ToDo: move into a new subroutine:
00308 !
00309 !                     functionality required by 
00310 !                     - psmile_find_intersect
00311 !                     - psmile_search_donor_gridless
00312 !                     - psmile_get_locations_3d
00313 !
00314            if ( gp%grid_type == PRISM_Gridless ) then
00315 
00316               ! find correct block
00317 
00318               if (Associated (Grids(grid_id)%partition)) then
00319 
00320                  nbr_blocks = size(Grids(grid_id)%partition(:,1))
00321 
00322                  do nar = 1, nardir
00323 
00324                     do nb = 1, nbr_blocks
00325 
00326                        if ( mp%recv_infos_direct(index)%dstars(2,1,nar) >=  &
00327                                  Grids(grid_id)%partition(nb,1) + 1 .and.   &
00328                             mp%recv_infos_direct(index)%dstars(1,1,nar) <=  &
00329                                  Grids(grid_id)%partition(nb,1) +           &
00330                                  Grids(grid_id)%extent   (nb,1)     .and.   &
00331                             mp%recv_infos_direct(index)%dstars(2,2,nar) >=  &
00332                                  Grids(grid_id)%partition(nb,2) + 1 .and.   &
00333                             mp%recv_infos_direct(index)%dstars(1,2,nar) <=  &
00334                                  Grids(grid_id)%partition(nb,2) +           &
00335                                  Grids(grid_id)%extent   (nb,2)     .and.   &
00336                             mp%recv_infos_direct(index)%dstars(2,3,nar) >=  &
00337                                  Grids(grid_id)%partition(nb,3) + 1 .and.   &
00338                             mp%recv_infos_direct(index)%dstars(1,3,nar) <=  &
00339                                  Grids(grid_id)%partition(nb,3) +           &
00340                                  Grids(grid_id)%extent   (nb,3) ) exit
00341                     enddo
00342 
00343                     if ( nb <= nbr_blocks ) then
00344 #ifdef DEBUG
00345                        print *, ' Transform block ', nb, Grids(grid_id)%partition(nb,1)+1, &
00346                                               ' - ',     Grids(grid_id)%partition(nb,1)+   &
00347                                                          Grids(grid_id)%extent   (nb,1)
00348                        print *, ' global dstars   ', nb, mp%recv_infos_direct(index)%dstars(:, :, nar)
00349 #endif
00350                        offset    = 0
00351                        addoffset = 0
00352 
00353                        do i = 1, ndim_3d
00354                           idim(i) = Grids(grid_id)%grid_shape(2,i) - &
00355                                     Grids(grid_id)%grid_shape(1,i)+1
00356                           do n = 1, nb-1
00357                              addoffset(i) = Grids(grid_id)%extent(n,i) + offset(i)
00358                              if ( addoffset(i) < idim(i) ) &
00359                              offset(i) = addoffset(i)
00360                           enddo
00361                        enddo
00362 
00363                        do i = 1, ndim_3d
00364                           extent(i) = mp%recv_infos_direct(index)%dstars(2, i, nar) - &
00365                                       mp%recv_infos_direct(index)%dstars(1, i, nar)
00366 
00367                           mp%recv_infos_direct(index)%dstars(1, i, nar) = &
00368                           mp%recv_infos_direct(index)%dstars(1, i, nar) + offset(i) &
00369                                                             - Grids(grid_id)%partition(nb,i) &
00370                                                             + Grids(grid_id)%grid_shape(1,i) - 1
00371                           mp%recv_infos_direct(index)%dstars(2, i, nar) = &
00372                           mp%recv_infos_direct(index)%dstars(1, i, nar) + extent(i)
00373                        end do
00374 #ifdef DEBUG
00375                        print *, ' part offset  ', nb, offset(:)
00376                        print *, ' local dstars ', nb, mp%recv_infos_direct(index)%dstars(:, :, nar)
00377 #endif
00378                     else
00379 
00380                        ierror = PRISM_Error_Internal
00381                        ierrp (1) = n
00382                        ierrp (2) = nbr_blocks
00383                        call psmile_error (ierror, "No block found", ierrp, 2, &
00384                             __FILE__, __LINE__)
00385                        return
00386 
00387                     endif
00388 
00389                  enddo ! nar
00390 
00391               endif ! Associated (Grids(grid_id)%partition
00392 
00393            endif ! PRISM_Gridless
00394 
00395         endif
00396 
00397      endif
00398 !
00399 !===> All done
00400 !
00401 #ifdef VERBOSE
00402       print 9980, trim(ch_id), ierror, ncpl, ndir, nardir
00403 
00404       call psmile_flushstd
00405 #endif /* VERBOSE */
00406 !
00407 !  Formats:
00408 !
00409 
00410 #ifdef VERBOSE
00411 
00412 9990 format (1x, a, ': psmile_get_locations_3d: sender ', i6)
00413 9980 format (1x, a, ': psmile_get_locations_3d: eof ierror =', i3, &
00414                     '; ncpl', i8, ', ndir ', i8, ', nardir', i3)
00415 
00416 #endif /* VERBOSE */
00417 
00418       end subroutine PSMILe_Get_locations_3d