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