PartMC
2.2.1
|
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