PartMC  2.2.1
integer_rmap.F90
Go to the documentation of this file.
00001 ! Copyright (C) 2011-2012 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_integer_rmap module.
00007 
00008 !> The integer_rmap_t structure and assocated subroutines.
00009 module pmc_integer_rmap
00010 
00011   use pmc_integer_varray
00012   use pmc_util
00013   use pmc_mpi
00014 
00015   !> A map from integers to integers, together with its multi-valued
00016   !> inverse.
00017   !!
00018   !! The forward map takes integer \f$i\f$ in the domain
00019   !! 1,...,n_domain to an integer \f$j\f$ in the range
00020   !! 1,...,n_range. This is stored with <tt>j =
00021   !! integer_rmap%forward%entry(i)</tt>. This map will generally not be
00022   !! one-to-one or onto.
00023   !!
00024   !! The inverse map is multi-valued, with
00025   !! <tt>integer_rmap%inverse(j)</tt> containing all the inverses of
00026   !! \f$j\f$. The entries in the inverse map are given by
00027   !! <tt>inverse_rmap%index</tt>. The relationships between
00028   !! the forward and reverse maps are as follows.
00029   !!
00030   !! Given \f$i\f$, let:
00031   !! <pre>
00032   !! j = integer_rmap%forward%entry(i)
00033   !! k = integer_rmap%index%entry(i)
00034   !! </pre>
00035   !! Then:
00036   !! <pre>
00037   !! integer_rmap%inverse(j)%entry(k) == i
00038   !! </pre>
00039   !!
00040   !! Alternatively, given \f$j\f$ and \f$k\f$, let:
00041   !! <pre>
00042   !! i = integer_rmap%inverse(j)%entry(k)
00043   !! </pre>
00044   !! Then:
00045   !! <pre>
00046   !! integer_rmap%forward%entry(i) == j
00047   !! integer_rmap%index%entry(i) == k
00048   !! </pre>
00049   type integer_rmap_t
00050      !> Forward map (single valued).
00051      type(integer_varray_t) :: forward
00052      !> Inverse map (multi-valued).
00053      type(integer_varray_t), allocatable :: inverse(:)
00054      !> Forward map to inverse map entries (single valued).
00055      type(integer_varray_t) :: index
00056   end type integer_rmap_t
00057 
00058 contains
00059 
00060 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00061 
00062   !> Allocates an empty structure.
00063   elemental subroutine integer_rmap_allocate(integer_rmap)
00064 
00065     !> Structure to initialize.
00066     type(integer_rmap_t), intent(out) :: integer_rmap
00067 
00068     call integer_varray_allocate(integer_rmap%forward)
00069     allocate(integer_rmap%inverse(0))
00070     call integer_varray_allocate(integer_rmap%index)
00071 
00072   end subroutine integer_rmap_allocate
00073   
00074 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00075 
00076   !> Allocates a structure with the given size.
00077   elemental subroutine integer_rmap_allocate_size(integer_rmap, n_range)
00078 
00079     !> Structure to initialize.
00080     type(integer_rmap_t), intent(out) :: integer_rmap
00081     !> Size of range space.
00082     integer, intent(in) :: n_range
00083 
00084     call integer_varray_allocate(integer_rmap%forward)
00085     allocate(integer_rmap%inverse(n_range))
00086     call integer_varray_allocate(integer_rmap%inverse)
00087     call integer_varray_allocate(integer_rmap%index)
00088 
00089   end subroutine integer_rmap_allocate_size
00090   
00091 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00092 
00093   !> Deallocates a previously allocated structure.
00094   elemental subroutine integer_rmap_deallocate(integer_rmap)
00095 
00096     !> Structure to deallocate.
00097     type(integer_rmap_t), intent(inout) :: integer_rmap
00098     
00099     call integer_varray_deallocate(integer_rmap%forward)
00100     call integer_varray_deallocate(integer_rmap%inverse)
00101     deallocate(integer_rmap%inverse)
00102     call integer_varray_deallocate(integer_rmap%index)
00103 
00104   end subroutine integer_rmap_deallocate
00105   
00106 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00107 
00108   !> Resets an integer_rmap to have zero particles per bin.
00109   elemental subroutine integer_rmap_zero(integer_rmap)
00110 
00111     !> Structure to zero.
00112     type(integer_rmap_t), intent(inout) :: integer_rmap
00113 
00114     call integer_varray_zero(integer_rmap%forward)
00115     call integer_varray_zero(integer_rmap%inverse)
00116     call integer_varray_zero(integer_rmap%index)
00117 
00118   end subroutine integer_rmap_zero
00119   
00120 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00121 
00122   !> Set the map value of the next free domain value to \c i_range.
00123   subroutine integer_rmap_append(integer_rmap, i_range)
00124 
00125     !> Map to append to.
00126     type(integer_rmap_t), intent(inout) :: integer_rmap
00127     !> Range value.
00128     integer, intent(in) :: i_range
00129 
00130     call assert(549740445, i_range >= 1)
00131     call assert(145872613, i_range <= size(integer_rmap%inverse))
00132 
00133     ! grow map by one element
00134     call integer_varray_append(integer_rmap%forward, i_range)
00135     call integer_varray_append(integer_rmap%inverse(i_range), &
00136          integer_rmap%forward%n_entry)
00137     call integer_varray_append(integer_rmap%index, &
00138          integer_rmap%inverse(i_range)%n_entry)
00139 
00140   end subroutine integer_rmap_append
00141 
00142 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00143 
00144   !> Change the map value of \c i_domain to \c i_range.
00145   subroutine integer_rmap_change(integer_rmap, i_domain, i_range)
00146 
00147     !> Map to change.
00148     type(integer_rmap_t), intent(inout) :: integer_rmap
00149     !> Domain value.
00150     integer, intent(in) :: i_domain
00151     !> Range value.
00152     integer, intent(in) :: i_range
00153 
00154     integer :: i_range_old, i_index_old, i_domain_shifted
00155 
00156     call assert(709581778, i_domain >= 1)
00157     call assert(494892311, i_domain <= integer_rmap%forward%n_entry)
00158 
00159     call assert(590911054, i_range >= 1)
00160     call assert(859774512, i_range <= size(integer_rmap%inverse))
00161 
00162     i_range_old = integer_rmap%forward%entry(i_domain)
00163     if (i_range_old == i_range) return
00164     i_index_old = integer_rmap%index%entry(i_domain)
00165 
00166     ! remove the old inverse map
00167     call integer_varray_remove_entry(integer_rmap%inverse(i_range_old), &
00168          i_index_old)
00169     if (i_index_old <= integer_rmap%inverse(i_range_old)%n_entry) then
00170        ! the removed entry wasn't the last one, so the last entry
00171        ! was moved and needs fixing
00172        i_domain_shifted = integer_rmap%inverse(i_range_old)%entry(i_index_old)
00173        integer_rmap%index%entry(i_domain_shifted) = i_index_old
00174     end if
00175 
00176     ! set the new map and inverse
00177     integer_rmap%forward%entry(i_domain) = i_range
00178     call integer_varray_append(integer_rmap%inverse(i_range), i_domain)
00179     integer_rmap%index%entry(i_domain) = integer_rmap%inverse(i_range)%n_entry
00180 
00181   end subroutine integer_rmap_change
00182 
00183 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00184 
00185   !> Replace the map at the given \c i_domain with the map value of
00186   !> the last entry, and delete the last entry.
00187   subroutine integer_rmap_remove(integer_rmap, i_domain)
00188 
00189     !> Map to remove from.
00190     type(integer_rmap_t), intent(inout) :: integer_rmap
00191     !> Domain value to replace.
00192     integer, intent(in) :: i_domain
00193 
00194     integer :: i_range_old, i_index_old, i_domain_shifted, i_range_fix
00195     integer :: i_index_fix, i_domain_fix
00196 
00197     call assert(745161821, i_domain >= 1)
00198     call assert(143043782, i_domain <= integer_rmap%forward%n_entry)
00199 
00200     ! Deleting particles shifts the end particles into the empty slots
00201     ! in the aero_particle_array and the aero_sorted forward and
00202     ! reverse indexes. All must be fixed in the right order to
00203     ! maintain consistency.
00204 
00205     i_range_old = integer_rmap%forward%entry(i_domain)
00206     i_index_old = integer_rmap%index%entry(i_domain)
00207 
00208     i_domain_shifted = integer_rmap%forward%n_entry ! old loc of shifted value
00209     if (i_domain_shifted /= i_domain) then
00210        i_range_fix = integer_rmap%forward%entry(i_domain_shifted)
00211        i_index_fix = integer_rmap%index%entry(i_domain_shifted)
00212        integer_rmap%inverse(i_range_fix)%entry(i_index_fix) = i_domain
00213     end if
00214 
00215     ! remove the particle from the forward map (with the side effect
00216     ! of fixing the forward map for the shifted value)
00217     call integer_varray_remove_entry(integer_rmap%forward, i_domain)
00218     call integer_varray_remove_entry(integer_rmap%index, i_domain)
00219 
00220     ! remove the inverse map
00221     i_index_fix = integer_rmap%inverse(i_range_old)%n_entry
00222     i_domain_fix = integer_rmap%inverse(i_range_old)%entry(i_index_fix)
00223     call integer_varray_remove_entry(integer_rmap%inverse(i_range_old), &
00224          i_index_old)
00225 
00226     if (i_index_fix /= i_index_old) then
00227        ! fix index map
00228        integer_rmap%index%entry(i_domain_fix) = i_index_old
00229     end if
00230 
00231   end subroutine integer_rmap_remove
00232 
00233 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00234 
00235   !> Check that the data is consistent.
00236   subroutine integer_rmap_check(integer_rmap, name, n_domain, n_range, &
00237        continue_on_error)
00238 
00239     !> Structure to check.
00240     type(integer_rmap_t) :: integer_rmap
00241     !> Check name.
00242     character(len=*), intent(in) :: name
00243     !> Number of domain items.
00244     integer, intent(in) :: n_domain
00245     !> Number of image items.
00246     integer, intent(in) :: n_range
00247     !> Whether to continue despite error.
00248     logical, intent(in) :: continue_on_error
00249 
00250     integer :: i_domain, i_range, i_index
00251 
00252     if ((n_domain /= integer_rmap%forward%n_entry) &
00253          .or. (n_domain /= integer_rmap%index%n_entry) &
00254          .or. (n_range /= size(integer_rmap%inverse))) then
00255        write(0,*) 'ERROR integer_rmap A:', name
00256        write(0,*) 'n_domain', n_domain
00257        write(0,*) 'n_range', n_range
00258        write(0,*) 'integer_rmap%forward%n_entry', integer_rmap%forward%n_entry
00259        write(0,*) 'integer_rmap%index%n_entry', integer_rmap%index%n_entry
00260        write(0,*) 'size(integer_rmap%inverse)', size(integer_rmap%inverse)
00261        call assert(973643016, continue_on_error)
00262     end if
00263 
00264     do i_domain = 1,n_domain
00265        i_range = integer_rmap%forward%entry(i_domain)
00266        if ((i_range < 1) .or. (i_range > n_range)) then
00267           write(0,*) 'ERROR integer_rmap B:', name
00268           write(0,*) 'i_domain', i_domain
00269           write(0,*) 'i_range', i_range
00270           write(0,*) 'n_range', n_range
00271           call assert(798857945, continue_on_error)
00272        end if
00273 
00274        i_index = integer_rmap%index%entry(i_domain)
00275        if ((i_index < 1) &
00276             .or. (i_index > integer_rmap%inverse(i_range)%n_entry)) then
00277           write(0,*) 'ERROR integer_rmap C:', name
00278           write(0,*) 'i_domain', i_domain
00279           write(0,*) 'i_range', i_range
00280           write(0,*) 'i_index', i_index
00281           write(0,*) 'integer_rmap%inverse(i_range)%n_entry', &
00282                integer_rmap%inverse(i_range)%n_entry
00283           call assert(823748734, continue_on_error)
00284        end if
00285        if (i_domain /= integer_rmap%inverse(i_range)%entry(i_index)) then
00286           write(0,*) 'ERROR integer_rmap D:', name
00287           write(0,*) 'i_domain', i_domain
00288           write(0,*) 'i_range', i_range
00289           write(0,*) 'i_index', i_index
00290           write(0,*) 'integer_rmap%inverse(i_range)%entry(i_index)', &
00291                integer_rmap%inverse(i_range)%entry(i_index)
00292           call assert(735205557, continue_on_error)
00293        end if
00294     end do
00295 
00296     do i_range = 1,n_range
00297        do i_index = 1,integer_rmap%inverse(i_range)%n_entry
00298           i_domain = integer_rmap%inverse(i_range)%entry(i_index)
00299           if ((i_domain < 1) .or. (i_domain > n_domain)) then
00300              write(0,*) 'ERROR integer_rmap E:', name
00301              write(0,*) 'i_range', i_range
00302              write(0,*) 'i_index', i_index
00303              write(0,*) 'i_domain', i_domain
00304              write(0,*) 'n_domain', n_domain
00305              call assert(502643520, continue_on_error)
00306           end if
00307           if ((i_range /= integer_rmap%forward%entry(i_domain)) &
00308                .or. (i_index /= integer_rmap%index%entry(i_domain))) then
00309              write(0,*) 'ERROR integer_rmap F:', name
00310              write(0,*) 'i_domain', i_domain
00311              write(0,*) 'i_range', i_range
00312              write(0,*) 'integer_rmap%forward%entry(i_domain)', &
00313                   integer_rmap%forward%entry(i_domain)
00314              write(0,*) 'i_index', i_index
00315              write(0,*) 'integer_rmap%index%entry(i_domain)', &
00316                   integer_rmap%index%entry(i_domain)
00317              call assert(544747928, continue_on_error)
00318           end if
00319        end do
00320     end do
00321 
00322   end subroutine integer_rmap_check
00323 
00324 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00325 
00326   !> Determines the number of bytes required to pack the given value.
00327   integer function pmc_mpi_pack_size_integer_rmap(val)
00328 
00329     !> Value to pack.
00330     type(integer_rmap_t), intent(in) :: val
00331 
00332     integer :: i, total_size
00333 
00334     total_size = 0
00335     total_size = total_size + pmc_mpi_pack_size_integer(size(val%inverse))
00336     total_size = total_size + pmc_mpi_pack_size_integer_varray(val%forward)
00337     do i = 1,size(val%inverse)
00338        total_size = total_size &
00339             + pmc_mpi_pack_size_integer_varray(val%inverse(i))
00340     end do
00341     total_size = total_size + pmc_mpi_pack_size_integer_varray(val%index)
00342     pmc_mpi_pack_size_integer_rmap = total_size
00343 
00344   end function pmc_mpi_pack_size_integer_rmap
00345 
00346 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00347 
00348   !> Packs the given value into the buffer, advancing position.
00349   subroutine pmc_mpi_pack_integer_rmap(buffer, position, val)
00350 
00351     !> Memory buffer.
00352     character, intent(inout) :: buffer(:)
00353     !> Current buffer position.
00354     integer, intent(inout) :: position
00355     !> Value to pack.
00356     type(integer_rmap_t), intent(in) :: val
00357 
00358 #ifdef PMC_USE_MPI
00359     integer :: prev_position, i
00360 
00361     prev_position = position
00362     call pmc_mpi_pack_integer(buffer, position, size(val%inverse))
00363     call pmc_mpi_pack_integer_varray(buffer, position, val%forward)
00364     do i = 1,size(val%inverse)
00365        call pmc_mpi_pack_integer_varray(buffer, position, val%inverse(i))
00366     end do
00367     call pmc_mpi_pack_integer_varray(buffer, position, val%index)
00368     call assert(533568488, &
00369          position - prev_position <= pmc_mpi_pack_size_integer_rmap(val))
00370 #endif
00371 
00372   end subroutine pmc_mpi_pack_integer_rmap
00373 
00374 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00375 
00376   !> Unpacks the given value from the buffer, advancing position.
00377   subroutine pmc_mpi_unpack_integer_rmap(buffer, position, val)
00378 
00379     !> Memory buffer.
00380     character, intent(inout) :: buffer(:)
00381     !> Current buffer position.
00382     integer, intent(inout) :: position
00383     !> Value to pack.
00384     type(integer_rmap_t), intent(inout) :: val
00385 
00386 #ifdef PMC_USE_MPI
00387     integer :: prev_position, i, n
00388 
00389     prev_position = position
00390     call pmc_mpi_unpack_integer(buffer, position, n)
00391     call integer_rmap_deallocate(val)
00392     call integer_rmap_allocate_size(val, n)
00393     call pmc_mpi_unpack_integer_varray(buffer, position, val%forward)
00394     do i = 1,size(val%inverse)
00395        call pmc_mpi_unpack_integer_varray(buffer, position, val%inverse(i))
00396     end do
00397     call pmc_mpi_unpack_integer_varray(buffer, position, val%index)
00398     call assert(663161025, &
00399          position - prev_position <= pmc_mpi_pack_size_integer_rmap(val))
00400 #endif
00401 
00402   end subroutine pmc_mpi_unpack_integer_rmap
00403 
00404 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00405   
00406 end module pmc_integer_rmap