Line data    Source code

       1             : !--------------------------------------------------------------------------------------------------!
       2             : !   CP2K: A general program to perform molecular dynamics simulations                              !
       3             : !   Copyright 2000-2024 CP2K developers group <https://cp2k.org>                                   !
       4             : !                                                                                                  !
       5             : !   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
       6             : !--------------------------------------------------------------------------------------------------!
       7             : 
       8           2 : PROGRAM memory_utilities_TEST
       9           2 :    USE kinds,                           ONLY: dp
      10             :    USE memory_utilities,                ONLY: reallocate
      11             : 
      12             :    IMPLICIT NONE
      13             : 
      14           2 :    CALL check_real_rank1_allocated()
      15           2 :    CALL check_real_rank1_unallocated()
      16             : 
      17           2 :    CALL check_real_rank2_allocated()
      18           2 :    CALL check_real_rank2_unallocated()
      19             : 
      20           2 :    CALL check_string_rank1_allocated()
      21           2 :    CALL check_string_rank1_unallocated()
      22             : CONTAINS
      23             : ! **************************************************************************************************
      24             : !> \brief Check that an allocated r1 array can be extended
      25             : ! **************************************************************************************************
      26           2 :    SUBROUTINE check_real_rank1_allocated()
      27             :       INTEGER                                            :: idx
      28             :       REAL(KIND=dp), DIMENSION(:), POINTER               :: real_arr
      29             : 
      30           2 :       ALLOCATE (real_arr(10))
      31          22 :       real_arr = [(idx, idx=1, 10)]
      32             : 
      33           2 :       CALL reallocate(real_arr, 1, 20)
      34             : 
      35          22 :       IF (.NOT. ALL(real_arr(1:10) == [(idx, idx=1, 10)])) &
      36           0 :          ERROR STOP "check_real_rank1_allocated: reallocating changed the initial values"
      37             : 
      38          22 :       IF (.NOT. ALL(real_arr(11:20) == 0.)) &
      39           0 :          ERROR STOP "check_real_rank1_allocated: reallocation failed to initialise new values with 0."
      40             : 
      41           2 :       DEALLOCATE (real_arr)
      42             : 
      43           2 :       PRINT *, "check_real_rank1_allocated: OK"
      44           2 :    END SUBROUTINE
      45             : 
      46             : ! **************************************************************************************************
      47             : !> \brief Check that an unallocated and unassociated (null) r1 array can be extended
      48             : ! **************************************************************************************************
      49           2 :    SUBROUTINE check_real_rank1_unallocated()
      50           2 :       REAL(KIND=dp), DIMENSION(:), POINTER               :: real_arr
      51             : 
      52           2 :       NULLIFY (real_arr)
      53             : 
      54           2 :       CALL reallocate(real_arr, 1, 20)
      55             : 
      56          42 :       IF (.NOT. ALL(real_arr(1:20) == 0.)) &
      57           0 :          ERROR STOP "check_real_rank1_unallocated: reallocation failed to initialise new values with 0."
      58             : 
      59           2 :       DEALLOCATE (real_arr)
      60             : 
      61           2 :       PRINT *, "check_real_rank1_unallocated: OK"
      62           2 :    END SUBROUTINE
      63             : 
      64             : ! **************************************************************************************************
      65             : !> \brief Check that an allocated r2 array can be extended
      66             : ! **************************************************************************************************
      67           2 :    SUBROUTINE check_real_rank2_allocated()
      68             :       INTEGER                                            :: idx
      69             :       REAL(KIND=dp), DIMENSION(:, :), POINTER            :: real_arr
      70             : 
      71           2 :       ALLOCATE (real_arr(5, 2))
      72          26 :       real_arr = RESHAPE([(idx, idx=1, 10)], [5, 2])
      73             : 
      74           2 :       CALL reallocate(real_arr, 1, 10, 1, 5)
      75             : 
      76          22 :       IF (.NOT. (ALL(real_arr(1:5, 1) == [(idx, idx=1, 5)]) .AND. ALL(real_arr(1:5, 2) == [(idx, idx=6, 10)]))) &
      77           0 :          ERROR STOP "check_real_rank2_allocated: reallocating changed the initial values"
      78             : 
      79          94 :       IF (.NOT. (ALL(real_arr(6:10, 1:2) == 0.) .AND. ALL(real_arr(1:10, 3:5) == 0.))) &
      80           0 :          ERROR STOP "check_real_rank2_allocated: reallocation failed to initialise new values with 0."
      81             : 
      82           2 :       DEALLOCATE (real_arr)
      83             : 
      84           2 :       PRINT *, "check_real_rank1_allocated: OK"
      85           2 :    END SUBROUTINE
      86             : 
      87             : ! **************************************************************************************************
      88             : !> \brief Check that an unallocated and unassociated (null) r2 array can be extended
      89             : ! **************************************************************************************************
      90           2 :    SUBROUTINE check_real_rank2_unallocated()
      91           2 :       REAL(KIND=dp), DIMENSION(:, :), POINTER            :: real_arr
      92             : 
      93           2 :       NULLIFY (real_arr)
      94             : 
      95           2 :       CALL reallocate(real_arr, 1, 10, 1, 5)
      96             : 
      97         112 :       IF (.NOT. ALL(real_arr(1:10, 1:5) == 0.)) &
      98           0 :          ERROR STOP "check_real_rank2_unallocated: reallocation failed to initialise new values with 0."
      99             : 
     100           2 :       DEALLOCATE (real_arr)
     101             : 
     102           2 :       PRINT *, "check_real_rank2_unallocated: OK"
     103           2 :    END SUBROUTINE
     104             : 
     105             : ! **************************************************************************************************
     106             : !> \brief Check that an allocated string array can be extended
     107             : ! **************************************************************************************************
     108           2 :    SUBROUTINE check_string_rank1_allocated()
     109             :       CHARACTER(LEN=12), DIMENSION(:), POINTER           :: str_arr
     110             :       INTEGER                                            :: idx
     111             : 
     112           2 :       ALLOCATE (str_arr(10))
     113          22 :       str_arr = [("hello, there", idx=1, 10)]
     114             : 
     115           2 :       CALL reallocate(str_arr, 1, 20)
     116             : 
     117          22 :       IF (.NOT. ALL(str_arr(1:10) == [("hello, there", idx=1, 10)])) &
     118           0 :          ERROR STOP "check_string_rank1_allocated: reallocating changed the initial values"
     119             : 
     120          22 :       IF (.NOT. ALL(str_arr(11:20) == "")) &
     121           0 :          ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
     122             : 
     123           2 :       DEALLOCATE (str_arr)
     124             : 
     125           2 :       PRINT *, "check_string_rank1_allocated: OK"
     126           2 :    END SUBROUTINE
     127             : 
     128             : ! **************************************************************************************************
     129             : !> \brief Check that an unallocated string array can be extended
     130             : ! **************************************************************************************************
     131           2 :    SUBROUTINE check_string_rank1_unallocated()
     132           2 :       CHARACTER(LEN=12), DIMENSION(:), POINTER           :: str_arr
     133             : 
     134           2 :       NULLIFY (str_arr)
     135             : 
     136           2 :       CALL reallocate(str_arr, 1, 20)
     137             : 
     138          42 :       IF (.NOT. ALL(str_arr(1:20) == "")) &
     139           0 :          ERROR STOP "check_string_rank1_allocated: reallocation failed to initialise new values with ''."
     140             : 
     141           2 :       DEALLOCATE (str_arr)
     142             : 
     143           2 :       PRINT *, "check_string_rank1_unallocated: OK"
     144           2 :    END SUBROUTINE
     145             : 
     146             : END PROGRAM
     147             : ! vim: set ts=3 sw=3 tw=132 :