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 : ! **************************************************************************************************
9 : !> \brief Utility subroutines for mixed CDFT calculations
10 : !> \par History
11 : !> separated from mixed_cdft_methods [01.2017]
12 : !> \author Nico Holmberg [01.2017]
13 : ! **************************************************************************************************
14 : MODULE mixed_cdft_utils
15 : USE atomic_kind_types, ONLY: atomic_kind_type
16 : USE cell_types, ONLY: cell_type
17 : USE cp_array_utils, ONLY: cp_1d_i_p_type,&
18 : cp_1d_r_p_type,&
19 : cp_2d_r_p_type
20 : USE cp_blacs_env, ONLY: cp_blacs_env_create,&
21 : cp_blacs_env_type
22 : USE cp_control_types, ONLY: dft_control_type
23 : USE cp_dbcsr_api, ONLY: dbcsr_desymmetrize,&
24 : dbcsr_get_info,&
25 : dbcsr_init_p,&
26 : dbcsr_p_type,&
27 : dbcsr_release,&
28 : dbcsr_release_p,&
29 : dbcsr_type
30 : USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,&
31 : copy_fm_to_dbcsr_bc
32 : USE cp_files, ONLY: open_file
33 : USE cp_fm_struct, ONLY: cp_fm_struct_create,&
34 : cp_fm_struct_release,&
35 : cp_fm_struct_type
36 : USE cp_fm_types, ONLY: cp_fm_copy_general,&
37 : cp_fm_create,&
38 : cp_fm_get_info,&
39 : cp_fm_release,&
40 : cp_fm_to_fm,&
41 : cp_fm_type
42 : USE cp_log_handling, ONLY: cp_get_default_logger,&
43 : cp_logger_create,&
44 : cp_logger_set,&
45 : cp_logger_type,&
46 : cp_to_string
47 : USE cp_output_handling, ONLY: cp_print_key_finished_output,&
48 : cp_print_key_unit_nr
49 : USE cp_realspace_grid_init, ONLY: init_input_type
50 : USE cp_subsys_types, ONLY: cp_subsys_get,&
51 : cp_subsys_type
52 : USE cube_utils, ONLY: init_cube_info,&
53 : return_cube_max_iradius
54 : USE d3_poly, ONLY: init_d3_poly_module
55 : USE force_env_types, ONLY: force_env_get,&
56 : force_env_type,&
57 : multiple_fe_list
58 : USE gaussian_gridlevels, ONLY: init_gaussian_gridlevel
59 : USE global_types, ONLY: global_environment_type
60 : USE hirshfeld_types, ONLY: create_hirshfeld_type,&
61 : release_hirshfeld_type,&
62 : set_hirshfeld_info
63 : USE input_constants, ONLY: becke_cutoff_element,&
64 : mixed_cdft_parallel,&
65 : mixed_cdft_parallel_nobuild,&
66 : mixed_cdft_serial,&
67 : outer_scf_becke_constraint,&
68 : outer_scf_hirshfeld_constraint,&
69 : shape_function_gaussian
70 : USE input_section_types, ONLY: section_vals_duplicate,&
71 : section_vals_get,&
72 : section_vals_get_subs_vals,&
73 : section_vals_release,&
74 : section_vals_type,&
75 : section_vals_val_get
76 : USE kinds, ONLY: default_path_length,&
77 : dp
78 : USE message_passing, ONLY: mp_request_type,&
79 : mp_waitall
80 : USE mixed_cdft_types, ONLY: mixed_cdft_result_type_release,&
81 : mixed_cdft_result_type_set,&
82 : mixed_cdft_settings_type,&
83 : mixed_cdft_type,&
84 : mixed_cdft_work_type_init
85 : USE mixed_environment_types, ONLY: get_mixed_env,&
86 : mixed_environment_type
87 : USE pw_env_methods, ONLY: pw_env_create
88 : USE pw_env_types, ONLY: pw_env_get,&
89 : pw_env_type
90 : USE pw_grid_types, ONLY: HALFSPACE,&
91 : pw_grid_type
92 : USE pw_grids, ONLY: do_pw_grid_blocked_false,&
93 : pw_grid_create,&
94 : pw_grid_release
95 : USE pw_pool_types, ONLY: pw_pool_create,&
96 : pw_pool_p_type,&
97 : pw_pool_type
98 : USE qs_cdft_types, ONLY: cdft_control_create,&
99 : cdft_control_type
100 : USE qs_environment_types, ONLY: get_qs_env,&
101 : qs_environment_type
102 : USE qs_kind_types, ONLY: create_qs_kind_set,&
103 : qs_kind_type
104 : USE realspace_grid_types, ONLY: realspace_grid_desc_p_type,&
105 : realspace_grid_input_type,&
106 : realspace_grid_type,&
107 : rs_grid_create,&
108 : rs_grid_create_descriptor,&
109 : rs_grid_print
110 : #include "./base/base_uses.f90"
111 :
112 : IMPLICIT NONE
113 : PRIVATE
114 :
115 : ! *** Public subroutines ***
116 :
117 : PUBLIC :: mixed_cdft_parse_settings, mixed_cdft_transfer_settings, &
118 : mixed_cdft_init_structures, mixed_cdft_redistribute_arrays, &
119 : mixed_cdft_print_couplings, map_permutation_to_states, hfun_zero, &
120 : mixed_cdft_release_work, mixed_cdft_read_block_diag, &
121 : mixed_cdft_get_blocks, mixed_cdft_diagonalize_blocks, &
122 : mixed_cdft_assemble_block_diag
123 :
124 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mixed_cdft_utils'
125 :
126 : CONTAINS
127 :
128 : ! **************************************************************************************************
129 : !> \brief Parse settings for mixed cdft calculation and check their consistency
130 : !> \param force_env the force_env that holds the CDFT mixed_env
131 : !> \param mixed_env the mixed_env that holds the CDFT states
132 : !> \param mixed_cdft control section for mixed CDFT
133 : !> \param settings container for settings related to the mixed CDFT calculation
134 : !> \param natom the total number of atoms
135 : !> \par History
136 : !> 01.2017 created [Nico Holmberg]
137 : ! **************************************************************************************************
138 72 : SUBROUTINE mixed_cdft_parse_settings(force_env, mixed_env, mixed_cdft, &
139 : settings, natom)
140 : TYPE(force_env_type), POINTER :: force_env
141 : TYPE(mixed_environment_type), POINTER :: mixed_env
142 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
143 : TYPE(mixed_cdft_settings_type) :: settings
144 : INTEGER :: natom
145 :
146 : INTEGER :: i, iatom, iforce_eval, igroup, &
147 : nforce_eval, nkinds
148 72 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: constraint_type
149 72 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: array_sizes
150 : LOGICAL :: is_match
151 72 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
152 : TYPE(cdft_control_type), POINTER :: cdft_control
153 72 : TYPE(cp_1d_i_p_type), ALLOCATABLE, DIMENSION(:, :) :: atoms
154 72 : TYPE(cp_1d_r_p_type), ALLOCATABLE, DIMENSION(:, :) :: coeff
155 : TYPE(dft_control_type), POINTER :: dft_control
156 : TYPE(force_env_type), POINTER :: force_env_qs
157 : TYPE(pw_env_type), POINTER :: pw_env
158 : TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
159 : TYPE(qs_environment_type), POINTER :: qs_env
160 :
161 72 : NULLIFY (dft_control, qs_env, pw_env, auxbas_pw_pool, force_env_qs, &
162 72 : cdft_control)
163 : ! Allocate storage for temporaries used for checking settings consistency
164 72 : settings%max_nkinds = 30
165 72 : nforce_eval = SIZE(force_env%sub_force_env)
166 216 : ALLOCATE (settings%grid_span(nforce_eval))
167 216 : ALLOCATE (settings%npts(3, nforce_eval))
168 216 : ALLOCATE (settings%cutoff(nforce_eval))
169 144 : ALLOCATE (settings%rel_cutoff(nforce_eval))
170 144 : ALLOCATE (settings%spherical(nforce_eval))
171 216 : ALLOCATE (settings%rs_dims(2, nforce_eval))
172 144 : ALLOCATE (settings%odd(nforce_eval))
173 288 : ALLOCATE (settings%atoms(natom, nforce_eval))
174 72 : IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN
175 88 : ALLOCATE (settings%coeffs(natom, nforce_eval))
176 154 : settings%coeffs = 0.0_dp
177 : END IF
178 : ! Some of the checked settings are only defined for certain types of constraints
179 : ! We nonetheless use arrays that are large enough to contain settings for all constraints
180 : ! This is not completely optimal...
181 216 : ALLOCATE (settings%si(6, nforce_eval))
182 216 : ALLOCATE (settings%sb(8, nforce_eval))
183 216 : ALLOCATE (settings%sr(5, nforce_eval))
184 216 : ALLOCATE (settings%cutoffs(settings%max_nkinds, nforce_eval))
185 144 : ALLOCATE (settings%radii(settings%max_nkinds, nforce_eval))
186 240 : settings%grid_span = 0
187 744 : settings%npts = 0
188 240 : settings%cutoff = 0.0_dp
189 240 : settings%rel_cutoff = 0.0_dp
190 240 : settings%spherical = 0
191 72 : settings%is_spherical = .FALSE.
192 576 : settings%rs_dims = 0
193 240 : settings%odd = 0
194 72 : settings%is_odd = .FALSE.
195 614 : settings%atoms = 0
196 1248 : settings%si = 0
197 1080 : settings%sr = 0.0_dp
198 1584 : settings%sb = .FALSE.
199 5280 : settings%cutoffs = 0.0_dp
200 5280 : settings%radii = 0.0_dp
201 : ! Get information from the sub_force_envs
202 240 : DO iforce_eval = 1, nforce_eval
203 168 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
204 144 : force_env_qs => force_env%sub_force_env(iforce_eval)%force_env
205 144 : IF (mixed_env%do_mixed_qmmm_cdft) THEN
206 12 : qs_env => force_env_qs%qmmm_env%qs_env
207 : ELSE
208 132 : CALL force_env_get(force_env_qs, qs_env=qs_env)
209 : END IF
210 144 : CALL get_qs_env(qs_env, pw_env=pw_env, dft_control=dft_control)
211 144 : IF (.NOT. dft_control%qs_control%cdft) &
212 : CALL cp_abort(__LOCATION__, &
213 : "A mixed CDFT simulation with multiple force_evals was requested, "// &
214 0 : "but CDFT constraints were not active in the QS section of all force_evals!")
215 144 : cdft_control => dft_control%qs_control%cdft_control
216 144 : CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
217 1440 : settings%bo = auxbas_pw_pool%pw_grid%bounds_local
218 : ! Only the rank 0 process collects info about pw_grid and CDFT
219 216 : IF (force_env_qs%para_env%is_source()) THEN
220 : ! Grid settings
221 84 : settings%grid_span(iforce_eval) = auxbas_pw_pool%pw_grid%grid_span
222 336 : settings%npts(:, iforce_eval) = auxbas_pw_pool%pw_grid%npts
223 84 : settings%cutoff(iforce_eval) = auxbas_pw_pool%pw_grid%cutoff
224 84 : settings%rel_cutoff(iforce_eval) = dft_control%qs_control%relative_cutoff
225 84 : IF (auxbas_pw_pool%pw_grid%spherical) settings%spherical(iforce_eval) = 1
226 252 : settings%rs_dims(:, iforce_eval) = auxbas_pw_pool%pw_grid%para%group%num_pe_cart
227 84 : IF (auxbas_pw_pool%pw_grid%grid_span == HALFSPACE) settings%odd(iforce_eval) = 1
228 : ! Becke constraint atoms/coeffs
229 84 : IF (cdft_control%natoms .GT. SIZE(settings%atoms, 1)) &
230 : CALL cp_abort(__LOCATION__, &
231 : "More CDFT constraint atoms than defined in mixed section. "// &
232 0 : "Use default values for MIXED\MAPPING.")
233 233 : settings%atoms(1:cdft_control%natoms, iforce_eval) = cdft_control%atoms
234 84 : IF (mixed_cdft%run_type == mixed_cdft_parallel) &
235 66 : settings%coeffs(1:cdft_control%natoms, iforce_eval) = cdft_control%group(1)%coeff
236 : ! Integer type settings
237 84 : IF (cdft_control%type == outer_scf_becke_constraint) THEN
238 76 : settings%si(1, iforce_eval) = cdft_control%becke_control%cutoff_type
239 76 : settings%si(2, iforce_eval) = cdft_control%becke_control%cavity_shape
240 : END IF
241 84 : settings%si(3, iforce_eval) = dft_control%multiplicity
242 84 : settings%si(4, iforce_eval) = SIZE(cdft_control%group)
243 84 : settings%si(5, iforce_eval) = cdft_control%type
244 84 : IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN
245 8 : settings%si(6, iforce_eval) = cdft_control%hirshfeld_control%shape_function
246 8 : settings%si(6, iforce_eval) = cdft_control%hirshfeld_control%gaussian_shape
247 : END IF
248 : ! Logicals
249 84 : IF (cdft_control%type == outer_scf_becke_constraint) THEN
250 76 : settings%sb(1, iforce_eval) = cdft_control%becke_control%cavity_confine
251 76 : settings%sb(2, iforce_eval) = cdft_control%becke_control%should_skip
252 76 : settings%sb(3, iforce_eval) = cdft_control%becke_control%print_cavity
253 76 : settings%sb(4, iforce_eval) = cdft_control%becke_control%in_memory
254 76 : settings%sb(5, iforce_eval) = cdft_control%becke_control%adjust
255 76 : settings%sb(8, iforce_eval) = cdft_control%becke_control%use_bohr
256 : END IF
257 84 : IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN
258 8 : settings%sb(8, iforce_eval) = cdft_control%hirshfeld_control%use_bohr
259 : END IF
260 84 : settings%sb(6, iforce_eval) = cdft_control%atomic_charges
261 84 : settings%sb(7, iforce_eval) = qs_env%has_unit_metric
262 : ! Reals
263 84 : IF (cdft_control%type == outer_scf_becke_constraint) THEN
264 76 : settings%sr(1, iforce_eval) = cdft_control%becke_control%rcavity
265 76 : settings%sr(2, iforce_eval) = cdft_control%becke_control%rglobal
266 76 : settings%sr(3, iforce_eval) = cdft_control%becke_control%eps_cavity
267 : END IF
268 84 : IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN
269 8 : settings%sr(2, iforce_eval) = cdft_control%hirshfeld_control%radius
270 : END IF
271 84 : settings%sr(4, iforce_eval) = dft_control%qs_control%eps_rho_rspace
272 84 : settings%sr(5, iforce_eval) = pw_env%cube_info(pw_env%auxbas_grid)%max_rad_ga
273 84 : IF (cdft_control%type == outer_scf_becke_constraint) THEN
274 76 : IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN
275 50 : nkinds = SIZE(cdft_control%becke_control%cutoffs_tmp)
276 50 : IF (nkinds .GT. settings%max_nkinds) &
277 : CALL cp_abort(__LOCATION__, &
278 : "More than "//TRIM(cp_to_string(settings%max_nkinds))// &
279 : " unique elements were defined in BECKE_CONSTRAINT\ELEMENT_CUTOFF. Are you sure"// &
280 0 : " your input is correct? If yes, please increase max_nkinds and recompile.")
281 150 : settings%cutoffs(1:nkinds, iforce_eval) = cdft_control%becke_control%cutoffs_tmp(:)
282 : END IF
283 76 : IF (cdft_control%becke_control%adjust) THEN
284 52 : CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
285 52 : IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%becke_control%radii_tmp)) &
286 : CALL cp_abort(__LOCATION__, &
287 : "Length of keyword BECKE_CONSTRAINT\ATOMIC_RADII does not "// &
288 0 : "match number of atomic kinds in the input coordinate file.")
289 52 : nkinds = SIZE(cdft_control%becke_control%radii_tmp)
290 52 : IF (nkinds .GT. settings%max_nkinds) &
291 : CALL cp_abort(__LOCATION__, &
292 : "More than "//TRIM(cp_to_string(settings%max_nkinds))// &
293 : " unique elements were defined in BECKE_CONSTRAINT\ATOMIC_RADII. Are you sure"// &
294 0 : " your input is correct? If yes, please increase max_nkinds and recompile.")
295 156 : settings%radii(1:nkinds, iforce_eval) = cdft_control%becke_control%radii_tmp(:)
296 : END IF
297 : END IF
298 108 : IF (cdft_control%type == outer_scf_hirshfeld_constraint) THEN
299 8 : IF (ASSOCIATED(cdft_control%hirshfeld_control%radii)) THEN
300 0 : CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
301 0 : IF (.NOT. SIZE(atomic_kind_set) == SIZE(cdft_control%hirshfeld_control%radii)) &
302 : CALL cp_abort(__LOCATION__, &
303 : "Length of keyword HIRSHFELD_CONSTRAINT&RADII does not "// &
304 0 : "match number of atomic kinds in the input coordinate file.")
305 0 : nkinds = SIZE(cdft_control%hirshfeld_control%radii)
306 0 : IF (nkinds .GT. settings%max_nkinds) &
307 : CALL cp_abort(__LOCATION__, &
308 : "More than "//TRIM(cp_to_string(settings%max_nkinds))// &
309 : " unique elements were defined in HIRSHFELD_CONSTRAINT&RADII. Are you sure"// &
310 0 : " your input is correct? If yes, please increase max_nkinds and recompile.")
311 0 : settings%radii(1:nkinds, iforce_eval) = cdft_control%hirshfeld_control%radii(:)
312 : END IF
313 : END IF
314 : END IF
315 : END DO
316 : ! Make sure the grids are consistent
317 408 : CALL force_env%para_env%sum(settings%grid_span)
318 1416 : CALL force_env%para_env%sum(settings%npts)
319 408 : CALL force_env%para_env%sum(settings%cutoff)
320 408 : CALL force_env%para_env%sum(settings%rel_cutoff)
321 408 : CALL force_env%para_env%sum(settings%spherical)
322 1080 : CALL force_env%para_env%sum(settings%rs_dims)
323 408 : CALL force_env%para_env%sum(settings%odd)
324 72 : is_match = .TRUE.
325 168 : DO iforce_eval = 2, nforce_eval
326 96 : is_match = is_match .AND. (settings%grid_span(1) == settings%grid_span(iforce_eval))
327 96 : is_match = is_match .AND. (settings%npts(1, 1) == settings%npts(1, iforce_eval))
328 96 : is_match = is_match .AND. (settings%cutoff(1) == settings%cutoff(iforce_eval))
329 96 : is_match = is_match .AND. (settings%rel_cutoff(1) == settings%rel_cutoff(iforce_eval))
330 96 : is_match = is_match .AND. (settings%spherical(1) == settings%spherical(iforce_eval))
331 96 : is_match = is_match .AND. (settings%rs_dims(1, 1) == settings%rs_dims(1, iforce_eval))
332 96 : is_match = is_match .AND. (settings%rs_dims(2, 1) == settings%rs_dims(2, iforce_eval))
333 168 : is_match = is_match .AND. (settings%odd(1) == settings%odd(iforce_eval))
334 : END DO
335 72 : IF (.NOT. is_match) &
336 : CALL cp_abort(__LOCATION__, &
337 0 : "Mismatch detected in the &MGRID settings of the CDFT force_evals.")
338 72 : IF (settings%spherical(1) == 1) settings%is_spherical = .TRUE.
339 72 : IF (settings%odd(1) == 1) settings%is_odd = .TRUE.
340 : ! Make sure CDFT settings are consistent
341 1156 : CALL force_env%para_env%sum(settings%atoms)
342 72 : IF (mixed_cdft%run_type == mixed_cdft_parallel) &
343 286 : CALL force_env%para_env%sum(settings%coeffs)
344 72 : settings%ncdft = 0
345 224 : DO i = 1, SIZE(settings%atoms, 1)
346 374 : DO iforce_eval = 2, nforce_eval
347 374 : IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN
348 44 : IF (settings%atoms(i, 1) /= settings%atoms(i, iforce_eval)) is_match = .FALSE.
349 44 : IF (settings%coeffs(i, 1) /= settings%coeffs(i, iforce_eval)) is_match = .FALSE.
350 : END IF
351 : END DO
352 224 : IF (settings%atoms(i, 1) /= 0) settings%ncdft = settings%ncdft + 1
353 : END DO
354 72 : IF (.NOT. is_match .AND. mixed_cdft%run_type == mixed_cdft_parallel) &
355 : CALL cp_abort(__LOCATION__, &
356 : "Mismatch detected in the &CDFT section of the CDFT force_evals. "// &
357 : "Parallel mode mixed CDFT requires identical constraint definitions in both CDFT states. "// &
358 : "Switch to serial mode or disable keyword PARALLEL_BUILD if you "// &
359 0 : "want to use nonidentical constraint definitions.")
360 2424 : CALL force_env%para_env%sum(settings%si)
361 2088 : CALL force_env%para_env%sum(settings%sr)
362 648 : DO i = 1, SIZE(settings%sb, 1)
363 576 : CALL force_env%para_env%sum(settings%sb(i, 1))
364 1416 : DO iforce_eval = 2, nforce_eval
365 768 : CALL force_env%para_env%sum(settings%sb(i, iforce_eval))
366 1344 : IF (settings%sb(i, 1) .NEQV. settings%sb(i, iforce_eval)) is_match = .FALSE.
367 : END DO
368 : END DO
369 504 : DO i = 1, SIZE(settings%si, 1)
370 1080 : DO iforce_eval = 2, nforce_eval
371 1008 : IF (settings%si(i, 1) /= settings%si(i, iforce_eval)) is_match = .FALSE.
372 : END DO
373 : END DO
374 432 : DO i = 1, SIZE(settings%sr, 1)
375 912 : DO iforce_eval = 2, nforce_eval
376 840 : IF (settings%sr(i, 1) /= settings%sr(i, iforce_eval)) is_match = .FALSE.
377 : END DO
378 : END DO
379 72 : IF (.NOT. is_match) &
380 : CALL cp_abort(__LOCATION__, &
381 0 : "Mismatch detected in the &CDFT settings of the CDFT force_evals.")
382 : ! Some CDFT features are currently disabled for mixed calculations: check that these features were not requested
383 72 : IF (mixed_cdft%dlb .AND. .NOT. settings%sb(1, 1)) &
384 : CALL cp_abort(__LOCATION__, &
385 0 : "Parallel mode mixed CDFT load balancing requires Gaussian cavity confinement.")
386 : ! Check for identical constraints in case of run type serial/parallel_nobuild
387 72 : IF (mixed_cdft%run_type /= mixed_cdft_parallel) THEN
388 : ! Get array sizes
389 250 : ALLOCATE (array_sizes(nforce_eval, settings%si(4, 1), 2))
390 510 : array_sizes(:, :, :) = 0
391 174 : DO iforce_eval = 1, nforce_eval
392 124 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
393 122 : force_env_qs => force_env%sub_force_env(iforce_eval)%force_env
394 122 : IF (mixed_env%do_mixed_qmmm_cdft) THEN
395 8 : qs_env => force_env_qs%qmmm_env%qs_env
396 : ELSE
397 114 : CALL force_env_get(force_env_qs, qs_env=qs_env)
398 : END IF
399 122 : CALL get_qs_env(qs_env, dft_control=dft_control)
400 122 : cdft_control => dft_control%qs_control%cdft_control
401 172 : IF (force_env_qs%para_env%is_source()) THEN
402 128 : DO igroup = 1, SIZE(cdft_control%group)
403 64 : array_sizes(iforce_eval, igroup, 1) = SIZE(cdft_control%group(igroup)%atoms)
404 126 : array_sizes(iforce_eval, igroup, 2) = SIZE(cdft_control%group(igroup)%coeff)
405 : END DO
406 : END IF
407 : END DO
408 : ! Sum up array sizes and check consistency
409 50 : CALL force_env%para_env%sum(array_sizes)
410 410 : IF (ANY(array_sizes(:, :, 1) /= array_sizes(1, 1, 1)) .OR. &
411 : ANY(array_sizes(:, :, 2) /= array_sizes(1, 1, 2))) &
412 0 : mixed_cdft%identical_constraints = .FALSE.
413 : ! Check constraint definitions
414 50 : IF (mixed_cdft%identical_constraints) THEN
415 : ! Prepare temporary storage
416 380 : ALLOCATE (atoms(nforce_eval, settings%si(4, 1)))
417 330 : ALLOCATE (coeff(nforce_eval, settings%si(4, 1)))
418 200 : ALLOCATE (constraint_type(nforce_eval, settings%si(4, 1)))
419 230 : constraint_type(:, :) = 0
420 174 : DO iforce_eval = 1, nforce_eval
421 252 : DO i = 1, settings%si(4, 1)
422 128 : NULLIFY (atoms(iforce_eval, i)%array)
423 : NULLIFY (coeff(iforce_eval, i)%array)
424 384 : ALLOCATE (atoms(iforce_eval, i)%array(array_sizes(iforce_eval, i, 1)))
425 384 : ALLOCATE (coeff(iforce_eval, i)%array(array_sizes(iforce_eval, i, 1)))
426 346 : atoms(iforce_eval, i)%array(:) = 0
427 470 : coeff(iforce_eval, i)%array(:) = 0
428 : END DO
429 : ! Get constraint definitions
430 124 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
431 122 : force_env_qs => force_env%sub_force_env(iforce_eval)%force_env
432 122 : IF (mixed_env%do_mixed_qmmm_cdft) THEN
433 8 : qs_env => force_env_qs%qmmm_env%qs_env
434 : ELSE
435 114 : CALL force_env_get(force_env_qs, qs_env=qs_env)
436 : END IF
437 122 : CALL get_qs_env(qs_env, dft_control=dft_control)
438 122 : cdft_control => dft_control%qs_control%cdft_control
439 172 : IF (force_env_qs%para_env%is_source()) THEN
440 128 : DO i = 1, settings%si(4, 1)
441 173 : atoms(iforce_eval, i)%array(:) = cdft_control%group(i)%atoms
442 173 : coeff(iforce_eval, i)%array(:) = cdft_control%group(i)%coeff
443 126 : constraint_type(iforce_eval, i) = cdft_control%group(i)%constraint_type
444 : END DO
445 : END IF
446 : END DO
447 : ! Sum up constraint definitions and check consistency
448 100 : DO i = 1, settings%si(4, 1)
449 180 : DO iforce_eval = 1, nforce_eval
450 564 : CALL force_env%para_env%sum(atoms(iforce_eval, i)%array)
451 564 : CALL force_env%para_env%sum(coeff(iforce_eval, i)%array)
452 180 : CALL force_env%para_env%sum(constraint_type(iforce_eval, i))
453 : END DO
454 126 : DO iforce_eval = 2, nforce_eval
455 194 : DO iatom = 1, SIZE(atoms(1, i)%array)
456 120 : IF (atoms(1, i)%array(iatom) /= atoms(iforce_eval, i)%array(iatom)) &
457 0 : mixed_cdft%identical_constraints = .FALSE.
458 120 : IF (coeff(1, i)%array(iatom) /= coeff(iforce_eval, i)%array(iatom)) &
459 2 : mixed_cdft%identical_constraints = .FALSE.
460 194 : IF (.NOT. mixed_cdft%identical_constraints) EXIT
461 : END DO
462 76 : IF (constraint_type(1, i) /= constraint_type(iforce_eval, i)) &
463 0 : mixed_cdft%identical_constraints = .FALSE.
464 126 : IF (.NOT. mixed_cdft%identical_constraints) EXIT
465 : END DO
466 100 : IF (.NOT. mixed_cdft%identical_constraints) EXIT
467 : END DO
468 : ! Deallocate temporary storage
469 174 : DO iforce_eval = 1, nforce_eval
470 302 : DO i = 1, settings%si(4, 1)
471 128 : DEALLOCATE (atoms(iforce_eval, i)%array)
472 252 : DEALLOCATE (coeff(iforce_eval, i)%array)
473 : END DO
474 : END DO
475 50 : DEALLOCATE (atoms)
476 50 : DEALLOCATE (coeff)
477 50 : DEALLOCATE (constraint_type)
478 : END IF
479 50 : DEALLOCATE (array_sizes)
480 : END IF
481 : ! Deallocate some arrays that are no longer needed
482 72 : IF (mixed_cdft%identical_constraints .AND. mixed_cdft%run_type /= mixed_cdft_parallel_nobuild) THEN
483 228 : DO iforce_eval = 1, nforce_eval
484 160 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
485 138 : force_env_qs => force_env%sub_force_env(iforce_eval)%force_env
486 138 : IF (mixed_env%do_mixed_qmmm_cdft) THEN
487 12 : qs_env => force_env_qs%qmmm_env%qs_env
488 : ELSE
489 126 : CALL force_env_get(force_env_qs, qs_env=qs_env)
490 : END IF
491 138 : CALL get_qs_env(qs_env, dft_control=dft_control)
492 138 : cdft_control => dft_control%qs_control%cdft_control
493 206 : IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN
494 22 : IF (.NOT. dft_control%qs_control%gapw) THEN
495 44 : DO i = 1, SIZE(cdft_control%group)
496 22 : DEALLOCATE (cdft_control%group(i)%coeff)
497 44 : DEALLOCATE (cdft_control%group(i)%atoms)
498 : END DO
499 22 : IF (.NOT. cdft_control%atomic_charges) DEALLOCATE (cdft_control%atoms)
500 : END IF
501 116 : ELSE IF (mixed_cdft%run_type == mixed_cdft_serial) THEN
502 116 : IF (iforce_eval == 1) CYCLE
503 142 : DO igroup = 1, SIZE(cdft_control%group)
504 142 : IF (.NOT. dft_control%qs_control%gapw) THEN
505 72 : DEALLOCATE (cdft_control%group(igroup)%coeff)
506 72 : DEALLOCATE (cdft_control%group(igroup)%atoms)
507 : END IF
508 : END DO
509 70 : IF (cdft_control%type == outer_scf_becke_constraint) THEN
510 64 : IF (.NOT. cdft_control%atomic_charges) DEALLOCATE (cdft_control%atoms)
511 64 : IF (cdft_control%becke_control%cavity_confine) &
512 62 : CALL release_hirshfeld_type(cdft_control%becke_control%cavity_env)
513 64 : IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) &
514 42 : DEALLOCATE (cdft_control%becke_control%cutoffs_tmp)
515 64 : IF (cdft_control%becke_control%adjust) &
516 44 : DEALLOCATE (cdft_control%becke_control%radii_tmp)
517 : END IF
518 : END IF
519 : END DO
520 : END IF
521 :
522 144 : END SUBROUTINE mixed_cdft_parse_settings
523 :
524 : ! **************************************************************************************************
525 : !> \brief Transfer settings to mixed_cdft
526 : !> \param force_env the force_env that holds the CDFT states
527 : !> \param mixed_cdft the control section for mixed CDFT calculations
528 : !> \param settings container for settings related to the mixed CDFT calculation
529 : !> \par History
530 : !> 01.2017 created [Nico Holmberg]
531 : ! **************************************************************************************************
532 72 : SUBROUTINE mixed_cdft_transfer_settings(force_env, mixed_cdft, settings)
533 : TYPE(force_env_type), POINTER :: force_env
534 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
535 : TYPE(mixed_cdft_settings_type) :: settings
536 :
537 : INTEGER :: i, nkinds
538 : LOGICAL :: is_match
539 : TYPE(cdft_control_type), POINTER :: cdft_control
540 :
541 72 : NULLIFY (cdft_control)
542 72 : is_match = .TRUE.
543 : ! Transfer global settings
544 72 : mixed_cdft%multiplicity = settings%si(3, 1)
545 72 : mixed_cdft%has_unit_metric = settings%sb(7, 1)
546 72 : mixed_cdft%eps_rho_rspace = settings%sr(4, 1)
547 72 : mixed_cdft%nconstraint = settings%si(4, 1)
548 72 : settings%radius = settings%sr(5, 1)
549 : ! Transfer settings only needed if the constraint should be built in parallel
550 72 : IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN
551 22 : IF (settings%sb(6, 1)) &
552 : CALL cp_abort(__LOCATION__, &
553 0 : "Calculation of atomic Becke charges not supported with parallel mode mixed CDFT")
554 22 : IF (mixed_cdft%nconstraint /= 1) &
555 : CALL cp_abort(__LOCATION__, &
556 0 : "Parallel mode mixed CDFT does not yet support multiple constraints.")
557 :
558 22 : IF (settings%si(5, 1) /= outer_scf_becke_constraint) &
559 : CALL cp_abort(__LOCATION__, &
560 0 : "Parallel mode mixed CDFT does not support Hirshfeld constraints.")
561 :
562 66 : ALLOCATE (mixed_cdft%cdft_control)
563 22 : CALL cdft_control_create(mixed_cdft%cdft_control)
564 22 : cdft_control => mixed_cdft%cdft_control
565 66 : ALLOCATE (cdft_control%atoms(settings%ncdft))
566 66 : cdft_control%atoms = settings%atoms(1:settings%ncdft, 1)
567 44 : ALLOCATE (cdft_control%group(1))
568 66 : ALLOCATE (cdft_control%group(1)%atoms(settings%ncdft))
569 66 : ALLOCATE (cdft_control%group(1)%coeff(settings%ncdft))
570 22 : NULLIFY (cdft_control%group(1)%weight)
571 22 : NULLIFY (cdft_control%group(1)%gradients)
572 22 : NULLIFY (cdft_control%group(1)%integrated)
573 66 : cdft_control%group(1)%atoms = cdft_control%atoms
574 66 : cdft_control%group(1)%coeff = settings%coeffs(1:settings%ncdft, 1)
575 22 : cdft_control%natoms = settings%ncdft
576 22 : cdft_control%atomic_charges = settings%sb(6, 1)
577 22 : cdft_control%becke_control%cutoff_type = settings%si(1, 1)
578 22 : cdft_control%becke_control%cavity_confine = settings%sb(1, 1)
579 22 : cdft_control%becke_control%should_skip = settings%sb(2, 1)
580 22 : cdft_control%becke_control%print_cavity = settings%sb(3, 1)
581 22 : cdft_control%becke_control%in_memory = settings%sb(4, 1)
582 22 : cdft_control%becke_control%adjust = settings%sb(5, 1)
583 22 : cdft_control%becke_control%cavity_shape = settings%si(2, 1)
584 22 : cdft_control%becke_control%use_bohr = settings%sb(8, 1)
585 22 : cdft_control%becke_control%rcavity = settings%sr(1, 1)
586 22 : cdft_control%becke_control%rglobal = settings%sr(2, 1)
587 22 : cdft_control%becke_control%eps_cavity = settings%sr(3, 1)
588 22 : nkinds = 0
589 22 : IF (cdft_control%becke_control%cutoff_type == becke_cutoff_element) THEN
590 2250 : CALL force_env%para_env%sum(settings%cutoffs)
591 558 : DO i = 1, SIZE(settings%cutoffs, 1)
592 540 : IF (settings%cutoffs(i, 1) /= settings%cutoffs(i, 2)) is_match = .FALSE.
593 558 : IF (settings%cutoffs(i, 1) /= 0.0_dp) nkinds = nkinds + 1
594 : END DO
595 18 : IF (.NOT. is_match) &
596 : CALL cp_abort(__LOCATION__, &
597 : "Mismatch detected in the &BECKE_CONSTRAINT "// &
598 0 : "&ELEMENT_CUTOFF settings of the two force_evals.")
599 54 : ALLOCATE (cdft_control%becke_control%cutoffs_tmp(nkinds))
600 54 : cdft_control%becke_control%cutoffs_tmp = settings%cutoffs(1:nkinds, 1)
601 : END IF
602 22 : nkinds = 0
603 22 : IF (cdft_control%becke_control%adjust) THEN
604 2250 : CALL force_env%para_env%sum(settings%radii)
605 558 : DO i = 1, SIZE(settings%radii, 1)
606 540 : IF (settings%radii(i, 1) /= settings%radii(i, 2)) is_match = .FALSE.
607 558 : IF (settings%radii(i, 1) /= 0.0_dp) nkinds = nkinds + 1
608 : END DO
609 18 : IF (.NOT. is_match) &
610 : CALL cp_abort(__LOCATION__, &
611 : "Mismatch detected in the &BECKE_CONSTRAINT "// &
612 0 : "&ATOMIC_RADII settings of the two force_evals.")
613 54 : ALLOCATE (cdft_control%becke_control%radii(nkinds))
614 54 : cdft_control%becke_control%radii = settings%radii(1:nkinds, 1)
615 : END IF
616 : END IF
617 :
618 72 : END SUBROUTINE mixed_cdft_transfer_settings
619 :
620 : ! **************************************************************************************************
621 : !> \brief Initialize all the structures needed for a mixed CDFT calculation
622 : !> \param force_env the force_env that holds the CDFT mixed_env
623 : !> \param force_env_qs the force_env that holds the qs_env, which is CDFT state specific
624 : !> \param mixed_env the mixed_env that holds the CDFT states
625 : !> \param mixed_cdft the control section for mixed CDFT calculations
626 : !> \param settings container for settings related to the mixed CDFT calculation
627 : !> \par History
628 : !> 01.2017 created [Nico Holmberg]
629 : ! **************************************************************************************************
630 72 : SUBROUTINE mixed_cdft_init_structures(force_env, force_env_qs, mixed_env, mixed_cdft, settings)
631 : TYPE(force_env_type), POINTER :: force_env, force_env_qs
632 : TYPE(mixed_environment_type), POINTER :: mixed_env
633 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
634 : TYPE(mixed_cdft_settings_type) :: settings
635 :
636 : CHARACTER(len=default_path_length) :: c_val, input_file_path, output_file_path
637 : INTEGER :: i, imap, iounit, j, lp, n_force_eval, &
638 : ncpu, nforce_eval, ntargets, offset, &
639 : unit_nr
640 72 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: bounds
641 : INTEGER, DIMENSION(2, 3) :: bo, bo_mixed
642 : INTEGER, DIMENSION(3) :: higher_grid_layout
643 144 : INTEGER, DIMENSION(:), POINTER :: i_force_eval, mixed_rs_dims, recvbuffer, &
644 144 : recvbuffer2, sendbuffer
645 : LOGICAL :: is_match
646 72 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
647 : TYPE(cell_type), POINTER :: cell_mix
648 : TYPE(cp_logger_type), POINTER :: logger
649 : TYPE(cp_subsys_type), POINTER :: subsys_mix
650 : TYPE(global_environment_type), POINTER :: globenv
651 288 : TYPE(mp_request_type), DIMENSION(3) :: req
652 : TYPE(pw_env_type), POINTER :: pw_env
653 : TYPE(pw_grid_type), POINTER :: pw_grid
654 72 : TYPE(pw_pool_p_type), DIMENSION(:), POINTER :: pw_pools
655 : TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
656 : TYPE(qs_environment_type), POINTER :: qs_env
657 72 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
658 : TYPE(realspace_grid_desc_p_type), DIMENSION(:), &
659 72 : POINTER :: rs_descs
660 : TYPE(realspace_grid_input_type) :: input_settings
661 72 : TYPE(realspace_grid_type), DIMENSION(:), POINTER :: rs_grids
662 : TYPE(section_vals_type), POINTER :: force_env_section, force_env_sections, kind_section, &
663 : print_section, root_section, rs_grid_section, subsys_section
664 :
665 72 : NULLIFY (cell_mix, subsys_mix, force_env_section, subsys_section, &
666 72 : print_section, root_section, kind_section, force_env_sections, &
667 72 : rs_grid_section, auxbas_pw_pool, pw_env, pw_pools, pw_grid, &
668 72 : sendbuffer, qs_env, mixed_rs_dims, i_force_eval, recvbuffer, &
669 72 : recvbuffer2, globenv, atomic_kind_set, qs_kind_set, rs_descs, &
670 72 : rs_grids)
671 :
672 144 : logger => cp_get_default_logger()
673 72 : CALL force_env_get(force_env=force_env, force_env_section=force_env_section)
674 72 : print_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO")
675 72 : iounit = cp_print_key_unit_nr(logger, print_section, '', extension='.mixedLog')
676 72 : is_match = .TRUE.
677 72 : nforce_eval = SIZE(force_env%sub_force_env)
678 72 : ncpu = force_env%para_env%num_pe
679 : ! Get infos about the mixed subsys
680 72 : IF (.NOT. mixed_env%do_mixed_qmmm_cdft) THEN
681 : CALL force_env_get(force_env=force_env, &
682 64 : subsys=subsys_mix)
683 : ELSE
684 : CALL get_qs_env(force_env_qs%qmmm_env%qs_env, &
685 8 : cp_subsys=subsys_mix)
686 : END IF
687 : ! Init structures only needed when the CDFT states are treated in parallel
688 72 : IF (mixed_cdft%run_type == mixed_cdft_parallel) THEN
689 : ! Start building the mixed auxbas_pw_pool
690 22 : CALL pw_env_create(mixed_cdft%pw_env)
691 : ! Decide what kind of layout to use and setup the grid
692 : ! Processor mappings currently supported:
693 : ! (2np,1) --> (np,1)
694 : ! (nx,2ny) --> (nx,ny)
695 : ! (nx,ny) --> (nx*ny/2,1) (required when xc_smooth is in use and with intermediate proc counts)
696 : !
697 : ! For cases 2 and 3, dlb redistributes YZ slices from overloaded processors to underloaded processors
698 : ! For case 1, XZ slices are redistributed
699 : ! TODO: Unify mappings. Now we essentially have separate code for cases 1-2 and 3.
700 : ! This leads to very messy code especially with dlb turned on...
701 : ! In terms of memory usage, it would be beneficial to replace case 1 with 3
702 : ! and implement a similar arbitrary mapping to replace case 2
703 :
704 22 : mixed_cdft%is_pencil = .FALSE. ! Flag to control the first two mappings
705 22 : mixed_cdft%is_special = .FALSE. ! Flag to control the last mapping
706 : ! With xc smoothing, the grid is always (ncpu/2,1) distributed
707 : ! and correct behavior cannot be guaranteed for ncpu/2 > nx, so we abort...
708 22 : IF (ncpu/2 .GT. settings%npts(1, 1)) &
709 0 : CPABORT("ncpu/2 => nx: decrease ncpu or disable xc_smoothing")
710 : !
711 22 : ALLOCATE (mixed_rs_dims(2))
712 22 : IF (settings%rs_dims(2, 1) /= 1) mixed_cdft%is_pencil = .TRUE.
713 22 : IF (.NOT. mixed_cdft%is_pencil .AND. ncpu .GT. settings%npts(1, 1)) mixed_cdft%is_special = .TRUE.
714 22 : IF (mixed_cdft%is_special) THEN
715 0 : mixed_rs_dims = (/-1, -1/)
716 22 : ELSE IF (mixed_cdft%is_pencil) THEN
717 0 : mixed_rs_dims = (/settings%rs_dims(1, 1), 2*settings%rs_dims(2, 1)/)
718 : ELSE
719 66 : mixed_rs_dims = (/2*settings%rs_dims(1, 1), 1/)
720 : END IF
721 22 : IF (.NOT. mixed_env%do_mixed_qmmm_cdft) THEN
722 : CALL force_env_get(force_env=force_env, &
723 18 : cell=cell_mix)
724 : ELSE
725 : CALL get_qs_env(force_env_qs%qmmm_env%qs_env, &
726 4 : cell=cell_mix)
727 : END IF
728 : CALL pw_grid_create(pw_grid, force_env%para_env, cell_mix%hmat, grid_span=settings%grid_span(1), &
729 : npts=settings%npts(:, 1), cutoff=settings%cutoff(1), &
730 : spherical=settings%is_spherical, odd=settings%is_odd, &
731 : fft_usage=.TRUE., ncommensurate=0, icommensurate=1, &
732 : blocked=do_pw_grid_blocked_false, rs_dims=mixed_rs_dims, &
733 22 : iounit=iounit)
734 : ! Check if the layout was successfully created
735 22 : IF (mixed_cdft%is_special) THEN
736 0 : IF (.NOT. pw_grid%para%group%num_pe_cart(2) /= 1) is_match = .FALSE.
737 22 : ELSE IF (mixed_cdft%is_pencil) THEN
738 0 : IF (.NOT. pw_grid%para%group%num_pe_cart(1) == mixed_rs_dims(1)) is_match = .FALSE.
739 : ELSE
740 22 : IF (.NOT. pw_grid%para%group%num_pe_cart(2) == 1) is_match = .FALSE.
741 : END IF
742 : IF (.NOT. is_match) &
743 : CALL cp_abort(__LOCATION__, &
744 : "Unable to create a suitable grid distribution "// &
745 : "for mixed CDFT calculations. Try decreasing the total number "// &
746 0 : "of processors or disabling xc_smoothing.")
747 22 : DEALLOCATE (mixed_rs_dims)
748 : ! Create the pool
749 220 : bo_mixed = pw_grid%bounds_local
750 44 : ALLOCATE (pw_pools(1))
751 22 : NULLIFY (pw_pools(1)%pool)
752 22 : CALL pw_pool_create(pw_pools(1)%pool, pw_grid=pw_grid)
753 : ! Initialize Gaussian cavity confinement
754 22 : IF (mixed_cdft%cdft_control%becke_control%cavity_confine) THEN
755 22 : CALL create_hirshfeld_type(mixed_cdft%cdft_control%becke_control%cavity_env)
756 : CALL set_hirshfeld_info(mixed_cdft%cdft_control%becke_control%cavity_env, &
757 : shape_function_type=shape_function_gaussian, iterative=.FALSE., &
758 : radius_type=mixed_cdft%cdft_control%becke_control%cavity_shape, &
759 22 : use_bohr=mixed_cdft%cdft_control%becke_control%use_bohr)
760 : END IF
761 : ! Gaussian confinement/wavefunction overlap method needs qs_kind_set
762 : ! Gaussian cavity confinement also needs the auxbas_rs_grid
763 22 : IF (mixed_cdft%cdft_control%becke_control%cavity_confine .OR. &
764 : mixed_cdft%wfn_overlap_method) THEN
765 : print_section => section_vals_get_subs_vals(force_env_section, &
766 22 : "PRINT%GRID_INFORMATION")
767 22 : ALLOCATE (mixed_cdft%pw_env%gridlevel_info)
768 : CALL init_gaussian_gridlevel(mixed_cdft%pw_env%gridlevel_info, &
769 : ngrid_levels=1, cutoff=settings%cutoff, &
770 : rel_cutoff=settings%rel_cutoff(1), &
771 22 : print_section=print_section)
772 44 : ALLOCATE (rs_descs(1))
773 374 : ALLOCATE (rs_grids(1))
774 638 : ALLOCATE (mixed_cdft%pw_env%cube_info(1))
775 22 : higher_grid_layout = (/-1, -1, -1/)
776 22 : CALL init_d3_poly_module()
777 : CALL init_cube_info(mixed_cdft%pw_env%cube_info(1), &
778 : pw_grid%dr(:), pw_grid%dh(:, :), &
779 : pw_grid%dh_inv(:, :), &
780 22 : pw_grid%orthorhombic, settings%radius)
781 22 : NULLIFY (root_section, force_env_section, force_env_sections, rs_grid_section)
782 22 : CALL force_env_get(force_env, root_section=root_section)
783 22 : force_env_sections => section_vals_get_subs_vals(root_section, "FORCE_EVAL")
784 22 : CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, n_force_eval)
785 : CALL section_vals_duplicate(force_env_sections, force_env_section, &
786 22 : i_force_eval(2), i_force_eval(2))
787 22 : rs_grid_section => section_vals_get_subs_vals(force_env_section, "DFT%MGRID%RS_GRID")
788 : CALL init_input_type(input_settings, &
789 : nsmax=2*MAX(1, return_cube_max_iradius(mixed_cdft%pw_env%cube_info(1))) + 1, &
790 : rs_grid_section=rs_grid_section, ilevel=1, &
791 22 : higher_grid_layout=higher_grid_layout)
792 22 : NULLIFY (rs_descs(1)%rs_desc)
793 22 : CALL rs_grid_create_descriptor(rs_descs(1)%rs_desc, pw_grid, input_settings)
794 22 : IF (rs_descs(1)%rs_desc%distributed) higher_grid_layout = rs_descs(1)%rs_desc%group_dim
795 22 : CALL rs_grid_create(rs_grids(1), rs_descs(1)%rs_desc)
796 22 : CALL rs_grid_print(rs_grids(1), iounit)
797 22 : mixed_cdft%pw_env%rs_descs => rs_descs
798 22 : mixed_cdft%pw_env%rs_grids => rs_grids
799 : ! qs_kind_set
800 : subsys_section => section_vals_get_subs_vals(force_env_sections, "SUBSYS", &
801 22 : i_rep_section=i_force_eval(1))
802 22 : kind_section => section_vals_get_subs_vals(subsys_section, "KIND")
803 22 : NULLIFY (qs_kind_set)
804 22 : CALL cp_subsys_get(subsys_mix, atomic_kind_set=atomic_kind_set)
805 : CALL create_qs_kind_set(qs_kind_set, atomic_kind_set, kind_section, &
806 22 : force_env%para_env, force_env_section)
807 22 : mixed_cdft%qs_kind_set => qs_kind_set
808 22 : DEALLOCATE (i_force_eval)
809 22 : CALL section_vals_release(force_env_section)
810 : END IF
811 : CALL force_env_get(force_env=force_env, &
812 22 : force_env_section=force_env_section)
813 22 : CALL pw_grid_release(pw_grid)
814 22 : mixed_cdft%pw_env%auxbas_grid = 1
815 22 : NULLIFY (mixed_cdft%pw_env%pw_pools)
816 22 : mixed_cdft%pw_env%pw_pools => pw_pools
817 220 : bo = settings%bo
818 : ! Determine which processors need to exchange data when redistributing the weight/gradient
819 22 : IF (.NOT. mixed_cdft%is_special) THEN
820 22 : ALLOCATE (mixed_cdft%dest_list(2))
821 22 : ALLOCATE (mixed_cdft%source_list(2))
822 22 : imap = force_env%para_env%mepos/2
823 66 : mixed_cdft%dest_list = (/imap, imap + force_env%para_env%num_pe/2/)
824 : imap = MOD(force_env%para_env%mepos, force_env%para_env%num_pe/2) + &
825 22 : MODULO(force_env%para_env%mepos, force_env%para_env%num_pe/2)
826 66 : mixed_cdft%source_list = (/imap, imap + 1/)
827 : ! Determine bounds of the data that is replicated
828 22 : ALLOCATE (mixed_cdft%recv_bo(4))
829 22 : ALLOCATE (sendbuffer(2), recvbuffer(2), recvbuffer2(2))
830 22 : IF (mixed_cdft%is_pencil) THEN
831 0 : sendbuffer = (/bo_mixed(1, 2), bo_mixed(2, 2)/)
832 : ELSE
833 66 : sendbuffer = (/bo_mixed(1, 1), bo_mixed(2, 1)/)
834 : END IF
835 : ! Communicate bounds in steps
836 : CALL force_env%para_env%isend(msgin=sendbuffer, dest=mixed_cdft%dest_list(1), &
837 22 : request=req(1))
838 : CALL force_env%para_env%irecv(msgout=recvbuffer, source=mixed_cdft%source_list(1), &
839 22 : request=req(2))
840 : CALL force_env%para_env%irecv(msgout=recvbuffer2, source=mixed_cdft%source_list(2), &
841 22 : request=req(3))
842 22 : CALL req(1)%wait()
843 : CALL force_env%para_env%isend(msgin=sendbuffer, dest=mixed_cdft%dest_list(2), &
844 22 : request=req(1))
845 22 : CALL mp_waitall(req)
846 110 : mixed_cdft%recv_bo(1:2) = recvbuffer
847 110 : mixed_cdft%recv_bo(3:4) = recvbuffer2
848 22 : DEALLOCATE (sendbuffer, recvbuffer, recvbuffer2)
849 : ELSE
850 0 : IF (mixed_env%do_mixed_qmmm_cdft) THEN
851 0 : qs_env => force_env_qs%qmmm_env%qs_env
852 : ELSE
853 0 : CALL force_env_get(force_env_qs, qs_env=qs_env)
854 : END IF
855 0 : CALL get_qs_env(qs_env, pw_env=pw_env)
856 0 : CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
857 : ! work out the pw grid points each proc holds in the two (identical) parallel proc groups
858 : ! note we only care about the x dir since we assume the y dir is not subdivided
859 0 : ALLOCATE (bounds(0:auxbas_pw_pool%pw_grid%para%group%num_pe - 1, 1:2))
860 0 : DO i = 0, auxbas_pw_pool%pw_grid%para%group%num_pe - 1
861 0 : bounds(i, 1:2) = auxbas_pw_pool%pw_grid%para%bo(1:2, 1, i, 1)
862 0 : bounds(i, 1:2) = bounds(i, 1:2) - auxbas_pw_pool%pw_grid%npts(1)/2 - 1
863 : END DO
864 : ! work out which procs to send my grid points
865 : ! first get the number of target procs per group
866 0 : ntargets = 0
867 0 : offset = -1
868 0 : DO i = 0, auxbas_pw_pool%pw_grid%para%group%num_pe - 1
869 0 : IF ((bounds(i, 1) .GE. bo_mixed(1, 1) .AND. bounds(i, 1) .LE. bo_mixed(2, 1)) .OR. &
870 0 : (bounds(i, 2) .GE. bo_mixed(1, 1) .AND. bounds(i, 2) .LE. bo_mixed(2, 1))) THEN
871 0 : ntargets = ntargets + 1
872 0 : IF (offset == -1) offset = i
873 0 : ELSE IF (bounds(i, 2) .GT. bo_mixed(2, 1)) THEN
874 : EXIT
875 : ELSE
876 0 : CYCLE
877 : END IF
878 : END DO
879 0 : ALLOCATE (mixed_cdft%dest_list(ntargets))
880 0 : ALLOCATE (mixed_cdft%dest_list_bo(2, ntargets))
881 : ! now determine the actual grid points to send
882 0 : j = 1
883 0 : DO i = offset, offset + ntargets - 1
884 0 : mixed_cdft%dest_list(j) = i
885 : mixed_cdft%dest_list_bo(:, j) = (/bo_mixed(1, 1) + (bounds(i, 1) - bo_mixed(1, 1)), &
886 0 : bo_mixed(2, 1) + (bounds(i, 2) - bo_mixed(2, 1))/)
887 0 : j = j + 1
888 : END DO
889 0 : ALLOCATE (mixed_cdft%dest_list_save(ntargets), mixed_cdft%dest_bo_save(2, ntargets))
890 : ! We need to store backups of these arrays since they might get reallocated during dlb
891 0 : mixed_cdft%dest_list_save = mixed_cdft%dest_list
892 0 : mixed_cdft%dest_bo_save = mixed_cdft%dest_list_bo
893 : ! finally determine which procs will send me grid points
894 : ! now we need info about y dir also
895 0 : DEALLOCATE (bounds)
896 0 : ALLOCATE (bounds(0:pw_pools(1)%pool%pw_grid%para%group%num_pe - 1, 1:4))
897 0 : DO i = 0, pw_pools(1)%pool%pw_grid%para%group%num_pe - 1
898 0 : bounds(i, 1:2) = pw_pools(1)%pool%pw_grid%para%bo(1:2, 1, i, 1)
899 0 : bounds(i, 3:4) = pw_pools(1)%pool%pw_grid%para%bo(1:2, 2, i, 1)
900 0 : bounds(i, 1:2) = bounds(i, 1:2) - pw_pools(1)%pool%pw_grid%npts(1)/2 - 1
901 0 : bounds(i, 3:4) = bounds(i, 3:4) - pw_pools(1)%pool%pw_grid%npts(2)/2 - 1
902 : END DO
903 0 : ntargets = 0
904 0 : offset = -1
905 0 : DO i = 0, pw_pools(1)%pool%pw_grid%para%group%num_pe - 1
906 0 : IF ((bo(1, 1) .GE. bounds(i, 1) .AND. bo(1, 1) .LE. bounds(i, 2)) .OR. &
907 0 : (bo(2, 1) .GE. bounds(i, 1) .AND. bo(2, 1) .LE. bounds(i, 2))) THEN
908 0 : ntargets = ntargets + 1
909 0 : IF (offset == -1) offset = i
910 0 : ELSE IF (bo(2, 1) .LT. bounds(i, 1)) THEN
911 : EXIT
912 : ELSE
913 0 : CYCLE
914 : END IF
915 : END DO
916 0 : ALLOCATE (mixed_cdft%source_list(ntargets))
917 0 : ALLOCATE (mixed_cdft%source_list_bo(4, ntargets))
918 0 : j = 1
919 0 : DO i = offset, offset + ntargets - 1
920 0 : mixed_cdft%source_list(j) = i
921 0 : IF (bo(1, 1) .GE. bounds(i, 1) .AND. bo(2, 1) .LE. bounds(i, 2)) THEN
922 : mixed_cdft%source_list_bo(:, j) = (/bo(1, 1), bo(2, 1), &
923 0 : bounds(i, 3), bounds(i, 4)/)
924 0 : ELSE IF (bo(1, 1) .GE. bounds(i, 1) .AND. bo(1, 1) .LE. bounds(i, 2)) THEN
925 : mixed_cdft%source_list_bo(:, j) = (/bo(1, 1), bounds(i, 2), &
926 0 : bounds(i, 3), bounds(i, 4)/)
927 : ELSE
928 : mixed_cdft%source_list_bo(:, j) = (/bounds(i, 1), bo(2, 1), &
929 0 : bounds(i, 3), bounds(i, 4)/)
930 : END IF
931 0 : j = j + 1
932 : END DO
933 0 : ALLOCATE (mixed_cdft%source_list_save(ntargets), mixed_cdft%source_bo_save(4, ntargets))
934 : ! We need to store backups of these arrays since they might get reallocated during dlb
935 0 : mixed_cdft%source_list_save = mixed_cdft%source_list
936 0 : mixed_cdft%source_bo_save = mixed_cdft%source_list_bo
937 0 : DEALLOCATE (bounds)
938 : END IF
939 : ELSE
940 : ! Create loggers to redirect the output of all CDFT states to different files
941 : ! even when the states are treated in serial (the initial print of QS data [basis set etc] for
942 : ! all states unfortunately goes to the first log file)
943 50 : CALL force_env_get(force_env, root_section=root_section)
944 224 : ALLOCATE (mixed_cdft%sub_logger(nforce_eval - 1))
945 124 : DO i = 1, nforce_eval - 1
946 74 : IF (force_env%para_env%is_source()) THEN
947 : CALL section_vals_val_get(root_section, "GLOBAL%PROJECT_NAME", &
948 37 : c_val=input_file_path)
949 37 : lp = LEN_TRIM(input_file_path)
950 37 : input_file_path(lp + 1:LEN(input_file_path)) = "-r-"//ADJUSTL(cp_to_string(i + 1))
951 37 : lp = LEN_TRIM(input_file_path)
952 37 : output_file_path = input_file_path(1:lp)//".out"
953 : CALL open_file(file_name=output_file_path, file_status="UNKNOWN", &
954 : file_action="WRITE", file_position="APPEND", &
955 37 : unit_number=unit_nr)
956 : ELSE
957 37 : unit_nr = -1
958 : END IF
959 : CALL cp_logger_create(mixed_cdft%sub_logger(i)%p, &
960 : para_env=force_env%para_env, &
961 : default_global_unit_nr=unit_nr, &
962 74 : close_global_unit_on_dealloc=.FALSE.)
963 : ! Try to use better names for the local log if it is not too late
964 : CALL section_vals_val_get(root_section, "GLOBAL%OUTPUT_FILE_NAME", &
965 74 : c_val=c_val)
966 74 : IF (c_val /= "") THEN
967 : CALL cp_logger_set(mixed_cdft%sub_logger(i)%p, &
968 0 : local_filename=TRIM(c_val)//"_localLog")
969 : END IF
970 74 : CALL section_vals_val_get(root_section, "GLOBAL%PROJECT", c_val=c_val)
971 74 : IF (c_val /= "") THEN
972 : CALL cp_logger_set(mixed_cdft%sub_logger(i)%p, &
973 74 : local_filename=TRIM(c_val)//"_localLog")
974 : END IF
975 74 : mixed_cdft%sub_logger(i)%p%iter_info%project_name = c_val
976 : CALL section_vals_val_get(root_section, "GLOBAL%PRINT_LEVEL", &
977 124 : i_val=mixed_cdft%sub_logger(i)%p%iter_info%print_level)
978 : END DO
979 50 : IF (mixed_cdft%wfn_overlap_method) THEN
980 : ! qs_kind_set
981 6 : NULLIFY (root_section, force_env_section, force_env_sections, rs_grid_section)
982 6 : CALL force_env_get(force_env, root_section=root_section)
983 6 : force_env_sections => section_vals_get_subs_vals(root_section, "FORCE_EVAL")
984 6 : CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, n_force_eval)
985 : CALL section_vals_duplicate(force_env_sections, force_env_section, &
986 6 : i_force_eval(2), i_force_eval(2))
987 : subsys_section => section_vals_get_subs_vals(force_env_sections, "SUBSYS", &
988 6 : i_rep_section=i_force_eval(1))
989 6 : kind_section => section_vals_get_subs_vals(subsys_section, "KIND")
990 6 : NULLIFY (qs_kind_set)
991 6 : CALL cp_subsys_get(subsys_mix, atomic_kind_set=atomic_kind_set)
992 : CALL create_qs_kind_set(qs_kind_set, atomic_kind_set, kind_section, &
993 6 : force_env%para_env, force_env_section)
994 6 : mixed_cdft%qs_kind_set => qs_kind_set
995 6 : DEALLOCATE (i_force_eval)
996 6 : CALL section_vals_release(force_env_section)
997 6 : mixed_cdft%qs_kind_set => qs_kind_set
998 : END IF
999 : CALL force_env_get(force_env=force_env, &
1000 50 : force_env_section=force_env_section)
1001 : END IF
1002 : ! Deallocate settings temporaries
1003 72 : DEALLOCATE (settings%grid_span)
1004 72 : DEALLOCATE (settings%npts)
1005 72 : DEALLOCATE (settings%spherical)
1006 72 : DEALLOCATE (settings%rs_dims)
1007 72 : DEALLOCATE (settings%odd)
1008 72 : DEALLOCATE (settings%atoms)
1009 72 : IF (mixed_cdft%run_type == mixed_cdft_parallel) &
1010 22 : DEALLOCATE (settings%coeffs)
1011 72 : DEALLOCATE (settings%cutoffs)
1012 72 : DEALLOCATE (settings%radii)
1013 72 : DEALLOCATE (settings%si)
1014 72 : DEALLOCATE (settings%sr)
1015 72 : DEALLOCATE (settings%sb)
1016 72 : DEALLOCATE (settings%cutoff)
1017 72 : DEALLOCATE (settings%rel_cutoff)
1018 : ! Setup mixed blacs_env for redistributing arrays during ET coupling calculation
1019 72 : IF (mixed_env%do_mixed_et) THEN
1020 72 : NULLIFY (root_section)
1021 72 : CALL force_env_get(force_env, globenv=globenv, root_section=root_section)
1022 : CALL cp_blacs_env_create(mixed_cdft%blacs_env, force_env%para_env, globenv%blacs_grid_layout, &
1023 72 : globenv%blacs_repeatable)
1024 : END IF
1025 : CALL cp_print_key_finished_output(iounit, logger, force_env_section, &
1026 72 : "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO")
1027 :
1028 360 : END SUBROUTINE mixed_cdft_init_structures
1029 :
1030 : ! **************************************************************************************************
1031 : !> \brief Redistribute arrays needed for an ET coupling calculation from individual CDFT states to
1032 : !> the mixed CDFT env, that is, move the arrays to the correct blacs context. For parallel
1033 : !> simulations, the array processor distributions also change from N to 2N processors.
1034 : !> \param force_env the force_env that holds the CDFT states
1035 : !> \par History
1036 : !> 01.2017 created [Nico Holmberg]
1037 : ! **************************************************************************************************
1038 94 : SUBROUTINE mixed_cdft_redistribute_arrays(force_env)
1039 : TYPE(force_env_type), POINTER :: force_env
1040 :
1041 : INTEGER :: iforce_eval, ispin, ivar, ncol_overlap, &
1042 : ncol_wmat, nforce_eval, nrow_overlap, &
1043 : nrow_wmat, nspins, nvar
1044 94 : INTEGER, ALLOCATABLE, DIMENSION(:) :: ncol_mo, nrow_mo
1045 : LOGICAL :: uniform_occupation
1046 94 : LOGICAL, ALLOCATABLE, DIMENSION(:) :: has_occupation_numbers
1047 94 : TYPE(cp_1d_r_p_type), ALLOCATABLE, DIMENSION(:, :) :: occno_tmp
1048 : TYPE(cp_blacs_env_type), POINTER :: blacs_env
1049 : TYPE(cp_fm_struct_type), POINTER :: fm_struct_mo, fm_struct_overlap, &
1050 : fm_struct_tmp, fm_struct_wmat
1051 : TYPE(cp_fm_type) :: matrix_s_tmp, mixed_matrix_s_tmp
1052 94 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: matrix_p_tmp, mixed_matrix_p_tmp, &
1053 94 : mixed_wmat_tmp, mo_coeff_tmp, wmat_tmp
1054 94 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: mixed_mo_coeff
1055 94 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: density_matrix, w_matrix
1056 : TYPE(dbcsr_type) :: desymm_tmp
1057 : TYPE(dbcsr_type), POINTER :: mixed_matrix_s
1058 : TYPE(dft_control_type), POINTER :: dft_control
1059 : TYPE(force_env_type), POINTER :: force_env_qs
1060 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
1061 : TYPE(mixed_environment_type), POINTER :: mixed_env
1062 : TYPE(qs_environment_type), POINTER :: qs_env
1063 :
1064 94 : NULLIFY (mixed_env, mixed_cdft, qs_env, dft_control, fm_struct_mo, &
1065 94 : fm_struct_wmat, fm_struct_overlap, fm_struct_tmp, &
1066 94 : mixed_mo_coeff, mixed_matrix_s, density_matrix, blacs_env, w_matrix, force_env_qs)
1067 0 : CPASSERT(ASSOCIATED(force_env))
1068 94 : mixed_env => force_env%mixed_env
1069 94 : nforce_eval = SIZE(force_env%sub_force_env)
1070 94 : CALL get_mixed_env(mixed_env, cdft_control=mixed_cdft)
1071 94 : CPASSERT(ASSOCIATED(mixed_cdft))
1072 94 : CALL mixed_cdft_work_type_init(mixed_cdft%matrix)
1073 : ! Get nspins and query for non-uniform occupation numbers
1074 282 : ALLOCATE (has_occupation_numbers(nforce_eval))
1075 306 : has_occupation_numbers = .FALSE.
1076 306 : DO iforce_eval = 1, nforce_eval
1077 212 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
1078 176 : force_env_qs => force_env%sub_force_env(iforce_eval)%force_env
1079 176 : IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN
1080 24 : qs_env => force_env_qs%qmmm_env%qs_env
1081 : ELSE
1082 152 : CALL force_env_get(force_env_qs, qs_env=qs_env)
1083 : END IF
1084 176 : CALL get_qs_env(qs_env, dft_control=dft_control)
1085 176 : CPASSERT(ASSOCIATED(dft_control))
1086 176 : nspins = dft_control%nspins
1087 176 : IF (force_env_qs%para_env%is_source()) &
1088 236 : has_occupation_numbers(iforce_eval) = ALLOCATED(dft_control%qs_control%cdft_control%occupations)
1089 : END DO
1090 94 : CALL force_env%para_env%sum(has_occupation_numbers(1))
1091 212 : DO iforce_eval = 2, nforce_eval
1092 118 : CALL force_env%para_env%sum(has_occupation_numbers(iforce_eval))
1093 118 : IF (has_occupation_numbers(1) .NEQV. has_occupation_numbers(iforce_eval)) &
1094 : CALL cp_abort(__LOCATION__, &
1095 94 : "Mixing of uniform and non-uniform occupations is not allowed.")
1096 : END DO
1097 94 : uniform_occupation = .NOT. has_occupation_numbers(1)
1098 94 : DEALLOCATE (has_occupation_numbers)
1099 : ! Get number of weight functions per state as well as the type of each constraint
1100 94 : nvar = SIZE(dft_control%qs_control%cdft_control%target)
1101 94 : IF (.NOT. ALLOCATED(mixed_cdft%constraint_type)) THEN
1102 288 : ALLOCATE (mixed_cdft%constraint_type(nvar, nforce_eval))
1103 412 : mixed_cdft%constraint_type(:, :) = 0
1104 72 : IF (mixed_cdft%identical_constraints) THEN
1105 142 : DO ivar = 1, nvar
1106 : mixed_cdft%constraint_type(ivar, :) = &
1107 310 : dft_control%qs_control%cdft_control%group(ivar)%constraint_type
1108 : END DO
1109 : ELSE
1110 : ! Possibly couple spin and charge constraints
1111 6 : DO iforce_eval = 1, nforce_eval
1112 4 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
1113 4 : IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN
1114 0 : qs_env => force_env%sub_force_env(iforce_eval)%force_env%qmmm_env%qs_env
1115 : ELSE
1116 4 : CALL force_env_get(force_env%sub_force_env(iforce_eval)%force_env, qs_env=qs_env)
1117 : END IF
1118 4 : CALL get_qs_env(qs_env, dft_control=dft_control)
1119 6 : IF (force_env%sub_force_env(iforce_eval)%force_env%para_env%is_source()) THEN
1120 4 : DO ivar = 1, nvar
1121 : mixed_cdft%constraint_type(ivar, iforce_eval) = &
1122 4 : dft_control%qs_control%cdft_control%group(ivar)%constraint_type
1123 : END DO
1124 : END IF
1125 : END DO
1126 2 : CALL force_env%para_env%sum(mixed_cdft%constraint_type)
1127 : END IF
1128 : END IF
1129 : ! Transfer data from sub_force_envs to temporaries
1130 988 : ALLOCATE (mixed_cdft%matrix%mixed_mo_coeff(nforce_eval, nspins))
1131 94 : mixed_mo_coeff => mixed_cdft%matrix%mixed_mo_coeff
1132 688 : ALLOCATE (mixed_cdft%matrix%w_matrix(nforce_eval, nvar))
1133 94 : w_matrix => mixed_cdft%matrix%w_matrix
1134 94 : CALL dbcsr_init_p(mixed_cdft%matrix%mixed_matrix_s)
1135 94 : mixed_matrix_s => mixed_cdft%matrix%mixed_matrix_s
1136 94 : IF (mixed_cdft%calculate_metric) THEN
1137 144 : ALLOCATE (mixed_cdft%matrix%density_matrix(nforce_eval, nspins))
1138 14 : density_matrix => mixed_cdft%matrix%density_matrix
1139 : END IF
1140 1488 : ALLOCATE (mo_coeff_tmp(nforce_eval, nspins), wmat_tmp(nforce_eval, nvar))
1141 376 : ALLOCATE (nrow_mo(nspins), ncol_mo(nspins))
1142 210 : IF (mixed_cdft%calculate_metric) ALLOCATE (matrix_p_tmp(nforce_eval, nspins))
1143 94 : IF (.NOT. uniform_occupation) THEN
1144 140 : ALLOCATE (mixed_cdft%occupations(nforce_eval, nspins))
1145 126 : ALLOCATE (occno_tmp(nforce_eval, nspins))
1146 : END IF
1147 306 : DO iforce_eval = 1, nforce_eval
1148 : ! Temporary arrays need to be nulled on every process
1149 636 : DO ispin = 1, nspins
1150 : ! Valgrind 3.12/gfortran 4.8.4 oddly complains here (unconditional jump)
1151 : ! if mixed_cdft%calculate_metric = .FALSE. and the need to null the array
1152 : ! is queried with IF (mixed_cdft%calculate_metric) &
1153 424 : IF (.NOT. uniform_occupation) &
1154 268 : NULLIFY (occno_tmp(iforce_eval, ispin)%array)
1155 : END DO
1156 212 : IF (.NOT. ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE
1157 : ! From this point onward, we access data local to the sub_force_envs
1158 : ! Get qs_env
1159 176 : force_env_qs => force_env%sub_force_env(iforce_eval)%force_env
1160 176 : IF (force_env%mixed_env%do_mixed_qmmm_cdft) THEN
1161 24 : qs_env => force_env_qs%qmmm_env%qs_env
1162 : ELSE
1163 152 : CALL force_env_get(force_env_qs, qs_env=qs_env)
1164 : END IF
1165 176 : CALL get_qs_env(qs_env, dft_control=dft_control, blacs_env=blacs_env)
1166 : ! Store dimensions of the transferred arrays
1167 : CALL dbcsr_get_info(dft_control%qs_control%cdft_control%matrix_s%matrix, &
1168 176 : nfullrows_total=nrow_overlap, nfullcols_total=ncol_overlap)
1169 : CALL dbcsr_get_info(dft_control%qs_control%cdft_control%wmat(1)%matrix, &
1170 176 : nfullrows_total=nrow_wmat, nfullcols_total=ncol_wmat)
1171 : ! MO Coefficients
1172 528 : DO ispin = 1, nspins
1173 : CALL cp_fm_get_info(dft_control%qs_control%cdft_control%mo_coeff(ispin), &
1174 352 : ncol_global=ncol_mo(ispin), nrow_global=nrow_mo(ispin))
1175 : CALL cp_fm_create(matrix=mo_coeff_tmp(iforce_eval, ispin), &
1176 : matrix_struct=dft_control%qs_control%cdft_control%mo_coeff(ispin)%matrix_struct, &
1177 : name="MO_COEFF_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_" &
1178 352 : //TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX")
1179 : CALL cp_fm_to_fm(dft_control%qs_control%cdft_control%mo_coeff(ispin), &
1180 528 : mo_coeff_tmp(iforce_eval, ispin))
1181 : END DO
1182 176 : CALL cp_fm_release(dft_control%qs_control%cdft_control%mo_coeff)
1183 : ! Matrix representation(s) of the weight function(s) (dbcsr -> fm)
1184 : CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nrow_wmat, ncol_global=ncol_wmat, context=blacs_env, &
1185 : para_env=force_env%sub_force_env(iforce_eval)%force_env%para_env, &
1186 176 : square_blocks=.TRUE.)
1187 356 : DO ivar = 1, nvar
1188 180 : CALL cp_fm_create(wmat_tmp(iforce_eval, ivar), fm_struct_tmp, name="w_matrix")
1189 180 : CALL dbcsr_desymmetrize(dft_control%qs_control%cdft_control%wmat(ivar)%matrix, desymm_tmp)
1190 180 : CALL copy_dbcsr_to_fm(desymm_tmp, wmat_tmp(iforce_eval, ivar))
1191 180 : CALL dbcsr_release(desymm_tmp)
1192 356 : CALL dbcsr_release_p(dft_control%qs_control%cdft_control%wmat(ivar)%matrix)
1193 : END DO
1194 176 : DEALLOCATE (dft_control%qs_control%cdft_control%wmat)
1195 176 : CALL cp_fm_struct_release(fm_struct_tmp)
1196 : ! Overlap matrix is the same for all sub_force_envs, so we just copy the first one (dbcsr -> fm)
1197 176 : IF (iforce_eval == 1) THEN
1198 : CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nrow_overlap, &
1199 : ncol_global=ncol_overlap, context=blacs_env, &
1200 76 : para_env=force_env%sub_force_env(iforce_eval)%force_env%para_env)
1201 76 : CALL cp_fm_create(matrix_s_tmp, fm_struct_tmp, name="s_matrix")
1202 76 : CALL cp_fm_struct_release(fm_struct_tmp)
1203 76 : CALL dbcsr_desymmetrize(dft_control%qs_control%cdft_control%matrix_s%matrix, desymm_tmp)
1204 76 : CALL copy_dbcsr_to_fm(desymm_tmp, matrix_s_tmp)
1205 76 : CALL dbcsr_release(desymm_tmp)
1206 : END IF
1207 176 : CALL dbcsr_release_p(dft_control%qs_control%cdft_control%matrix_s%matrix)
1208 : ! Density_matrix (dbcsr -> fm)
1209 176 : IF (mixed_cdft%calculate_metric) THEN
1210 72 : DO ispin = 1, nspins
1211 : ! Size AOxAO
1212 : CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol_overlap, &
1213 : ncol_global=ncol_overlap, context=blacs_env, &
1214 48 : para_env=force_env%sub_force_env(iforce_eval)%force_env%para_env)
1215 48 : CALL cp_fm_create(matrix_p_tmp(iforce_eval, ispin), fm_struct_tmp, name="dm_matrix")
1216 48 : CALL cp_fm_struct_release(fm_struct_tmp)
1217 48 : CALL dbcsr_desymmetrize(dft_control%qs_control%cdft_control%matrix_p(ispin)%matrix, desymm_tmp)
1218 48 : CALL copy_dbcsr_to_fm(desymm_tmp, matrix_p_tmp(iforce_eval, ispin))
1219 48 : CALL dbcsr_release(desymm_tmp)
1220 72 : CALL dbcsr_release_p(dft_control%qs_control%cdft_control%matrix_p(ispin)%matrix)
1221 : END DO
1222 24 : DEALLOCATE (dft_control%qs_control%cdft_control%matrix_p)
1223 : END IF
1224 : ! Occupation numbers
1225 446 : IF (.NOT. uniform_occupation) THEN
1226 84 : DO ispin = 1, nspins
1227 56 : IF (ncol_mo(ispin) /= SIZE(dft_control%qs_control%cdft_control%occupations(ispin)%array)) &
1228 0 : CPABORT("Array dimensions dont match.")
1229 56 : IF (force_env_qs%para_env%is_source()) THEN
1230 84 : ALLOCATE (occno_tmp(iforce_eval, ispin)%array(ncol_mo(ispin)))
1231 126 : occno_tmp(iforce_eval, ispin)%array = dft_control%qs_control%cdft_control%occupations(ispin)%array
1232 : END IF
1233 84 : DEALLOCATE (dft_control%qs_control%cdft_control%occupations(ispin)%array)
1234 : END DO
1235 28 : DEALLOCATE (dft_control%qs_control%cdft_control%occupations)
1236 : END IF
1237 : END DO
1238 : ! Create needed fm structs
1239 : CALL cp_fm_struct_create(fm_struct_wmat, nrow_global=nrow_wmat, ncol_global=ncol_wmat, &
1240 94 : context=mixed_cdft%blacs_env, para_env=force_env%para_env)
1241 : CALL cp_fm_struct_create(fm_struct_overlap, nrow_global=nrow_overlap, ncol_global=ncol_overlap, &
1242 94 : context=mixed_cdft%blacs_env, para_env=force_env%para_env)
1243 : ! Redistribute arrays with copy_general (this is not optimal for dbcsr matrices but...)
1244 : ! We use this method for the serial case (mixed_cdft%run_type == mixed_cdft_serial) as well to move the arrays to the
1245 : ! correct blacs_env, which is impossible using a simple copy of the arrays
1246 594 : ALLOCATE (mixed_wmat_tmp(nforce_eval, nvar))
1247 94 : IF (mixed_cdft%calculate_metric) &
1248 130 : ALLOCATE (mixed_matrix_p_tmp(nforce_eval, nspins))
1249 306 : DO iforce_eval = 1, nforce_eval
1250 : ! MO coefficients
1251 636 : DO ispin = 1, nspins
1252 424 : NULLIFY (fm_struct_mo)
1253 : CALL cp_fm_struct_create(fm_struct_mo, nrow_global=nrow_mo(ispin), ncol_global=ncol_mo(ispin), &
1254 424 : context=mixed_cdft%blacs_env, para_env=force_env%para_env)
1255 : CALL cp_fm_create(matrix=mixed_mo_coeff(iforce_eval, ispin), &
1256 : matrix_struct=fm_struct_mo, &
1257 : name="MO_COEFF_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_" &
1258 424 : //TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX")
1259 : CALL cp_fm_copy_general(mo_coeff_tmp(iforce_eval, ispin), &
1260 : mixed_mo_coeff(iforce_eval, ispin), &
1261 424 : mixed_cdft%blacs_env%para_env)
1262 424 : CALL cp_fm_release(mo_coeff_tmp(iforce_eval, ispin))
1263 636 : CALL cp_fm_struct_release(fm_struct_mo)
1264 : END DO
1265 : ! Weight
1266 428 : DO ivar = 1, nvar
1267 216 : NULLIFY (w_matrix(iforce_eval, ivar)%matrix)
1268 216 : CALL dbcsr_init_p(w_matrix(iforce_eval, ivar)%matrix)
1269 : CALL cp_fm_create(matrix=mixed_wmat_tmp(iforce_eval, ivar), &
1270 : matrix_struct=fm_struct_wmat, &
1271 216 : name="WEIGHT_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_MATRIX")
1272 : CALL cp_fm_copy_general(wmat_tmp(iforce_eval, ivar), &
1273 : mixed_wmat_tmp(iforce_eval, ivar), &
1274 216 : mixed_cdft%blacs_env%para_env)
1275 216 : CALL cp_fm_release(wmat_tmp(iforce_eval, ivar))
1276 : ! (fm -> dbcsr)
1277 : CALL copy_fm_to_dbcsr_bc(mixed_wmat_tmp(iforce_eval, ivar), &
1278 216 : w_matrix(iforce_eval, ivar)%matrix)
1279 428 : CALL cp_fm_release(mixed_wmat_tmp(iforce_eval, ivar))
1280 : END DO
1281 : ! Density matrix (fm -> dbcsr)
1282 306 : IF (mixed_cdft%calculate_metric) THEN
1283 90 : DO ispin = 1, nspins
1284 60 : NULLIFY (density_matrix(iforce_eval, ispin)%matrix)
1285 60 : CALL dbcsr_init_p(density_matrix(iforce_eval, ispin)%matrix)
1286 : CALL cp_fm_create(matrix=mixed_matrix_p_tmp(iforce_eval, ispin), &
1287 : matrix_struct=fm_struct_overlap, &
1288 : name="DENSITY_"//TRIM(ADJUSTL(cp_to_string(iforce_eval)))//"_"// &
1289 60 : TRIM(ADJUSTL(cp_to_string(ispin)))//"_MATRIX")
1290 : CALL cp_fm_copy_general(matrix_p_tmp(iforce_eval, ispin), &
1291 : mixed_matrix_p_tmp(iforce_eval, ispin), &
1292 60 : mixed_cdft%blacs_env%para_env)
1293 60 : CALL cp_fm_release(matrix_p_tmp(iforce_eval, ispin))
1294 : CALL copy_fm_to_dbcsr_bc(mixed_matrix_p_tmp(iforce_eval, ispin), &
1295 60 : density_matrix(iforce_eval, ispin)%matrix)
1296 90 : CALL cp_fm_release(mixed_matrix_p_tmp(iforce_eval, ispin))
1297 : END DO
1298 : END IF
1299 : END DO
1300 94 : CALL cp_fm_struct_release(fm_struct_wmat)
1301 94 : DEALLOCATE (mo_coeff_tmp, wmat_tmp, mixed_wmat_tmp)
1302 94 : IF (mixed_cdft%calculate_metric) THEN
1303 14 : DEALLOCATE (matrix_p_tmp)
1304 14 : DEALLOCATE (mixed_matrix_p_tmp)
1305 : END IF
1306 : ! Overlap (fm -> dbcsr)
1307 : CALL cp_fm_create(matrix=mixed_matrix_s_tmp, &
1308 : matrix_struct=fm_struct_overlap, &
1309 94 : name="OVERLAP_MATRIX")
1310 94 : CALL cp_fm_struct_release(fm_struct_overlap)
1311 : CALL cp_fm_copy_general(matrix_s_tmp, &
1312 : mixed_matrix_s_tmp, &
1313 94 : mixed_cdft%blacs_env%para_env)
1314 94 : CALL cp_fm_release(matrix_s_tmp)
1315 94 : CALL copy_fm_to_dbcsr_bc(mixed_matrix_s_tmp, mixed_matrix_s)
1316 94 : CALL cp_fm_release(mixed_matrix_s_tmp)
1317 : ! Occupation numbers
1318 94 : IF (.NOT. uniform_occupation) THEN
1319 42 : DO iforce_eval = 1, nforce_eval
1320 98 : DO ispin = 1, nspins
1321 168 : ALLOCATE (mixed_cdft%occupations(iforce_eval, ispin)%array(ncol_mo(ispin)))
1322 252 : mixed_cdft%occupations(iforce_eval, ispin)%array = 0.0_dp
1323 56 : IF (ASSOCIATED(occno_tmp(iforce_eval, ispin)%array)) THEN
1324 126 : mixed_cdft%occupations(iforce_eval, ispin)%array = occno_tmp(iforce_eval, ispin)%array
1325 28 : DEALLOCATE (occno_tmp(iforce_eval, ispin)%array)
1326 : END IF
1327 476 : CALL force_env%para_env%sum(mixed_cdft%occupations(iforce_eval, ispin)%array)
1328 : END DO
1329 : END DO
1330 14 : DEALLOCATE (occno_tmp)
1331 : END IF
1332 94 : DEALLOCATE (ncol_mo, nrow_mo)
1333 :
1334 282 : END SUBROUTINE mixed_cdft_redistribute_arrays
1335 : ! **************************************************************************************************
1336 : !> \brief Routine to print out the electronic coupling(s) between CDFT states.
1337 : !> \param force_env the force_env that holds the CDFT states
1338 : !> \par History
1339 : !> 11.17 created [Nico Holmberg]
1340 : ! **************************************************************************************************
1341 94 : SUBROUTINE mixed_cdft_print_couplings(force_env)
1342 : TYPE(force_env_type), POINTER :: force_env
1343 :
1344 : INTEGER :: iounit, ipermutation, istate, ivar, &
1345 : jstate, nforce_eval, npermutations, &
1346 : nvar
1347 : TYPE(cp_logger_type), POINTER :: logger
1348 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
1349 : TYPE(section_vals_type), POINTER :: force_env_section, print_section
1350 :
1351 94 : NULLIFY (print_section, mixed_cdft)
1352 :
1353 94 : logger => cp_get_default_logger()
1354 94 : CPASSERT(ASSOCIATED(force_env))
1355 : CALL force_env_get(force_env=force_env, &
1356 94 : force_env_section=force_env_section)
1357 94 : CALL get_mixed_env(force_env%mixed_env, cdft_control=mixed_cdft)
1358 94 : CPASSERT(ASSOCIATED(mixed_cdft))
1359 94 : print_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO")
1360 94 : iounit = cp_print_key_unit_nr(logger, print_section, '', extension='.mixedLog')
1361 : !
1362 94 : CPASSERT(ALLOCATED(mixed_cdft%results%strength))
1363 94 : CPASSERT(ALLOCATED(mixed_cdft%results%W_diagonal))
1364 94 : CPASSERT(ALLOCATED(mixed_cdft%results%S))
1365 94 : CPASSERT(ALLOCATED(mixed_cdft%results%energy))
1366 94 : nforce_eval = SIZE(force_env%sub_force_env)
1367 94 : nvar = SIZE(mixed_cdft%results%strength, 1)
1368 94 : npermutations = nforce_eval*(nforce_eval - 1)/2 ! Size of upper triangular part
1369 94 : IF (iounit > 0) THEN
1370 : WRITE (iounit, '(/,T3,A,T66)') &
1371 47 : '------------------------- CDFT coupling information --------------------------'
1372 : WRITE (iounit, '(T3,A,T66,(3X,F12.2))') &
1373 47 : 'Information at step (fs):', mixed_cdft%sim_step*mixed_cdft%sim_dt
1374 135 : DO ipermutation = 1, npermutations
1375 88 : CALL map_permutation_to_states(nforce_eval, ipermutation, istate, jstate)
1376 88 : WRITE (iounit, '(/,T3,A)') REPEAT('#', 44)
1377 88 : WRITE (iounit, '(T3,A,I3,A,I3,A)') '###### CDFT states I =', istate, ' and J = ', jstate, ' ######'
1378 88 : WRITE (iounit, '(T3,A)') REPEAT('#', 44)
1379 177 : DO ivar = 1, nvar
1380 89 : IF (ivar > 1) &
1381 1 : WRITE (iounit, '(A)') ''
1382 89 : WRITE (iounit, '(T3,A,T60,(3X,I18))') 'Atomic group:', ivar
1383 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1384 89 : 'Strength of constraint I:', mixed_cdft%results%strength(ivar, istate)
1385 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1386 89 : 'Strength of constraint J:', mixed_cdft%results%strength(ivar, jstate)
1387 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1388 89 : 'Final value of constraint I:', mixed_cdft%results%W_diagonal(ivar, istate)
1389 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1390 177 : 'Final value of constraint J:', mixed_cdft%results%W_diagonal(ivar, jstate)
1391 : END DO
1392 : WRITE (iounit, '(/,T3,A,T60,(3X,F18.12))') &
1393 88 : 'Overlap between states I and J:', mixed_cdft%results%S(istate, jstate)
1394 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1395 88 : 'Charge transfer energy (J-I) (Hartree):', (mixed_cdft%results%energy(jstate) - mixed_cdft%results%energy(istate))
1396 88 : WRITE (iounit, *)
1397 88 : IF (ALLOCATED(mixed_cdft%results%rotation)) THEN
1398 86 : IF (ABS(mixed_cdft%results%rotation(ipermutation))*1.0E3_dp .GE. 0.1_dp) THEN
1399 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1400 85 : 'Diabatic electronic coupling (rotation, mHartree):', &
1401 170 : ABS(mixed_cdft%results%rotation(ipermutation)*1.0E3_dp)
1402 : ELSE
1403 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1404 1 : 'Diabatic electronic coupling (rotation, microHartree):', &
1405 2 : ABS(mixed_cdft%results%rotation(ipermutation)*1.0E6_dp)
1406 : END IF
1407 : END IF
1408 88 : IF (ALLOCATED(mixed_cdft%results%lowdin)) THEN
1409 10 : IF (ABS(mixed_cdft%results%lowdin(ipermutation))*1.0E3_dp .GE. 0.1_dp) THEN
1410 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1411 9 : 'Diabatic electronic coupling (Lowdin, mHartree):', &
1412 18 : ABS(mixed_cdft%results%lowdin(ipermutation)*1.0E3_dp)
1413 : ELSE
1414 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1415 1 : 'Diabatic electronic coupling (Lowdin, microHartree):', &
1416 2 : ABS(mixed_cdft%results%lowdin(ipermutation)*1.0E6_dp)
1417 : END IF
1418 : END IF
1419 88 : IF (ALLOCATED(mixed_cdft%results%wfn)) THEN
1420 6 : IF (mixed_cdft%results%wfn(ipermutation)*1.0E3_dp .GE. 0.1_dp) THEN
1421 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1422 5 : 'Diabatic electronic coupling (wfn overlap, mHartree):', &
1423 10 : ABS(mixed_cdft%results%wfn(ipermutation)*1.0E3_dp)
1424 : ELSE
1425 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1426 1 : 'Diabatic electronic coupling (wfn overlap, microHartree):', &
1427 2 : ABS(mixed_cdft%results%wfn(ipermutation)*1.0E6_dp)
1428 : END IF
1429 : END IF
1430 88 : IF (ALLOCATED(mixed_cdft%results%nonortho)) THEN
1431 : WRITE (iounit, '(T3,A,T60,(3X,F18.12))') &
1432 50 : 'Diabatic electronic coupling (nonorthogonal, Hartree):', mixed_cdft%results%nonortho(ipermutation)
1433 : END IF
1434 223 : IF (ALLOCATED(mixed_cdft%results%metric)) THEN
1435 9 : WRITE (iounit, *)
1436 9 : IF (SIZE(mixed_cdft%results%metric, 2) == 1) THEN
1437 : WRITE (iounit, '(T3,A,T66,(3X,F12.6))') &
1438 0 : 'Coupling reliability metric (0 is ideal):', mixed_cdft%results%metric(ipermutation, 1)
1439 : ELSE
1440 : WRITE (iounit, '(T3,A,T54,(3X,2F12.6))') &
1441 9 : 'Coupling reliability metric (0 is ideal):', &
1442 18 : mixed_cdft%results%metric(ipermutation, 1), mixed_cdft%results%metric(ipermutation, 2)
1443 : END IF
1444 : END IF
1445 : END DO
1446 : WRITE (iounit, '(T3,A)') &
1447 47 : '------------------------------------------------------------------------------'
1448 : END IF
1449 : CALL cp_print_key_finished_output(iounit, logger, force_env_section, &
1450 94 : "MIXED%MIXED_CDFT%PRINT%PROGRAM_RUN_INFO")
1451 :
1452 94 : END SUBROUTINE mixed_cdft_print_couplings
1453 :
1454 : ! **************************************************************************************************
1455 : !> \brief Release storage reserved for mixed CDFT matrices
1456 : !> \param force_env the force_env that holds the CDFT states
1457 : !> \par History
1458 : !> 11.17 created [Nico Holmberg]
1459 : ! **************************************************************************************************
1460 94 : SUBROUTINE mixed_cdft_release_work(force_env)
1461 : TYPE(force_env_type), POINTER :: force_env
1462 :
1463 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
1464 :
1465 94 : NULLIFY (mixed_cdft)
1466 :
1467 94 : CPASSERT(ASSOCIATED(force_env))
1468 94 : CALL get_mixed_env(force_env%mixed_env, cdft_control=mixed_cdft)
1469 94 : CPASSERT(ASSOCIATED(mixed_cdft))
1470 94 : CALL mixed_cdft_result_type_release(mixed_cdft%results)
1471 :
1472 94 : END SUBROUTINE mixed_cdft_release_work
1473 :
1474 : ! **************************************************************************************************
1475 : !> \brief Given the size of a symmetric matrix and a permutation index, returns indices (i, j) of the
1476 : !> off-diagonal element that corresponds to the permutation index. Assumes that the permutation
1477 : !> index was computed by going through the upper triangular part of the input matrix row-by-row.
1478 : !> \param n the size of the symmetric matrix
1479 : !> \param ipermutation the permutation index
1480 : !> \param i the row index corresponding to ipermutation
1481 : !> \param j the column index corresponding to ipermutation
1482 : ! **************************************************************************************************
1483 1248 : SUBROUTINE map_permutation_to_states(n, ipermutation, i, j)
1484 : INTEGER, INTENT(IN) :: n, ipermutation
1485 : INTEGER, INTENT(OUT) :: i, j
1486 :
1487 : INTEGER :: kcol, kpermutation, krow, npermutations
1488 :
1489 1248 : npermutations = n*(n - 1)/2 ! Size of upper triangular part
1490 1248 : IF (ipermutation > npermutations) &
1491 0 : CPABORT("Permutation index out of bounds")
1492 1248 : kpermutation = 0
1493 2124 : DO krow = 1, n
1494 7566 : DO kcol = krow + 1, n
1495 6690 : kpermutation = kpermutation + 1
1496 7566 : IF (kpermutation == ipermutation) THEN
1497 1248 : i = krow
1498 1248 : j = kcol
1499 1248 : RETURN
1500 : END IF
1501 : END DO
1502 : END DO
1503 :
1504 : END SUBROUTINE map_permutation_to_states
1505 :
1506 : ! **************************************************************************************************
1507 : !> \brief Determine confinement bounds along confinement dir (hardcoded to be z)
1508 : !> and determine the number of nonzero entries
1509 : !> Optionally zero entries below a given threshold
1510 : !> \param fun input 3D potential (real space)
1511 : !> \param th threshold for screening values
1512 : !> \param just_zero determines if fun should only be zeroed without returning bounds/work
1513 : !> \param bounds the confinement bounds: fun is nonzero only between these values along 3rd dimension
1514 : !> \param work an estimate of the total number of grid points where fun is nonzero
1515 : ! **************************************************************************************************
1516 34 : SUBROUTINE hfun_zero(fun, th, just_zero, bounds, work)
1517 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: fun
1518 : REAL(KIND=dp), INTENT(IN) :: th
1519 : LOGICAL :: just_zero
1520 : INTEGER, OPTIONAL :: bounds(2), work
1521 :
1522 : INTEGER :: i1, i2, i3, lb, n1, n2, n3, nzeroed, &
1523 : nzeroed_total, ub
1524 : LOGICAL :: lb_final, ub_final
1525 :
1526 34 : n1 = SIZE(fun, 1)
1527 34 : n2 = SIZE(fun, 2)
1528 34 : n3 = SIZE(fun, 3)
1529 34 : nzeroed_total = 0
1530 34 : IF (.NOT. just_zero) THEN
1531 34 : CPASSERT(PRESENT(bounds))
1532 34 : CPASSERT(PRESENT(work))
1533 : lb = 1
1534 : lb_final = .FALSE.
1535 : ub_final = .FALSE.
1536 : END IF
1537 1586 : DO i3 = 1, n3
1538 1552 : IF (.NOT. just_zero) nzeroed = 0
1539 75920 : DO i2 = 1, n2
1540 1956496 : DO i1 = 1, n1
1541 1954944 : IF (fun(i1, i2, i3) < th) THEN
1542 983300 : IF (.NOT. just_zero) THEN
1543 983300 : nzeroed = nzeroed + 1
1544 983300 : nzeroed_total = nzeroed_total + 1
1545 : ELSE
1546 0 : fun(i1, i2, i3) = 0.0_dp
1547 : END IF
1548 : END IF
1549 : END DO
1550 : END DO
1551 1586 : IF (.NOT. just_zero) THEN
1552 1552 : IF (nzeroed == (n2*n1)) THEN
1553 80 : IF (.NOT. lb_final) THEN
1554 : lb = i3
1555 56 : ELSE IF (.NOT. ub_final) THEN
1556 8 : ub = i3
1557 8 : ub_final = .TRUE.
1558 : END IF
1559 : ELSE
1560 : IF (.NOT. lb_final) lb_final = .TRUE.
1561 : IF (ub_final) ub_final = .FALSE. ! Safeguard against "holes"
1562 : END IF
1563 : END IF
1564 : END DO
1565 34 : IF (.NOT. just_zero) THEN
1566 34 : IF (.NOT. ub_final) ub = n3
1567 34 : bounds(1) = lb
1568 34 : bounds(2) = ub
1569 102 : bounds = bounds - (n3/2) - 1
1570 34 : work = n3*n2*n1 - nzeroed_total
1571 : END IF
1572 :
1573 34 : END SUBROUTINE hfun_zero
1574 :
1575 : ! **************************************************************************************************
1576 : !> \brief Read input section related to block diagonalization of the mixed CDFT Hamiltonian matrix.
1577 : !> \param force_env the force_env that holds the CDFT states
1578 : !> \param blocks list of CDFT states defining the matrix blocks
1579 : !> \param ignore_excited flag that determines if excited states resulting from the block
1580 : !> diagonalization process should be ignored
1581 : !> \param nrecursion integer that determines how many steps of recursive block diagonalization
1582 : !> is performed (1 if disabled)
1583 : !> \par History
1584 : !> 01.18 created [Nico Holmberg]
1585 : ! **************************************************************************************************
1586 8 : SUBROUTINE mixed_cdft_read_block_diag(force_env, blocks, ignore_excited, nrecursion)
1587 : TYPE(force_env_type), POINTER :: force_env
1588 : TYPE(cp_1d_i_p_type), ALLOCATABLE, DIMENSION(:), &
1589 : INTENT(OUT) :: blocks
1590 : LOGICAL, INTENT(OUT) :: ignore_excited
1591 : INTEGER, INTENT(OUT) :: nrecursion
1592 :
1593 : INTEGER :: i, j, k, l, nblk, nforce_eval
1594 8 : INTEGER, DIMENSION(:), POINTER :: tmplist
1595 : LOGICAL :: do_recursive, explicit, has_duplicates
1596 : TYPE(section_vals_type), POINTER :: block_section, force_env_section
1597 :
1598 : EXTERNAL :: dsygv
1599 :
1600 8 : NULLIFY (force_env_section, block_section)
1601 0 : CPASSERT(ASSOCIATED(force_env))
1602 8 : nforce_eval = SIZE(force_env%sub_force_env)
1603 :
1604 : CALL force_env_get(force_env=force_env, &
1605 8 : force_env_section=force_env_section)
1606 8 : block_section => section_vals_get_subs_vals(force_env_section, "MIXED%MIXED_CDFT%BLOCK_DIAGONALIZE")
1607 :
1608 8 : CALL section_vals_get(block_section, explicit=explicit)
1609 8 : IF (.NOT. explicit) &
1610 : CALL cp_abort(__LOCATION__, &
1611 : "Block diagonalization of CDFT Hamiltonian was requested, but the "// &
1612 0 : "corresponding input section is missing!")
1613 :
1614 8 : CALL section_vals_val_get(block_section, "BLOCK", n_rep_val=nblk)
1615 44 : ALLOCATE (blocks(nblk))
1616 28 : DO i = 1, nblk
1617 20 : NULLIFY (blocks(i)%array)
1618 20 : CALL section_vals_val_get(block_section, "BLOCK", i_rep_val=i, i_vals=tmplist)
1619 20 : IF (SIZE(tmplist) < 1) &
1620 0 : CPABORT("Each BLOCK must contain at least 1 state.")
1621 60 : ALLOCATE (blocks(i)%array(SIZE(tmplist)))
1622 66 : blocks(i)%array(:) = tmplist(:)
1623 : END DO
1624 8 : CALL section_vals_val_get(block_section, "IGNORE_EXCITED", l_val=ignore_excited)
1625 8 : CALL section_vals_val_get(block_section, "RECURSIVE_DIAGONALIZATION", l_val=do_recursive)
1626 : ! Check that the requested states exist
1627 28 : DO i = 1, nblk
1628 66 : DO j = 1, SIZE(blocks(i)%array)
1629 38 : IF (blocks(i)%array(j) < 1 .OR. blocks(i)%array(j) > nforce_eval) &
1630 20 : CPABORT("Requested state does not exist.")
1631 : END DO
1632 : END DO
1633 : ! Check for duplicates
1634 8 : has_duplicates = .FALSE.
1635 28 : DO i = 1, nblk
1636 : ! Within same block
1637 58 : DO j = 1, SIZE(blocks(i)%array)
1638 76 : DO k = j + 1, SIZE(blocks(i)%array)
1639 56 : IF (blocks(i)%array(j) == blocks(i)%array(k)) has_duplicates = .TRUE.
1640 : END DO
1641 : END DO
1642 : ! Within different blocks
1643 46 : DO j = i + 1, nblk
1644 74 : DO k = 1, SIZE(blocks(i)%array)
1645 122 : DO l = 1, SIZE(blocks(j)%array)
1646 104 : IF (blocks(i)%array(k) == blocks(j)%array(l)) has_duplicates = .TRUE.
1647 : END DO
1648 : END DO
1649 : END DO
1650 : END DO
1651 8 : IF (has_duplicates) CPABORT("Duplicate states are not allowed.")
1652 8 : nrecursion = 1
1653 8 : IF (do_recursive) THEN
1654 2 : IF (MODULO(nblk, 2) /= 0) THEN
1655 : CALL cp_warn(__LOCATION__, &
1656 : "Number of blocks not divisible with 2. Recursive diagonalization not possible. "// &
1657 0 : "Calculation proceeds without.")
1658 0 : nrecursion = 1
1659 : ELSE
1660 2 : nrecursion = nblk/2
1661 : END IF
1662 2 : IF (nrecursion /= 1 .AND. .NOT. ignore_excited) &
1663 : CALL cp_abort(__LOCATION__, &
1664 0 : "Keyword IGNORE_EXCITED must be active for recursive diagonalization.")
1665 : END IF
1666 :
1667 32 : END SUBROUTINE mixed_cdft_read_block_diag
1668 :
1669 : ! **************************************************************************************************
1670 : !> \brief Assembles the matrix blocks from the mixed CDFT Hamiltonian.
1671 : !> \param mixed_cdft the env that holds the CDFT states
1672 : !> \param blocks list of CDFT states defining the matrix blocks
1673 : !> \param H_block list of Hamiltonian matrix blocks
1674 : !> \param S_block list of overlap matrix blocks
1675 : !> \par History
1676 : !> 01.18 created [Nico Holmberg]
1677 : ! **************************************************************************************************
1678 10 : SUBROUTINE mixed_cdft_get_blocks(mixed_cdft, blocks, H_block, S_block)
1679 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
1680 : TYPE(cp_1d_i_p_type), ALLOCATABLE, DIMENSION(:) :: blocks
1681 : TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:), &
1682 : INTENT(OUT) :: H_block, S_block
1683 :
1684 : INTEGER :: i, icol, irow, j, k, nblk
1685 :
1686 : EXTERNAL :: dsygv
1687 :
1688 10 : CPASSERT(ASSOCIATED(mixed_cdft))
1689 :
1690 10 : nblk = SIZE(blocks)
1691 98 : ALLOCATE (H_block(nblk), S_block(nblk))
1692 34 : DO i = 1, nblk
1693 24 : NULLIFY (H_block(i)%array)
1694 24 : NULLIFY (S_block(i)%array)
1695 96 : ALLOCATE (H_block(i)%array(SIZE(blocks(i)%array), SIZE(blocks(i)%array)))
1696 96 : ALLOCATE (S_block(i)%array(SIZE(blocks(i)%array), SIZE(blocks(i)%array)))
1697 24 : icol = 0
1698 70 : DO j = 1, SIZE(blocks(i)%array)
1699 46 : irow = 0
1700 46 : icol = icol + 1
1701 160 : DO k = 1, SIZE(blocks(i)%array)
1702 90 : irow = irow + 1
1703 90 : H_block(i)%array(irow, icol) = mixed_cdft%results%H(blocks(i)%array(k), blocks(i)%array(j))
1704 136 : S_block(i)%array(irow, icol) = mixed_cdft%results%S(blocks(i)%array(k), blocks(i)%array(j))
1705 : END DO
1706 : END DO
1707 : ! Check that none of the interaction energies is repulsive
1708 160 : IF (ANY(H_block(i)%array .GE. 0.0_dp)) &
1709 : CALL cp_abort(__LOCATION__, &
1710 : "At least one of the interaction energies within block "//TRIM(ADJUSTL(cp_to_string(i)))// &
1711 10 : " is repulsive.")
1712 : END DO
1713 :
1714 10 : END SUBROUTINE mixed_cdft_get_blocks
1715 :
1716 : ! **************************************************************************************************
1717 : !> \brief Diagonalizes each of the matrix blocks.
1718 : !> \param blocks list of CDFT states defining the matrix blocks
1719 : !> \param H_block list of Hamiltonian matrix blocks
1720 : !> \param S_block list of overlap matrix blocks
1721 : !> \param eigenvalues list of eigenvalues for each block
1722 : !> \par History
1723 : !> 01.18 created [Nico Holmberg]
1724 : ! **************************************************************************************************
1725 10 : SUBROUTINE mixed_cdft_diagonalize_blocks(blocks, H_block, S_block, eigenvalues)
1726 : TYPE(cp_1d_i_p_type), ALLOCATABLE, DIMENSION(:) :: blocks
1727 : TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:) :: H_block, S_block
1728 : TYPE(cp_1d_r_p_type), ALLOCATABLE, DIMENSION(:), &
1729 : INTENT(OUT) :: eigenvalues
1730 :
1731 : INTEGER :: i, info, nblk, work_array_size
1732 10 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: work
1733 10 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: H_mat_copy, S_mat_copy
1734 :
1735 : EXTERNAL :: dsygv
1736 :
1737 10 : nblk = SIZE(blocks)
1738 54 : ALLOCATE (eigenvalues(nblk))
1739 34 : DO i = 1, nblk
1740 24 : NULLIFY (eigenvalues(i)%array)
1741 72 : ALLOCATE (eigenvalues(i)%array(SIZE(blocks(i)%array)))
1742 70 : eigenvalues(i)%array = 0.0_dp
1743 : ! Workspace query
1744 24 : ALLOCATE (work(1))
1745 24 : info = 0
1746 96 : ALLOCATE (H_mat_copy(SIZE(blocks(i)%array), SIZE(blocks(i)%array)))
1747 72 : ALLOCATE (S_mat_copy(SIZE(blocks(i)%array), SIZE(blocks(i)%array)))
1748 160 : H_mat_copy(:, :) = H_block(i)%array(:, :) ! Need explicit copies because dsygv destroys original values
1749 160 : S_mat_copy(:, :) = S_block(i)%array(:, :)
1750 : CALL dsygv(1, 'V', 'U', SIZE(blocks(i)%array), H_mat_copy, SIZE(blocks(i)%array), &
1751 24 : S_mat_copy, SIZE(blocks(i)%array), eigenvalues(i)%array, work, -1, info)
1752 24 : work_array_size = NINT(work(1))
1753 24 : DEALLOCATE (H_mat_copy, S_mat_copy)
1754 : ! Allocate work array
1755 24 : DEALLOCATE (work)
1756 72 : ALLOCATE (work(work_array_size))
1757 1588 : work = 0.0_dp
1758 : ! Solve Hc = eSc
1759 24 : info = 0
1760 : CALL dsygv(1, 'V', 'U', SIZE(blocks(i)%array), H_block(i)%array, SIZE(blocks(i)%array), &
1761 24 : S_block(i)%array, SIZE(blocks(i)%array), eigenvalues(i)%array, work, work_array_size, info)
1762 24 : IF (info /= 0) THEN
1763 0 : IF (info > SIZE(blocks(i)%array)) THEN
1764 0 : CPABORT("Matrix S is not positive definite")
1765 : ELSE
1766 0 : CPABORT("Diagonalization of H matrix failed.")
1767 : END IF
1768 : END IF
1769 34 : DEALLOCATE (work)
1770 : END DO
1771 :
1772 10 : END SUBROUTINE mixed_cdft_diagonalize_blocks
1773 :
1774 : ! **************************************************************************************************
1775 : !> \brief Assembles the new block diagonalized mixed CDFT Hamiltonian and overlap matrices.
1776 : !> \param mixed_cdft the env that holds the CDFT states
1777 : !> \param blocks list of CDFT states defining the matrix blocks
1778 : !> \param H_block list of Hamiltonian matrix blocks
1779 : !> \param eigenvalues list of eigenvalues for each block
1780 : !> \param n size of the new Hamiltonian and overlap matrices
1781 : !> \param iounit the output unit
1782 : !> \par History
1783 : !> 01.18 created [Nico Holmberg]
1784 : ! **************************************************************************************************
1785 10 : SUBROUTINE mixed_cdft_assemble_block_diag(mixed_cdft, blocks, H_block, eigenvalues, &
1786 : n, iounit)
1787 : TYPE(mixed_cdft_type), POINTER :: mixed_cdft
1788 : TYPE(cp_1d_i_p_type), ALLOCATABLE, DIMENSION(:) :: blocks
1789 : TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:) :: H_block
1790 : TYPE(cp_1d_r_p_type), ALLOCATABLE, DIMENSION(:) :: eigenvalues
1791 : INTEGER :: n, iounit
1792 :
1793 : CHARACTER(LEN=20) :: ilabel, jlabel
1794 : CHARACTER(LEN=3) :: tmp
1795 : INTEGER :: i, icol, ipermutation, irow, j, k, l, &
1796 : nblk, npermutations
1797 : LOGICAL :: ignore_excited
1798 10 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: H_mat, H_offdiag, S_mat, S_offdiag
1799 :
1800 : EXTERNAL :: dsygv
1801 :
1802 60 : ALLOCATE (H_mat(n, n), S_mat(n, n))
1803 10 : nblk = SIZE(blocks)
1804 10 : ignore_excited = (nblk == n)
1805 : ! The diagonal contains the eigenvalues of each block
1806 10 : IF (iounit > 0) WRITE (iounit, '(/,T3,A)') "Eigenvalues of the block diagonalized states"
1807 126 : H_mat(:, :) = 0.0_dp
1808 126 : S_mat(:, :) = 0.0_dp
1809 10 : k = 1
1810 34 : DO i = 1, nblk
1811 24 : IF (iounit > 0) WRITE (iounit, '(T6,A,I3)') "Block", i
1812 42 : DO j = 1, SIZE(eigenvalues(i)%array)
1813 28 : H_mat(k, k) = eigenvalues(i)%array(j)
1814 28 : S_mat(k, k) = 1.0_dp
1815 28 : k = k + 1
1816 28 : IF (iounit > 0) THEN
1817 14 : IF (j == 1) THEN
1818 12 : WRITE (iounit, '(T9,A,T58,(3X,F20.14))') 'Ground state energy:', eigenvalues(i)%array(j)
1819 : ELSE
1820 : WRITE (iounit, '(T9,A,I2,A,T58,(3X,F20.14))') &
1821 2 : 'Excited state (', j - 1, ' ) energy:', eigenvalues(i)%array(j)
1822 : END IF
1823 : END IF
1824 32 : IF (ignore_excited .AND. j == 1) EXIT
1825 : END DO
1826 : END DO
1827 : ! Transform the off-diagonal blocks using the eigenvectors of each block
1828 10 : npermutations = nblk*(nblk - 1)/2
1829 10 : IF (iounit > 0) WRITE (iounit, '(/,T3,A)') "Interactions between block diagonalized states"
1830 30 : DO ipermutation = 1, npermutations
1831 20 : CALL map_permutation_to_states(nblk, ipermutation, i, j)
1832 : ! Get the untransformed off-diagonal block
1833 80 : ALLOCATE (H_offdiag(SIZE(blocks(i)%array), SIZE(blocks(j)%array)))
1834 60 : ALLOCATE (S_offdiag(SIZE(blocks(i)%array), SIZE(blocks(j)%array)))
1835 58 : icol = 0
1836 58 : DO k = 1, SIZE(blocks(j)%array)
1837 38 : irow = 0
1838 38 : icol = icol + 1
1839 134 : DO l = 1, SIZE(blocks(i)%array)
1840 76 : irow = irow + 1
1841 76 : H_offdiag(irow, icol) = mixed_cdft%results%H(blocks(i)%array(l), blocks(j)%array(k))
1842 114 : S_offdiag(irow, icol) = mixed_cdft%results%S(blocks(i)%array(l), blocks(j)%array(k))
1843 : END DO
1844 : END DO
1845 : ! Check that none of the interaction energies is repulsive
1846 134 : IF (ANY(H_offdiag .GE. 0.0_dp)) &
1847 : CALL cp_abort(__LOCATION__, &
1848 : "At least one of the interaction energies between blocks "//TRIM(ADJUSTL(cp_to_string(i)))// &
1849 0 : " and "//TRIM(ADJUSTL(cp_to_string(j)))//" is repulsive.")
1850 : ! Now transform: C_i^T * H * C_j
1851 952 : H_offdiag(:, :) = MATMUL(H_offdiag, H_block(j)%array)
1852 972 : H_offdiag(:, :) = MATMUL(TRANSPOSE(H_block(i)%array), H_offdiag)
1853 952 : S_offdiag(:, :) = MATMUL(S_offdiag, H_block(j)%array)
1854 972 : S_offdiag(:, :) = MATMUL(TRANSPOSE(H_block(i)%array), S_offdiag)
1855 : ! Make sure the transformation preserves the sign of elements in the S and H matrices
1856 : ! The S/H matrices contain only positive/negative values so that any sign flipping occurs in the
1857 : ! same elements in both matrices
1858 : ! Check for sign flipping using the S matrix
1859 30 : IF (ANY(S_offdiag .LT. 0.0_dp)) THEN
1860 58 : DO l = 1, SIZE(S_offdiag, 2)
1861 134 : DO k = 1, SIZE(S_offdiag, 1)
1862 114 : IF (S_offdiag(k, l) .LT. 0.0_dp) THEN
1863 36 : S_offdiag(k, l) = -1.0_dp*S_offdiag(k, l)
1864 36 : H_offdiag(k, l) = -1.0_dp*H_offdiag(k, l)
1865 : END IF
1866 : END DO
1867 : END DO
1868 : END IF
1869 20 : IF (ignore_excited) THEN
1870 18 : H_mat(i, j) = H_offdiag(1, 1)
1871 18 : H_mat(j, i) = H_mat(i, j)
1872 18 : S_mat(i, j) = S_offdiag(1, 1)
1873 18 : S_mat(j, i) = S_mat(i, j)
1874 : ELSE
1875 2 : irow = 1
1876 2 : icol = 1
1877 2 : DO k = 1, i - 1
1878 2 : irow = irow + SIZE(blocks(k)%array)
1879 : END DO
1880 4 : DO k = 1, j - 1
1881 4 : icol = icol + SIZE(blocks(k)%array)
1882 : END DO
1883 14 : H_mat(irow:irow + SIZE(H_offdiag, 1) - 1, icol:icol + SIZE(H_offdiag, 2) - 1) = H_offdiag(:, :)
1884 14 : H_mat(icol:icol + SIZE(H_offdiag, 2) - 1, irow:irow + SIZE(H_offdiag, 1) - 1) = TRANSPOSE(H_offdiag)
1885 14 : S_mat(irow:irow + SIZE(H_offdiag, 1) - 1, icol:icol + SIZE(H_offdiag, 2) - 1) = S_offdiag(:, :)
1886 14 : S_mat(icol:icol + SIZE(H_offdiag, 2) - 1, irow:irow + SIZE(H_offdiag, 1) - 1) = TRANSPOSE(S_offdiag)
1887 : END IF
1888 20 : IF (iounit > 0) THEN
1889 10 : WRITE (iounit, '(/,T3,A)') REPEAT('#', 39)
1890 10 : WRITE (iounit, '(T3,A,I3,A,I3,A)') '###### Blocks I =', i, ' and J = ', j, ' ######'
1891 10 : WRITE (iounit, '(T3,A)') REPEAT('#', 39)
1892 10 : WRITE (iounit, '(T3,A)') 'Interaction energies'
1893 21 : DO irow = 1, SIZE(H_offdiag, 1)
1894 20 : ilabel = "(ground state)"
1895 20 : IF (irow > 1) THEN
1896 10 : IF (ignore_excited) EXIT
1897 1 : WRITE (tmp, '(I3)') irow - 1
1898 1 : ilabel = "(excited state "//TRIM(ADJUSTL(tmp))//")"
1899 : END IF
1900 34 : DO icol = 1, SIZE(H_offdiag, 2)
1901 21 : jlabel = "(ground state)"
1902 21 : IF (icol > 1) THEN
1903 10 : IF (ignore_excited) EXIT
1904 2 : WRITE (tmp, '(I3)') icol - 1
1905 2 : jlabel = "(excited state "//TRIM(ADJUSTL(tmp))//")"
1906 : END IF
1907 24 : WRITE (iounit, '(T6,A,T58,(3X,F20.14))') TRIM(ilabel)//'-'//TRIM(jlabel)//':', H_offdiag(irow, icol)
1908 : END DO
1909 : END DO
1910 10 : WRITE (iounit, '(T3,A)') 'Overlaps'
1911 21 : DO irow = 1, SIZE(H_offdiag, 1)
1912 20 : ilabel = "(ground state)"
1913 20 : IF (irow > 1) THEN
1914 10 : IF (ignore_excited) EXIT
1915 1 : ilabel = "(excited state)"
1916 1 : WRITE (tmp, '(I3)') irow - 1
1917 1 : ilabel = "(excited state "//TRIM(ADJUSTL(tmp))//")"
1918 : END IF
1919 34 : DO icol = 1, SIZE(H_offdiag, 2)
1920 21 : jlabel = "(ground state)"
1921 21 : IF (icol > 1) THEN
1922 10 : IF (ignore_excited) EXIT
1923 2 : WRITE (tmp, '(I3)') icol - 1
1924 2 : jlabel = "(excited state "//TRIM(ADJUSTL(tmp))//")"
1925 : END IF
1926 24 : WRITE (iounit, '(T6,A,T58,(3X,F20.14))') TRIM(ilabel)//'-'//TRIM(jlabel)//':', S_offdiag(irow, icol)
1927 : END DO
1928 : END DO
1929 : END IF
1930 50 : DEALLOCATE (H_offdiag, S_offdiag)
1931 : END DO
1932 10 : CALL mixed_cdft_result_type_set(mixed_cdft%results, H=H_mat, S=S_mat)
1933 : ! Deallocate work
1934 10 : DEALLOCATE (H_mat, S_mat)
1935 :
1936 10 : END SUBROUTINE mixed_cdft_assemble_block_diag
1937 :
1938 : END MODULE mixed_cdft_utils
|
