LCOV - code coverage report
Current view: top level - src - qs_fb_buffer_types.F (source / functions) Coverage Total Hit
Test: CP2K Regtests (git:42dac4a) Lines: 33.2 % 238 79
Test Date: 2025-07-25 12:55:17 Functions: 23.1 % 26 6

            Line data    Source code
       1              : !--------------------------------------------------------------------------------------------------!
       2              : !   CP2K: A general program to perform molecular dynamics simulations                              !
       3              : !   Copyright 2000-2025 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
        

Generated by: LCOV version 2.0-1