PartMC 2.1.3
|
00001 ! Copyright (C) 2005-2011 Nicole Riemer and Matthew West 00002 ! Licensed under the GNU General Public License version 2 or (at your 00003 ! option) any later version. See the file COPYING for details. 00004 00005 !> \file 00006 !> The pmc_coagulation_dist module. 00007 00008 !> Parallel aerosol particle coagulation with MPI 00009 module pmc_coagulation_dist 00010 00011 use pmc_bin_grid 00012 use pmc_aero_data 00013 use pmc_util 00014 use pmc_env_state 00015 use pmc_aero_state 00016 use pmc_coagulation 00017 use pmc_mpi 00018 #ifdef PMC_USE_MPI 00019 use mpi 00020 #endif 00021 00022 !> Size of the outgoing buffer for \c bsend (bytes). 00023 !! 00024 !! FIXME: check that this size is big enough. It must be large 00025 !! enough to handle the required number of messages of the given 00026 !! sizes, plus MPI_BSEND_OVERHEAD per message, plus some extra room 00027 !! because it's only kind of a circular buffer --- the messages 00028 !! themselves aren't allowed to wrap around then end, so we might 00029 !! need extra space up to the size of the largest message type. 00030 integer, parameter :: COAG_DIST_OUTGOING_BUFFER_SIZE = 1000000 00031 !> Size of send and receive buffer for each message (bytes). 00032 !! 00033 !! The biggest message type will be one of the particle-sending 00034 !! types, for which we need pmc_mpi_pack_size_aero_particle(), plus 00035 !! a couple of integers or something. At the moment this means 00036 !! something like (10 + n_spec) reals, (3 + 2) integers, which for 00037 !! n_spec = 20 gives a size of 260 bytes. 00038 integer, parameter :: COAG_DIST_MAX_BUFFER_SIZE = 10000 00039 integer, parameter :: COAG_DIST_MAX_REQUESTS = 1 00040 integer, parameter :: COAG_DIST_TAG_REQUEST_PARTICLE = 5321 00041 integer, parameter :: COAG_DIST_TAG_RETURN_REQ_PARTICLE = 5322 00042 integer, parameter :: COAG_DIST_TAG_RETURN_UNREQ_PARTICLE = 5323 00043 integer, parameter :: COAG_DIST_TAG_RETURN_NO_PARTICLE = 5324 00044 integer, parameter :: COAG_DIST_TAG_DONE = 5325 00045 00046 !> A single outstanding request for a remote particle. 00047 type request_t 00048 !> Local \c aero_particle to maybe coagulate with the received 00049 !> particle. 00050 type(aero_particle_t) :: local_aero_particle 00051 !> Remote process number that we sent the request to 00052 !> (-1 means this request is currently not used). 00053 integer :: remote_proc 00054 !> Local bin number from which we took \c local_aero_particle. 00055 integer :: local_bin 00056 !> Remote bin number from which we requested an \c aero_particle. 00057 integer :: remote_bin 00058 !> Whether this request is currently active 00059 logical :: active 00060 end type request_t 00061 00062 contains 00063 00064 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00065 00066 ! Allocate a request object and set its state to invalid. 00067 subroutine request_allocate(request) 00068 00069 !> Request object to allocate. 00070 type(request_t), intent(out) :: request 00071 00072 call aero_particle_allocate(request%local_aero_particle) 00073 request%active = .false. 00074 00075 end subroutine request_allocate 00076 00077 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00078 00079 !> Deallocate a request object and set it to be invalid. 00080 subroutine request_deallocate(request) 00081 00082 !> Request object to deallocate 00083 type(request_t), intent(inout) :: request 00084 00085 call aero_particle_deallocate(request%local_aero_particle) 00086 request%active = .false. 00087 00088 end subroutine request_deallocate 00089 00090 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00091 00092 !> Whether the given reqest object is currectly active. 00093 logical function request_is_active(request) 00094 00095 !> Request object to test for activeness. 00096 type(request_t), intent(in) :: request 00097 00098 request_is_active = request%active 00099 00100 end function request_is_active 00101 00102 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00103 00104 !> Do coagulation for time del_t. 00105 subroutine mc_coag_dist(coag_kernel_type, bin_grid, env_state, & 00106 aero_data, aero_weight, aero_state, del_t, k_max, tot_n_samp, & 00107 tot_n_coag) 00108 00109 !> Coagulation kernel type. 00110 integer, intent(in) :: coag_kernel_type 00111 !> Bin grid. 00112 type(bin_grid_t), intent(in) :: bin_grid 00113 !> Environment state. 00114 type(env_state_t), intent(in) :: env_state 00115 !> Aerosol data. 00116 type(aero_data_t), intent(in) :: aero_data 00117 !> Aerosol weight. 00118 type(aero_weight_t), intent(in) :: aero_weight 00119 !> Aerosol state. 00120 type(aero_state_t), intent(inout) :: aero_state 00121 !> Timestep. 00122 real(kind=dp), intent(in) :: del_t 00123 !> Maximum kernel. 00124 real(kind=dp), intent(in) :: k_max(bin_grid%n_bin,bin_grid%n_bin) 00125 !> Total number of samples tested. 00126 integer, intent(out) :: tot_n_samp 00127 !> Number of coagulation events. 00128 integer, intent(out) :: tot_n_coag 00129 00130 #ifdef PMC_USE_MPI 00131 logical :: samps_remaining, sent_dones 00132 integer :: i, j, n_samp, i_samp, i_proc, n_proc, i_bin 00133 integer :: ierr, status(MPI_STATUS_SIZE), current_i, current_j, i_req 00134 real(kind=dp) :: n_samp_real 00135 integer, allocatable :: n_parts(:,:) 00136 real(kind=dp), allocatable :: comp_vols(:) 00137 type(request_t) :: requests(COAG_DIST_MAX_REQUESTS) 00138 integer :: n_samps(bin_grid%n_bin, bin_grid%n_bin) 00139 real(kind=dp) :: accept_factors(bin_grid%n_bin, bin_grid%n_bin) 00140 logical, allocatable :: procs_done(:) 00141 integer :: outgoing_buffer(COAG_DIST_OUTGOING_BUFFER_SIZE) 00142 integer :: outgoing_buffer_size_check 00143 00144 n_proc = pmc_mpi_size() 00145 00146 call pmc_mpi_barrier() 00147 00148 allocate(n_parts(bin_grid%n_bin, n_proc)) 00149 allocate(comp_vols(n_proc)) 00150 call sync_info(aero_state%bin(:)%n_part, aero_state%comp_vol, & 00151 n_parts, comp_vols) 00152 00153 call generate_n_samps(bin_grid, n_parts, comp_vols, del_t, k_max, & 00154 n_samps, accept_factors) 00155 tot_n_samp = sum(n_samps) 00156 tot_n_coag = 0 00157 00158 ! main loop 00159 do i_req = 1,COAG_DIST_MAX_REQUESTS 00160 call request_allocate(requests(i_req)) 00161 end do 00162 samps_remaining = .true. 00163 current_i = 1 00164 current_j = 1 00165 allocate(procs_done(n_proc)) 00166 procs_done = .false. 00167 sent_dones = .false. 00168 call mpi_buffer_attach(outgoing_buffer, & 00169 COAG_DIST_OUTGOING_BUFFER_SIZE, ierr) 00170 call pmc_mpi_check_ierr(ierr) 00171 do while (.not. all(procs_done)) 00172 ! add requests if we have any slots available call 00173 call add_coagulation_requests(bin_grid, aero_state, requests, & 00174 n_parts, current_i, current_j, n_samps, samps_remaining) 00175 00176 ! if we have no outstanding requests, send done messages 00177 if (.not. sent_dones) then 00178 if (.not. any_requests_active(requests)) then 00179 sent_dones = .true. 00180 do i_proc = 0, (n_proc - 1) 00181 call send_done(i_proc) 00182 end do 00183 end if 00184 end if 00185 00186 ! receive exactly one message 00187 call coag_dist_recv(requests, bin_grid, env_state, aero_data, & 00188 aero_weight, aero_state, accept_factors, coag_kernel_type, & 00189 tot_n_coag, comp_vols, procs_done) 00190 end do 00191 00192 do i_req = 1,COAG_DIST_MAX_REQUESTS 00193 call assert(502009333, .not. request_is_active(requests(i_req))) 00194 call request_deallocate(requests(i_req)) 00195 end do 00196 deallocate(procs_done) 00197 deallocate(n_parts) 00198 deallocate(comp_vols) 00199 call mpi_buffer_detach(outgoing_buffer, & 00200 outgoing_buffer_size_check, ierr) 00201 call pmc_mpi_check_ierr(ierr) 00202 call assert(577822730, & 00203 COAG_DIST_OUTGOING_BUFFER_SIZE == outgoing_buffer_size_check) 00204 #endif 00205 00206 end subroutine mc_coag_dist 00207 00208 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00209 00210 subroutine coag_dist_recv(requests, bin_grid, env_state, aero_data, & 00211 aero_weight, aero_state, accept_factors, coag_kernel_type, & 00212 tot_n_coag, comp_vols, procs_done) 00213 00214 !> Array of outstanding requests. 00215 type(request_t), intent(inout) :: requests(COAG_DIST_MAX_REQUESTS) 00216 !> Bin grid. 00217 type(bin_grid_t), intent(in) :: bin_grid 00218 !> Environment state. 00219 type(env_state_t), intent(in) :: env_state 00220 !> Aerosol data. 00221 type(aero_data_t), intent(in) :: aero_data 00222 !> Aerosol weight. 00223 type(aero_weight_t), intent(in) :: aero_weight 00224 !> Aerosol state. 00225 type(aero_state_t), intent(inout) :: aero_state 00226 !> Accept scale factors per bin pair (1). 00227 real(kind=dp), intent(out) :: 00228 accept_factors(bin_grid%n_bin,bin_grid%n_bin) 00229 !> Coagulation kernel type. 00230 integer, intent(in) :: coag_kernel_type 00231 !> Number of coagulation events. 00232 integer, intent(inout) :: tot_n_coag 00233 !> Computational volumes on all processes. 00234 real(kind=dp), intent(in) :: comp_vols(:) 00235 !> Which processes are finished with coagulation. 00236 logical, intent(inout) :: procs_done(:) 00237 00238 #ifdef PMC_USE_MPI 00239 integer :: status(MPI_STATUS_SIZE), ierr 00240 00241 call mpi_probe(MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, & 00242 status, ierr) 00243 call pmc_mpi_check_ierr(ierr) 00244 if (status(MPI_TAG) == COAG_DIST_TAG_REQUEST_PARTICLE) then 00245 call recv_request_particle(aero_state) 00246 elseif (status(MPI_TAG) == COAG_DIST_TAG_RETURN_REQ_PARTICLE) then 00247 call recv_return_req_particle(requests, bin_grid, & 00248 env_state, aero_data, aero_weight, aero_state, accept_factors, & 00249 coag_kernel_type, tot_n_coag, comp_vols) 00250 elseif (status(MPI_TAG) == COAG_DIST_TAG_RETURN_UNREQ_PARTICLE) then 00251 call recv_return_unreq_particle(aero_state, bin_grid) 00252 elseif (status(MPI_TAG) == COAG_DIST_TAG_RETURN_NO_PARTICLE) then 00253 call recv_return_no_particle(requests, bin_grid, & 00254 aero_data, aero_state) 00255 elseif (status(MPI_TAG) == COAG_DIST_TAG_DONE) then 00256 call recv_done(procs_done) 00257 else 00258 call die_msg(856123972, & 00259 'unknown tag: ' // trim(integer_to_string(status(MPI_TAG)))) 00260 end if 00261 #endif 00262 00263 end subroutine coag_dist_recv 00264 00265 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00266 00267 subroutine add_coagulation_requests(bin_grid, aero_state, requests, & 00268 n_parts, local_bin, remote_bin, n_samps, samps_remaining) 00269 00270 !> Bin grid. 00271 type(bin_grid_t), intent(in) :: bin_grid 00272 !> Aerosol state. 00273 type(aero_state_t), intent(inout) :: aero_state 00274 !> Array of outstanding requests. 00275 type(request_t), intent(inout) :: requests(COAG_DIST_MAX_REQUESTS) 00276 !> Number of particles per bin per process. 00277 integer, intent(in) :: n_parts(:,:) 00278 !> Bin index of first particle we need to coagulate. 00279 integer, intent(inout) :: local_bin 00280 !> Bin index of second particle we need to coagulate. 00281 integer, intent(inout) :: remote_bin 00282 !> Number of samples remaining per bin pair 00283 integer, intent(inout) :: n_samps(bin_grid%n_bin,bin_grid%n_bin) 00284 !> Whether there are still coagulation samples that need to be done. 00285 logical, intent(inout) :: samps_remaining 00286 00287 integer :: i_req 00288 00289 if (.not. samps_remaining) return 00290 00291 outer: do i_req = 1,COAG_DIST_MAX_REQUESTS 00292 if (.not. request_is_active(requests(i_req))) then 00293 inner: do 00294 call update_n_samps(bin_grid, n_samps, local_bin, & 00295 remote_bin, samps_remaining) 00296 if (.not. samps_remaining) exit outer 00297 if (aero_state%bin(local_bin)%n_part > 0) then 00298 call find_rand_remote_proc(bin_grid, n_parts, & 00299 remote_bin, requests(i_req)%remote_proc) 00300 requests(i_req)%active = .true. 00301 requests(i_req)%local_bin = local_bin 00302 requests(i_req)%remote_bin = remote_bin 00303 call aero_state_remove_rand_particle_from_bin(aero_state, & 00304 local_bin, requests(i_req)%local_aero_particle) 00305 call send_request_particle(requests(i_req)%remote_proc, & 00306 requests(i_req)%remote_bin) 00307 exit inner 00308 end if 00309 end do inner 00310 end if 00311 end do outer 00312 00313 end subroutine add_coagulation_requests 00314 00315 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00316 00317 !> Returns \c .true. if any of the requests are active, otherwise 00318 !> returns \c .false. 00319 logical function any_requests_active(requests) 00320 00321 !> Array of outstanding requests. 00322 type(request_t), intent(inout) :: requests(COAG_DIST_MAX_REQUESTS) 00323 00324 integer :: i_req 00325 00326 do i_req = 1,COAG_DIST_MAX_REQUESTS 00327 if (request_is_active(requests(i_req))) then 00328 any_requests_active = .true. 00329 return 00330 end if 00331 end do 00332 any_requests_active = .false. 00333 00334 end function any_requests_active 00335 00336 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00337 00338 subroutine find_rand_remote_proc(bin_grid, n_parts, remote_bin, remote_proc) 00339 00340 !> Bin grid. 00341 type(bin_grid_t), intent(in) :: bin_grid 00342 !> Number of particles per bin per process. 00343 integer, intent(in) :: n_parts(:,:) 00344 !> Remote bin number. 00345 integer, intent(in) :: remote_bin 00346 !> Remote process number chosen at random. 00347 integer, intent(out) :: remote_proc 00348 00349 #ifdef PMC_USE_MPI 00350 call assert(542705260, size(n_parts, 1) == bin_grid%n_bin) 00351 call assert(770964285, size(n_parts, 2) == pmc_mpi_size()) 00352 remote_proc = sample_disc_pdf(n_parts(remote_bin,:)) - 1 00353 #endif 00354 00355 end subroutine find_rand_remote_proc 00356 00357 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00358 00359 subroutine update_n_samps(bin_grid, n_samps, local_bin, remote_bin, & 00360 samps_remaining) 00361 00362 !> Bin grid. 00363 type(bin_grid_t), intent(in) :: bin_grid 00364 !> Number of samples remaining per bin pair 00365 integer, intent(inout) :: n_samps(bin_grid%n_bin,bin_grid%n_bin) 00366 !> Bin index of first particle we need to coagulate. 00367 integer, intent(inout) :: local_bin 00368 !> Bin index of second particle we need to coagulate. 00369 integer, intent(inout) :: remote_bin 00370 !> Whether there are still coagulation samples that need to be done. 00371 logical, intent(inout) :: samps_remaining 00372 00373 if (.not. samps_remaining) return 00374 00375 do 00376 if (n_samps(local_bin, remote_bin) > 0) exit 00377 00378 remote_bin = remote_bin + 1 00379 if (remote_bin > bin_grid%n_bin) then 00380 remote_bin = 1 00381 local_bin = local_bin + 1 00382 end if 00383 if (local_bin > bin_grid%n_bin) exit 00384 end do 00385 00386 if (local_bin > bin_grid%n_bin) then 00387 samps_remaining = .false. 00388 else 00389 n_samps(local_bin, remote_bin) = n_samps(local_bin, remote_bin) - 1 00390 end if 00391 00392 end subroutine update_n_samps 00393 00394 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00395 00396 subroutine send_request_particle(remote_proc, remote_bin) 00397 00398 !> Remote process number. 00399 integer, intent(in) :: remote_proc 00400 !> Remote bin number. 00401 integer, intent(in) :: remote_bin 00402 00403 #ifdef PMC_USE_MPI 00404 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00405 integer :: buffer_size, max_buffer_size, position, ierr 00406 00407 max_buffer_size = 0 00408 max_buffer_size = max_buffer_size + pmc_mpi_pack_size_integer(remote_bin) 00409 call assert(893545122, max_buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00410 position = 0 00411 call pmc_mpi_pack_integer(buffer, position, remote_bin) 00412 call assert(610314213, position <= max_buffer_size) 00413 buffer_size = position 00414 call mpi_bsend(buffer, buffer_size, MPI_CHARACTER, remote_proc, & 00415 COAG_DIST_TAG_REQUEST_PARTICLE, MPI_COMM_WORLD, ierr) 00416 call pmc_mpi_check_ierr(ierr) 00417 #endif 00418 00419 end subroutine send_request_particle 00420 00421 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00422 00423 subroutine recv_request_particle(aero_state) 00424 00425 !> Aero state. 00426 type(aero_state_t), intent(inout) :: aero_state 00427 00428 #ifdef PMC_USE_MPI 00429 integer :: buffer_size, position, request_bin, sent_proc, ierr 00430 integer :: remote_proc, status(MPI_STATUS_SIZE) 00431 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00432 type(aero_particle_t) :: aero_particle 00433 00434 ! get the message 00435 call mpi_recv(buffer, COAG_DIST_MAX_BUFFER_SIZE, MPI_CHARACTER, & 00436 MPI_ANY_SOURCE, COAG_DIST_TAG_REQUEST_PARTICLE, MPI_COMM_WORLD, & 00437 status, ierr) 00438 call pmc_mpi_check_ierr(ierr) 00439 call assert(920139874, status(MPI_TAG) & 00440 == COAG_DIST_TAG_REQUEST_PARTICLE) 00441 call mpi_get_count(status, MPI_CHARACTER, buffer_size, ierr) 00442 call pmc_mpi_check_ierr(ierr) 00443 call assert(190658659, buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00444 remote_proc = status(MPI_SOURCE) 00445 00446 ! unpack it 00447 position = 0 00448 call pmc_mpi_unpack_integer(buffer, position, request_bin) 00449 call assert(895128380, position == buffer_size) 00450 00451 ! send the particle back if we have one 00452 if (aero_state%bin(request_bin)%n_part == 0) then 00453 call send_return_no_particle(remote_proc, request_bin) 00454 else 00455 call aero_particle_allocate(aero_particle) 00456 call aero_state_remove_rand_particle_from_bin(aero_state, & 00457 request_bin, aero_particle) 00458 call send_return_req_particle(aero_particle, request_bin, & 00459 remote_proc) 00460 call aero_particle_deallocate(aero_particle) 00461 end if 00462 #endif 00463 00464 end subroutine recv_request_particle 00465 00466 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00467 00468 subroutine send_return_no_particle(dest_proc, i_bin) 00469 00470 !> Process number to send message to. 00471 integer, intent(in) :: dest_proc 00472 !> Bin number where there was no particle. 00473 integer, intent(in) :: i_bin 00474 00475 #ifdef PMC_USE_MPI 00476 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00477 integer :: buffer_size, max_buffer_size, position, ierr 00478 00479 max_buffer_size = 0 00480 max_buffer_size = max_buffer_size + pmc_mpi_pack_size_integer(i_bin) 00481 call assert(744787119, max_buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00482 position = 0 00483 call pmc_mpi_pack_integer(buffer, position, i_bin) 00484 call assert(445960340, position <= max_buffer_size) 00485 buffer_size = position 00486 call mpi_bsend(buffer, buffer_size, MPI_CHARACTER, dest_proc, & 00487 COAG_DIST_TAG_RETURN_NO_PARTICLE, MPI_COMM_WORLD, ierr) 00488 call pmc_mpi_check_ierr(ierr) 00489 #endif 00490 00491 end subroutine send_return_no_particle 00492 00493 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00494 00495 subroutine recv_return_no_particle(requests, bin_grid, & 00496 aero_data, aero_state) 00497 00498 !> Array of outstanding requests. 00499 type(request_t), intent(inout) :: requests(COAG_DIST_MAX_REQUESTS) 00500 !> Bin grid. 00501 type(bin_grid_t), intent(in) :: bin_grid 00502 !> Aerosol data. 00503 type(aero_data_t), intent(in) :: aero_data 00504 !> Aerosol state. 00505 type(aero_state_t), intent(inout) :: aero_state 00506 00507 #ifdef PMC_USE_MPI 00508 logical :: found_request 00509 integer :: buffer_size, position, sent_bin, sent_proc, i_req, ierr 00510 integer :: status(MPI_STATUS_SIZE) 00511 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00512 00513 ! get the message 00514 call mpi_recv(buffer, COAG_DIST_MAX_BUFFER_SIZE, MPI_CHARACTER, & 00515 MPI_ANY_SOURCE, COAG_DIST_TAG_RETURN_NO_PARTICLE, & 00516 MPI_COMM_WORLD, status, ierr) 00517 call pmc_mpi_check_ierr(ierr) 00518 call assert(918153221, status(MPI_TAG) & 00519 == COAG_DIST_TAG_RETURN_NO_PARTICLE) 00520 call mpi_get_count(status, MPI_CHARACTER, buffer_size, ierr) 00521 call pmc_mpi_check_ierr(ierr) 00522 call assert(461111487, buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00523 sent_proc = status(MPI_SOURCE) 00524 00525 ! unpack it 00526 position = 0 00527 call pmc_mpi_unpack_integer(buffer, position, sent_bin) 00528 call assert(518172999, position == buffer_size) 00529 00530 ! find the matching request 00531 found_request = .false. 00532 do i_req = 1,COAG_DIST_MAX_REQUESTS 00533 if ((requests(i_req)%remote_proc == sent_proc) & 00534 .and. (requests(i_req)%remote_bin == sent_bin)) then 00535 found_request = .true. 00536 exit 00537 end if 00538 end do 00539 call assert(215612776, found_request) 00540 00541 ! we can't do coagulation with the local particle, so store it back 00542 call aero_state_add_particle(aero_state, requests(i_req)%local_bin, & 00543 requests(i_req)%local_aero_particle) 00544 call request_deallocate(requests(i_req)) 00545 call request_allocate(requests(i_req)) 00546 #endif 00547 00548 end subroutine recv_return_no_particle 00549 00550 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00551 00552 subroutine send_return_req_particle(aero_particle, i_bin, dest_proc) 00553 00554 !> Aero particle to send. 00555 type(aero_particle_t), intent(in) :: aero_particle 00556 !> Bin that the particle is in. 00557 integer, intent(in) :: i_bin 00558 !> Process number to send particle to. 00559 integer, intent(in) :: dest_proc 00560 00561 #ifdef PMC_USE_MPI 00562 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00563 integer :: buffer_size, max_buffer_size, position, ierr 00564 00565 max_buffer_size = 0 00566 max_buffer_size = max_buffer_size + pmc_mpi_pack_size_integer(i_bin) 00567 max_buffer_size = max_buffer_size & 00568 + pmc_mpi_pack_size_aero_particle(aero_particle) 00569 call assert(496283814, max_buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00570 position = 0 00571 call pmc_mpi_pack_integer(buffer, position, i_bin) 00572 call pmc_mpi_pack_aero_particle(buffer, position, aero_particle) 00573 call assert(263666386, position <= max_buffer_size) 00574 buffer_size = position 00575 call mpi_bsend(buffer, buffer_size, MPI_CHARACTER, dest_proc, & 00576 COAG_DIST_TAG_RETURN_REQ_PARTICLE, MPI_COMM_WORLD, ierr) 00577 call pmc_mpi_check_ierr(ierr) 00578 #endif 00579 00580 end subroutine send_return_req_particle 00581 00582 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00583 00584 subroutine recv_return_req_particle(requests, bin_grid, env_state, & 00585 aero_data, aero_weight, aero_state, accept_factors, coag_kernel_type, & 00586 tot_n_coag, comp_vols) 00587 00588 !> Array of outstanding requests. 00589 type(request_t), intent(inout) :: requests(COAG_DIST_MAX_REQUESTS) 00590 !> Bin grid. 00591 type(bin_grid_t), intent(in) :: bin_grid 00592 !> Environment state. 00593 type(env_state_t), intent(in) :: env_state 00594 !> Aerosol weight. 00595 type(aero_weight_t), intent(in) :: aero_weight 00596 !> Aerosol data. 00597 type(aero_data_t), intent(in) :: aero_data 00598 !> Aerosol state. 00599 type(aero_state_t), intent(inout) :: aero_state 00600 !> Accept scale factors per bin pair (1). 00601 real(kind=dp), intent(out) :: 00602 accept_factors(bin_grid%n_bin,bin_grid%n_bin) 00603 !> Coagulation kernel type. 00604 integer, intent(in) :: coag_kernel_type 00605 !> Number of coagulation events. 00606 integer, intent(inout) :: tot_n_coag 00607 !> Computational volumes on all processes. 00608 real(kind=dp), intent(in) :: comp_vols(:) 00609 00610 #ifdef PMC_USE_MPI 00611 logical :: found_request, remove_1, remove_2 00612 integer :: buffer_size, position, sent_bin, sent_proc, i_req, ierr 00613 integer :: status(MPI_STATUS_SIZE) 00614 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00615 type(aero_particle_t) :: sent_aero_particle 00616 real(kind=dp) :: k, p 00617 00618 ! get the message 00619 call mpi_recv(buffer, COAG_DIST_MAX_BUFFER_SIZE, MPI_CHARACTER, & 00620 MPI_ANY_SOURCE, COAG_DIST_TAG_RETURN_REQ_PARTICLE, & 00621 MPI_COMM_WORLD, status, ierr) 00622 call pmc_mpi_check_ierr(ierr) 00623 call assert(133285061, status(MPI_TAG) & 00624 == COAG_DIST_TAG_RETURN_REQ_PARTICLE) 00625 call mpi_get_count(status, MPI_CHARACTER, buffer_size, ierr) 00626 call pmc_mpi_check_ierr(ierr) 00627 call assert(461111487, buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00628 sent_proc = status(MPI_SOURCE) 00629 00630 ! unpack it 00631 position = 0 00632 call pmc_mpi_unpack_integer(buffer, position, sent_bin) 00633 call aero_particle_allocate(sent_aero_particle) 00634 call pmc_mpi_unpack_aero_particle(buffer, position, sent_aero_particle) 00635 call assert(753356021, position == buffer_size) 00636 00637 ! find the matching request 00638 found_request = .false. 00639 do i_req = 1,COAG_DIST_MAX_REQUESTS 00640 if ((requests(i_req)%remote_proc == sent_proc) & 00641 .and. (requests(i_req)%remote_bin == sent_bin)) then 00642 found_request = .true. 00643 exit 00644 end if 00645 end do 00646 call assert(579308475, found_request) 00647 00648 ! maybe do coagulation 00649 call weighted_kernel(coag_kernel_type, & 00650 requests(i_req)%local_aero_particle, & 00651 sent_aero_particle, aero_data, aero_weight, env_state, k) 00652 p = k * accept_factors(requests(i_req)%local_bin, sent_bin) 00653 00654 if (pmc_random() .lt. p) then 00655 ! coagulation happened, do it 00656 tot_n_coag = tot_n_coag + 1 00657 call coagulate_dist(bin_grid, aero_data, aero_weight, & 00658 aero_state, requests(i_req)%local_aero_particle, & 00659 sent_aero_particle, sent_proc, comp_vols, remove_1, remove_2) 00660 else 00661 remove_1 = .false. 00662 remove_2 = .false. 00663 end if 00664 00665 ! send the particles back 00666 if (.not. remove_1) then 00667 call aero_state_add_particle(aero_state, requests(i_req)%local_bin, & 00668 requests(i_req)%local_aero_particle) 00669 end if 00670 if (.not. remove_2) then 00671 call send_return_unreq_particle(sent_aero_particle, sent_proc) 00672 end if 00673 00674 call request_deallocate(requests(i_req)) 00675 call request_allocate(requests(i_req)) 00676 call aero_particle_deallocate(sent_aero_particle) 00677 #endif 00678 00679 end subroutine recv_return_req_particle 00680 00681 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00682 00683 subroutine send_return_unreq_particle(aero_particle, dest_proc) 00684 00685 !> Aero particle to send. 00686 type(aero_particle_t), intent(in) :: aero_particle 00687 !> Process to send the particle to. 00688 integer, intent(in) :: dest_proc 00689 00690 #ifdef PMC_USE_MPI 00691 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00692 integer :: buffer_size, max_buffer_size, position, ierr 00693 00694 max_buffer_size = 0 00695 max_buffer_size = max_buffer_size & 00696 + pmc_mpi_pack_size_aero_particle(aero_particle) 00697 call assert(414990602, max_buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00698 position = 0 00699 call pmc_mpi_pack_aero_particle(buffer, position, aero_particle) 00700 call assert(898537822, position <= max_buffer_size) 00701 buffer_size = position 00702 call mpi_bsend(buffer, buffer_size, MPI_CHARACTER, dest_proc, & 00703 COAG_DIST_TAG_RETURN_UNREQ_PARTICLE, MPI_COMM_WORLD, ierr) 00704 call pmc_mpi_check_ierr(ierr) 00705 #endif 00706 00707 end subroutine send_return_unreq_particle 00708 00709 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00710 00711 subroutine recv_return_unreq_particle(aero_state, bin_grid) 00712 00713 !> Aerosol state. 00714 type(aero_state_t), intent(inout) :: aero_state 00715 !> Bin grid. 00716 type(bin_grid_t), intent(in) :: bin_grid 00717 00718 #ifdef PMC_USE_MPI 00719 logical :: found_request 00720 integer :: buffer_size, position, sent_proc, ierr 00721 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00722 type(aero_particle_t) :: aero_particle 00723 integer :: i_bin, status(MPI_STATUS_SIZE), send_proc 00724 00725 ! get the message 00726 call mpi_recv(buffer, COAG_DIST_MAX_BUFFER_SIZE, MPI_CHARACTER, & 00727 MPI_ANY_SOURCE, COAG_DIST_TAG_RETURN_UNREQ_PARTICLE, & 00728 MPI_COMM_WORLD, status, ierr) 00729 call pmc_mpi_check_ierr(ierr) 00730 call assert(496247788, status(MPI_TAG) & 00731 == COAG_DIST_TAG_RETURN_UNREQ_PARTICLE) 00732 call mpi_get_count(status, MPI_CHARACTER, buffer_size, ierr) 00733 call pmc_mpi_check_ierr(ierr) 00734 call assert(590644042, buffer_size <= COAG_DIST_MAX_BUFFER_SIZE) 00735 sent_proc = status(MPI_SOURCE) 00736 00737 ! unpack it 00738 position = 0 00739 call aero_particle_allocate(aero_particle) 00740 call pmc_mpi_unpack_aero_particle(buffer, position, aero_particle) 00741 call assert(833588594, position == buffer_size) 00742 00743 ! put it back 00744 i_bin = aero_particle_in_bin(aero_particle, bin_grid) 00745 call aero_state_add_particle(aero_state, i_bin, aero_particle) 00746 call aero_particle_deallocate(aero_particle) 00747 #endif 00748 00749 end subroutine recv_return_unreq_particle 00750 00751 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00752 00753 !> Send a message saying that this process is finished with its 00754 !> coagulation. 00755 subroutine send_done(dest_proc) 00756 00757 !> Process to send the message to. 00758 integer, intent(in) :: dest_proc 00759 00760 #ifdef PMC_USE_MPI 00761 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00762 integer :: buffer_size, ierr 00763 00764 buffer_size = 0 00765 call mpi_bsend(buffer, buffer_size, MPI_CHARACTER, dest_proc, & 00766 COAG_DIST_TAG_DONE, MPI_COMM_WORLD, ierr) 00767 call pmc_mpi_check_ierr(ierr) 00768 #endif 00769 00770 end subroutine send_done 00771 00772 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00773 00774 !> Receive a done message. 00775 subroutine recv_done(procs_done) 00776 00777 !> Which processes are finished with coagulation. 00778 logical, intent(inout) :: procs_done(:) 00779 00780 #ifdef PMC_USE_MPI 00781 integer :: buffer_size, sent_proc, ierr 00782 character :: buffer(COAG_DIST_MAX_BUFFER_SIZE) 00783 integer :: status(MPI_STATUS_SIZE) 00784 00785 ! get the message 00786 call mpi_recv(buffer, COAG_DIST_MAX_BUFFER_SIZE, MPI_CHARACTER, & 00787 MPI_ANY_SOURCE, COAG_DIST_TAG_DONE, MPI_COMM_WORLD, & 00788 status, ierr) 00789 call pmc_mpi_check_ierr(ierr) 00790 call assert(348737947, status(MPI_TAG) & 00791 == COAG_DIST_TAG_DONE) 00792 call mpi_get_count(status, MPI_CHARACTER, buffer_size, ierr) 00793 call pmc_mpi_check_ierr(ierr) 00794 call assert(214904056, buffer_size == 0) 00795 sent_proc = status(MPI_SOURCE) 00796 00797 ! process it 00798 procs_done(sent_proc + 1) = .true. 00799 #endif 00800 00801 end subroutine recv_done 00802 00803 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00804 00805 !> Do an allgather to exchange number of particles and computational 00806 !> volume information between all processes. 00807 subroutine sync_info(local_n_parts, local_comp_vol, & 00808 global_n_parts, global_comp_vols) 00809 00810 !> Number of particles per bin on the local process. 00811 integer, intent(in) :: local_n_parts(:) 00812 !> Computational volume on the local process. 00813 real(kind=dp), intent(in) :: local_comp_vol 00814 !> Number of particles per bin on all processes. 00815 integer, intent(out) :: global_n_parts(:,:) 00816 !> Computational volumes on all processes (m^3). 00817 real(kind=dp), intent(out) :: global_comp_vols(:) 00818 00819 #ifdef PMC_USE_MPI 00820 integer :: n_bin, n_proc, ierr 00821 integer, allocatable :: send_buf(:), recv_buf(:) 00822 00823 n_bin = size(local_n_parts) 00824 n_proc = pmc_mpi_size() 00825 call assert(816230609, all(shape(global_n_parts) == (/n_bin, n_proc/))) 00826 call assert(883861456, all(shape(global_comp_vols) == (/n_proc/))) 00827 00828 ! use a new send_buf to make sure the memory is contiguous 00829 allocate(send_buf(n_bin)) 00830 allocate(recv_buf(n_bin * n_proc)) 00831 send_buf = local_n_parts 00832 call mpi_allgather(send_buf, n_bin, MPI_INTEGER, & 00833 recv_buf, n_bin, MPI_INTEGER, MPI_COMM_WORLD, ierr) 00834 call pmc_mpi_check_ierr(ierr) 00835 global_n_parts = reshape(recv_buf, (/n_bin, n_proc/)) 00836 deallocate(send_buf) 00837 deallocate(recv_buf) 00838 00839 call mpi_allgather(local_comp_vol, 1, MPI_REAL8, & 00840 global_comp_vols, 1, MPI_REAL8, MPI_COMM_WORLD, ierr) 00841 call pmc_mpi_check_ierr(ierr) 00842 00843 #endif 00844 00845 end subroutine sync_info 00846 00847 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00848 00849 !> generate the number of samples to do per bin pair. 00850 subroutine generate_n_samps(bin_grid, n_parts, comp_vols, del_t, & 00851 k_max, n_samps, accept_factors) 00852 00853 !> Bin grid. 00854 type(bin_grid_t), intent(in) :: bin_grid 00855 !> Number of particles per bin on all processes. 00856 integer, intent(in) :: n_parts(:,:) 00857 !> Computational volumes on all processes.. 00858 real(kind=dp), intent(in) :: comp_vols(:) 00859 !> Timestep. 00860 real(kind=dp), intent(in) :: del_t 00861 !> Maximum kernel. 00862 real(kind=dp), intent(in) :: k_max(bin_grid%n_bin,bin_grid%n_bin) 00863 !> Number of samples to do per bin pair. 00864 integer, intent(out) :: n_samps(bin_grid%n_bin,bin_grid%n_bin) 00865 !> Accept scale factors per bin pair (1). 00866 real(kind=dp), intent(out) :: 00867 accept_factors(bin_grid%n_bin,bin_grid%n_bin) 00868 00869 integer :: i, j, rank 00870 real(kind=dp) :: n_samp_real 00871 00872 rank = pmc_mpi_rank() 00873 do i = 1,bin_grid%n_bin 00874 do j = 1,bin_grid%n_bin 00875 call compute_n_samp(n_parts(i, rank + 1), & 00876 sum(n_parts(j,:)), i == j, k_max(i,j), & 00877 sum(comp_vols), del_t, n_samps(i,j), accept_factors(i,j)) 00878 end do 00879 end do 00880 00881 end subroutine generate_n_samps 00882 00883 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00884 00885 subroutine coagulate_dist(bin_grid, aero_data, aero_weight, & 00886 aero_state, aero_particle_1, aero_particle_2, remote_proc, & 00887 comp_vols, remove_1, remove_2) 00888 00889 !> Bin grid. 00890 type(bin_grid_t), intent(in) :: bin_grid 00891 !> Aerosol data. 00892 type(aero_data_t), intent(in) :: aero_data 00893 !> Aerosol weight. 00894 type(aero_weight_t), intent(in) :: aero_weight 00895 !> Aerosol state. 00896 type(aero_state_t), intent(inout) :: aero_state 00897 !> First particle to coagulate. 00898 type(aero_particle_t), intent(in) :: aero_particle_1 00899 !> Second particle to coagulate. 00900 type(aero_particle_t), intent(in) :: aero_particle_2 00901 !> Remote process that the particle came from. 00902 integer, intent(in) :: remote_proc 00903 !> Computational volumes on all processes (m^3). 00904 real(kind=dp), intent(in) :: comp_vols(:) 00905 !> Whether to remove aero_particle_1 after the coagulation. 00906 logical, intent(out) :: remove_1 00907 !> Whether to remove aero_particle_2 after the coagulation. 00908 logical, intent(out) :: remove_2 00909 00910 type(aero_particle_t) :: aero_particle_new 00911 integer :: proc_new 00912 type(aero_info_t) :: aero_info_1, aero_info_2 00913 logical :: create_new, id_1_lost, id_2_lost 00914 00915 call aero_particle_allocate(aero_particle_new) 00916 call aero_info_allocate(aero_info_1) 00917 call aero_info_allocate(aero_info_2) 00918 00919 call coagulate_weighting(aero_particle_1, aero_particle_2, & 00920 aero_particle_new, aero_data, aero_weight, remove_1, remove_2, & 00921 create_new, id_1_lost, id_2_lost, aero_info_1, aero_info_2) 00922 00923 if (id_1_lost) then 00924 call aero_info_array_add_aero_info(aero_state%aero_info_array, & 00925 aero_info_1) 00926 end if 00927 if (id_2_lost) then 00928 call aero_info_array_add_aero_info(aero_state%aero_info_array, & 00929 aero_info_2) 00930 end if 00931 00932 ! add new particle 00933 if (create_new) then 00934 proc_new = sample_cts_pdf(comp_vols) - 1 00935 call send_return_unreq_particle(aero_particle_new, proc_new) 00936 end if 00937 00938 call aero_particle_deallocate(aero_particle_new) 00939 call aero_info_deallocate(aero_info_1) 00940 call aero_info_deallocate(aero_info_2) 00941 00942 end subroutine coagulate_dist 00943 00944 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00945 00946 end module pmc_coagulation_dist