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