Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 2 : PROGRAM topology_snapshot_unittest
9 2 : USE cp_files, ONLY: close_file,&
10 : open_file
11 : USE kinds, ONLY: dp
12 : USE orbital_pointers, ONLY: init_orbital_pointers
13 : USE topology_snapshot, ONLY: check_snapshot,&
14 : check_snapshot_seam,&
15 : snapshot_overlap,&
16 : snapshot_type
17 :
18 : IMPLICIT NONE
19 : REAL(KIND=dp), PARAMETER :: pi = 3.1415926535897932384626433832795_dp, tolerance = 1.e-12_dp
20 122 : TYPE(snapshot_type) :: a, b
21 : COMPLEX(KIND=dp) :: m(1, 1), reverse(1, 1), phase
22 : REAL(KIND=dp) :: metric, gap
23 : INTEGER :: i
24 2 : CALL test_scratch_links()
25 2 : CALL init_orbital_pointers(1)
26 2 : a%nao = 1
27 2 : a%rank = 1
28 2 : a%nspin = 1
29 2 : a%channel = 1
30 8 : DO i = 1, 3
31 6 : a%cell(i, i) = 20.0_dp
32 8 : a%inverse(i, i) = 0.05_dp
33 : END DO
34 10 : ALLOCATE (a%atoms(1), a%bands(1), a%energies(2), a%coefficients(1, 1))
35 2 : a%bands(1) = 1
36 6 : a%energies(:) = [-1.0_dp, 1.0_dp]
37 6 : a%coefficients(:, :) = 1.0_dp
38 2 : a%atoms(1)%kind = 1
39 2 : a%atoms(1)%count = 1
40 10 : ALLOCATE (a%atoms(1)%shells(1))
41 : ASSOCIATE (s => a%atoms(1)%shells(1))
42 2 : s%first = 1
43 2 : s%count = 1
44 2 : s%radius = 5.0_dp
45 2 : ALLOCATE (s%exponent(1), s%radii(1), s%contraction(1, 1))
46 2 : s%exponent(1) = 1.0_dp
47 2 : s%radii(1) = 5.0_dp
48 2 : s%contraction(1, 1) = (2.0_dp/pi)**0.75_dp
49 : END ASSOCIATE
50 2 : CALL check_snapshot(a, tolerance, tolerance, metric, gap)
51 2 : IF (metric > tolerance .OR. ABS(gap - 2.0_dp) > tolerance) ERROR STOP 'Incorrect snapshot metric or gap'
52 : ! Derived-type assignment deliberately deep-copies allocatable frame components.
53 6 : b = a
54 2 : b%atoms(1)%center(1) = 0.7_dp
55 2 : b%atoms(1)%shells(1)%center(1) = 0.7_dp
56 2 : phase = EXP(CMPLX(0.0_dp, 0.3_dp, dp))
57 6 : b%coefficients(:, :) = phase
58 2 : CALL snapshot_overlap(a, b, a%k, b%k, m)
59 2 : IF (ABS(m(1, 1) - phase*EXP(-0.7_dp**2/2.0_dp)) > tolerance) ERROR STOP 'Moving Gaussian overlap failed'
60 2 : CALL snapshot_overlap(b, a, b%k, a%k, reverse)
61 2 : IF (ABS(m(1, 1) - CONJG(reverse(1, 1))) > tolerance) ERROR STOP 'Directed overlap adjoint failed'
62 8 : b%atoms(1)%center(:) = 0.0_dp
63 8 : b%atoms(1)%shells(1)%center(:) = 0.0_dp
64 2 : CALL check_snapshot_seam(a, b, [1], tolerance)
65 2 : CALL snapshot_overlap(a, b, a%k, b%k, m)
66 2 : IF (ABS(m(1, 1) - phase) > tolerance) ERROR STOP 'Endpoint gauge sewing failed'
67 :
68 : CONTAINS
69 :
70 : ! **************************************************************************************************
71 : !> \brief Exercise anonymous link storage without named files or shared-unit collisions.
72 : ! **************************************************************************************************
73 2 : SUBROUTINE test_scratch_links()
74 : CHARACTER(LEN=5) :: text
75 : COMPLEX(KIND=dp) :: link(2, 2), restored(2, 2)
76 : INTEGER :: binary_unit, ios, record_size, text_unit
77 : LOGICAL :: named, opened
78 :
79 14 : link(:, :) = CMPLX(1.0_dp, 2.0_dp, dp)
80 : CALL open_file('', unit_number=binary_unit, file_status='SCRATCH', file_access='STREAM', &
81 2 : file_form='UNFORMATTED', file_action='READWRITE')
82 2 : INQUIRE (UNIT=binary_unit, NAMED=named, IOSTAT=ios)
83 2 : IF (ios /= 0) ERROR STOP 'Cannot inquire scratch link storage'
84 2 : IF (named) ERROR STOP 'Link scratch storage must be anonymous'
85 2 : CALL open_file('', unit_number=text_unit, file_status='SCRATCH', file_pad='NO', file_action='READWRITE')
86 2 : IF (binary_unit == text_unit) ERROR STOP 'Scratch streams share a unit'
87 2 : INQUIRE (IOLENGTH=record_size) link
88 2 : WRITE (binary_unit, IOSTAT=ios) link
89 2 : IF (ios /= 0) ERROR STOP 'Cannot write first scratch link'
90 14 : WRITE (binary_unit, IOSTAT=ios) 2.0_dp*link
91 2 : IF (ios /= 0) ERROR STOP 'Cannot write second scratch link'
92 2 : READ (binary_unit, POS=record_size + 1, IOSTAT=ios) restored
93 2 : IF (ios /= 0) ERROR STOP 'Cannot read second scratch link'
94 14 : IF (MAXVAL(ABS(restored - 2.0_dp*link)) > tolerance) ERROR STOP 'Incorrect second scratch link'
95 2 : READ (binary_unit, POS=1, IOSTAT=ios) restored
96 2 : IF (ios /= 0) ERROR STOP 'Cannot read first scratch link'
97 14 : IF (MAXVAL(ABS(restored - link)) > tolerance) ERROR STOP 'Incorrect first scratch link'
98 2 : WRITE (text_unit, '(A)', IOSTAT=ios) 'links'
99 2 : IF (ios /= 0) ERROR STOP 'Cannot write formatted scratch file'
100 2 : REWIND (text_unit)
101 2 : READ (text_unit, '(A)', IOSTAT=ios) text
102 2 : IF (ios /= 0) ERROR STOP 'Cannot read formatted scratch file'
103 2 : IF (text /= 'links') ERROR STOP 'Incorrect formatted scratch contents'
104 2 : CALL close_file(binary_unit)
105 2 : CALL close_file(text_unit)
106 2 : INQUIRE (UNIT=binary_unit, OPENED=opened, IOSTAT=ios)
107 2 : IF (ios /= 0) ERROR STOP 'Cannot inquire closed scratch stream'
108 2 : IF (opened) ERROR STOP 'Scratch stream was not closed'
109 2 : INQUIRE (UNIT=text_unit, OPENED=opened, IOSTAT=ios)
110 2 : IF (ios /= 0) ERROR STOP 'Cannot inquire closed formatted scratch file'
111 2 : IF (opened) ERROR STOP 'Formatted scratch file was not closed'
112 2 : END SUBROUTINE test_scratch_links
113 : END PROGRAM topology_snapshot_unittest
|
