FrontISTR 5.2.0
Large-scale structural analysis program with finit element method
Loading...
Searching...
No Matches
bucket_search.f90
Go to the documentation of this file.
1!-------------------------------------------------------------------------------
2! Copyright (c) 2019 FrontISTR Commons
3! This software is released under the MIT License, see LICENSE.txt
4!-------------------------------------------------------------------------------
8 use hecmw
9 implicit none
10
11 private
12 public :: bucketdb
13 public :: bucketdb_init
14 public :: bucketdb_finalize
15 public :: bucketdb_setup
16 public :: bucketdb_getbucketid
17 public :: bucketdb_registerpre
18 public :: bucketdb_allocate
19 public :: bucketdb_register
20 public :: bucketdb_getnumcand
21 public :: bucketdb_getcand
22
23 integer(kind=kint), parameter :: DEBUG = 0
24
26 type bucket
27 integer(kind=kint) :: n
28 integer(kind=kint) :: n_max
29 integer(kind=kint), pointer :: member(:) => null()
30 end type bucket
31
34 private
35 real(kind=kreal) :: x_min(3)
36 real(kind=kreal) :: x_max(3)
37 real(kind=kreal) :: d(3)
38 integer(kind=kint) :: ndiv(3)
39 type(bucket), pointer :: buckets(:,:,:) => null()
40 integer(kind=kint) :: n_tot
41 integer(kind=kint), pointer :: member_all(:) => null()
42 end type bucketdb
43
44contains
45
47 subroutine assert(cond, mesg)
48 implicit none
49 logical, intent(in) :: cond
50 character(len=*) :: mesg
51 if (debug > 0) then
52 if (.not. cond) then
53 write(0,*) 'ASSERTION FAILED: ',mesg
54 call hecmw_abort( hecmw_comm_get_comm() )
55 endif
56 endif
57 end subroutine assert
58
59!!!
60!!! routines for type(bucket)
61!!!
62
64 subroutine bucket_init(bkt)
65 implicit none
66 type(bucket), intent(inout) :: bkt
67 bkt%n = 0
68 bkt%n_max = 0
69 nullify(bkt%member)
70 end subroutine bucket_init
71
73 subroutine bucket_finalize(bkt)
74 implicit none
75 type(bucket), intent(inout) :: bkt
76 !if (bkt%n > 0) deallocate(bkt%member)
77 nullify(bkt%member)
78 bkt%n = 0
79 bkt%n_max = 0
80 end subroutine bucket_finalize
81
83 subroutine bucket_incr_count(bkt)
84 implicit none
85 type(bucket), intent(inout) :: bkt
86 !$omp atomic
87 bkt%n = bkt%n + 1
88 end subroutine bucket_incr_count
89
91 subroutine bucket_assign(bkt, mem)
92 implicit none
93 type(bucket), intent(inout) :: bkt
94 integer(kind=kint), pointer :: mem(:)
95 bkt%member => mem
96 bkt%n_max = bkt%n
97 bkt%n = 0
98 end subroutine bucket_assign
99
101 subroutine bucket_register(bkt, sid)
102 implicit none
103 type(bucket), intent(inout) :: bkt
104 integer(kind=kint), intent(in) :: sid
105 integer(kind=kint) :: idx
106 !$omp atomic capture
107 bkt%n = bkt%n + 1
108 idx = bkt%n
109 !$omp end atomic
110 call assert(idx <= bkt%n_max, 'bucket_register: too many members')
111 bkt%member(idx) = sid
112 end subroutine bucket_register
113
115 function bucket_get_n(bkt)
116 implicit none
117 integer(kind=kint) :: bucket_get_n
118 type(bucket), intent(in) :: bkt
119 bucket_get_n = bkt%n
120 end function bucket_get_n
121
123 subroutine bucket_get_member(bkt, n, memb)
124 implicit none
125 type(bucket), intent(in) :: bkt
126 integer(kind=kint), intent(in) :: n
127 integer(kind=kint), intent(out) :: memb(n)
128 call assert(n == bkt%n, 'bucket_get_member: wrong n')
129 memb(1:n) = bkt%member(1:n)
130 end subroutine bucket_get_member
131
132!!!
133!!! routines for type(bucketDB)
134!!!
135
137 subroutine bucketdb_init(bktdb)
138 implicit none
139 type(bucketdb), intent(inout) :: bktdb
140 bktdb%x_min(:) = 0.d0
141 bktdb%x_max(:) = 0.d0
142 bktdb%d(:) = 0.d0
143 bktdb%ndiv(:) = 0
144 nullify(bktdb%buckets)
145 bktdb%n_tot = 0
146 nullify(bktdb%member_all)
147 end subroutine bucketdb_init
148
150 subroutine bucketdb_finalize(bktdb)
151 implicit none
152 type(bucketdb), intent(inout) :: bktdb
153 integer(kind=kint) :: i, j, k
154 if (bktdb%n_tot > 0) then
155 deallocate(bktdb%member_all)
156 bktdb%n_tot = 0
157 endif
158 if (any(bktdb%ndiv == 0)) then
159 bktdb%ndiv(:) = 0
160 return
161 endif
162 do k = 1, bktdb%ndiv(3)
163 do j = 1, bktdb%ndiv(2)
164 do i = 1, bktdb%ndiv(1)
165 call bucket_finalize(bktdb%buckets(i,j,k))
166 enddo
167 enddo
168 enddo
169 deallocate(bktdb%buckets)
170 bktdb%ndiv(:) = 0
171 end subroutine bucketdb_finalize
172
174 subroutine bucketdb_setup(bktdb, x_min, x_max, dmin, n_tot)
175 implicit none
176 type(bucketdb), intent(inout) :: bktdb
177 real(kind=kreal), intent(in) :: x_min(3)
178 real(kind=kreal), intent(in) :: x_max(3)
179 real(kind=kreal), intent(in) :: dmin
180 integer(kind=kint), intent(in) :: n_tot
181 real(kind=kreal) :: xrange(3)
182 integer(kind=kint) :: i, j, k
183 real(kind=kreal), parameter :: eps = 1.d-6
184 if (debug >= 1) write(0,*) 'DEBUG: bucketDB_setup', x_min, x_max, dmin, n_tot
185 if (associated(bktdb%buckets)) deallocate(bktdb%buckets)
186 bktdb%x_min(:) = x_min(:)
187 bktdb%x_max(:) = x_max(:)
188 xrange(:) = x_max(:) - x_min(:)
189 call assert(all(xrange > 0.d0), 'bucketDB_setup: invalid x_min, x_max')
190 do i = 1, 3
191 bktdb%ndiv(i) = max(floor(xrange(i) / dmin), 1)
192 bktdb%d(i) = xrange(i) / bktdb%ndiv(i) * (1.d0 + eps)
193 enddo
194 if (debug >= 1) write(0,*) 'DEBUG: bucketDB_setup: ndiv, d: ', bktdb%ndiv, bktdb%d
195 call assert(all(bktdb%d > 0.d0), 'bucketDB_setup: invalid bktdb%d')
196 allocate(bktdb%buckets(bktdb%ndiv(1), bktdb%ndiv(2), bktdb%ndiv(3)))
197 do k = 1, bktdb%ndiv(3)
198 do j = 1, bktdb%ndiv(2)
199 do i = 1, bktdb%ndiv(1)
200 call bucket_init(bktdb%buckets(i,j,k))
201 enddo
202 enddo
203 enddo
204 if (bktdb%n_tot /= n_tot) then
205 if (associated(bktdb%member_all)) deallocate(bktdb%member_all)
206 allocate(bktdb%member_all(n_tot))
207 bktdb%n_tot = n_tot
208 endif
209 end subroutine bucketdb_setup
210
212 function encode_bid(bktdb, baddr)
213 implicit none
214 integer(kind=kint) :: encode_bid
215 type(bucketdb), intent(in) :: bktdb
216 integer(kind=kint), intent(in) :: baddr(3)
217 if (any(baddr <= 0) .or. any(baddr > bktdb%ndiv)) then
218 encode_bid = -1
219 else
220 encode_bid = &
221 (baddr(3)-1) * bktdb%ndiv(1) * bktdb%ndiv(2) + (baddr(2)-1) * bktdb%ndiv(1) + baddr(1)
222 endif
223 end function encode_bid
224
226 function decode_bid(bktdb, bid)
227 implicit none
228 integer(kind=kint) :: decode_bid(3)
229 type(bucketdb), intent(in) :: bktdb
230 integer(kind=kint), intent(in) :: bid
231 call assert(bid <= bktdb%ndiv(1)*bktdb%ndiv(2)*bktdb%ndiv(3), 'decode_bid: out of range')
232 if (bid < 0) then
233 decode_bid(:) = -1
234 else
235 decode_bid(1) = mod(bid-1, bktdb%ndiv(1)) + 1
236 decode_bid(2) = mod((bid-1)/bktdb%ndiv(1), bktdb%ndiv(2)) + 1
237 decode_bid(3) = (bid-1)/(bktdb%ndiv(1) * bktdb%ndiv(2)) + 1
238 call assert(encode_bid(bktdb, decode_bid) == bid, 'decode_bid')
239 endif
240 end function decode_bid
241
243 function bucketdb_getbucketid(bktdb, x)
244 implicit none
245 integer(kind=kint) :: bucketdb_getbucketid
246 type(bucketdb), intent(in) :: bktdb
247 real(kind=kreal), intent(in) :: x(3)
248 integer(kind=kint) :: baddr(3)
249 integer(kind=kint) :: i
250 if (bktdb%n_tot == 0) then
252 return
253 endif
254 do i = 1, 3
255 call assert(bktdb%d(i) > 0.d0, 'bucketDB_getBucketID: bktdb%d(i) is zero')
256 baddr(i) = floor((x(i) - bktdb%x_min(i)) / bktdb%d(i)) + 1
257 enddo
258 if (debug >= 2) write(0,*) ' DEBUG: bucketDB_getBucketID: ',x,baddr
259 bucketdb_getbucketid = encode_bid(bktdb, baddr)
260 end function bucketdb_getbucketid
261
264 subroutine bucketdb_registerpre(bktdb, bid)
265 implicit none
266 type(bucketdb), intent(inout) :: bktdb
267 integer(kind=kint), intent(in) :: bid
268 integer(kind=kint) :: baddr(3)
269 baddr = decode_bid(bktdb, bid)
270 call assert(all(baddr > 0) .and. all(baddr <= bktdb%ndiv), 'bucketDB_register_pre: block ID out of range')
271 call bucket_incr_count(bktdb%buckets(baddr(1),baddr(2),baddr(3)))
272 if (debug >= 2) write(0,*) ' DEBUG: bucketDB_registerPre: ', baddr
273 end subroutine bucketdb_registerpre
274
277 subroutine bucketdb_allocate(bktdb)
278 implicit none
279 type(bucketdb), intent(inout) :: bktdb
280 integer(kind=kint) :: i, j, k, count, n
281 integer(kind=kint), pointer :: pmemb(:)
282 count = 0
283 do k = 1, bktdb%ndiv(3)
284 do j = 1, bktdb%ndiv(2)
285 do i = 1, bktdb%ndiv(1)
286 !call bucket_allocate(bktdb%buckets(i,j,k))
287 n = bucket_get_n(bktdb%buckets(i,j,k))
288 pmemb => bktdb%member_all(count+1:count+n)
289 call bucket_assign(bktdb%buckets(i,j,k), pmemb)
290 count = count + n
291 enddo
292 enddo
293 enddo
294 end subroutine bucketdb_allocate
295
298 subroutine bucketdb_register(bktdb, bid, sid)
299 implicit none
300 type(bucketdb), intent(inout) :: bktdb
301 integer(kind=kint), intent(in) :: bid
302 integer(kind=kint), intent(in) :: sid
303 integer(kind=kint) :: baddr(3)
304 baddr = decode_bid(bktdb, bid)
305 call assert(all(baddr > 0) .and. all(baddr <= bktdb%ndiv), 'bucketDB_register: block ID our of range')
306 call bucket_register(bktdb%buckets(baddr(1),baddr(2),baddr(3)), sid)
307 if (debug >= 2) write(0,*) ' DEBUG: bucketDB_register: ', baddr, sid
308 end subroutine bucketdb_register
309
312 function bucketdb_getnumcand(bktdb, bid)
313 implicit none
314 integer(kind=kint) :: bucketdb_getnumcand
315 type(bucketdb), intent(in) :: bktdb
316 integer(kind=kint), intent(in) :: bid
317 integer(kind=kint) :: baddr(3), ncand, i, j, k, is, ie, js, je, ks, ke
318 if (bid < 0) then
320 return
321 endif
322 baddr = decode_bid(bktdb, bid)
323 ncand = 0
324 is = max(baddr(1)-1, 1)
325 ie = min(baddr(1)+1, bktdb%ndiv(1))
326 js = max(baddr(2)-1, 1)
327 je = min(baddr(2)+1, bktdb%ndiv(2))
328 ks = max(baddr(3)-1, 1)
329 ke = min(baddr(3)+1, bktdb%ndiv(3))
330 do k = ks, ke
331 do j = js, je
332 do i = is, ie
333 ncand = ncand + bucket_get_n(bktdb%buckets(i,j,k))
334 enddo
335 enddo
336 enddo
337 bucketdb_getnumcand = ncand
338 if (debug >= 2) write(0,*) ' DEBUG: bucketDB_getNumCand: ',ncand
339 end function bucketdb_getnumcand
340
343 subroutine bucketdb_getcand(bktdb, bid, ncand, cand)
344 implicit none
345 type(bucketdb), intent(in) :: bktdb
346 integer(kind=kint), intent(in) :: bid
347 integer(kind=kint), intent(in) :: ncand
348 integer(kind=kint), intent(out), target :: cand(ncand)
349 integer(kind=kint) :: baddr(3), i, j, k, n, cnt, is, ie, js, je, ks, ke
350 integer(kind=kint), pointer :: pcand(:)
351 if (bid < 0 .or. ncand == 0) return
352 baddr = decode_bid(bktdb, bid)
353 cnt = 0
354 is = max(baddr(1)-1, 1)
355 ie = min(baddr(1)+1, bktdb%ndiv(1))
356 js = max(baddr(2)-1, 1)
357 je = min(baddr(2)+1, bktdb%ndiv(2))
358 ks = max(baddr(3)-1, 1)
359 ke = min(baddr(3)+1, bktdb%ndiv(3))
360 do k = ks, ke
361 do j = js, je
362 do i = is, ie
363 n = bucket_get_n(bktdb%buckets(i,j,k))
364 pcand => cand(cnt+1:cnt+n)
365 call bucket_get_member(bktdb%buckets(i,j,k), n, pcand)
366 cnt = cnt + n
367 call assert(cnt <= ncand, 'bucketDB_get_cand: array overflow')
368 enddo
369 enddo
370 enddo
371 call assert(cnt == ncand, 'bucketDB_get_cand: count mismatch')
372 if (debug >= 3) write(0,*) ' DEBUG: bucketDB_getCand: ',cand
373 end subroutine bucketdb_getcand
374
375end module bucket_search
This module provides bucket-search functionality It provides definition of bucket info and its access...
subroutine, public bucketdb_allocate(bktdb)
Allocate memory before actually registering members Before allocating memory, bucketDB_registerPre ha...
subroutine, public bucketdb_registerpre(bktdb, bid)
Pre-register for just counting members to be actually registered Bucket ID has to be obtained with bu...
integer(kind=kint) function, public bucketdb_getbucketid(bktdb, x)
Get bucket ID that includes given point.
subroutine, public bucketdb_register(bktdb, bid, sid)
Register member Before actually register, bucketDB_allocate has to be called.
subroutine, public bucketdb_finalize(bktdb)
Finalizer.
subroutine assert(cond, mesg)
Assertion routine for debugging.
integer(kind=kint) function, public bucketdb_getnumcand(bktdb, bid)
Get number of candidates within neighboring buckets of a given bucket Bucket ID has to be obtained wi...
subroutine, public bucketdb_init(bktdb)
Initializer.
subroutine, public bucketdb_getcand(bktdb, bid, ncand, cand)
Get candidates within neighboring buckets of a given bucket Number of candidates has to be obtained w...
subroutine, public bucketdb_setup(bktdb, x_min, x_max, dmin, n_tot)
Setup basic info of buckets.
Definition: hecmw.f90:6
Structure for bucket search.