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