PartMC 2.1.2
coagulation_dist.F90
Go to the documentation of this file.
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