(git:6344619)
Loading...
Searching...
No Matches
dbt_split.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Routines to split blocks and to convert between tensors with different block sizes.
10!> \author Patrick Seewald
11! **************************************************************************************************
12MODULE dbt_split
13
14
15
16 USE dbt_allocate_wrap, ONLY: allocate_any
17 USE dbt_array_list_methods, ONLY: get_ith_array
18 USE dbt_block, ONLY: dbt_iterator_type, &
19 dbt_copy_block, &
20 dbt_get_block, &
21 dbt_put_block, &
22 dbt_iterator_start, &
23 dbt_iterator_num_blocks, &
24 dbt_iterator_blocks_left, &
25 dbt_iterator_stop, &
26 dbt_iterator_next_block, &
27 dbt_reserve_blocks
28 USE dbt_index, ONLY: dbt_get_mapping_info, &
29 dbt_inverse_order
30 USE dbt_types, ONLY: dbt_create, &
31 dbt_type, &
32 ndims_tensor, &
33 dbt_distribution_type, &
34 dbt_distribution, &
35 dbt_distribution_destroy, &
36 dbt_distribution_new_expert, &
37 dbt_clear, &
38 dbt_finalize, &
39 dbt_get_num_blocks, &
40 dbt_blk_offsets, &
41 dbt_blk_sizes, &
42 ndims_matrix_row, &
43 ndims_matrix_column, &
44 dbt_filter, &
45 dbt_copy_contraction_storage
46 USE kinds, ONLY: dp, dp
47
48#include "../base/base_uses.f90"
49 IMPLICIT NONE
50 PRIVATE
51 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbt_split'
52 PUBLIC :: &
53 dbt_make_compatible_blocks, &
54 dbt_split_blocks, &
55 dbt_split_blocks_generic, &
56 dbt_split_copyback, &
57 dbt_crop
58
59CONTAINS
60
61! **************************************************************************************************
62!> \brief Split tensor blocks into smaller blocks
63!> \param tensor_in Input tensor
64!> \param tensor_out Output tensor (splitted blocks)
65!> \param blk_size_i block sizes for each of the tensor dimensions
66!> \param nodata don't copy data from tensor_in to tensor_out
67!> \author Patrick Seewald
68! **************************************************************************************************
69 SUBROUTINE dbt_split_blocks_generic(tensor_in, tensor_out, blk_size_1, blk_size_2, blk_size_3, blk_size_4, nodata)
70 TYPE(dbt_type), INTENT(INOUT) :: tensor_in
71 TYPE(dbt_type), INTENT(OUT) :: tensor_out
72 INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: blk_size_1, blk_size_2, blk_size_3, blk_size_4
73 LOGICAL, INTENT(IN), OPTIONAL :: nodata
74
75 TYPE(dbt_distribution_type) :: dist_old, dist_split
76 TYPE(dbt_iterator_type) :: iter
77 INTEGER, DIMENSION(:), ALLOCATABLE :: nd_dist_split_1, nd_dist_split_2, nd_dist_split_3, nd_dist_split_4
78 INTEGER, DIMENSION(:), ALLOCATABLE :: nd_blk_size_split_1, nd_blk_size_split_2, nd_blk_size_split_3,&
79 & nd_blk_size_split_4
80 INTEGER, DIMENSION(:), ALLOCATABLE :: index_split_offset_1, index_split_offset_2, index_split_offset_3,&
81 & index_split_offset_4
82 INTEGER, DIMENSION(:), ALLOCATABLE :: inblock_offset_1, inblock_offset_2, inblock_offset_3, inblock_offset_4
83 INTEGER, DIMENSION(:), ALLOCATABLE :: blk_nsplit_1, blk_nsplit_2, blk_nsplit_3, blk_nsplit_4
84 INTEGER :: split_blk_1, split_blk_2, split_blk_3, split_blk_4
85 INTEGER :: idim, i, isplit_sum, nsplit, handle, splitsum, bcount
86 INTEGER, DIMENSION(:, :), ALLOCATABLE :: blks_to_allocate
87 INTEGER, DIMENSION(:), ALLOCATABLE :: dist_d, blk_size_d, blk_size_split_d, dist_split_d
88 INTEGER, DIMENSION(ndims_matrix_row(tensor_in)) :: map1_2d
89 INTEGER, DIMENSION(ndims_matrix_column(tensor_in)) :: map2_2d
90 INTEGER, DIMENSION(ndims_tensor(tensor_in)) :: blk_index, blk_size, blk_offset, &
91 blk_shape
92 INTEGER, DIMENSION(4) :: bi_split, inblock_offset
93 LOGICAL :: found
94
95 REAL(dp), DIMENSION(:,:), ALLOCATABLE :: block_2d
96 REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: block_3d
97 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: block_4d
98 CHARACTER(LEN=*), PARAMETER :: routinen = 'dbt_split_blocks_generic'
99
100 CALL timeset(routinen, handle)
101
102 dist_old = dbt_distribution(tensor_in)
103
104 DO idim = 1, ndims_tensor(tensor_in)
105 CALL get_ith_array(dist_old%nd_dist, idim, dist_d)
106 CALL get_ith_array(tensor_in%blk_sizes, idim, blk_size_d)
107
108 IF (idim == 1) THEN
109 ! split block index offset for each normal block index
110 ALLOCATE (index_split_offset_1(SIZE(dist_d)))
111 ! how many split blocks for each normal block index
112 ALLOCATE (blk_nsplit_1(SIZE(dist_d)))
113 ! data offset of split blocks w.r.t. corresponding normal block
114 ALLOCATE (inblock_offset_1(SIZE(blk_size_1)))
115 ALLOCATE (blk_size_split_d, source=blk_size_1)
116 END IF
117 IF (idim == 2) THEN
118 ! split block index offset for each normal block index
119 ALLOCATE (index_split_offset_2(SIZE(dist_d)))
120 ! how many split blocks for each normal block index
121 ALLOCATE (blk_nsplit_2(SIZE(dist_d)))
122 ! data offset of split blocks w.r.t. corresponding normal block
123 ALLOCATE (inblock_offset_2(SIZE(blk_size_2)))
124 ALLOCATE (blk_size_split_d, source=blk_size_2)
125 END IF
126 IF (idim == 3) THEN
127 ! split block index offset for each normal block index
128 ALLOCATE (index_split_offset_3(SIZE(dist_d)))
129 ! how many split blocks for each normal block index
130 ALLOCATE (blk_nsplit_3(SIZE(dist_d)))
131 ! data offset of split blocks w.r.t. corresponding normal block
132 ALLOCATE (inblock_offset_3(SIZE(blk_size_3)))
133 ALLOCATE (blk_size_split_d, source=blk_size_3)
134 END IF
135 IF (idim == 4) THEN
136 ! split block index offset for each normal block index
137 ALLOCATE (index_split_offset_4(SIZE(dist_d)))
138 ! how many split blocks for each normal block index
139 ALLOCATE (blk_nsplit_4(SIZE(dist_d)))
140 ! data offset of split blocks w.r.t. corresponding normal block
141 ALLOCATE (inblock_offset_4(SIZE(blk_size_4)))
142 ALLOCATE (blk_size_split_d, source=blk_size_4)
143 END IF
144
145 ! distribution vector for split blocks
146 ALLOCATE (dist_split_d(SIZE(blk_size_split_d)))
147
148 isplit_sum = 0 ! counting splits
149 DO i = 1, SIZE(blk_size_d)
150 nsplit = 0 ! number of splits for current normal block
151 splitsum = 0 ! summing split block sizes for current normal block
152 DO WHILE (splitsum < blk_size_d(i))
153 nsplit = nsplit + 1
154 isplit_sum = isplit_sum + 1
155 IF (idim == 1) inblock_offset_1(isplit_sum) = splitsum
156 IF (idim == 2) inblock_offset_2(isplit_sum) = splitsum
157 IF (idim == 3) inblock_offset_3(isplit_sum) = splitsum
158 IF (idim == 4) inblock_offset_4(isplit_sum) = splitsum
159 dist_split_d(isplit_sum) = dist_d(i)
160 splitsum = splitsum + blk_size_split_d(isplit_sum)
161 END DO
162 cpassert(splitsum == blk_size_d(i))
163 IF (idim == 1) THEN
164 blk_nsplit_1(i) = nsplit
165 index_split_offset_1(i) = isplit_sum - nsplit
166 END IF
167 IF (idim == 2) THEN
168 blk_nsplit_2(i) = nsplit
169 index_split_offset_2(i) = isplit_sum - nsplit
170 END IF
171 IF (idim == 3) THEN
172 blk_nsplit_3(i) = nsplit
173 index_split_offset_3(i) = isplit_sum - nsplit
174 END IF
175 IF (idim == 4) THEN
176 blk_nsplit_4(i) = nsplit
177 index_split_offset_4(i) = isplit_sum - nsplit
178 END IF
179 END DO
180
181 IF (idim == 1) THEN
182 ALLOCATE (nd_dist_split_1, source=dist_split_d)
183 ALLOCATE (nd_blk_size_split_1, source=blk_size_split_d)
184 END IF
185 IF (idim == 2) THEN
186 ALLOCATE (nd_dist_split_2, source=dist_split_d)
187 ALLOCATE (nd_blk_size_split_2, source=blk_size_split_d)
188 END IF
189 IF (idim == 3) THEN
190 ALLOCATE (nd_dist_split_3, source=dist_split_d)
191 ALLOCATE (nd_blk_size_split_3, source=blk_size_split_d)
192 END IF
193 IF (idim == 4) THEN
194 ALLOCATE (nd_dist_split_4, source=dist_split_d)
195 ALLOCATE (nd_blk_size_split_4, source=blk_size_split_d)
196 END IF
197 DEALLOCATE (dist_split_d)
198 DEALLOCATE (blk_size_split_d)
199
200 END DO
201
202 CALL dbt_get_mapping_info(tensor_in%nd_index_blk, map1_2d=map1_2d, map2_2d=map2_2d)
203
204 IF (ndims_tensor(tensor_in) == 2) THEN
205 CALL dbt_distribution_new_expert(dist_split, tensor_in%pgrid, map1_2d, map2_2d, &
206 nd_dist_split_1, nd_dist_split_2)
207 CALL dbt_create(tensor_out, tensor_in%name, dist_split, map1_2d, map2_2d, &
208 nd_blk_size_split_1, nd_blk_size_split_2)
209 END IF
210 IF (ndims_tensor(tensor_in) == 3) THEN
211 CALL dbt_distribution_new_expert(dist_split, tensor_in%pgrid, map1_2d, map2_2d, &
212 nd_dist_split_1, nd_dist_split_2, nd_dist_split_3)
213 CALL dbt_create(tensor_out, tensor_in%name, dist_split, map1_2d, map2_2d, &
214 nd_blk_size_split_1, nd_blk_size_split_2, nd_blk_size_split_3)
215 END IF
216 IF (ndims_tensor(tensor_in) == 4) THEN
217 CALL dbt_distribution_new_expert(dist_split, tensor_in%pgrid, map1_2d, map2_2d, &
218 nd_dist_split_1, nd_dist_split_2, nd_dist_split_3, nd_dist_split_4)
219 CALL dbt_create(tensor_out, tensor_in%name, dist_split, map1_2d, map2_2d, &
220 nd_blk_size_split_1, nd_blk_size_split_2, nd_blk_size_split_3, nd_blk_size_split_4)
221 END IF
222
223 CALL dbt_distribution_destroy(dist_split)
224
225 IF (PRESENT(nodata)) THEN
226 IF (nodata) THEN
227 CALL timestop(handle)
228 RETURN
229 END IF
230 END IF
231
232!$OMP PARALLEL DEFAULT(NONE) &
233!$OMP SHARED(tensor_in,tensor_out) &
234!$OMP SHARED(blk_nsplit_1, blk_nsplit_2, blk_nsplit_3, blk_nsplit_4) &
235!$OMP SHARED(inblock_offset_1, inblock_offset_2, inblock_offset_3, inblock_offset_4) &
236!$OMP SHARED(blk_size_1, blk_size_2, blk_size_3, blk_size_4) &
237!$OMP SHARED(index_split_offset_1, index_split_offset_2, index_split_offset_3, index_split_offset_4) &
238!$OMP PRIVATE(iter,found,bcount,blks_to_allocate,bi_split,inblock_offset) &
239!$OMP PRIVATE(blk_index,blk_size,blk_offset,blk_shape) &
240!$OMP PRIVATE(block_2d,block_3d,block_4d)
241 CALL dbt_iterator_start(iter, tensor_in)
242
243 bcount = 0
244 DO WHILE (dbt_iterator_blocks_left(iter))
245 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size)
246 IF (ndims_tensor(tensor_in) == 2) THEN
247 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
248 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
249 bcount = bcount + 1
250 END DO
251 END DO
252 END IF
253 IF (ndims_tensor(tensor_in) == 3) THEN
254 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
255 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
256 DO split_blk_3 = 1, blk_nsplit_3(blk_index(3))
257 bcount = bcount + 1
258 END DO
259 END DO
260 END DO
261 END IF
262 IF (ndims_tensor(tensor_in) == 4) THEN
263 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
264 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
265 DO split_blk_3 = 1, blk_nsplit_3(blk_index(3))
266 DO split_blk_4 = 1, blk_nsplit_4(blk_index(4))
267 bcount = bcount + 1
268 END DO
269 END DO
270 END DO
271 END DO
272 END IF
273 END DO
274 CALL dbt_iterator_stop(iter)
275
276 ALLOCATE (blks_to_allocate(bcount, ndims_tensor(tensor_in)))
277
278 CALL dbt_iterator_start(iter, tensor_in)
279
280 bcount = 0
281 DO WHILE (dbt_iterator_blocks_left(iter))
282 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
283
284 IF (ndims_tensor(tensor_in) == 2) THEN
285 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
286 bi_split(1) = index_split_offset_1(blk_index(1)) + split_blk_1
287 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
288 bi_split(2) = index_split_offset_2(blk_index(2)) + split_blk_2
289 bcount = bcount + 1
290 blks_to_allocate(bcount, :) = bi_split(1:ndims_tensor(tensor_in))
291 END DO
292 END DO
293 END IF
294 IF (ndims_tensor(tensor_in) == 3) THEN
295 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
296 bi_split(1) = index_split_offset_1(blk_index(1)) + split_blk_1
297 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
298 bi_split(2) = index_split_offset_2(blk_index(2)) + split_blk_2
299 DO split_blk_3 = 1, blk_nsplit_3(blk_index(3))
300 bi_split(3) = index_split_offset_3(blk_index(3)) + split_blk_3
301 bcount = bcount + 1
302 blks_to_allocate(bcount, :) = bi_split(1:ndims_tensor(tensor_in))
303 END DO
304 END DO
305 END DO
306 END IF
307 IF (ndims_tensor(tensor_in) == 4) THEN
308 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
309 bi_split(1) = index_split_offset_1(blk_index(1)) + split_blk_1
310 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
311 bi_split(2) = index_split_offset_2(blk_index(2)) + split_blk_2
312 DO split_blk_3 = 1, blk_nsplit_3(blk_index(3))
313 bi_split(3) = index_split_offset_3(blk_index(3)) + split_blk_3
314 DO split_blk_4 = 1, blk_nsplit_4(blk_index(4))
315 bi_split(4) = index_split_offset_4(blk_index(4)) + split_blk_4
316 bcount = bcount + 1
317 blks_to_allocate(bcount, :) = bi_split(1:ndims_tensor(tensor_in))
318 END DO
319 END DO
320 END DO
321 END DO
322 END IF
323 END DO
324
325 CALL dbt_iterator_stop(iter)
326
327 CALL dbt_reserve_blocks(tensor_out, blks_to_allocate)
328
329 CALL dbt_iterator_start(iter, tensor_in)
330
331 DO WHILE (dbt_iterator_blocks_left(iter))
332 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
333 IF (ndims_tensor(tensor_in) == 2) THEN
334 CALL dbt_get_block(tensor_in, blk_index, block_2d, found)
335 cpassert(found)
336 END IF
337 IF (ndims_tensor(tensor_in) == 3) THEN
338 CALL dbt_get_block(tensor_in, blk_index, block_3d, found)
339 cpassert(found)
340 END IF
341 IF (ndims_tensor(tensor_in) == 4) THEN
342 CALL dbt_get_block(tensor_in, blk_index, block_4d, found)
343 cpassert(found)
344 END IF
345 IF (ndims_tensor(tensor_in) == 2) THEN
346 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
347 ! split block index
348 bi_split(1) = index_split_offset_1(blk_index(1)) + split_blk_1
349 blk_shape(1) = blk_size_1(bi_split(1))
350 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
351 ! split block index
352 bi_split(2) = index_split_offset_2(blk_index(2)) + split_blk_2
353 blk_shape(2) = blk_size_2(bi_split(2))
354
355 inblock_offset(1) = inblock_offset_1(bi_split(1))
356 inblock_offset(2) = inblock_offset_2(bi_split(2))
357 CALL dbt_put_block(tensor_out, bi_split(1:2), &
358 blk_shape, &
359 block_2d( &
360 inblock_offset(1) + 1:inblock_offset(1) + blk_shape(1), inblock_offset(2) +&
361 & 1:inblock_offset(2) + blk_shape(2)))
362
363 END DO
364 END DO
365
366 DEALLOCATE (block_2d)
367 END IF
368 IF (ndims_tensor(tensor_in) == 3) THEN
369 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
370 ! split block index
371 bi_split(1) = index_split_offset_1(blk_index(1)) + split_blk_1
372 blk_shape(1) = blk_size_1(bi_split(1))
373 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
374 ! split block index
375 bi_split(2) = index_split_offset_2(blk_index(2)) + split_blk_2
376 blk_shape(2) = blk_size_2(bi_split(2))
377 DO split_blk_3 = 1, blk_nsplit_3(blk_index(3))
378 ! split block index
379 bi_split(3) = index_split_offset_3(blk_index(3)) + split_blk_3
380 blk_shape(3) = blk_size_3(bi_split(3))
381
382 inblock_offset(1) = inblock_offset_1(bi_split(1))
383 inblock_offset(2) = inblock_offset_2(bi_split(2))
384 inblock_offset(3) = inblock_offset_3(bi_split(3))
385 CALL dbt_put_block(tensor_out, bi_split(1:3), &
386 blk_shape, &
387 block_3d( &
388 inblock_offset(1) + 1:inblock_offset(1) + blk_shape(1), inblock_offset(2) +&
389 & 1:inblock_offset(2) + blk_shape(2), inblock_offset(3) + 1:inblock_offset(3) +&
390 & blk_shape(3)))
391
392 END DO
393 END DO
394 END DO
395
396 DEALLOCATE (block_3d)
397 END IF
398 IF (ndims_tensor(tensor_in) == 4) THEN
399 DO split_blk_1 = 1, blk_nsplit_1(blk_index(1))
400 ! split block index
401 bi_split(1) = index_split_offset_1(blk_index(1)) + split_blk_1
402 blk_shape(1) = blk_size_1(bi_split(1))
403 DO split_blk_2 = 1, blk_nsplit_2(blk_index(2))
404 ! split block index
405 bi_split(2) = index_split_offset_2(blk_index(2)) + split_blk_2
406 blk_shape(2) = blk_size_2(bi_split(2))
407 DO split_blk_3 = 1, blk_nsplit_3(blk_index(3))
408 ! split block index
409 bi_split(3) = index_split_offset_3(blk_index(3)) + split_blk_3
410 blk_shape(3) = blk_size_3(bi_split(3))
411 DO split_blk_4 = 1, blk_nsplit_4(blk_index(4))
412 ! split block index
413 bi_split(4) = index_split_offset_4(blk_index(4)) + split_blk_4
414 blk_shape(4) = blk_size_4(bi_split(4))
415
416 inblock_offset(1) = inblock_offset_1(bi_split(1))
417 inblock_offset(2) = inblock_offset_2(bi_split(2))
418 inblock_offset(3) = inblock_offset_3(bi_split(3))
419 inblock_offset(4) = inblock_offset_4(bi_split(4))
420 CALL dbt_put_block(tensor_out, bi_split(1:4), &
421 blk_shape, &
422 block_4d( &
423 inblock_offset(1) + 1:inblock_offset(1) + blk_shape(1), inblock_offset(2) +&
424 & 1:inblock_offset(2) + blk_shape(2), inblock_offset(3) + 1:inblock_offset(3) +&
425 & blk_shape(3), inblock_offset(4) + 1:inblock_offset(4) + blk_shape(4)))
426
427 END DO
428 END DO
429 END DO
430 END DO
431
432 DEALLOCATE (block_4d)
433 END IF
434 END DO
435 CALL dbt_iterator_stop(iter)
436!$OMP END PARALLEL
437
438 CALL dbt_finalize(tensor_out)
439
440 ! remove blocks that are exactly 0, these can occur if a cropping operation was performed before splitting
441 CALL dbt_filter(tensor_out, tiny(0.0_dp))
442
443 CALL timestop(handle)
444
445 END SUBROUTINE dbt_split_blocks_generic
446
447! **************************************************************************************************
448!> \brief Split tensor blocks into smaller blocks of maximum size PRODUCT(block_sizes).
449!> \param tensor_in Input tensor
450!> \param tensor_out Output tensor (split blocks)
451!> \param block_sizes block sizes for each of the tensor dimensions
452!> \param nodata don't copy data from tensor_in to tensor_out
453!> \author Patrick Seewald
454! **************************************************************************************************
455 SUBROUTINE dbt_split_blocks(tensor_in, tensor_out, block_sizes, nodata)
456
457 TYPE(dbt_type), INTENT(INOUT) :: tensor_in
458 TYPE(dbt_type), INTENT(OUT) :: tensor_out
459 INTEGER, DIMENSION(ndims_tensor(tensor_in)), &
460 INTENT(IN) :: block_sizes
461 LOGICAL, INTENT(IN), OPTIONAL :: nodata
462
463 INTEGER, DIMENSION(:), ALLOCATABLE :: nd_blk_size_split_1, nd_blk_size_split_2,&
464 & nd_blk_size_split_3, nd_blk_size_split_4
465 INTEGER :: idim, i, isplit_sum, blk_remainder, nsplit, isplit
466 INTEGER, DIMENSION(:), ALLOCATABLE :: blk_size_d, blk_size_split_d
467
468 DO idim = 1, ndims_tensor(tensor_in)
469 CALL get_ith_array(tensor_in%blk_sizes, idim, blk_size_d)
470
471 isplit_sum = 0
472 DO i = 1, SIZE(blk_size_d)
473 nsplit = (blk_size_d(i) + block_sizes(idim) - 1)/block_sizes(idim)
474 isplit_sum = isplit_sum + nsplit
475 END DO
476
477 ALLOCATE (blk_size_split_d(isplit_sum))
478
479 isplit_sum = 0
480 DO i = 1, SIZE(blk_size_d)
481 nsplit = (blk_size_d(i) + block_sizes(idim) - 1)/block_sizes(idim)
482 blk_remainder = blk_size_d(i)
483 DO isplit = 1, nsplit
484 isplit_sum = isplit_sum + 1
485 blk_size_split_d(isplit_sum) = min(block_sizes(idim), blk_remainder)
486 blk_remainder = blk_remainder - block_sizes(idim)
487 END DO
488
489 END DO
490
491 IF (idim == 1) THEN
492 ALLOCATE (nd_blk_size_split_1, source=blk_size_split_d)
493 END IF
494 IF (idim == 2) THEN
495 ALLOCATE (nd_blk_size_split_2, source=blk_size_split_d)
496 END IF
497 IF (idim == 3) THEN
498 ALLOCATE (nd_blk_size_split_3, source=blk_size_split_d)
499 END IF
500 IF (idim == 4) THEN
501 ALLOCATE (nd_blk_size_split_4, source=blk_size_split_d)
502 END IF
503 DEALLOCATE (blk_size_split_d)
504 END DO
505
506 IF (ndims_tensor(tensor_in) == 2) CALL dbt_split_blocks_generic(tensor_in, tensor_out, &
507 nd_blk_size_split_1, nd_blk_size_split_2, &
508 nodata=nodata)
509 IF (ndims_tensor(tensor_in) == 3) CALL dbt_split_blocks_generic(tensor_in, tensor_out, &
510 nd_blk_size_split_1, nd_blk_size_split_2,&
511 & nd_blk_size_split_3, &
512 nodata=nodata)
513 IF (ndims_tensor(tensor_in) == 4) CALL dbt_split_blocks_generic(tensor_in, tensor_out, &
514 nd_blk_size_split_1, nd_blk_size_split_2,&
515 & nd_blk_size_split_3, nd_blk_size_split_&
516 &4, &
517 nodata=nodata)
518
519 END SUBROUTINE dbt_split_blocks
520
521! **************************************************************************************************
522!> \brief Copy tensor with split blocks to tensor with original block sizes.
523!> \param tensor_split_in tensor with smaller blocks
524!> \param tensor_out original tensor
525!> \author Patrick Seewald
526! **************************************************************************************************
527 SUBROUTINE dbt_split_copyback(tensor_split_in, tensor_out, summation)
528 TYPE(dbt_type), INTENT(INOUT) :: tensor_split_in
529 TYPE(dbt_type), INTENT(INOUT) :: tensor_out
530 LOGICAL, INTENT(IN), OPTIONAL :: summation
531 INTEGER, DIMENSION(:), ALLOCATABLE :: first_split_d, last_split_d
532 INTEGER, DIMENSION(:), ALLOCATABLE :: blk_size_split_d, blk_size_d
533 INTEGER, DIMENSION(:), ALLOCATABLE :: last_split_1, last_split_2, last_split_3, last_split_4, &
534 first_split_1, first_split_2, first_split_3,&
535 & first_split_4, &
536 split_1, split_2, split_3, split_4
537 INTEGER, DIMENSION(:), ALLOCATABLE :: inblock_offset_1, inblock_offset_2, inblock_offset_3,&
538 & inblock_offset_4, blk_size_split_1, blk_size_split_2, blk_size_split_3, blk_size_split_4
539 INTEGER, DIMENSION(:, :), ALLOCATABLE :: blks_to_allocate
540 INTEGER :: idim, iblk, bcount
541 INTEGER :: iblk_1, iblk_2, iblk_3, iblk_4, isplit_sum, splitsum
542 TYPE(dbt_iterator_type) :: iter
543 INTEGER, DIMENSION(ndims_tensor(tensor_out)) :: blk_index, blk_size, blk_offset, blk_shape, blk_index_n
544 LOGICAL :: found
545
546 INTEGER, DIMENSION(4) :: inblock_offset
547 INTEGER :: handle
548 CHARACTER(LEN=*), PARAMETER :: routinen = 'dbt_split_copyback'
549 REAL(dp), DIMENSION(:,:), ALLOCATABLE :: block_2d
550 REAL(dp), DIMENSION(:,:), ALLOCATABLE :: block_split_2d
551 REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: block_3d
552 REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: block_split_3d
553 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: block_4d
554 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: block_split_4d
555
556 CALL timeset(routinen, handle)
557 cpassert(tensor_out%valid)
558 IF (PRESENT(summation)) THEN
559 IF (.NOT. summation) CALL dbt_clear(tensor_out)
560 ELSE
561 CALL dbt_clear(tensor_out)
562 END IF
563
564 DO idim = 1, ndims_tensor(tensor_split_in)
565 CALL get_ith_array(tensor_split_in%blk_sizes, idim, blk_size_split_d)
566 CALL get_ith_array(tensor_out%blk_sizes, idim, blk_size_d)
567
568 IF (idim == 1) THEN
569 ! data offset of split blocks w.r.t. corresponding normal block
570 ALLOCATE (inblock_offset_1(SIZE(blk_size_split_d)))
571 ! normal block index for each split block
572 ALLOCATE (split_1(SIZE(blk_size_split_d)))
573 END IF
574 IF (idim == 2) THEN
575 ! data offset of split blocks w.r.t. corresponding normal block
576 ALLOCATE (inblock_offset_2(SIZE(blk_size_split_d)))
577 ! normal block index for each split block
578 ALLOCATE (split_2(SIZE(blk_size_split_d)))
579 END IF
580 IF (idim == 3) THEN
581 ! data offset of split blocks w.r.t. corresponding normal block
582 ALLOCATE (inblock_offset_3(SIZE(blk_size_split_d)))
583 ! normal block index for each split block
584 ALLOCATE (split_3(SIZE(blk_size_split_d)))
585 END IF
586 IF (idim == 4) THEN
587 ! data offset of split blocks w.r.t. corresponding normal block
588 ALLOCATE (inblock_offset_4(SIZE(blk_size_split_d)))
589 ! normal block index for each split block
590 ALLOCATE (split_4(SIZE(blk_size_split_d)))
591 END IF
592
593 ALLOCATE (last_split_d(SIZE(blk_size_d)))
594 ALLOCATE (first_split_d(SIZE(blk_size_d)))
595 first_split_d(1) = 1
596 isplit_sum = 0
597 DO iblk = 1, SIZE(blk_size_d)
598 splitsum = 0
599 IF (iblk > 1) first_split_d(iblk) = last_split_d(iblk - 1) + 1
600 DO WHILE (splitsum < blk_size_d(iblk))
601 isplit_sum = isplit_sum + 1
602 IF (idim == 1) THEN
603 inblock_offset_1(isplit_sum) = splitsum
604 split_1(isplit_sum) = iblk
605 END IF
606 IF (idim == 2) THEN
607 inblock_offset_2(isplit_sum) = splitsum
608 split_2(isplit_sum) = iblk
609 END IF
610 IF (idim == 3) THEN
611 inblock_offset_3(isplit_sum) = splitsum
612 split_3(isplit_sum) = iblk
613 END IF
614 IF (idim == 4) THEN
615 inblock_offset_4(isplit_sum) = splitsum
616 split_4(isplit_sum) = iblk
617 END IF
618 splitsum = splitsum + blk_size_split_d(isplit_sum)
619 END DO
620 cpassert(splitsum == blk_size_d(iblk))
621 last_split_d(iblk) = isplit_sum
622 END DO
623 IF (idim == 1) THEN
624 ALLOCATE (first_split_1, source=first_split_d)
625 ALLOCATE (last_split_1, source=last_split_d)
626 ALLOCATE (blk_size_split_1, source=blk_size_split_d)
627 END IF
628 IF (idim == 2) THEN
629 ALLOCATE (first_split_2, source=first_split_d)
630 ALLOCATE (last_split_2, source=last_split_d)
631 ALLOCATE (blk_size_split_2, source=blk_size_split_d)
632 END IF
633 IF (idim == 3) THEN
634 ALLOCATE (first_split_3, source=first_split_d)
635 ALLOCATE (last_split_3, source=last_split_d)
636 ALLOCATE (blk_size_split_3, source=blk_size_split_d)
637 END IF
638 IF (idim == 4) THEN
639 ALLOCATE (first_split_4, source=first_split_d)
640 ALLOCATE (last_split_4, source=last_split_d)
641 ALLOCATE (blk_size_split_4, source=blk_size_split_d)
642 END IF
643 DEALLOCATE (first_split_d, last_split_d)
644 DEALLOCATE (blk_size_split_d, blk_size_d)
645 END DO
646
647!$OMP PARALLEL DEFAULT(NONE) &
648!$OMP SHARED(tensor_split_in,tensor_out,summation) &
649!$OMP SHARED(split_1, split_2, split_3, split_4) &
650!$OMP SHARED(first_split_1, first_split_2, first_split_3, first_split_4) &
651!$OMP SHARED(last_split_1, last_split_2, last_split_3, last_split_4) &
652!$OMP SHARED(inblock_offset_1, inblock_offset_2, inblock_offset_3, inblock_offset_4) &
653!$OMP PRIVATE(iter,blks_to_allocate,bcount,blk_index_n) &
654!$OMP PRIVATE(blk_index,blk_size,blk_shape,blk_offset,inblock_offset,found) &
655!$OMP PRIVATE(block_2d,block_3d,block_4d,block_split_2d,block_split_3d,block_split_4d)
656 CALL dbt_iterator_start(iter, tensor_split_in)
657 ALLOCATE (blks_to_allocate(dbt_iterator_num_blocks(iter), ndims_tensor(tensor_split_in)))
658 bcount = 0
659 DO WHILE (dbt_iterator_blocks_left(iter))
660 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size)
661 IF (ndims_tensor(tensor_out) == 2) THEN
662 blk_index_n(1) = split_1(blk_index(1))
663 blk_index_n(2) = split_2(blk_index(2))
664 END IF
665 IF (ndims_tensor(tensor_out) == 3) THEN
666 blk_index_n(1) = split_1(blk_index(1))
667 blk_index_n(2) = split_2(blk_index(2))
668 blk_index_n(3) = split_3(blk_index(3))
669 END IF
670 IF (ndims_tensor(tensor_out) == 4) THEN
671 blk_index_n(1) = split_1(blk_index(1))
672 blk_index_n(2) = split_2(blk_index(2))
673 blk_index_n(3) = split_3(blk_index(3))
674 blk_index_n(4) = split_4(blk_index(4))
675 END IF
676 blks_to_allocate(bcount + 1, :) = blk_index_n
677 bcount = bcount + 1
678 END DO
679 CALL dbt_iterator_stop(iter)
680 CALL dbt_reserve_blocks(tensor_out, blks_to_allocate)
681
682 CALL dbt_iterator_start(iter, tensor_out)
683 DO WHILE (dbt_iterator_blocks_left(iter))
684 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
685
686 IF (ndims_tensor(tensor_out) == 2) THEN
687 CALL allocate_any(block_2d, blk_size)
688 block_2d = 0.0_dp
689 DO iblk_1 = first_split_1(blk_index(1)), last_split_1(blk_index(1))
690 DO iblk_2 = first_split_2(blk_index(2)), last_split_2(blk_index(2))
691 inblock_offset(1) = inblock_offset_1(iblk_1)
692 inblock_offset(2) = inblock_offset_2(iblk_2)
693
694 CALL dbt_get_block(tensor_split_in, [iblk_1, iblk_2], &
695 block_split_2d, found)
696 IF (found) THEN
697 blk_shape(1:2) = shape(block_split_2d)
698 block_2d( &
699 inblock_offset(1) + 1:inblock_offset(1) + blk_shape(1), inblock_offset(2) + 1:inblock_offset(2) +&
700 & blk_shape(2)) = &
701 block_split_2d
702 END IF
703
704 END DO
705 END DO
706 CALL dbt_put_block(tensor_out, blk_index, blk_size, block_2d, summation=summation)
707 DEALLOCATE (block_2d)
708 END IF
709 IF (ndims_tensor(tensor_out) == 3) THEN
710 CALL allocate_any(block_3d, blk_size)
711 block_3d = 0.0_dp
712 DO iblk_1 = first_split_1(blk_index(1)), last_split_1(blk_index(1))
713 DO iblk_2 = first_split_2(blk_index(2)), last_split_2(blk_index(2))
714 DO iblk_3 = first_split_3(blk_index(3)), last_split_3(blk_index(3))
715 inblock_offset(1) = inblock_offset_1(iblk_1)
716 inblock_offset(2) = inblock_offset_2(iblk_2)
717 inblock_offset(3) = inblock_offset_3(iblk_3)
718
719 CALL dbt_get_block(tensor_split_in, [iblk_1, iblk_2, iblk_3], &
720 block_split_3d, found)
721 IF (found) THEN
722 blk_shape(1:3) = shape(block_split_3d)
723 block_3d( &
724 inblock_offset(1) + 1:inblock_offset(1) + blk_shape(1), inblock_offset(2) + 1:inblock_offset(2) +&
725 & blk_shape(2), inblock_offset(3) + 1:inblock_offset(3) + blk_shape(3)) = &
726 block_split_3d
727 END IF
728
729 END DO
730 END DO
731 END DO
732 CALL dbt_put_block(tensor_out, blk_index, blk_size, block_3d, summation=summation)
733 DEALLOCATE (block_3d)
734 END IF
735 IF (ndims_tensor(tensor_out) == 4) THEN
736 CALL allocate_any(block_4d, blk_size)
737 block_4d = 0.0_dp
738 DO iblk_1 = first_split_1(blk_index(1)), last_split_1(blk_index(1))
739 DO iblk_2 = first_split_2(blk_index(2)), last_split_2(blk_index(2))
740 DO iblk_3 = first_split_3(blk_index(3)), last_split_3(blk_index(3))
741 DO iblk_4 = first_split_4(blk_index(4)), last_split_4(blk_index(4))
742 inblock_offset(1) = inblock_offset_1(iblk_1)
743 inblock_offset(2) = inblock_offset_2(iblk_2)
744 inblock_offset(3) = inblock_offset_3(iblk_3)
745 inblock_offset(4) = inblock_offset_4(iblk_4)
746
747 CALL dbt_get_block(tensor_split_in, [iblk_1, iblk_2, iblk_3, iblk_4], &
748 block_split_4d, found)
749 IF (found) THEN
750 blk_shape(1:4) = shape(block_split_4d)
751 block_4d( &
752 inblock_offset(1) + 1:inblock_offset(1) + blk_shape(1), inblock_offset(2) + 1:inblock_offset(2) +&
753 & blk_shape(2), inblock_offset(3) + 1:inblock_offset(3) + blk_shape(3), inblock_offset(4) +&
754 & 1:inblock_offset(4) + blk_shape(4)) = &
755 block_split_4d
756 END IF
757
758 END DO
759 END DO
760 END DO
761 END DO
762 CALL dbt_put_block(tensor_out, blk_index, blk_size, block_4d, summation=summation)
763 DEALLOCATE (block_4d)
764 END IF
765 END DO
766 CALL dbt_iterator_stop(iter)
767!$OMP END PARALLEL
768
769 CALL timestop(handle)
770
771 END SUBROUTINE dbt_split_copyback
772
773! **************************************************************************************************
774!> \brief split two tensors with same total sizes but different block sizes such that they have
775!> equal block sizes
776!> \param move_data memory optimization: transfer data s.t. tensor1 and tensor2 may be empty on return
777!> \param tensor1_split tensor 1 with split blocks
778!> \param tensor2_split tensor 2 with split blocks
779!> \param nodata1 don't copy data of tensor 1
780!> \param nodata2 don't copy data of tensor 2
781!> \param
782!> \param
783!> \param
784!> \param
785!> \author Patrick Seewald
786! **************************************************************************************************
787 SUBROUTINE dbt_make_compatible_blocks(tensor1, tensor2, tensor1_split, tensor2_split, &
788 order, nodata1, nodata2, move_data)
789 TYPE(dbt_type), INTENT(INOUT) :: tensor1, tensor2
790 TYPE(dbt_type), INTENT(OUT) :: tensor1_split, tensor2_split
791 INTEGER, DIMENSION(ndims_tensor(tensor1)), &
792 INTENT(IN), OPTIONAL :: order
793 LOGICAL, INTENT(IN), OPTIONAL :: nodata1, nodata2, move_data
794 INTEGER, DIMENSION(:), ALLOCATABLE :: blk_size_split_1_1, blk_size_split_1_2, blk_size_split_1_3,&
795 & blk_size_split_1_4, &
796 blk_size_split_2_1, blk_size_split_2_2, blk_size_split_2_3,&
797 & blk_size_split_2_4, &
798 blk_size_d_1, blk_size_d_2, blk_size_d_split
799 INTEGER :: size_sum_1, size_sum_2, size_sum, bind_1, bind_2, isplit, bs, idim, i
800 LOGICAL :: move_prv, nodata1_prv, nodata2_prv
801 INTEGER, DIMENSION(ndims_tensor(tensor1)) :: order_prv
802
803 IF (PRESENT(move_data)) THEN
804 move_prv = move_data
805 ELSE
806 move_prv = .false.
807 END IF
808
809 IF (PRESENT(nodata1)) THEN
810 nodata1_prv = nodata1
811 ELSE
812 nodata1_prv = .false.
813 END IF
814 IF (PRESENT(nodata2)) THEN
815 nodata2_prv = nodata2
816 ELSE
817 nodata2_prv = .false.
818 END IF
819
820 IF (PRESENT(order)) THEN
821 order_prv(:) = dbt_inverse_order(order)
822 ELSE
823 order_prv(:) = (/(i, i=1, ndims_tensor(tensor1))/)
824 END IF
825
826 DO idim = 1, ndims_tensor(tensor2)
827 CALL get_ith_array(tensor1%blk_sizes, order_prv(idim), blk_size_d_1)
828 CALL get_ith_array(tensor2%blk_sizes, idim, blk_size_d_2)
829 ALLOCATE (blk_size_d_split(SIZE(blk_size_d_1) + SIZE(blk_size_d_2)))
830 size_sum_1 = 0
831 size_sum_2 = 0
832 size_sum = 0
833 bind_1 = 0
834 bind_2 = 0
835 isplit = 0
836
837 DO WHILE (bind_1 < SIZE(blk_size_d_1) .AND. bind_2 < SIZE(blk_size_d_2))
838 IF (blk_size_d_1(bind_1 + 1) < blk_size_d_2(bind_2 + 1)) THEN
839 bind_1 = bind_1 + 1
840 bs = blk_size_d_1(bind_1)
841 blk_size_d_2(bind_2 + 1) = blk_size_d_2(bind_2 + 1) - bs
842 size_sum = size_sum + bs
843 isplit = isplit + 1
844 blk_size_d_split(isplit) = bs
845 ELSE IF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN
846 bind_2 = bind_2 + 1
847 bs = blk_size_d_2(bind_2)
848 blk_size_d_1(bind_1 + 1) = blk_size_d_1(bind_1 + 1) - bs
849 size_sum = size_sum + bs
850 isplit = isplit + 1
851 blk_size_d_split(isplit) = bs
852 ELSE
853 bind_1 = bind_1 + 1
854 bind_2 = bind_2 + 1
855 bs = blk_size_d_1(bind_1)
856 size_sum = size_sum + bs
857 isplit = isplit + 1
858 blk_size_d_split(isplit) = bs
859 END IF
860 END DO
861
862 IF (bind_1 < SIZE(blk_size_d_1)) THEN
863 bind_1 = bind_1 + 1
864 bs = blk_size_d_1(bind_1)
865 size_sum = size_sum + bs
866 isplit = isplit + 1
867 blk_size_d_split(isplit) = bs
868 END IF
869
870 IF (bind_2 < SIZE(blk_size_d_2)) THEN
871 bind_2 = bind_2 + 1
872 bs = blk_size_d_2(bind_2)
873 size_sum = size_sum + bs
874 isplit = isplit + 1
875 blk_size_d_split(isplit) = bs
876 END IF
877
878 IF (order_prv(idim) == 1) THEN
879 ALLOCATE (blk_size_split_1_1, source=blk_size_d_split(:isplit))
880 END IF
881 IF (order_prv(idim) == 2) THEN
882 ALLOCATE (blk_size_split_1_2, source=blk_size_d_split(:isplit))
883 END IF
884 IF (order_prv(idim) == 3) THEN
885 ALLOCATE (blk_size_split_1_3, source=blk_size_d_split(:isplit))
886 END IF
887 IF (order_prv(idim) == 4) THEN
888 ALLOCATE (blk_size_split_1_4, source=blk_size_d_split(:isplit))
889 END IF
890
891 IF (idim == 1) THEN
892 ALLOCATE (blk_size_split_2_1, source=blk_size_d_split(:isplit))
893 END IF
894 IF (idim == 2) THEN
895 ALLOCATE (blk_size_split_2_2, source=blk_size_d_split(:isplit))
896 END IF
897 IF (idim == 3) THEN
898 ALLOCATE (blk_size_split_2_3, source=blk_size_d_split(:isplit))
899 END IF
900 IF (idim == 4) THEN
901 ALLOCATE (blk_size_split_2_4, source=blk_size_d_split(:isplit))
902 END IF
903
904 DEALLOCATE (blk_size_d_split, blk_size_d_1, blk_size_d_2)
905 END DO
906
907 IF (ndims_tensor(tensor1) == 2) THEN
908 CALL dbt_split_blocks_generic(tensor1, tensor1_split, blk_size_split_1_1, blk_size_split_1_2, nodata=nodata1)
909 IF (move_prv .AND. .NOT. nodata1_prv) CALL dbt_clear(tensor1)
910 CALL dbt_split_blocks_generic(tensor2, tensor2_split, blk_size_split_2_1, blk_size_split_2_2, nodata=nodata2)
911 IF (move_prv .AND. .NOT. nodata2_prv) CALL dbt_clear(tensor2)
912 END IF
913 IF (ndims_tensor(tensor1) == 3) THEN
914 CALL dbt_split_blocks_generic(tensor1, tensor1_split, blk_size_split_1_1, blk_size_split_1_2,&
915 & blk_size_split_1_3, nodata=nodata1)
916 IF (move_prv .AND. .NOT. nodata1_prv) CALL dbt_clear(tensor1)
917 CALL dbt_split_blocks_generic(tensor2, tensor2_split, blk_size_split_2_1, blk_size_split_2_2,&
918 & blk_size_split_2_3, nodata=nodata2)
919 IF (move_prv .AND. .NOT. nodata2_prv) CALL dbt_clear(tensor2)
920 END IF
921 IF (ndims_tensor(tensor1) == 4) THEN
922 CALL dbt_split_blocks_generic(tensor1, tensor1_split, blk_size_split_1_1, blk_size_split_1_2,&
923 & blk_size_split_1_3, blk_size_split_1_4, nodata=nodata1)
924 IF (move_prv .AND. .NOT. nodata1_prv) CALL dbt_clear(tensor1)
925 CALL dbt_split_blocks_generic(tensor2, tensor2_split, blk_size_split_2_1, blk_size_split_2_2,&
926 & blk_size_split_2_3, blk_size_split_2_4, nodata=nodata2)
927 IF (move_prv .AND. .NOT. nodata2_prv) CALL dbt_clear(tensor2)
928 END IF
929
930 END SUBROUTINE dbt_make_compatible_blocks
931
932! **************************************************************************************************
933!> \author Patrick Seewald
934! **************************************************************************************************
935 SUBROUTINE dbt_crop(tensor_in, tensor_out, bounds, move_data)
936 TYPE(dbt_type), INTENT(INOUT) :: tensor_in
937 TYPE(dbt_type), INTENT(OUT) :: tensor_out
938 INTEGER, DIMENSION(2, ndims_tensor(tensor_in)), INTENT(IN) :: bounds
939 LOGICAL, INTENT(IN), OPTIONAL :: move_data
940
941 CHARACTER(LEN=*), PARAMETER :: routinen = 'dbt_crop'
942
943 INTEGER, DIMENSION(2, ndims_tensor(tensor_in)) :: blk_bounds
944 TYPE(dbt_iterator_type) :: iter
945 INTEGER, DIMENSION(ndims_tensor(tensor_in)) :: blk_index, blk_size, blk_offset
946 LOGICAL :: found, move_data_prv
947 INTEGER :: handle, idim, iblk_out
948 INTEGER, DIMENSION(:, :), ALLOCATABLE :: blk_ind_out
949 REAL(dp), DIMENSION(:,:), ALLOCATABLE :: block_2d, block_put_2d
950 REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: block_3d, block_put_3d
951 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: block_4d, block_put_4d
952
953 CALL timeset(routinen, handle)
954
955 IF (PRESENT(move_data)) THEN
956 move_data_prv = move_data
957 ELSE
958 move_data_prv = .false.
959 END IF
960
961 CALL dbt_create(tensor_in, tensor_out)
962
963!$OMP PARALLEL DEFAULT(NONE) SHARED(tensor_in,tensor_out,bounds) &
964!$OMP PRIVATE(iter,blk_ind_out,iblk_out,blk_index,blk_size,blk_offset,found,blk_bounds) &
965!$OMP PRIVATE(block_2d,block_put_2d,block_3d,block_put_3d,block_4d,block_put_4d)
966
967 ! reserve blocks inside bounds
968 CALL dbt_iterator_start(iter, tensor_in)
969 ALLOCATE (blk_ind_out(dbt_iterator_num_blocks(iter), ndims_tensor(tensor_in)))
970 blk_ind_out(:, :) = 0
971 iblk_out = 0
972 blk_loop: DO WHILE (dbt_iterator_blocks_left(iter))
973 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
974 DO idim = 1, ndims_tensor(tensor_in)
975 IF (bounds(1, idim) > blk_offset(idim) - 1 + blk_size(idim)) cycle blk_loop
976 IF (bounds(2, idim) < blk_offset(idim)) cycle blk_loop
977 END DO
978 iblk_out = iblk_out + 1
979 blk_ind_out(iblk_out, :) = blk_index
980 END DO blk_loop
981 CALL dbt_iterator_stop(iter)
982
983 CALL dbt_reserve_blocks(tensor_out, blk_ind_out(1:iblk_out, :))
984 DEALLOCATE (blk_ind_out)
985
986 ! copy blocks
987 CALL dbt_iterator_start(iter, tensor_out)
988 iter_loop: DO WHILE (dbt_iterator_blocks_left(iter))
989 CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
990
991 DO idim = 1, ndims_tensor(tensor_in)
992 blk_bounds(1, idim) = max(bounds(1, idim) - blk_offset(idim) + 1, 1)
993 blk_bounds(2, idim) = min(bounds(2, idim) - blk_offset(idim) + 1, blk_size(idim))
994 END DO
995
996 ! tensor_out was created from tensor_in, hence uncropped blocks copy as is
997 IF (all(blk_bounds(1, :) == 1) .AND. all(blk_bounds(2, :) == blk_size)) THEN
998 CALL dbt_copy_block(tensor_in, tensor_out, blk_index)
999 cycle iter_loop
1000 END IF
1001
1002 IF (ndims_tensor(tensor_in) == 2) THEN
1003 CALL dbt_get_block(tensor_in, blk_index, block_2d, found)
1004
1005 ALLOCATE (block_put_2d(blk_size(1), blk_size(2)))
1006 block_put_2d = 0.0_dp
1007 block_put_2d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2)) = &
1008 block_2d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2))
1009 CALL dbt_put_block(tensor_out, blk_index, blk_size, block_put_2d)
1010 DEALLOCATE (block_2d)
1011 DEALLOCATE (block_put_2d)
1012 END IF
1013 IF (ndims_tensor(tensor_in) == 3) THEN
1014 CALL dbt_get_block(tensor_in, blk_index, block_3d, found)
1015
1016 ALLOCATE (block_put_3d(blk_size(1), blk_size(2), blk_size(3)))
1017 block_put_3d = 0.0_dp
1018 block_put_3d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2), blk_bounds(1, 3):blk_bounds(2,3)) = &
1019 block_3d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2), blk_bounds(1, 3):blk_bounds(2,3))
1020 CALL dbt_put_block(tensor_out, blk_index, blk_size, block_put_3d)
1021 DEALLOCATE (block_3d)
1022 DEALLOCATE (block_put_3d)
1023 END IF
1024 IF (ndims_tensor(tensor_in) == 4) THEN
1025 CALL dbt_get_block(tensor_in, blk_index, block_4d, found)
1026
1027 ALLOCATE (block_put_4d(blk_size(1), blk_size(2), blk_size(3), blk_size(4)))
1028 block_put_4d = 0.0_dp
1029 block_put_4d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2), blk_bounds(1, 3):blk_bounds(2,3),&
1030 & blk_bounds(1, 4):blk_bounds(2,4)) = &
1031 block_4d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2), blk_bounds(1, 3):blk_bounds(2,3),&
1032 & blk_bounds(1, 4):blk_bounds(2,4))
1033 CALL dbt_put_block(tensor_out, blk_index, blk_size, block_put_4d)
1034 DEALLOCATE (block_4d)
1035 DEALLOCATE (block_put_4d)
1036 END IF
1037 END DO iter_loop
1038 CALL dbt_iterator_stop(iter)
1039!$OMP END PARALLEL
1040 CALL dbt_finalize(tensor_out)
1041
1042 IF (move_data_prv) CALL dbt_clear(tensor_in)
1043
1044 ! transfer data for batched contraction
1045 CALL dbt_copy_contraction_storage(tensor_in, tensor_out)
1046
1047 CALL timestop(handle)
1048 END SUBROUTINE dbt_crop
1049
1050 END MODULE dbt_split
dbt_allocate_wrap::allocate_any
Definition dbt_allocate_wrap.F:26
dbt_array_list_methods::get_ith_array
Definition dbt_array_list_methods.F:54
dbt_block::dbt_get_block
Definition dbt_block.F:88
dbt_block::dbt_put_block
Definition dbt_block.F:81
dbt_block::dbt_reserve_blocks
Definition dbt_block.F:98
dbt_types::dbt_create
Definition dbt_types.F:166
dbt_allocate_wrap
Wrapper for allocating, copying and reshaping arrays.
Definition dbt_allocate_wrap.F:15
dbt_array_list_methods
Representation of arbitrary number of 1d integer arrays with arbitrary sizes. This is needed for gene...
Definition dbt_array_list_methods.F:14
dbt_block
Methods to operate on n-dimensional tensor blocks.
Definition dbt_block.F:12
dbt_block::dbt_iterator_num_blocks
integer function, public dbt_iterator_num_blocks(iterator)
Generalization of block_iterator_num_blocks for tensors.
Definition dbt_block.F:188
dbt_block::dbt_iterator_blocks_left
logical function, public dbt_iterator_blocks_left(iterator)
Generalization of block_iterator_blocks_left for tensors.
Definition dbt_block.F:200
dbt_block::dbt_copy_block
subroutine, public dbt_copy_block(tensor_in, tensor_out, ind, summation)
Copy a block between tensors with the same index mapping and block sizes (e.g., one created from the ...
Definition dbt_block.F:569
dbt_block::dbt_iterator_stop
subroutine, public dbt_iterator_stop(iterator)
Generalization of block_iterator_stop for tensors.
Definition dbt_block.F:137
dbt_block::dbt_iterator_start
subroutine, public dbt_iterator_start(iterator, tensor)
Generalization of block_iterator_start for tensors.
Definition dbt_block.F:124
dbt_block::dbt_iterator_next_block
subroutine, public dbt_iterator_next_block(iterator, ind_nd, blk_size, blk_offset)
iterate over nd blocks of an nd rank tensor, index only (blocks must be retrieved by calling dbt_get_...
Definition dbt_block.F:164
dbt_index
tensor index and mapping to DBM index
Definition dbt_index.F:12
dbt_index::dbt_inverse_order
pure integer function, dimension(size(order)), public dbt_inverse_order(order)
Invert order.
Definition dbt_index.F:410
dbt_index::dbt_get_mapping_info
pure subroutine, public dbt_get_mapping_info(map, ndim_nd, ndim1_2d, ndim2_2d, dims_2d_i8, dims_2d, dims_nd, dims1_2d, dims2_2d, map1_2d, map2_2d, map_nd, base, col_major)
get mapping info
Definition dbt_index.F:176
dbt_split
Routines to split blocks and to convert between tensors with different block sizes.
Definition dbt_split.F:12
dbt_split::dbt_split_blocks
subroutine, public dbt_split_blocks(tensor_in, tensor_out, block_sizes, nodata)
Split tensor blocks into smaller blocks of maximum size PRODUCT(block_sizes).
Definition dbt_split.F:456
dbt_split::dbt_split_copyback
subroutine, public dbt_split_copyback(tensor_split_in, tensor_out, summation)
Copy tensor with split blocks to tensor with original block sizes.
Definition dbt_split.F:528
dbt_split::dbt_make_compatible_blocks
subroutine, public dbt_make_compatible_blocks(tensor1, tensor2, tensor1_split, tensor2_split, order, nodata1, nodata2, move_data)
split two tensors with same total sizes but different block sizes such that they have equal block siz...
Definition dbt_split.F:789
dbt_split::dbt_split_blocks_generic
subroutine, public dbt_split_blocks_generic(tensor_in, tensor_out, blk_size_1, blk_size_2, blk_size_3, blk_size_4, nodata)
Split tensor blocks into smaller blocks.
Definition dbt_split.F:70
dbt_split::dbt_crop
subroutine, public dbt_crop(tensor_in, tensor_out, bounds, move_data)
Definition dbt_split.F:936
dbt_types
DBT tensor framework for block-sparse tensor contraction: Types and create/destroy routines.
Definition dbt_types.F:12
dbt_types::dbt_copy_contraction_storage
subroutine, public dbt_copy_contraction_storage(tensor_in, tensor_out)
Definition dbt_types.F:1877
dbt_types::dbt_blk_sizes
subroutine, public dbt_blk_sizes(tensor, ind, blk_size)
Size of tensor block.
Definition dbt_types.F:1468
dbt_types::dbt_distribution_new_expert
subroutine, public dbt_distribution_new_expert(dist, pgrid, map1_2d, map2_2d, nd_dist_1, nd_dist_2, nd_dist_3, nd_dist_4, own_comm)
Create a tensor distribution.
Definition dbt_types.F:787
dbt_types::dbt_distribution
type(dbt_distribution_type) function, public dbt_distribution(tensor)
get distribution from tensor
Definition dbt_types.F:969
dbt_types::ndims_tensor
pure integer function, public ndims_tensor(tensor)
tensor rank
Definition dbt_types.F:1216
dbt_types::dbt_get_num_blocks
pure integer function, public dbt_get_num_blocks(tensor)
As block_get_num_blocks: get number of local blocks.
Definition dbt_types.F:1748
dbt_types::dbt_clear
subroutine, public dbt_clear(tensor)
Clear tensor (s.t. it does not contain any blocks).
Definition dbt_types.F:1768
dbt_types::dbt_finalize
subroutine, public dbt_finalize(tensor)
Finalize tensor, as block_finalize. This should be taken care of internally in DBT tensors,...
Definition dbt_types.F:1779
dbt_types::ndims_matrix_row
pure integer(int_8) function, public ndims_matrix_row(tensor)
how many tensor dimensions are mapped to matrix row
Definition dbt_types.F:1193
dbt_types::ndims_matrix_column
pure integer(int_8) function, public ndims_matrix_column(tensor)
how many tensor dimensions are mapped to matrix column
Definition dbt_types.F:1205
dbt_types::dbt_blk_offsets
subroutine, public dbt_blk_offsets(tensor, ind, blk_offset)
offset of tensor block
Definition dbt_types.F:1484
dbt_types::dbt_filter
subroutine, public dbt_filter(tensor, eps)
As block_filter.
Definition dbt_types.F:1577
dbt_types::dbt_distribution_destroy
subroutine, public dbt_distribution_destroy(dist)
Destroy tensor distribution.
Definition dbt_types.F:915
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
dbt_block::dbt_iterator_type
Definition dbt_block.F:66
dbt_types::dbt_distribution_type
Definition dbt_types.F:129
dbt_types::dbt_type
Definition dbt_types.F:110