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