memory_utilities_unittest.F

Go to the documentation of this file.

!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright 2000-2024 CP2K developers group <https://cp2k.org>                                   !
!                                                                                                  !
!   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
!--------------------------------------------------------------------------------------------------!
 
PROGRAM memory_utilities_test
   USE kinds,                           ONLY: dp
   USE memory_utilities,                ONLY: reallocate
 
   IMPLICIT NONE
 
   CALL check_real_rank1_allocated()
   CALL check_real_rank1_unallocated()
 
   CALL check_real_rank2_allocated()
   CALL check_real_rank2_unallocated()
 
   CALL check_string_rank1_allocated()
   CALL check_string_rank1_unallocated()
CONTAINS
! **************************************************************************************************
!> \brief Check that an allocated r1 array can be extended
! **************************************************************************************************
   SUBROUTINE check_real_rank1_allocated()
      INTEGER                                            :: idx
      REAL(KIND=dp), DIMENSION(:), POINTER               :: real_arr
 
      ALLOCATE (real_arr(10))
      real_arr = [(idx, idx=1, 10)]
 
      CALL reallocate(real_arr, 1, 20)
 
      IF (.NOT. all(real_arr(1:10) == [(idx, idx=1, 10)])) &
         error stop "check_real_rank1_allocated: reallocating changed the initial values"
 
      IF (.NOT. all(real_arr(11:20) == 0.)) &
         error stop "check_real_rank1_allocated: reallocation failed to initialise new values with 0."
 
      DEALLOCATE (real_arr)
 
      print *, "check_real_rank1_allocated: OK"
   END SUBROUTINE
 
! **************************************************************************************************
!> \brief Check that an unallocated and unassociated (null) r1 array can be extended
! **************************************************************************************************
   SUBROUTINE check_real_rank1_unallocated()
      REAL(KIND=dp), DIMENSION(:), POINTER               :: real_arr
 
      NULLIFY (real_arr)
 
      CALL reallocate(real_arr, 1, 20)
 
      IF (.NOT. all(real_arr(1:20) == 0.)) &
         error stop "check_real_rank1_unallocated: reallocation failed to initialise new values with 0."
 
      DEALLOCATE (real_arr)
 
      print *, "check_real_rank1_unallocated: OK"
   END SUBROUTINE
 
! **************************************************************************************************
!> \brief Check that an allocated r2 array can be extended
! **************************************************************************************************
   SUBROUTINE check_real_rank2_allocated()
      INTEGER                                            :: idx
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: real_arr
 
      ALLOCATE (real_arr(5, 2))
      real_arr = reshape([(idx, idx=1, 10)], [5, 2])
 
      CALL reallocate(real_arr, 1, 10, 1, 5)
 
      IF (.NOT. (all(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. all(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) &
         error stop "check_real_rank2_allocated: reallocating changed the initial values"
 
      IF (.NOT. (all(real_arr(6:10, 1:2) == 0.) .AND. all(real_arr(1:10, 3:5) == 0.))) &
         error stop "check_real_rank2_allocated: reallocation failed to initialise new values with 0."
 
      DEALLOCATE (real_arr)
 
      print *, "check_real_rank1_allocated: OK"
   END SUBROUTINE
 
! **************************************************************************************************
!> \brief Check that an unallocated and unassociated (null) r2 array can be extended
! **************************************************************************************************
   SUBROUTINE check_real_rank2_unallocated()
      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: real_arr
 
      NULLIFY (real_arr)
 
      CALL reallocate(real_arr, 1, 10, 1, 5)
 
      IF (.NOT. all(real_arr(1:10, 1:5) == 0.)) &
         error stop "check_real_rank2_unallocated: reallocation failed to initialise new values with 0."
 
      DEALLOCATE (real_arr)
 
      print *, "check_real_rank2_unallocated: OK"
   END SUBROUTINE
 
! **************************************************************************************************
!> \brief Check that an allocated string array can be extended
! **************************************************************************************************
   SUBROUTINE check_string_rank1_allocated()
      CHARACTER(LEN=12), DIMENSION(:), POINTER           :: str_arr
      INTEGER                                            :: idx
 
      ALLOCATE (str_arr(10))
      str_arr = [("hello, there", idx=1, 10)]
 
      CALL reallocate(str_arr, 1, 20)
 
      IF (.NOT. all(str_arr(1:10) == [("hello, there", idx=1, 10)])) &
         error stop "check_string_rank1_allocated: reallocating changed the initial values"
 
      IF (.NOT. all(str_arr(11:20) == "")) &
         error stop "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
 
      DEALLOCATE (str_arr)
 
      print *, "check_string_rank1_allocated: OK"
   END SUBROUTINE
 
! **************************************************************************************************
!> \brief Check that an unallocated string array can be extended
! **************************************************************************************************
   SUBROUTINE check_string_rank1_unallocated()
      CHARACTER(LEN=12), DIMENSION(:), POINTER           :: str_arr
 
      NULLIFY (str_arr)
 
      CALL reallocate(str_arr, 1, 20)
 
      IF (.NOT. all(str_arr(1:20) == "")) &
         error stop "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
 
      DEALLOCATE (str_arr)
 
      print *, "check_string_rank1_unallocated: OK"
   END SUBROUTINE
 
END PROGRAM
! vim: set ts=3 sw=3 tw=132 :