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