Line data Source code
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 : MODULE qs_fb_buffer_types
9 :
10 : USE kinds, ONLY: dp
11 : #include "./base/base_uses.f90"
12 :
13 : IMPLICIT NONE
14 :
15 : PRIVATE
16 :
17 : ! public types
18 : PUBLIC :: fb_buffer_d_obj
19 :
20 : ! public methods
21 : !API
22 : PUBLIC :: fb_buffer_add, &
23 : fb_buffer_create, &
24 : fb_buffer_get, &
25 : fb_buffer_has_data, &
26 : fb_buffer_release, &
27 : fb_buffer_nullify, &
28 : fb_buffer_replace
29 :
30 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_fb_buffer_types'
31 :
32 : ! **********************************************************************
33 : !> \brief data for the fb_buffer object (integer)
34 : !> \param n : number of data slices in the buffer
35 : !> \param disps : displacement in data array of each slice, it contains
36 : !> one more element at the end recording the total
37 : !> size of the current data, which is the same as the
38 : !> displacement for the new data to be added
39 : !> \param data_1d : where all of the slices are stored
40 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
41 : ! **********************************************************************
42 : TYPE fb_buffer_i_data
43 : INTEGER :: n = -1
44 : INTEGER, DIMENSION(:), POINTER :: disps => NULL()
45 : INTEGER, DIMENSION(:), POINTER :: data_1d => NULL()
46 : END TYPE fb_buffer_i_data
47 :
48 : ! **********************************************************************
49 : !> \brief object/pointer wrapper for fb_buffer object
50 : !> \param obj : pointer to fb_buffer data
51 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
52 : ! **********************************************************************
53 : TYPE fb_buffer_i_obj
54 : TYPE(fb_buffer_i_data), POINTER, PRIVATE :: obj => NULL()
55 : END TYPE fb_buffer_i_obj
56 :
57 : ! **********************************************************************
58 : !> \brief data for the fb_buffer object (real, double)
59 : !> \param n : number of data slices in the buffer
60 : !> \param disps : displacement in data array of each slice, it contains
61 : !> one more element at the end recording the total
62 : !> size of the current data, which is the same as the
63 : !> displacement for the new data to be added
64 : !> \param data_1d : where all of the slices are stored
65 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
66 : ! **********************************************************************
67 : TYPE fb_buffer_d_data
68 : INTEGER :: n = -1
69 : INTEGER, DIMENSION(:), POINTER :: disps => NULL()
70 : REAL(KIND=dp), DIMENSION(:), POINTER :: data_1d => NULL()
71 : END TYPE fb_buffer_d_data
72 :
73 : ! **********************************************************************
74 : !> \brief object/pointer wrapper for fb_buffer object
75 : !> \param obj : pointer to fb_buffer data
76 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
77 : ! **********************************************************************
78 : TYPE fb_buffer_d_obj
79 : TYPE(fb_buffer_d_data), POINTER, PRIVATE :: obj => NULL()
80 : END TYPE fb_buffer_d_obj
81 :
82 : ! method overload interfaces
83 : INTERFACE fb_buffer_add
84 : MODULE PROCEDURE fb_buffer_i_add
85 : MODULE PROCEDURE fb_buffer_d_add
86 : END INTERFACE fb_buffer_add
87 :
88 : INTERFACE fb_buffer_create
89 : MODULE PROCEDURE fb_buffer_i_create
90 : MODULE PROCEDURE fb_buffer_d_create
91 : END INTERFACE fb_buffer_create
92 :
93 : INTERFACE fb_buffer_calc_disps
94 : MODULE PROCEDURE fb_buffer_i_calc_disps
95 : MODULE PROCEDURE fb_buffer_d_calc_disps
96 : END INTERFACE fb_buffer_calc_disps
97 :
98 : INTERFACE fb_buffer_calc_sizes
99 : MODULE PROCEDURE fb_buffer_i_calc_sizes
100 : MODULE PROCEDURE fb_buffer_d_calc_sizes
101 : END INTERFACE fb_buffer_calc_sizes
102 :
103 : INTERFACE fb_buffer_get
104 : MODULE PROCEDURE fb_buffer_i_get
105 : MODULE PROCEDURE fb_buffer_d_get
106 : END INTERFACE fb_buffer_get
107 :
108 : INTERFACE fb_buffer_has_data
109 : MODULE PROCEDURE fb_buffer_i_has_data
110 : MODULE PROCEDURE fb_buffer_d_has_data
111 : END INTERFACE fb_buffer_has_data
112 :
113 : INTERFACE fb_buffer_release
114 : MODULE PROCEDURE fb_buffer_i_release
115 : MODULE PROCEDURE fb_buffer_d_release
116 : END INTERFACE fb_buffer_release
117 :
118 : INTERFACE fb_buffer_nullify
119 : MODULE PROCEDURE fb_buffer_i_nullify
120 : MODULE PROCEDURE fb_buffer_d_nullify
121 : END INTERFACE fb_buffer_nullify
122 :
123 : INTERFACE fb_buffer_replace
124 : MODULE PROCEDURE fb_buffer_i_replace
125 : MODULE PROCEDURE fb_buffer_d_replace
126 : END INTERFACE fb_buffer_replace
127 :
128 : CONTAINS
129 :
130 : ! INTEGER VERSION
131 :
132 : ! **************************************************************************************************
133 : !> \brief releases the given fb_buffer
134 : !> \param buffer : the fb_bffer object
135 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
136 : ! **************************************************************************************************
137 0 : SUBROUTINE fb_buffer_i_release(buffer)
138 : TYPE(fb_buffer_i_obj), INTENT(INOUT) :: buffer
139 :
140 0 : IF (ASSOCIATED(buffer%obj)) THEN
141 0 : IF (ASSOCIATED(buffer%obj%data_1d)) THEN
142 0 : DEALLOCATE (buffer%obj%data_1d)
143 : END IF
144 0 : IF (ASSOCIATED(buffer%obj%disps)) THEN
145 0 : DEALLOCATE (buffer%obj%disps)
146 : END IF
147 0 : DEALLOCATE (buffer%obj)
148 : ELSE
149 0 : NULLIFY (buffer%obj)
150 : END IF
151 0 : END SUBROUTINE fb_buffer_i_release
152 :
153 : ! **************************************************************************************************
154 : !> \brief nullify the given fb_buffer
155 : !> \param buffer : the fb_bffer object
156 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
157 : ! **************************************************************************************************
158 0 : SUBROUTINE fb_buffer_i_nullify(buffer)
159 : TYPE(fb_buffer_i_obj), INTENT(INOUT) :: buffer
160 :
161 0 : NULLIFY (buffer%obj)
162 0 : END SUBROUTINE fb_buffer_i_nullify
163 :
164 : ! **************************************************************************************************
165 : !> \brief check if an object as associated data
166 : !> \param buffer : fb_buffer object
167 : !> \return : .TRUE. if buffer has associated data
168 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
169 : ! **************************************************************************************************
170 0 : PURE FUNCTION fb_buffer_i_has_data(buffer) RESULT(res)
171 : TYPE(fb_buffer_i_obj), INTENT(IN) :: buffer
172 : LOGICAL :: res
173 :
174 0 : res = ASSOCIATED(buffer%obj)
175 0 : END FUNCTION fb_buffer_i_has_data
176 :
177 : ! **************************************************************************************************
178 : !> \brief creates a fb_buffer object
179 : !> \param buffer : fb_buffer object
180 : !> \param max_size : requested total size of the data array
181 : !> \param nslices : total number of slices for the data
182 : !> \param data_1d : the data to be copied to the buffer
183 : !> \param sizes : the size of the slices in the buffer
184 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
185 : ! **************************************************************************************************
186 0 : SUBROUTINE fb_buffer_i_create(buffer, &
187 : max_size, &
188 : nslices, &
189 0 : data_1d, &
190 0 : sizes)
191 : TYPE(fb_buffer_i_obj), INTENT(INOUT) :: buffer
192 : INTEGER, INTENT(IN), OPTIONAL :: max_size, nslices
193 : INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: data_1d, sizes
194 :
195 : INTEGER :: my_max_size, my_ndata, my_nslices
196 : LOGICAL :: check_ok
197 :
198 : ! check optional input
199 :
200 0 : IF (PRESENT(data_1d)) THEN
201 0 : CPASSERT(PRESENT(sizes))
202 : END IF
203 :
204 0 : CPASSERT(.NOT. ASSOCIATED(buffer%obj))
205 0 : ALLOCATE (buffer%obj)
206 : ! work out the size of the data array and number of slices
207 0 : my_max_size = 0
208 0 : my_nslices = 0
209 0 : my_ndata = 0
210 : NULLIFY (buffer%obj%data_1d, &
211 : buffer%obj%disps)
212 : ! work out sizes
213 0 : IF (PRESENT(max_size)) my_max_size = max_size
214 0 : IF (PRESENT(nslices)) my_nslices = nslices
215 0 : IF (PRESENT(sizes)) THEN
216 0 : my_nslices = MIN(my_nslices, SIZE(sizes))
217 0 : my_ndata = SUM(sizes(1:my_nslices))
218 0 : my_max_size = MAX(my_max_size, my_ndata)
219 : END IF
220 : ! allocate the arrays
221 0 : ALLOCATE (buffer%obj%data_1d(my_max_size))
222 0 : ALLOCATE (buffer%obj%disps(my_nslices))
223 0 : buffer%obj%data_1d = 0
224 0 : buffer%obj%disps = 0
225 : ! set n for buffer before calc disps
226 0 : buffer%obj%n = my_nslices
227 : ! compute disps from sizes if required
228 0 : IF (PRESENT(sizes)) THEN
229 0 : CALL fb_buffer_calc_disps(buffer, sizes)
230 : END IF
231 : ! copy data
232 0 : IF (PRESENT(data_1d)) THEN
233 : check_ok = SIZE(data_1d) >= my_max_size .AND. &
234 0 : PRESENT(sizes)
235 0 : CPASSERT(check_ok)
236 0 : buffer%obj%data_1d(1:my_ndata) = data_1d(1:my_ndata)
237 : END IF
238 0 : END SUBROUTINE fb_buffer_i_create
239 :
240 : ! **************************************************************************************************
241 : !> \brief add some data into the buffer
242 : !> \param buffer : fb_buffer object
243 : !> \param data_1d : data to be copied into the object
244 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
245 : ! **************************************************************************************************
246 0 : SUBROUTINE fb_buffer_i_add(buffer, data_1d)
247 : TYPE(fb_buffer_i_obj), INTENT(INOUT) :: buffer
248 : INTEGER, DIMENSION(:), INTENT(IN) :: data_1d
249 :
250 : INTEGER :: new_data_size, new_n, this_size
251 0 : INTEGER, DIMENSION(:), POINTER :: new_data, new_disps
252 :
253 0 : NULLIFY (new_disps, new_data)
254 :
255 0 : this_size = SIZE(data_1d)
256 0 : new_n = buffer%obj%n + 1
257 0 : new_data_size = buffer%obj%disps(new_n) + this_size
258 : ! resize when needed
259 0 : IF (SIZE(buffer%obj%disps) < new_n + 1) THEN
260 0 : ALLOCATE (new_disps(new_n*2))
261 0 : new_disps = 0
262 0 : new_disps(1:buffer%obj%n + 1) = buffer%obj%disps(1:buffer%obj%n + 1)
263 0 : DEALLOCATE (buffer%obj%disps)
264 0 : buffer%obj%disps => new_disps
265 : END IF
266 0 : IF (SIZE(buffer%obj%data_1d) < new_data_size) THEN
267 0 : ALLOCATE (new_data(new_data_size*2))
268 0 : new_data = 0
269 : new_data(1:buffer%obj%disps(new_n)) = &
270 0 : buffer%obj%data_1d(1:buffer%obj%disps(new_n))
271 0 : DEALLOCATE (buffer%obj%data_1d)
272 0 : buffer%obj%data_1d => new_data
273 : END IF
274 : ! append to the buffer
275 0 : buffer%obj%disps(new_n + 1) = new_data_size
276 : buffer%obj%data_1d(buffer%obj%disps(new_n) + 1:new_data_size) = &
277 0 : data_1d(1:this_size)
278 0 : buffer%obj%n = new_n
279 0 : END SUBROUTINE fb_buffer_i_add
280 :
281 : ! **************************************************************************************************
282 : !> \brief compute the displacements of each slice in a data buffer from
283 : !> a given list of sizes of each slice
284 : !> \param buffer : fb_buffer object
285 : !> \param sizes : list of sizes of each slice on input
286 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
287 : ! **************************************************************************************************
288 0 : SUBROUTINE fb_buffer_i_calc_disps(buffer, sizes)
289 : TYPE(fb_buffer_i_obj), INTENT(INOUT) :: buffer
290 : INTEGER, DIMENSION(:), INTENT(IN) :: sizes
291 :
292 : INTEGER :: ii
293 :
294 0 : CPASSERT(SIZE(sizes) >= buffer%obj%n)
295 0 : buffer%obj%disps(1) = 0
296 0 : DO ii = 2, buffer%obj%n + 1
297 0 : buffer%obj%disps(ii) = buffer%obj%disps(ii - 1) + sizes(ii - 1)
298 : END DO
299 0 : END SUBROUTINE fb_buffer_i_calc_disps
300 :
301 : ! **************************************************************************************************
302 : !> \brief compute the sizes of each slice
303 : !> \param buffer : fb_buffer object
304 : !> \param sizes : list of sizes of each slice on output
305 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
306 : ! **************************************************************************************************
307 0 : SUBROUTINE fb_buffer_i_calc_sizes(buffer, sizes)
308 : TYPE(fb_buffer_i_obj), INTENT(IN) :: buffer
309 : INTEGER, DIMENSION(:), INTENT(OUT) :: sizes
310 :
311 : INTEGER :: ii
312 :
313 0 : CPASSERT(SIZE(sizes) >= buffer%obj%n)
314 0 : DO ii = 1, buffer%obj%n
315 0 : sizes(ii) = buffer%obj%disps(ii + 1) - buffer%obj%disps(ii)
316 : END DO
317 0 : END SUBROUTINE fb_buffer_i_calc_sizes
318 :
319 : ! **************************************************************************************************
320 : !> \brief get data from the fb_buffer object
321 : !> \param buffer : fb_buffer object
322 : !> \param i_slice : see data_1d, data_2d
323 : !> \param n : outputs number of slices in data array
324 : !> \param data_size : outputs the total size of stored data
325 : !> \param sizes : outputs sizes of the slices in data array
326 : !> \param disps : outputs displacements in the data array for each slice
327 : !> \param data_1d : if i_slice is present:
328 : !> returns pointer to the section of data array corresponding
329 : !> to i_slice-th slice
330 : !> else:
331 : !> return pointer to the entire non-empty part of the data array
332 : !> \param data_2d : similar to data_1d, but with the 1D data array reshaped to 2D
333 : !> works only with i_slice present
334 : !> \param data_2d_ld : leading dimension for data_2d for slice i_slice
335 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
336 : ! **************************************************************************************************
337 0 : SUBROUTINE fb_buffer_i_get(buffer, &
338 : i_slice, &
339 : n, &
340 : data_size, &
341 0 : sizes, &
342 0 : disps, &
343 : data_1d, &
344 : data_2d, &
345 : data_2d_ld)
346 : TYPE(fb_buffer_i_obj), INTENT(IN) :: buffer
347 : INTEGER, INTENT(IN), OPTIONAL :: i_slice
348 : INTEGER, INTENT(OUT), OPTIONAL :: n, data_size
349 : INTEGER, DIMENSION(:), INTENT(OUT), OPTIONAL :: sizes, disps
350 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: data_1d
351 : INTEGER, DIMENSION(:, :), OPTIONAL, POINTER :: data_2d
352 : INTEGER, INTENT(IN), OPTIONAL :: data_2d_ld
353 :
354 : INTEGER :: ncols, slice_size
355 :
356 0 : IF (PRESENT(n)) n = buffer%obj%n
357 0 : IF (PRESENT(data_size)) data_size = buffer%obj%disps(buffer%obj%n + 1)
358 0 : IF (PRESENT(sizes)) THEN
359 0 : CALL fb_buffer_calc_sizes(buffer, sizes)
360 : END IF
361 0 : IF (PRESENT(disps)) THEN
362 0 : CPASSERT(SIZE(disps) >= buffer%obj%n)
363 0 : disps(1:buffer%obj%n) = buffer%obj%disps(1:buffer%obj%n)
364 : END IF
365 0 : IF (PRESENT(data_1d)) THEN
366 0 : IF (PRESENT(i_slice)) THEN
367 0 : CPASSERT(i_slice <= buffer%obj%n)
368 : data_1d => buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: &
369 0 : buffer%obj%disps(i_slice + 1))
370 : ELSE
371 0 : data_1d => buffer%obj%data_1d(1:buffer%obj%disps(buffer%obj%n + 1))
372 : END IF
373 : END IF
374 0 : IF (PRESENT(data_2d)) THEN
375 0 : CPASSERT(PRESENT(data_2d_ld))
376 0 : CPASSERT(PRESENT(i_slice))
377 : ! cannot, or rather, it is inefficient to use reshape here, as
378 : ! a) reshape does not return a targeted array, so cannot
379 : ! associate pointer unless copied to a targeted array. b) in
380 : ! F2003 standard, pointers should rank remap automatically by
381 : ! association to a rank 1 array
382 0 : slice_size = buffer%obj%disps(i_slice + 1) - buffer%obj%disps(i_slice)
383 0 : ncols = slice_size/data_2d_ld
384 0 : CPASSERT(slice_size == data_2d_ld*ncols)
385 : data_2d(1:data_2d_ld, 1:ncols) => &
386 : buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: &
387 0 : buffer%obj%disps(i_slice + 1))
388 : END IF
389 0 : END SUBROUTINE fb_buffer_i_get
390 :
391 : ! **************************************************************************************************
392 : !> \brief replace a slice of the buffer, the replace data size must be
393 : !> identical to the original slice size
394 : !> \param buffer : fb_buffer object
395 : !> \param i_slice : the slice index in the buffer
396 : !> \param data_1d : the data to replace the slice
397 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
398 : ! **************************************************************************************************
399 0 : SUBROUTINE fb_buffer_i_replace(buffer, i_slice, data_1d)
400 : TYPE(fb_buffer_i_obj), INTENT(INOUT) :: buffer
401 : INTEGER, INTENT(IN) :: i_slice
402 : INTEGER, DIMENSION(:), INTENT(IN) :: data_1d
403 :
404 : INTEGER :: slice_size
405 :
406 0 : slice_size = buffer%obj%disps(i_slice + 1) - buffer%obj%disps(i_slice)
407 0 : CPASSERT(SIZE(data_1d) == slice_size)
408 : buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: &
409 0 : buffer%obj%disps(i_slice + 1)) = data_1d
410 0 : END SUBROUTINE fb_buffer_i_replace
411 :
412 : ! DOUBLE PRECISION VERSION
413 :
414 : ! **************************************************************************************************
415 : !> \brief releases the given fb_buffer
416 : !> \param buffer : the fb_bffer object
417 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
418 : ! **************************************************************************************************
419 48 : SUBROUTINE fb_buffer_d_release(buffer)
420 : TYPE(fb_buffer_d_obj), INTENT(INOUT) :: buffer
421 :
422 48 : IF (ASSOCIATED(buffer%obj)) THEN
423 48 : IF (ASSOCIATED(buffer%obj%data_1d)) THEN
424 48 : DEALLOCATE (buffer%obj%data_1d)
425 : END IF
426 48 : IF (ASSOCIATED(buffer%obj%disps)) THEN
427 48 : DEALLOCATE (buffer%obj%disps)
428 : END IF
429 48 : DEALLOCATE (buffer%obj)
430 : ELSE
431 0 : NULLIFY (buffer%obj)
432 : END IF
433 48 : END SUBROUTINE fb_buffer_d_release
434 :
435 : ! **************************************************************************************************
436 : !> \brief nullify the given fb_buffer
437 : !> \param buffer : the fb_bffer object
438 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
439 : ! **************************************************************************************************
440 48 : SUBROUTINE fb_buffer_d_nullify(buffer)
441 : TYPE(fb_buffer_d_obj), INTENT(INOUT) :: buffer
442 :
443 48 : NULLIFY (buffer%obj)
444 48 : END SUBROUTINE fb_buffer_d_nullify
445 :
446 : ! **************************************************************************************************
447 : !> \brief check if an object as associated data
448 : !> \param buffer : fb_buffer object
449 : !> \return : .TRUE. if buffer has associated data
450 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
451 : ! **************************************************************************************************
452 96 : PURE FUNCTION fb_buffer_d_has_data(buffer) RESULT(res)
453 : TYPE(fb_buffer_d_obj), INTENT(IN) :: buffer
454 : LOGICAL :: res
455 :
456 96 : res = ASSOCIATED(buffer%obj)
457 96 : END FUNCTION fb_buffer_d_has_data
458 :
459 : ! **************************************************************************************************
460 : !> \brief creates a fb_buffer object
461 : !> \param buffer : fb_buffer object
462 : !> \param max_size : requested total size of the data array
463 : !> \param nslices : total number of slices for the data
464 : !> \param data_1d : the data to be copied to the buffer
465 : !> \param sizes : the size of the slices in the buffer
466 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
467 : ! **************************************************************************************************
468 48 : SUBROUTINE fb_buffer_d_create(buffer, &
469 : max_size, &
470 : nslices, &
471 48 : data_1d, &
472 48 : sizes)
473 : TYPE(fb_buffer_d_obj), INTENT(INOUT) :: buffer
474 : INTEGER, INTENT(IN), OPTIONAL :: max_size, nslices
475 : REAL(KIND=dp), DIMENSION(:), INTENT(IN), OPTIONAL :: data_1d
476 : INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: sizes
477 :
478 : INTEGER :: my_max_size, my_ndata, my_nslices
479 : LOGICAL :: check_ok
480 :
481 : ! check optional input
482 :
483 48 : IF (PRESENT(data_1d)) THEN
484 0 : CPASSERT(PRESENT(sizes))
485 : END IF
486 :
487 48 : CPASSERT(.NOT. ASSOCIATED(buffer%obj))
488 48 : ALLOCATE (buffer%obj)
489 : ! work out the size of the data array and number of slices
490 48 : my_max_size = 0
491 48 : my_nslices = 0
492 48 : my_ndata = 0
493 : NULLIFY (buffer%obj%data_1d, &
494 : buffer%obj%disps)
495 : ! work out sizes
496 48 : IF (PRESENT(max_size)) my_max_size = max_size
497 48 : IF (PRESENT(nslices)) my_nslices = nslices
498 48 : IF (PRESENT(sizes)) THEN
499 0 : my_nslices = MIN(my_nslices, SIZE(sizes))
500 0 : my_ndata = SUM(sizes(1:my_nslices))
501 0 : my_max_size = MAX(my_max_size, my_ndata)
502 : END IF
503 : ! allocate the arrays
504 96 : ALLOCATE (buffer%obj%data_1d(my_max_size))
505 144 : ALLOCATE (buffer%obj%disps(my_nslices + 1))
506 48 : buffer%obj%data_1d = 0
507 96 : buffer%obj%disps = 0
508 : ! set n for buffer before calc disps
509 48 : buffer%obj%n = my_nslices
510 : ! compute disps from sizes if required
511 48 : IF (PRESENT(sizes)) THEN
512 0 : CALL fb_buffer_calc_disps(buffer, sizes)
513 : END IF
514 : ! copy data
515 48 : IF (PRESENT(data_1d)) THEN
516 : check_ok = SIZE(data_1d) >= my_max_size .AND. &
517 0 : PRESENT(sizes)
518 0 : CPASSERT(check_ok)
519 0 : buffer%obj%data_1d(1:my_ndata) = data_1d(1:my_ndata)
520 : END IF
521 48 : END SUBROUTINE fb_buffer_d_create
522 :
523 : ! **************************************************************************************************
524 : !> \brief add some data into the buffer
525 : !> \param buffer : fb_buffer object
526 : !> \param data_1d : data to be copied into the object
527 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
528 : ! **************************************************************************************************
529 1664 : SUBROUTINE fb_buffer_d_add(buffer, data_1d)
530 : TYPE(fb_buffer_d_obj), INTENT(INOUT) :: buffer
531 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: data_1d
532 :
533 : INTEGER :: new_data_size, new_n, this_size
534 1664 : INTEGER, DIMENSION(:), POINTER :: new_disps
535 1664 : REAL(KIND=dp), DIMENSION(:), POINTER :: new_data
536 :
537 1664 : NULLIFY (new_disps, new_data)
538 :
539 1664 : this_size = SIZE(data_1d)
540 1664 : new_n = buffer%obj%n + 1
541 1664 : new_data_size = buffer%obj%disps(new_n) + this_size
542 : ! resize when needed
543 1664 : IF (SIZE(buffer%obj%disps) < new_n + 1) THEN
544 864 : ALLOCATE (new_disps(new_n*2))
545 6336 : new_disps = 0
546 3312 : new_disps(1:buffer%obj%n + 1) = buffer%obj%disps(1:buffer%obj%n + 1)
547 288 : DEALLOCATE (buffer%obj%disps)
548 288 : buffer%obj%disps => new_disps
549 : END IF
550 1664 : IF (SIZE(buffer%obj%data_1d) < new_data_size) THEN
551 720 : ALLOCATE (new_data(new_data_size*2))
552 711600 : new_data = 0.0_dp
553 : new_data(1:buffer%obj%disps(new_n)) = &
554 324720 : buffer%obj%data_1d(1:buffer%obj%disps(new_n))
555 240 : DEALLOCATE (buffer%obj%data_1d)
556 240 : buffer%obj%data_1d => new_data
557 : END IF
558 : ! append to the buffer
559 1664 : buffer%obj%disps(new_n + 1) = new_data_size
560 : buffer%obj%data_1d(buffer%obj%disps(new_n) + 1:new_data_size) = &
561 222976 : data_1d(1:this_size)
562 1664 : buffer%obj%n = new_n
563 1664 : END SUBROUTINE fb_buffer_d_add
564 :
565 : ! **************************************************************************************************
566 : !> \brief compute the displacements of each slice in a data buffer from
567 : !> a given list of sizes of each slice
568 : !> \param buffer : fb_buffer object
569 : !> \param sizes : list of sizes of each slice on input
570 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
571 : ! **************************************************************************************************
572 0 : SUBROUTINE fb_buffer_d_calc_disps(buffer, sizes)
573 : TYPE(fb_buffer_d_obj), INTENT(INOUT) :: buffer
574 : INTEGER, DIMENSION(:), INTENT(IN) :: sizes
575 :
576 : INTEGER :: ii
577 :
578 0 : CPASSERT(SIZE(sizes) >= buffer%obj%n)
579 0 : buffer%obj%disps(1) = 0
580 0 : DO ii = 2, buffer%obj%n + 1
581 0 : buffer%obj%disps(ii) = buffer%obj%disps(ii - 1) + sizes(ii - 1)
582 : END DO
583 0 : END SUBROUTINE fb_buffer_d_calc_disps
584 :
585 : ! **************************************************************************************************
586 : !> \brief compute the sizes of each slice
587 : !> \param buffer : fb_buffer object
588 : !> \param sizes : list of sizes of each slice on output
589 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
590 : ! **************************************************************************************************
591 0 : SUBROUTINE fb_buffer_d_calc_sizes(buffer, sizes)
592 : TYPE(fb_buffer_d_obj), INTENT(IN) :: buffer
593 : INTEGER, DIMENSION(:), INTENT(OUT) :: sizes
594 :
595 : INTEGER :: ii
596 :
597 0 : CPASSERT(SIZE(sizes) >= buffer%obj%n)
598 0 : DO ii = 1, buffer%obj%n
599 0 : sizes(ii) = buffer%obj%disps(ii + 1) - buffer%obj%disps(ii)
600 : END DO
601 0 : END SUBROUTINE fb_buffer_d_calc_sizes
602 :
603 : ! **************************************************************************************************
604 : !> \brief get data from the fb_buffer object
605 : !> \param buffer : fb_buffer object
606 : !> \param i_slice : see data_1d, data_2d
607 : !> \param n : outputs number of slices in data array
608 : !> \param data_size : outputs the total size of stored data
609 : !> \param sizes : outputs sizes of the slices in data array
610 : !> \param disps : outputs displacements in the data array for each slice
611 : !> \param data_1d : if i_slice is present:
612 : !> returns pointer to the section of data array corresponding
613 : !> to i_slice-th slice
614 : !> else:
615 : !> return pointer to the entire non-empty part of the data array
616 : !> \param data_2d : similar to data_1d, but with the 1D data array reshaped to 2D
617 : !> works only with i_slice present
618 : !> \param data_2d_ld : leading dimension for data_2d for slice i_slice
619 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
620 : ! **************************************************************************************************
621 5120 : SUBROUTINE fb_buffer_d_get(buffer, &
622 : i_slice, &
623 : n, &
624 : data_size, &
625 5120 : sizes, &
626 5120 : disps, &
627 : data_1d, &
628 : data_2d, &
629 : data_2d_ld)
630 : TYPE(fb_buffer_d_obj), INTENT(IN) :: buffer
631 : INTEGER, INTENT(IN), OPTIONAL :: i_slice
632 : INTEGER, INTENT(OUT), OPTIONAL :: n, data_size
633 : INTEGER, DIMENSION(:), INTENT(OUT), OPTIONAL :: sizes, disps
634 : REAL(KIND=dp), DIMENSION(:), OPTIONAL, POINTER :: data_1d
635 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: data_2d
636 : INTEGER, INTENT(IN), OPTIONAL :: data_2d_ld
637 :
638 : INTEGER :: ncols, slice_size
639 :
640 5120 : IF (PRESENT(n)) n = buffer%obj%n
641 5120 : IF (PRESENT(data_size)) data_size = buffer%obj%disps(buffer%obj%n + 1)
642 5120 : IF (PRESENT(sizes)) THEN
643 0 : CALL fb_buffer_calc_sizes(buffer, sizes)
644 : END IF
645 5120 : IF (PRESENT(disps)) THEN
646 0 : CPASSERT(SIZE(disps) >= buffer%obj%n)
647 0 : disps(1:buffer%obj%n) = buffer%obj%disps(1:buffer%obj%n)
648 : END IF
649 5120 : IF (PRESENT(data_1d)) THEN
650 0 : IF (PRESENT(i_slice)) THEN
651 0 : CPASSERT(i_slice <= buffer%obj%n)
652 : data_1d => buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: &
653 0 : buffer%obj%disps(i_slice + 1))
654 : ELSE
655 0 : data_1d => buffer%obj%data_1d(1:buffer%obj%disps(buffer%obj%n + 1))
656 : END IF
657 : END IF
658 5120 : IF (PRESENT(data_2d)) THEN
659 5120 : CPASSERT(PRESENT(data_2d_ld))
660 5120 : CPASSERT(PRESENT(i_slice))
661 : ! cannot, or rather, it is inefficient to use reshape here, as
662 : ! a) reshape does not return a targeted array, so cannot
663 : ! associate pointer unless copied to a targeted array. b) in
664 : ! F2003 standard, pointers should rank remap automatically by
665 : ! association to a rank 1 array
666 5120 : slice_size = buffer%obj%disps(i_slice + 1) - buffer%obj%disps(i_slice)
667 5120 : ncols = slice_size/data_2d_ld
668 5120 : CPASSERT(slice_size == data_2d_ld*ncols)
669 : data_2d(1:data_2d_ld, 1:ncols) => &
670 : buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: &
671 5120 : buffer%obj%disps(i_slice + 1))
672 : END IF
673 5120 : END SUBROUTINE fb_buffer_d_get
674 :
675 : ! **************************************************************************************************
676 : !> \brief replace a slice of the buffer, the replace data size must be
677 : !> identical to the original slice size
678 : !> \param buffer : fb_buffer object
679 : !> \param i_slice : the slice index in the buffer
680 : !> \param data_1d : the data to replace the slice
681 : !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
682 : ! **************************************************************************************************
683 0 : SUBROUTINE fb_buffer_d_replace(buffer, i_slice, data_1d)
684 : TYPE(fb_buffer_d_obj), INTENT(INOUT) :: buffer
685 : INTEGER, INTENT(IN) :: i_slice
686 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: data_1d
687 :
688 : INTEGER :: slice_size
689 :
690 0 : slice_size = buffer%obj%disps(i_slice + 1) - buffer%obj%disps(i_slice)
691 0 : CPASSERT(SIZE(data_1d) == slice_size)
692 : buffer%obj%data_1d(buffer%obj%disps(i_slice) + 1: &
693 0 : buffer%obj%disps(i_slice + 1)) = data_1d
694 0 : END SUBROUTINE fb_buffer_d_replace
695 :
696 0 : END MODULE qs_fb_buffer_types
|
