psmile_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_Locations_3d
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_locations_3d (                       &
00012                       found, loc, range, control,            &
00013                       search, method_id, msk_required,       &
00014                       virtual_cell, virtual_cell_required,   &
00015                       dir_index, cpl_index, len_cpl, ierror)
00016 !
00017 ! !USES:
00018 !
00019       use PRISM_constants
00020 !
00021       use PSMILe, dummy_interface => PSMILe_Locations_3d
00022 
00023       implicit none
00024 !
00025 ! !INPUT PARAMETERS:
00026 !
00027       Type (Enddef_search), Intent (InOut) :: search
00028 
00029 !     Info's on coordinates to be searched
00030 !
00031       Integer, Intent (In)            :: range (2, ndim_3d, search%npart)
00032 
00033 !     Dimension of loc and found
00034 !     ??? muss range nicht shape sein ?
00035 !
00036       Type (integer_vector)           :: found (search%npart)
00037 
00038 !     Finest level number on which a grid cell was found for point
00039 !     (i,j,k) in range (2, ndim_3d, ipart) for ipart-th partition.
00040 
00041       Type (integer_vector)           :: loc (search%npart)
00042 !
00043 !     Indices of the grid cell in which the point was found.
00044 !     Assumed input value loc(:)%vector(:, len) = 0
00045 
00046       Type (integer_vector)           :: virtual_cell (search%npart)
00047 
00048 !     Code for virtual cells if point was found in virtual cell
00049 
00050       Integer, Intent (In)            :: control (2, ndim_3d, search%npart)
00051 
00052 !     Index range found
00053 !
00054       Integer, Intent (In)            :: method_id
00055 
00056 !     Method id of donor cells (on this process)
00057 
00058       Logical, Intent (In)            :: msk_required
00059 
00060 !     Switch to determine whether an additional src location mask is required.
00061 !
00062       Logical, Intent (In)            :: virtual_cell_required
00063 
00064 !     Storage of virtual cell info required ?
00065 
00066 ! !OUTPUT PARAMETERS:
00067 !
00068       Integer, Intent (Out)           :: dir_index
00069 
00070 !     Send index if data has to be directly transferred to the
00071 !     destination process.
00072 !     PRISM_undefined, if no data has to be sent.
00073 !
00074       Integer, Intent (Out)           :: cpl_index
00075 
00076 !     Send index if data has to be transferred to the coupler
00077 !     PRISM_undefined, if no data has to be sent.
00078 
00079       Integer, Intent (Out)           :: len_cpl (search%npart)
00080 
00081 !     Number of points to be sent to the coupler for each partition.
00082 !
00083       Integer, Intent (Out)           :: ierror
00084 
00085 !     Returns the error code of PSMILe_Locations_3d;
00086 !             ierror = 0 : No error
00087 !             ierror > 0 : Severe error
00088 !
00089 ! !LOCAL PARAMETERS
00090 !
00091 ! val_direct  = Code for locations which should to be directly transferred
00092 !               to the destination process.
00093 ! val_coupler = Code for locations which should to be transferred
00094 !               to the coupler process.
00095 ! val_both    = Code that all locations should be transferred
00096 !               to the coupler process.
00097 !
00098       Integer, Parameter              :: val_direct  =  1
00099       Integer, Parameter              :: val_coupler = -1
00100       Integer, Parameter              :: val_both    =  0
00101 !
00102       Integer, Parameter              :: send_coupler_index = 1
00103       Integer, Parameter              :: send_direct_index  = 2
00104 !
00105       Integer, Parameter              :: ialloc = 1
00106 !
00107 ! !LOCAL VARIABLES
00108 !
00109 !     ... Method pointer
00110 !
00111       Type (Method), Pointer          :: mp
00112 !
00113 !     ... for locations to be stored and transferred
00114 !
00115       Real                            :: ratio
00116 !
00117       Integer                         :: len, n, nadd, ncpl, ndir, nprev, nprevi
00118       Integer                         :: index
00119       Integer                         :: val_cpl
00120 !
00121 !     ... for partitions
00122 !
00123       Integer                         :: ipart
00124       Integer                         :: ibeg (search%npart)
00125       Integer                         :: iend (search%npart)
00126 !
00127 !     ... for error handling
00128 !
00129       Integer, parameter              :: nerrp = 2
00130       Integer                         :: ierrp (nerrp)
00131 !
00132 ! !DESCRIPTION:
00133 !
00134 ! Subroutine "PSMILe_Locations_3d" stores the data on locations found
00135 ! for the method (grid) and the subgrid coords.
00136 !
00137 ! TODO: request into send_info and free dstijk
00138 ! TODO: elimination of multiple points in dstijk and srclocs
00139 !
00140 ! !REVISION HISTORY:
00141 !
00142 !   Date      Programmer   Description
00143 ! ----------  ----------   -----------
00144 ! 03.07.04    H. Ritzdorf  created
00145 !
00146 !EOP
00147 !----------------------------------------------------------------------
00148 !
00149 !  $Id: psmile_locations_3d.F90 2969 2011-02-21 10:08:22Z hanke $
00150 !  $Author: hanke $
00151 !
00152    Character(len=len_cvs_string), save :: mycvs = 
00153        '$Id: psmile_locations_3d.F90 2969 2011-02-21 10:08:22Z hanke $'
00154 !
00155 !----------------------------------------------------------------------
00156 !
00157 !  Initialization
00158 !
00159 #ifdef VERBOSE
00160       print 9990, trim(ch_id), method_id, search%msg_intersections%first_tgt_method_id, &
00161                                search%sender
00162 
00163       call psmile_flushstd
00164 #endif /* VERBOSE */
00165 !
00166       ierror = 0
00167 !
00168       cpl_index = PRISM_undefined
00169       dir_index = PRISM_undefined
00170 !
00171       len_cpl (:) = 0
00172 !
00173       mp => Methods(method_id)
00174 !
00175 #ifdef PRISM_ASSERTION
00176       if ( mp%status == PSMILe_Status_free .or. &
00177            mp%status == PSMILe_Status_undefined ) then
00178          call psmile_assert (__FILE__, __LINE__, "Incorrect method")
00179       endif
00180 
00181       do ipart = 1, search%npart
00182          if (control (1,1,ipart) <   range (1,1,ipart) .or. &
00183                range (2,1,ipart) < control (2,1,ipart) .or. &
00184              control (1,2,ipart) <   range (1,2,ipart) .or. &
00185                range (2,2,ipart) < control (2,2,ipart) .or. &
00186              control (1,3,ipart) <   range (1,3,ipart) .or. &
00187                range (2,3,ipart) < control (2,3,ipart)) then
00188             print *, ipart, control (:, :, ipart), range (:, :, ipart)
00189             call psmile_assert (__FILE__, __LINE__, "control is out of range")
00190          endif
00191       end do ! ipart
00192 #endif
00193 !
00194 !----------------------------------------------------------------------------
00195 !     Determine maximal number of points to be transferred to the
00196 !     coupler or directly to the destination process
00197 !----------------------------------------------------------------------------
00198 !
00199       ndir = 0
00200       ncpl = 0
00201 !
00202       do ipart = 1, search%npart
00203          len = (range(2,1,ipart)-range(1,1,ipart)+1) &
00204              * (range(2,2,ipart)-range(1,2,ipart)+1) &
00205              * (range(2,3,ipart)-range(1,3,ipart)+1)
00206 !
00207          ibeg (ipart) = 1
00208          iend (ipart) = len
00209 !
00210 !     ibeg = (control(1,3)-range(1,3))*(range(2,2)-range(1,2)+1) &
00211 !                                     *(range(2,1)-range(1,1)+1) &
00212 !          + (control(1,2)-range(1,2))*(range(2,1)-range(1,1)+1) &
00213 !          + (control(1,1)-range(1,1)) + 1
00214 !
00215 !     iend = (control(2,3)-range(1,3))*(range(2,2)-range(1,2)+1) &
00216 !                                     *(range(2,1)-range(1,1)+1) &
00217 !          + (control(2,2)-range(1,2))*(range(2,1)-range(1,1)+1) &
00218 !          + (control(2,1)-range(1,1)) + 1
00219 !
00220 !
00221 !===> Get number of locations to be sent directly to another process
00222 !     ndir = Number of locations which can be sent directly
00223 !     ncpl = Number of locations sent to the coupler
00224 !
00225 !     ? ibeg_dir, iend_dir, ibeg_cpl, iend_cpl berechnen ?
00226 !
00227 !cdir vector
00228          do n = ibeg(ipart), iend(ipart)
00229             if (found(ipart)%vector(n) == val_coupler) then
00230                ncpl = ncpl + 1
00231             else if (found(ipart)%vector(n) == val_direct) then
00232                ndir = ndir + 1
00233             endif
00234          end do
00235       end do ! ipart
00236 !
00237       if (ncpl + ndir > 0) then
00238          ratio = real(ndir) / (ncpl+ndir)
00239       else
00240          ratio = 0.0
00241       endif
00242 !
00243 #ifdef DEBUG
00244       print *, trim(ch_id), ':ratio, ndir, ncpl', ratio, ndir, ncpl
00245 #endif
00246 !
00247 #ifdef ONLY_FOR_TESTING
00248       print *, '######## psmile_locations_3d: ratio set to 0.0'
00249       ratio = 0.01
00250 #endif
00251 !
00252 !===> Store locations
00253 !     ??? Derzeit werden die Daten Zellweise abgespeichert.
00254 !         Clustern der Daten, wenn moeglich !!!
00255 !     ??? ratio ist ein schwaches Kriterium;
00256 !
00257       if (ndir > 0 .and. ratio < 0.05) then
00258 !
00259 !       ... The number of points which can be sent directly is
00260 !           "large" enough
00261 !       ... Send all points to the coupler
00262 !
00263         ncpl = ncpl + ndir
00264         ndir = 0
00265 !
00266         val_cpl = val_both
00267       else
00268         val_cpl = val_coupler
00269       endif
00270 
00271 #ifdef DEBUG
00272       print *, trim(ch_id), ': psmile_locations_3d:'
00273       print *, "range:  ", range
00274       print *, "control:", control
00275       print *, "ibeg:",    ibeg
00276       print *, "iend:",    iend
00277       print *, "ncpl   :", ncpl
00278       print *, "ndir   :", ndir
00279       call psmile_flushstd
00280 #endif
00281 !
00282 !----------------------------------------------------------------------------
00283 !     Generate send areas for data send to a coupler process
00284 !----------------------------------------------------------------------------
00285 !
00286       if (ncpl > 0) then
00287          call psmile_get_info_index (method_id, send_coupler_index, index, ierror)
00288          if (ierror > 0) return
00289 !
00290          cpl_index = index
00291 !
00292          mp%send_infos_coupler(index)%nvec      = 1
00293          mp%send_infos_coupler(index)%nparts    = 1
00294          mp%send_infos_coupler(index)%remote_method_id = &
00295             search%msg_intersections%first_tgt_method_id
00296 !
00297          mp%send_infos_coupler(index)%nrecv    = 0
00298          mp%send_infos_coupler(index)%num2recv = 0
00299 !
00300 !       ... Rank of coupler in communicator "comm_coupler"
00301 !
00302          mp%send_infos_coupler(index)%dest = 0
00303 !
00304 !       ... generate send areas for data exchange with coupler
00305 !
00306          call psmile_locations_alloc (mp%send_infos_coupler(index), ierror)
00307          if (ierror > 0) return
00308 
00309          nprev = 0
00310          nprevi = 0
00311 
00312          if (msk_required) then
00313             Allocate (mp%send_infos_coupler(index)%msklocs(1,search%npart), &
00314                      STAT = ierror)
00315                if ( ierror > 0 ) then
00316                   ierrp (1) = ierror
00317                   ierrp (2) = search%npart
00318 
00319                   ierror = PRISM_Error_Alloc
00320                   call psmile_error ( ierror, 'mp%send_infos_coupler(index)%msklocs', &
00321                         ierrp, 2, __FILE__, __LINE__ )
00322                   return
00323                endif
00324          endif
00325 
00326          if (virtual_cell_required) then
00327             Allocate (mp%send_infos_coupler(index)%virtual(1,search%npart), &
00328                      STAT = ierror)
00329                if ( ierror > 0 ) then
00330                   ierrp (1) = ierror
00331                   ierrp (2) = search%npart
00332 
00333                   ierror = PRISM_Error_Alloc
00334                   call psmile_error ( ierror, 'mp%send_infos_coupler(index)%virtual', &
00335                         ierrp, 2, __FILE__, __LINE__ )
00336                   return
00337                endif
00338                ! Derefference pointer explicitly as some compilers
00339                ! set a reference by default
00340                do ipart = 1, search%npart
00341                   Nullify(mp%send_infos_coupler(index)%virtual(1,ipart)%vector)
00342                enddo
00343          endif
00344 
00345          do ipart = 1, search%npart
00346             call psmile_store_dest_locs_3d (found(ipart)%vector,   &
00347                               loc(ipart)%vector, range(:,:,ipart), &
00348                               control(:,:,ipart),                  &
00349                               mp%send_infos_coupler(index), ncpl,  &
00350                               val_cpl, nprev, nadd, ierror)
00351             if (ierror > 0) return
00352 
00353             nprev = nprev + nadd
00354             len_cpl (ipart) = nadd
00355 
00356             call psmile_store_source_locs_3d (found(ipart)%vector, &
00357                               loc(ipart)%vector,                   &
00358                               ibeg(ipart), iend(ipart),            &
00359                               mp%send_infos_coupler(index), ncpl,  &
00360                               val_cpl, nprevi, nadd, ierror)
00361             if (ierror > 0) return
00362 
00363             if (msk_required) then
00364                call psmile_store_mask_locs_3d ( ipart, range(:,:, ipart),    &
00365                      control (:,:, ipart), found(ipart)%vector,        &
00366                      mp%send_infos_coupler(index), nprevi, ncpl, ierror )
00367                if (ierror > 0) return
00368             endif
00369 !
00370             if (virtual_cell_required) then
00371 ! Note: Data is stored as single 1d vector (ipart == 1)
00372 !       independent on number of partitions of for target grid
00373                call psmile_store_source_virt_3d (found(ipart)%vector, &
00374                          virtual_cell(ipart)%vector,                  &
00375                          ibeg(ipart), iend(ipart),                    &
00376                          mp%send_infos_coupler(index), ncpl,          &
00377                          val_cpl, ialloc, 1, nprevi, ierror)
00378                if (ierror > 0) return
00379             endif
00380 !
00381             nprevi = nprevi + nadd
00382          end do
00383 !
00384          mp%send_infos_coupler(index)%nloc = nprev
00385 
00386       endif
00387 !
00388 !----------------------------------------------------------------------------
00389 !     Generate send areas for data exchange with application process
00390 !----------------------------------------------------------------------------
00391 !
00392       if (ndir > 0) then
00393 !
00394          call psmile_get_info_index (method_id, send_direct_index, index, ierror)
00395          if (ierror > 0) return
00396 !
00397          dir_index = index
00398 !
00399          mp%send_infos_direct(index)%dest   = search%sender
00400          mp%send_infos_direct(index)%nvec   = 1
00401          mp%send_infos_direct(index)%nparts = 1
00402 !
00403          mp%send_infos_direct(index)%nrecv    = 0
00404          mp%send_infos_direct(index)%num2recv = 0
00405 !
00406          mp%send_infos_direct(index)%remote_method_id = search%msg_intersections%first_tgt_method_id
00407 !
00408 !       ... generate send areas for direct data exchange
00409 !
00410          call psmile_locations_alloc (mp%send_infos_direct(index), ierror)
00411          if (ierror > 0) return
00412 !
00413          nprev  = 0
00414 
00415          do ipart = 1, search%npart
00416             call psmile_store_dest_locs_3d (found(ipart)%vector,      &
00417                               loc(ipart)%vector, range (:, :, ipart), &
00418                               control (:, :, ipart),                  &
00419                               mp%send_infos_direct(index), ndir,      &
00420                               val_direct, nprev, nadd, ierror)
00421             if (ierror > 0) return
00422 
00423             call psmile_store_source_locs_3d (found(ipart)%vector,    &
00424                               loc(ipart)%vector,                      &
00425                               ibeg (ipart), iend (ipart),             &
00426                               mp%send_infos_direct(index), ndir,      &
00427                               val_direct, nprev, nadd, ierror)
00428             if (ierror > 0) return
00429 !
00430             nprev = nprev + nadd
00431 
00432          end do ! ipart
00433 !
00434          mp%send_infos_direct(index)%nloc = nprev
00435       endif
00436 !
00437 !===> All done
00438 !
00439 #ifdef VERBOSE
00440       print 9980, trim(ch_id), ierror, dir_index, cpl_index
00441 
00442       call psmile_flushstd
00443 #endif /* VERBOSE */
00444 !
00445 !  Formats:
00446 !
00447 
00448 #ifdef VERBOSE
00449 
00450 9990 format (1x, a, ': psmile_locations_3d: method_id', i3, &
00451                     ' to ', i3, '(', i2, ')')
00452 9980 format (1x, a, ': psmile_locations_3d: eof ierror =', i3, &
00453                     '; dir_index', i7, ', cpl_index', i7)
00454 
00455 #endif /* VERBOSE */
00456 
00457       end subroutine PSMILe_Locations_3d