(git:e7e05ae)
dbt_split.F
Go to the documentation of this file.
1 !--------------------------------------------------------------------------------------------------!
2 ! CP2K: A general program to perform molecular dynamics simulations !
3 ! Copyright 2000-2024 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 ! **************************************************************************************************
12 MODULE 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 
58 CONTAINS
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
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
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 .GT. 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
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, blk_size_split_2_1, blk_size_split_2_2, blk_size_split_2_3,&
795  & blk_size_split_2_4, &
796  blk_size_d_1, blk_size_d_2, blk_size_d_split
797  INTEGER :: size_sum_1, size_sum_2, size_sum, bind_1, bind_2, isplit, bs, idim, i
798  LOGICAL :: move_prv, nodata1_prv, nodata2_prv
799  INTEGER, DIMENSION(ndims_tensor(tensor1)) :: order_prv
800 
801  IF (PRESENT(move_data)) THEN
802  move_prv = move_data
803  ELSE
804  move_prv = .false.
805  END IF
806 
807  IF (PRESENT(nodata1)) THEN
808  nodata1_prv = nodata1
809  ELSE
810  nodata1_prv = .false.
811  END IF
812  IF (PRESENT(nodata2)) THEN
813  nodata2_prv = nodata2
814  ELSE
815  nodata2_prv = .false.
816  END IF
817 
818  IF (PRESENT(order)) THEN
819  order_prv(:) = dbt_inverse_order(order)
820  ELSE
821  order_prv(:) = (/(i, i=1, ndims_tensor(tensor1))/)
822  END IF
823 
824  DO idim = 1, ndims_tensor(tensor2)
825  CALL get_ith_array(tensor1%blk_sizes, order_prv(idim), blk_size_d_1)
826  CALL get_ith_array(tensor2%blk_sizes, idim, blk_size_d_2)
827  ALLOCATE (blk_size_d_split(SIZE(blk_size_d_1) + SIZE(blk_size_d_2)))
828  size_sum_1 = 0
829  size_sum_2 = 0
830  size_sum = 0
831  bind_1 = 0
832  bind_2 = 0
833  isplit = 0
834 
835  DO WHILE (bind_1 < SIZE(blk_size_d_1) .AND. bind_2 < SIZE(blk_size_d_2))
836  IF (blk_size_d_1(bind_1 + 1) < blk_size_d_2(bind_2 + 1)) THEN
837  bind_1 = bind_1 + 1
838  bs = blk_size_d_1(bind_1)
839  blk_size_d_2(bind_2 + 1) = blk_size_d_2(bind_2 + 1) - bs
840  size_sum = size_sum + bs
841  isplit = isplit + 1
842  blk_size_d_split(isplit) = bs
843  ELSEIF (blk_size_d_1(bind_1 + 1) > blk_size_d_2(bind_2 + 1)) THEN
844  bind_2 = bind_2 + 1
845  bs = blk_size_d_2(bind_2)
846  blk_size_d_1(bind_1 + 1) = blk_size_d_1(bind_1 + 1) - bs
847  size_sum = size_sum + bs
848  isplit = isplit + 1
849  blk_size_d_split(isplit) = bs
850  ELSE
851  bind_1 = bind_1 + 1
852  bind_2 = bind_2 + 1
853  bs = blk_size_d_1(bind_1)
854  size_sum = size_sum + bs
855  isplit = isplit + 1
856  blk_size_d_split(isplit) = bs
857  END IF
858  END DO
859 
860  IF (bind_1 < SIZE(blk_size_d_1)) THEN
861  bind_1 = bind_1 + 1
862  bs = blk_size_d_1(bind_1)
863  size_sum = size_sum + bs
864  isplit = isplit + 1
865  blk_size_d_split(isplit) = bs
866  END IF
867 
868  IF (bind_2 < SIZE(blk_size_d_2)) THEN
869  bind_2 = bind_2 + 1
870  bs = blk_size_d_2(bind_2)
871  size_sum = size_sum + bs
872  isplit = isplit + 1
873  blk_size_d_split(isplit) = bs
874  END IF
875 
876  IF (order_prv(idim) == 1) THEN
877  ALLOCATE (blk_size_split_1_1, source=blk_size_d_split(:isplit))
878  END IF
879  IF (order_prv(idim) == 2) THEN
880  ALLOCATE (blk_size_split_1_2, source=blk_size_d_split(:isplit))
881  END IF
882  IF (order_prv(idim) == 3) THEN
883  ALLOCATE (blk_size_split_1_3, source=blk_size_d_split(:isplit))
884  END IF
885  IF (order_prv(idim) == 4) THEN
886  ALLOCATE (blk_size_split_1_4, source=blk_size_d_split(:isplit))
887  END IF
888 
889  IF (idim == 1) THEN
890  ALLOCATE (blk_size_split_2_1, source=blk_size_d_split(:isplit))
891  END IF
892  IF (idim == 2) THEN
893  ALLOCATE (blk_size_split_2_2, source=blk_size_d_split(:isplit))
894  END IF
895  IF (idim == 3) THEN
896  ALLOCATE (blk_size_split_2_3, source=blk_size_d_split(:isplit))
897  END IF
898  IF (idim == 4) THEN
899  ALLOCATE (blk_size_split_2_4, source=blk_size_d_split(:isplit))
900  END IF
901 
902  DEALLOCATE (blk_size_d_split, blk_size_d_1, blk_size_d_2)
903  END DO
904 
905  IF (ndims_tensor(tensor1) == 2) THEN
906  CALL dbt_split_blocks_generic(tensor1, tensor1_split, blk_size_split_1_1, blk_size_split_1_2, nodata=nodata1)
907  IF (move_prv .AND. .NOT. nodata1_prv) CALL dbt_clear(tensor1)
908  CALL dbt_split_blocks_generic(tensor2, tensor2_split, blk_size_split_2_1, blk_size_split_2_2, nodata=nodata2)
909  IF (move_prv .AND. .NOT. nodata2_prv) CALL dbt_clear(tensor2)
910  END IF
911  IF (ndims_tensor(tensor1) == 3) THEN
912  CALL dbt_split_blocks_generic(tensor1, tensor1_split, blk_size_split_1_1, blk_size_split_1_2,&
913  & blk_size_split_1_3, nodata=nodata1)
914  IF (move_prv .AND. .NOT. nodata1_prv) CALL dbt_clear(tensor1)
915  CALL dbt_split_blocks_generic(tensor2, tensor2_split, blk_size_split_2_1, blk_size_split_2_2,&
916  & blk_size_split_2_3, nodata=nodata2)
917  IF (move_prv .AND. .NOT. nodata2_prv) CALL dbt_clear(tensor2)
918  END IF
919  IF (ndims_tensor(tensor1) == 4) THEN
920  CALL dbt_split_blocks_generic(tensor1, tensor1_split, blk_size_split_1_1, blk_size_split_1_2,&
921  & blk_size_split_1_3, blk_size_split_1_4, nodata=nodata1)
922  IF (move_prv .AND. .NOT. nodata1_prv) CALL dbt_clear(tensor1)
923  CALL dbt_split_blocks_generic(tensor2, tensor2_split, blk_size_split_2_1, blk_size_split_2_2,&
924  & blk_size_split_2_3, blk_size_split_2_4, nodata=nodata2)
925  IF (move_prv .AND. .NOT. nodata2_prv) CALL dbt_clear(tensor2)
926  END IF
927 
928  END SUBROUTINE
929 
930 ! **************************************************************************************************
931 !> \author Patrick Seewald
932 ! **************************************************************************************************
933  SUBROUTINE dbt_crop(tensor_in, tensor_out, bounds, move_data)
934  TYPE(dbt_type), INTENT(INOUT) :: tensor_in
935  TYPE(dbt_type), INTENT(OUT) :: tensor_out
936  INTEGER, DIMENSION(2, ndims_tensor(tensor_in)), INTENT(IN) :: bounds
937  LOGICAL, INTENT(IN), OPTIONAL :: move_data
938 
939  CHARACTER(LEN=*), PARAMETER :: routinen = 'dbt_crop'
940 
941  INTEGER, DIMENSION(2, ndims_tensor(tensor_in)) :: blk_bounds
942  TYPE(dbt_iterator_type) :: iter
943  INTEGER, DIMENSION(ndims_tensor(tensor_in)) :: blk_index, blk_size, blk_offset
944  LOGICAL :: found, move_data_prv
945  INTEGER :: handle, idim, iblk_out
946  INTEGER, DIMENSION(:, :), ALLOCATABLE :: blk_ind_out
947  REAL(dp), DIMENSION(:,:), ALLOCATABLE :: block_2d, block_put_2d
948  REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: block_3d, block_put_3d
949  REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: block_4d, block_put_4d
950 
951  CALL timeset(routinen, handle)
952 
953  IF (PRESENT(move_data)) THEN
954  move_data_prv = move_data
955  ELSE
956  move_data_prv = .false.
957  END IF
958 
959  CALL dbt_create(tensor_in, tensor_out)
960 
961 !$OMP PARALLEL DEFAULT(NONE) SHARED(tensor_in,tensor_out,bounds) &
962 !$OMP PRIVATE(iter,blk_ind_out,iblk_out,blk_index,blk_size,blk_offset,found,blk_bounds) &
963 !$OMP PRIVATE(block_2d,block_put_2d,block_3d,block_put_3d,block_4d,block_put_4d)
964 
965  ! reserve blocks inside bounds
966  CALL dbt_iterator_start(iter, tensor_in)
967  ALLOCATE (blk_ind_out(dbt_iterator_num_blocks(iter), ndims_tensor(tensor_in)))
968  blk_ind_out(:, :) = 0
969  iblk_out = 0
970  blk_loop: DO WHILE (dbt_iterator_blocks_left(iter))
971  CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
972  DO idim = 1, ndims_tensor(tensor_in)
973  IF (bounds(1, idim) > blk_offset(idim) - 1 + blk_size(idim)) cycle blk_loop
974  IF (bounds(2, idim) < blk_offset(idim)) cycle blk_loop
975  END DO
976  iblk_out = iblk_out + 1
977  blk_ind_out(iblk_out, :) = blk_index
978  END DO blk_loop
979  CALL dbt_iterator_stop(iter)
980 
981  CALL dbt_reserve_blocks(tensor_out, blk_ind_out(1:iblk_out, :))
982  DEALLOCATE (blk_ind_out)
983 
984  ! copy blocks
985  CALL dbt_iterator_start(iter, tensor_out)
986  iter_loop: DO WHILE (dbt_iterator_blocks_left(iter))
987  CALL dbt_iterator_next_block(iter, blk_index, blk_size=blk_size, blk_offset=blk_offset)
988 
989  DO idim = 1, ndims_tensor(tensor_in)
990  blk_bounds(1, idim) = max(bounds(1, idim) - blk_offset(idim) + 1, 1)
991  blk_bounds(2, idim) = min(bounds(2, idim) - blk_offset(idim) + 1, blk_size(idim))
992  END DO
993 
994  IF (ndims_tensor(tensor_in) == 2) THEN
995  CALL dbt_get_block(tensor_in, blk_index, block_2d, found)
996 
997  ALLOCATE (block_put_2d(blk_size(1), blk_size(2)))
998  block_put_2d = 0.0_dp
999  block_put_2d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2)) = &
1000  block_2d(blk_bounds(1, 1):blk_bounds(2,1), blk_bounds(1, 2):blk_bounds(2,2))
1001  CALL dbt_put_block(tensor_out, blk_index, blk_size, block_put_2d)
1002  DEALLOCATE (block_2d)
1003  DEALLOCATE (block_put_2d)
1004  END IF
1005  IF (ndims_tensor(tensor_in) == 3) THEN
1006  CALL dbt_get_block(tensor_in, blk_index, block_3d, found)
1007 
1008  ALLOCATE (block_put_3d(blk_size(1), blk_size(2), blk_size(3)))
1009  block_put_3d = 0.0_dp
1010  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)) = &
1011  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))
1012  CALL dbt_put_block(tensor_out, blk_index, blk_size, block_put_3d)
1013  DEALLOCATE (block_3d)
1014  DEALLOCATE (block_put_3d)
1015  END IF
1016  IF (ndims_tensor(tensor_in) == 4) THEN
1017  CALL dbt_get_block(tensor_in, blk_index, block_4d, found)
1018 
1019  ALLOCATE (block_put_4d(blk_size(1), blk_size(2), blk_size(3), blk_size(4)))
1020  block_put_4d = 0.0_dp
1021  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),&
1022  & blk_bounds(1, 4):blk_bounds(2,4)) = &
1023  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),&
1024  & blk_bounds(1, 4):blk_bounds(2,4))
1025  CALL dbt_put_block(tensor_out, blk_index, blk_size, block_put_4d)
1026  DEALLOCATE (block_4d)
1027  DEALLOCATE (block_put_4d)
1028  END IF
1029  END DO iter_loop
1030  CALL dbt_iterator_stop(iter)
1031 !$OMP END PARALLEL
1032  CALL dbt_finalize(tensor_out)
1033 
1034  IF (move_data_prv) CALL dbt_clear(tensor_in)
1035 
1036  ! transfer data for batched contraction
1037  CALL dbt_copy_contraction_storage(tensor_in, tensor_out)
1038 
1039  CALL timestop(handle)
1040  END SUBROUTINE
1041 
1042  END MODULE
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_array_list_methods::get_ith_array
subroutine, public get_ith_array(list, i, array_size, array)
get ith array
Definition: dbt_array_list_methods.F:237
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:934
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:1888
dbt_types::dbt_blk_sizes
subroutine, public dbt_blk_sizes(tensor, ind, blk_size)
Size of tensor block.
Definition: dbt_types.F:1479
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:980
dbt_types::ndims_tensor
pure integer function, public ndims_tensor(tensor)
tensor rank
Definition: dbt_types.F:1227
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:1759
dbt_types::dbt_clear
subroutine, public dbt_clear(tensor)
Clear tensor (s.t. it does not contain any blocks)
Definition: dbt_types.F:1779
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:1790
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:1204
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:1216
dbt_types::dbt_blk_offsets
subroutine, public dbt_blk_offsets(tensor, ind, blk_offset)
offset of tensor block
Definition: dbt_types.F:1495
dbt_types::dbt_filter
subroutine, public dbt_filter(tensor, eps)
As block_filter.
Definition: dbt_types.F:1588
dbt_types::dbt_distribution_destroy
subroutine, public dbt_distribution_destroy(dist)
Destroy tensor distribution.
Definition: dbt_types.F:926
kinds
Defines the basic variable types.
Definition: kinds.F:23
kinds::dp
integer, parameter, public dp
Definition: kinds.F:34