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 : ! **************************************************************************************************
9 : !> \brief Contains types used for a Dimer Method calculations
10 : !> \par History
11 : !> Luca Bellucci 11.2017 added kdimer and beta
12 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
13 : ! **************************************************************************************************
14 : MODULE dimer_types
15 :
16 : USE cell_types, ONLY: &
17 : cell_transform_input_cartesian, cell_type, use_perd_x, use_perd_xy, use_perd_xyz, &
18 : use_perd_xz, use_perd_y, use_perd_yz, use_perd_z
19 : USE cp_log_handling, ONLY: cp_logger_get_default_io_unit,&
20 : cp_to_string
21 : USE cp_parser_methods, ONLY: parser_get_next_line,&
22 : parser_search_string
23 : USE cp_parser_types, ONLY: cp_parser_type,&
24 : parser_create,&
25 : parser_release
26 : USE cp_subsys_types, ONLY: cp_subsys_get,&
27 : cp_subsys_type
28 : USE force_env_types, ONLY: force_env_type
29 : USE global_types, ONLY: global_environment_type
30 : USE input_constants, ONLY: dimer_init_molden,&
31 : dimer_init_random,&
32 : do_first_rotation_step
33 : USE input_section_types, ONLY: section_vals_get,&
34 : section_vals_get_subs_vals,&
35 : section_vals_type,&
36 : section_vals_val_get
37 : USE kinds, ONLY: default_path_length,&
38 : dp
39 : USE message_passing, ONLY: mp_para_env_type
40 : USE molecule_kind_list_types, ONLY: molecule_kind_list_type
41 : USE molecule_kind_types, ONLY: fixd_constraint_type,&
42 : get_molecule_kind,&
43 : molecule_kind_type
44 : #include "../base/base_uses.f90"
45 :
46 : IMPLICIT NONE
47 : PRIVATE
48 :
49 : LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .TRUE.
50 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dimer_types'
51 :
52 : PUBLIC :: dimer_env_type, &
53 : dimer_env_create, &
54 : dimer_env_retain, &
55 : dimer_env_release, &
56 : dimer_fixed_atom_control, &
57 : dimer_init_vector, &
58 : vib_get_index_weight
59 :
60 : ! **************************************************************************************************
61 : !> \brief Type containing all informations abour the rotation of the Dimer
62 : !> \par History
63 : !> none
64 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
65 : ! **************************************************************************************************
66 : TYPE dimer_rotational_type
67 : ! Rotational parameters
68 : INTEGER :: rotation_step = 0
69 : LOGICAL :: interpolate_gradient = .FALSE.
70 : REAL(KIND=dp) :: angle_tol = 0.0_dp, angle1 = 0.0_dp, angle2 = 0.0_dp, &
71 : dCdp = 0.0_dp, curvature = 0.0_dp
72 : REAL(KIND=dp), POINTER, DIMENSION(:) :: g0 => NULL(), g1 => NULL(), g1p => NULL()
73 : END TYPE dimer_rotational_type
74 :
75 : ! **************************************************************************************************
76 : !> \brief Type containing all informations abour the translation of the Dimer
77 : !> \par History
78 : !> none
79 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
80 : ! **************************************************************************************************
81 : TYPE dimer_translational_type
82 : ! Translational parameters
83 : REAL(KIND=dp), POINTER, DIMENSION(:) :: tls_vec => NULL()
84 : END TYPE dimer_translational_type
85 :
86 : ! **************************************************************************************************
87 : !> \brief Conjugate Directions type
88 : !> \par History
89 : !> none
90 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
91 : ! **************************************************************************************************
92 : TYPE dimer_cg_rot_type
93 : REAL(KIND=dp) :: norm_theta = 0.0_dp, norm_theta_old = 0.0_dp, norm_h = 0.0_dp
94 : REAL(KIND=dp), POINTER, DIMENSION(:) :: nvec_old => NULL()
95 : END TYPE dimer_cg_rot_type
96 :
97 : ! **************************************************************************************************
98 : !> \brief Defines the environment for a Dimer Method calculation
99 : !> \par History
100 : !> none
101 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
102 : ! **************************************************************************************************
103 : TYPE dimer_env_type
104 : INTEGER :: ref_count = 0
105 : REAL(KIND=dp) :: dr = 0.0_dp
106 : REAL(KIND=dp), POINTER, DIMENSION(:) :: nvec => NULL()
107 : REAL(KIND=dp) :: beta = 0.0_dp
108 : TYPE(dimer_rotational_type) :: rot = dimer_rotational_type()
109 : TYPE(dimer_translational_type) :: tsl = dimer_translational_type()
110 : TYPE(dimer_cg_rot_type) :: cg_rot = dimer_cg_rot_type()
111 : LOGICAL :: kdimer = .FALSE.
112 : END TYPE dimer_env_type
113 :
114 : CONTAINS
115 :
116 : ! **************************************************************************************************
117 : !> \brief ...
118 : !> \param dimer_env ...
119 : !> \param subsys ...
120 : !> \param globenv ...
121 : !> \param dimer_section ...
122 : !> \param force_env ...
123 : !> \par History
124 : !> Luca Bellucci 11.2017 added K-DIMER and BETA
125 : !> 2016/03/03 [LTong] changed input natom to subsys
126 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
127 : ! **************************************************************************************************
128 24 : SUBROUTINE dimer_env_create(dimer_env, subsys, globenv, dimer_section, force_env)
129 : TYPE(dimer_env_type), POINTER :: dimer_env
130 : TYPE(cp_subsys_type), POINTER :: subsys
131 : TYPE(global_environment_type), POINTER :: globenv
132 : TYPE(section_vals_type), POINTER :: dimer_section
133 : TYPE(force_env_type), POINTER :: force_env
134 :
135 : INTEGER :: i, j, k, natom, unit_nr
136 : REAL(KIND=dp) :: norm, xval(3)
137 : TYPE(cell_type), POINTER :: cell
138 :
139 24 : NULLIFY (cell)
140 24 : unit_nr = cp_logger_get_default_io_unit()
141 24 : CPASSERT(.NOT. ASSOCIATED(dimer_env))
142 24 : ALLOCATE (dimer_env)
143 24 : dimer_env%ref_count = 1
144 : ! Setup NVEC
145 : ! get natom
146 24 : CALL cp_subsys_get(subsys=subsys, cell=cell, natom=natom)
147 : ! Allocate the working arrays
148 72 : ALLOCATE (dimer_env%rot%g0(natom*3))
149 48 : ALLOCATE (dimer_env%rot%g1(natom*3))
150 48 : ALLOCATE (dimer_env%rot%g1p(natom*3))
151 : ! Read dimer vector from input
152 : CALL dimer_init_vector(dimer_env, dimer_section, natom, &
153 24 : unit_nr, globenv, force_env)
154 24 : IF (unit_nr > 0) THEN
155 : WRITE (unit_nr, "(/,T2,A,T9,A,T71,I10)") &
156 12 : "DIMER|", "Dimension of dimer vector (natom * 3)", natom*3
157 53 : DO j = 1, natom
158 : WRITE (unit_nr, "(T2,A,T9,3(F12.6,3X))") &
159 176 : "DIMER|", dimer_env%nvec(3*j - 2:3*j)
160 : END DO
161 : END IF
162 : ! Transform input cell
163 106 : DO i = 1, natom
164 328 : xval(:) = dimer_env%nvec(3*i - 2:3*i)
165 82 : CALL cell_transform_input_cartesian(cell, xval)
166 352 : dimer_env%nvec(3*i - 2:3*i) = xval(:)
167 : END DO
168 : ! Check for translation in the dimer vector and remove them
169 24 : IF (natom > 1) THEN
170 22 : xval = 0.0_dp
171 102 : DO j = 1, natom
172 342 : DO k = 1, 3
173 240 : i = (j - 1)*3 + k
174 320 : xval(k) = xval(k) + dimer_env%nvec(i)
175 : END DO
176 : END DO
177 22 : IF (unit_nr > 0) THEN
178 : WRITE (unit_nr, "(/,T2,A,T9,A)") &
179 11 : "DIMER|", "Overall translation to be removed from the initial dimer vector"
180 : WRITE (unit_nr, "(T2,A,T9,3(F12.6,3X))") &
181 11 : "DIMER|", xval(1:3)
182 : END IF
183 : ! Subtract net translations
184 88 : xval = xval/REAL(natom*3, KIND=dp)
185 102 : DO j = 1, natom
186 342 : DO k = 1, 3
187 240 : i = (j - 1)*3 + k
188 320 : dimer_env%nvec(i) = dimer_env%nvec(i) - xval(k)
189 : END DO
190 : END DO
191 : END IF
192 : ! set nvec components to zero for the corresponding constraints
193 24 : CALL dimer_fixed_atom_control(dimer_env%nvec, subsys, unit_nr)
194 : ! Normalize dimer vector
195 270 : norm = SQRT(SUM(dimer_env%nvec**2))
196 24 : IF (norm <= EPSILON(0.0_dp)) THEN
197 0 : CPABORT("The norm of the dimer vector is 0! Calculation cannot proceed further.")
198 : END IF
199 24 : IF (unit_nr > 0) THEN
200 : WRITE (unit_nr, "(T2,A,T9,A,T69,F12.6)") &
201 12 : "DIMER|", "Norm of dimer vector to be normalized by rescaling", norm
202 : END IF
203 270 : dimer_env%nvec = dimer_env%nvec/norm
204 24 : dimer_env%rot%rotation_step = do_first_rotation_step
205 24 : CALL section_vals_val_get(dimer_section, "DR", r_val=dimer_env%dr)
206 : CALL section_vals_val_get(dimer_section, "INTERPOLATE_GRADIENT", &
207 24 : l_val=dimer_env%rot%interpolate_gradient)
208 : CALL section_vals_val_get(dimer_section, "ANGLE_TOLERANCE", &
209 24 : r_val=dimer_env%rot%angle_tol)
210 : CALL section_vals_val_get(dimer_section, "K-DIMER", &
211 24 : l_val=dimer_env%kdimer)
212 : CALL section_vals_val_get(dimer_section, "BETA", &
213 24 : r_val=dimer_env%beta)
214 : ! initialise values
215 24 : dimer_env%cg_rot%norm_h = 1.0_dp
216 270 : dimer_env%rot%g0 = 0.0_dp
217 270 : dimer_env%rot%g1 = 0.0_dp
218 270 : dimer_env%rot%g1p = 0.0_dp
219 48 : ALLOCATE (dimer_env%cg_rot%nvec_old(natom*3))
220 24 : END SUBROUTINE dimer_env_create
221 :
222 : ! **************************************************************************************************
223 : !> \brief ...
224 : !> \param dimer_env ...
225 : !> \par History
226 : !> none
227 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
228 : ! **************************************************************************************************
229 24 : SUBROUTINE dimer_env_retain(dimer_env)
230 : TYPE(dimer_env_type), POINTER :: dimer_env
231 :
232 24 : CPASSERT(ASSOCIATED(dimer_env))
233 24 : CPASSERT(dimer_env%ref_count > 0)
234 24 : dimer_env%ref_count = dimer_env%ref_count + 1
235 24 : END SUBROUTINE dimer_env_retain
236 :
237 : ! **************************************************************************************************
238 : !> \brief ...
239 : !> \param dimer_env ...
240 : !> \par History
241 : !> none
242 : !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008
243 : ! **************************************************************************************************
244 1126 : SUBROUTINE dimer_env_release(dimer_env)
245 : TYPE(dimer_env_type), POINTER :: dimer_env
246 :
247 1126 : IF (ASSOCIATED(dimer_env)) THEN
248 48 : CPASSERT(dimer_env%ref_count > 0)
249 48 : dimer_env%ref_count = dimer_env%ref_count - 1
250 48 : IF (dimer_env%ref_count == 0) THEN
251 24 : IF (ASSOCIATED(dimer_env%nvec)) THEN
252 24 : DEALLOCATE (dimer_env%nvec)
253 : END IF
254 24 : IF (ASSOCIATED(dimer_env%rot%g0)) THEN
255 24 : DEALLOCATE (dimer_env%rot%g0)
256 : END IF
257 24 : IF (ASSOCIATED(dimer_env%rot%g1)) THEN
258 24 : DEALLOCATE (dimer_env%rot%g1)
259 : END IF
260 24 : IF (ASSOCIATED(dimer_env%rot%g1p)) THEN
261 24 : DEALLOCATE (dimer_env%rot%g1p)
262 : END IF
263 24 : IF (ASSOCIATED(dimer_env%cg_rot%nvec_old)) THEN
264 24 : DEALLOCATE (dimer_env%cg_rot%nvec_old)
265 : END IF
266 : ! No need to deallocate tls_vec (just a pointer to aother local array)
267 24 : NULLIFY (dimer_env%tsl%tls_vec)
268 24 : DEALLOCATE (dimer_env)
269 : END IF
270 : END IF
271 1126 : END SUBROUTINE dimer_env_release
272 :
273 : ! **************************************************************************************************
274 : !> \brief Set parts of a given array vec to zero according to fixed atom constraints.
275 : !> When atoms are (partially) fixed then the relevant components of
276 : !> nvec should be set to zero. Furthermore, the relevant components
277 : !> of the gradient in CG should also be set to zero.
278 : !> \param vec : vector to be modified
279 : !> \param subsys : subsys type object used by CP2k
280 : !> \param unit : unit to write message to
281 : !> \par History
282 : !> 2016/03/03 [LTong] created
283 : !> \author Lianheng Tong [LTong]
284 : ! **************************************************************************************************
285 432 : SUBROUTINE dimer_fixed_atom_control(vec, subsys, unit)
286 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec
287 : TYPE(cp_subsys_type), POINTER :: subsys
288 : INTEGER, INTENT(IN), OPTIONAL :: unit
289 :
290 : INTEGER :: ii, ikind, ind, iparticle, nfixed_atoms, &
291 : nkinds
292 432 : TYPE(fixd_constraint_type), DIMENSION(:), POINTER :: fixd_list
293 : TYPE(molecule_kind_list_type), POINTER :: molecule_kinds
294 432 : TYPE(molecule_kind_type), DIMENSION(:), POINTER :: molecule_kind_set
295 : TYPE(molecule_kind_type), POINTER :: molecule_kind
296 :
297 432 : NULLIFY (molecule_kinds, molecule_kind, fixd_list)
298 :
299 : ! need to get constraint information from molecule information
300 : CALL cp_subsys_get(subsys=subsys, &
301 432 : molecule_kinds=molecule_kinds)
302 432 : molecule_kind_set => molecule_kinds%els
303 :
304 : ! get total number of fixed atoms
305 : ! nkinds is the kinds of molecules, not atoms
306 432 : nkinds = molecule_kinds%n_els
307 1158 : DO ikind = 1, nkinds
308 726 : molecule_kind => molecule_kind_set(ikind)
309 : CALL get_molecule_kind(molecule_kind, &
310 : nfixd=nfixed_atoms, &
311 726 : fixd_list=fixd_list)
312 1158 : IF (ASSOCIATED(fixd_list)) THEN
313 168 : IF (PRESENT(unit)) THEN
314 24 : IF (unit > 0) THEN
315 : WRITE (unit, "(/,T2,A,T9,A,T71,I10)") &
316 12 : "DIMER|", "Number of fixed atoms to adjust dimer vector", nfixed_atoms
317 : END IF
318 : END IF
319 224 : DO ii = 1, nfixed_atoms
320 224 : IF (.NOT. fixd_list(ii)%restraint%active) THEN
321 56 : iparticle = fixd_list(ii)%fixd
322 56 : ind = (iparticle - 1)*3
323 : ! apply constraint to nvec
324 56 : SELECT CASE (fixd_list(ii)%itype)
325 : CASE (use_perd_x)
326 0 : vec(ind + 1) = 0.0_dp
327 : CASE (use_perd_y)
328 0 : vec(ind + 2) = 0.0_dp
329 : CASE (use_perd_z)
330 0 : vec(ind + 3) = 0.0_dp
331 : CASE (use_perd_xy)
332 0 : vec(ind + 1) = 0.0_dp
333 0 : vec(ind + 2) = 0.0_dp
334 : CASE (use_perd_xz)
335 0 : vec(ind + 1) = 0.0_dp
336 0 : vec(ind + 3) = 0.0_dp
337 : CASE (use_perd_yz)
338 0 : vec(ind + 2) = 0.0_dp
339 0 : vec(ind + 3) = 0.0_dp
340 : CASE (use_perd_xyz)
341 56 : vec(ind + 1) = 0.0_dp
342 56 : vec(ind + 2) = 0.0_dp
343 56 : vec(ind + 3) = 0.0_dp
344 : END SELECT
345 : END IF ! .NOT.fixd_list(ii)%restraint%active
346 : END DO ! ii
347 : END IF ! ASSOCIATED(fixd_list)
348 : END DO ! ikind
349 432 : END SUBROUTINE dimer_fixed_atom_control
350 :
351 : ! **************************************************************************************************
352 : !> \brief Read dimer vector from input and store into dimer_env%nvec
353 : !> \param dimer_env ...
354 : !> \param dimer_section ...
355 : !> \param natom ...
356 : !> \param unit ...
357 : !> \param globenv ...
358 : !> \param force_env ...
359 : !> \par History
360 : !> 2026/05 created
361 : !> \author HE Zilong
362 : ! **************************************************************************************************
363 24 : SUBROUTINE dimer_init_vector(dimer_env, dimer_section, natom, unit, globenv, force_env)
364 : TYPE(dimer_env_type), INTENT(INOUT), POINTER :: dimer_env
365 : TYPE(section_vals_type), INTENT(INOUT), POINTER :: dimer_section
366 : INTEGER, INTENT(IN) :: natom, unit
367 : TYPE(global_environment_type), INTENT(IN), POINTER :: globenv
368 : TYPE(force_env_type), POINTER :: force_env
369 :
370 : CHARACTER(LEN=17) :: vib_name
371 : CHARACTER(LEN=default_path_length) :: molden_name
372 : INTEGER :: dimer_init_method, i, ierr, isize, j, &
373 : n_rep_val, nvec_size, vib_list_size
374 24 : INTEGER, ALLOCATABLE, DIMENSION(:) :: vib_id_list
375 : LOGICAL :: explicit, found
376 48 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: array_r, vib_wt_list
377 24 : REAL(KIND=dp), DIMENSION(:), POINTER :: array
378 : TYPE(cp_parser_type) :: parser
379 : TYPE(mp_para_env_type), POINTER :: para_env
380 : TYPE(section_vals_type), POINTER :: nvec_section
381 :
382 24 : para_env => force_env%para_env
383 48 : nvec_section => section_vals_get_subs_vals(dimer_section, "DIMER_VECTOR")
384 24 : NULLIFY (array)
385 24 : nvec_size = natom*3
386 :
387 72 : ALLOCATE (dimer_env%nvec(nvec_size))
388 270 : dimer_env%nvec(:) = 0.0_dp
389 24 : CALL section_vals_get(nvec_section, explicit=explicit)
390 24 : IF (explicit) THEN
391 4 : IF (unit > 0) WRITE (unit, "(/,T2,A,T9,A)") &
392 2 : "DIMER|", "Initial dimer vector read from input DIMER_VECTOR section"
393 4 : isize = 0
394 4 : CALL section_vals_val_get(nvec_section, "_DEFAULT_KEYWORD_", n_rep_val=n_rep_val)
395 10 : DO i = 1, n_rep_val
396 6 : CALL section_vals_val_get(nvec_section, "_DEFAULT_KEYWORD_", r_vals=array, i_rep_val=i)
397 34 : DO j = 1, SIZE(array)
398 24 : isize = isize + 1
399 30 : IF (isize <= nvec_size) THEN
400 24 : dimer_env%nvec(isize) = array(j)
401 : ELSE
402 0 : CPABORT("Size of input DIMER_VECTOR more than natom * 3")
403 : END IF
404 : END DO
405 : END DO
406 4 : IF (isize /= nvec_size) THEN
407 0 : CPABORT("Size of input DIMER_VECTOR inconsistent with natom * 3")
408 : END IF
409 : ELSE
410 20 : CALL section_vals_val_get(dimer_section, "INITIALIZATION_METHOD", i_val=dimer_init_method)
411 18 : SELECT CASE (dimer_init_method)
412 : CASE (dimer_init_random)
413 18 : IF (unit > 0) WRITE (unit, "(/,T2,A,T9,A)") &
414 9 : "DIMER|", "Initial dimer vector generated randomly"
415 18 : CALL globenv%gaussian_rng_stream%fill(dimer_env%nvec)
416 : CASE (dimer_init_molden)
417 2 : CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", explicit=explicit)
418 2 : IF (.NOT. explicit) THEN
419 0 : CPABORT("INITIALIZATION_METHOD MOLDEN requires VIB_MOLDEN_NAME")
420 : END IF
421 2 : CALL section_vals_val_get(dimer_section, "VIB_MOLDEN_NAME", c_val=molden_name)
422 2 : IF (unit > 0) THEN
423 : WRITE (unit, "(/,T2,A,T9,A)") &
424 1 : "DIMER|", "Initial dimer vector by linear combination of normal modes from:"
425 : WRITE (unit, "(T2,A,T9,A)") &
426 1 : "DIMER|", TRIM(ADJUSTL(molden_name))
427 : END IF
428 : ! Build lists of indices and weights for linear combination
429 : CALL vib_get_index_weight(dimer_section, vib_id_list, vib_wt_list, &
430 2 : vib_list_size, unit)
431 : ! Find vibrational modes in molden and do linear combination
432 4 : ALLOCATE (array_r(nvec_size))
433 2 : CALL parser_create(parser, molden_name, para_env=para_env, apply_preprocessing=.FALSE.)
434 4 : Vib_modes: DO i = 1, vib_list_size
435 : ! Format below is from molden_utils.F
436 2 : WRITE (UNIT=vib_name, FMT='(T2,A,1X,I6)') "vibration", vib_id_list(i)
437 : CALL parser_search_string(parser, TRIM(vib_name), &
438 : ignore_case=.FALSE., found=found, &
439 2 : begin_line=.TRUE., search_from_begin_of_file=.TRUE.)
440 2 : IF (.NOT. found) CALL cp_abort(__LOCATION__, &
441 0 : "Could not found <"//vib_name//"> from molden file")
442 12 : DO j = 1, natom
443 10 : CALL parser_get_next_line(parser, 1)
444 : READ (UNIT=parser%input_line, FMT=*, IOSTAT=ierr) &
445 10 : array_r(3*j - 2), array_r(3*j - 1), array_r(3*j)
446 12 : IF (ierr /= 0) THEN
447 : CALL cp_abort(__LOCATION__, &
448 : "Error while reading MOLDEN file: cannot parse the line "// &
449 : TRIM(ADJUSTL(cp_to_string(j)))//" of <"//vib_name//"> "// &
450 0 : "for components of the normal mode")
451 : END IF
452 : END DO
453 34 : dimer_env%nvec(:) = dimer_env%nvec(:) + array_r(:)*vib_wt_list(i)
454 : END DO Vib_modes
455 2 : CALL parser_release(parser)
456 2 : IF (ALLOCATED(array_r)) DEALLOCATE (array_r)
457 2 : IF (ALLOCATED(vib_id_list)) DEALLOCATE (vib_id_list)
458 4 : IF (ALLOCATED(vib_wt_list)) DEALLOCATE (vib_wt_list)
459 : CASE DEFAULT
460 20 : CPABORT("Invalid or not yet implemented dimer initialization method")
461 : END SELECT
462 : END IF
463 :
464 120 : END SUBROUTINE dimer_init_vector
465 :
466 : ! **************************************************************************************************
467 : !> \brief Read VIB_INDEX and VIB_WEIGHT under DIMER section
468 : !> \param dimer_section ...
469 : !> \param vib_id_list ...
470 : !> \param vib_wt_list ...
471 : !> \param vib_list_size ...
472 : !> \param unit ...
473 : !> \par History
474 : !> 2026/05 created
475 : !> \author HE Zilong
476 : ! **************************************************************************************************
477 2 : SUBROUTINE vib_get_index_weight(dimer_section, vib_id_list, vib_wt_list, vib_list_size, unit)
478 : TYPE(section_vals_type), INTENT(IN), POINTER :: dimer_section
479 : INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: vib_id_list
480 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
481 : INTENT(OUT) :: vib_wt_list
482 : INTEGER, INTENT(OUT) :: vib_list_size
483 : INTEGER, INTENT(IN) :: unit
484 :
485 : INTEGER :: i, isize, n_rep_val, vib_id_size, &
486 : vib_wt_size
487 2 : INTEGER, DIMENSION(:), POINTER :: tmpilist
488 2 : REAL(KIND=dp), DIMENSION(:), POINTER :: tmprlist
489 :
490 2 : vib_id_size = 0
491 2 : CALL section_vals_val_get(dimer_section, "VIB_INDEX", n_rep_val=n_rep_val)
492 4 : DO i = 1, n_rep_val
493 : CALL section_vals_val_get(dimer_section, "VIB_INDEX", &
494 2 : i_vals=tmpilist, i_rep_val=i)
495 4 : vib_id_size = vib_id_size + SIZE(tmpilist)
496 : END DO
497 6 : ALLOCATE (vib_id_list(vib_id_size))
498 2 : isize = 0
499 4 : DO i = 1, n_rep_val
500 : CALL section_vals_val_get(dimer_section, "VIB_INDEX", &
501 2 : i_vals=tmpilist, i_rep_val=i)
502 4 : vib_id_list(isize + 1:isize + SIZE(tmpilist)) = tmpilist
503 4 : isize = isize + SIZE(tmpilist)
504 : END DO
505 :
506 2 : vib_wt_size = 0
507 2 : CALL section_vals_val_get(dimer_section, "VIB_WEIGHT", n_rep_val=n_rep_val)
508 4 : DO i = 1, n_rep_val
509 : CALL section_vals_val_get(dimer_section, "VIB_WEIGHT", &
510 2 : r_vals=tmprlist, i_rep_val=i)
511 4 : vib_wt_size = vib_wt_size + SIZE(tmprlist)
512 : END DO
513 6 : ALLOCATE (vib_wt_list(vib_wt_size))
514 2 : isize = 0
515 4 : DO i = 1, n_rep_val
516 : CALL section_vals_val_get(dimer_section, "VIB_WEIGHT", &
517 2 : r_vals=tmprlist, i_rep_val=i)
518 4 : vib_wt_list(isize + 1:isize + SIZE(tmprlist)) = tmprlist
519 4 : isize = isize + SIZE(tmprlist)
520 : END DO
521 :
522 2 : IF (vib_id_size /= vib_wt_size) THEN
523 : CALL cp_abort(__LOCATION__, &
524 : "Inconsistent count of values speficied in input between "// &
525 : "VIB_INDEX ("//TRIM(ADJUSTL(cp_to_string(vib_id_size)))//") "// &
526 0 : "and VIB_WEIGHT ("//TRIM(ADJUSTL(cp_to_string(vib_wt_size)))//")")
527 : ELSE
528 2 : vib_list_size = vib_id_size
529 : END IF
530 2 : IF (unit > 0) THEN
531 : WRITE (unit, "(/,T2,A,T9,A)") &
532 1 : "DIMER|", "Indices and weights of vibrational modes in linear combination"
533 2 : DO i = 1, vib_list_size
534 : WRITE (unit, "(T2,A,T10,I6,T18,F12.6)") &
535 2 : "DIMER|", vib_id_list(i), vib_wt_list(i)
536 : END DO
537 : END IF
538 :
539 4 : END SUBROUTINE vib_get_index_weight
540 :
541 0 : END MODULE dimer_types
|
