Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Optimization routines for all ALMO-based SCF methods
10 : !> \par History
11 : !> 2011.05 created [Rustam Z Khaliullin]
12 : !> 2014.10 as a separate file [Rustam Z Khaliullin]
13 : !> \author Rustam Z Khaliullin
14 : ! **************************************************************************************************
15 : MODULE almo_scf_optimizer
16 : USE almo_scf_diis_types, ONLY: almo_scf_diis_extrapolate,&
17 : almo_scf_diis_init,&
18 : almo_scf_diis_push,&
19 : almo_scf_diis_release,&
20 : almo_scf_diis_type
21 : USE almo_scf_lbfgs_types, ONLY: lbfgs_create,&
22 : lbfgs_get_direction,&
23 : lbfgs_history_type,&
24 : lbfgs_release,&
25 : lbfgs_seed
26 : USE almo_scf_methods, ONLY: &
27 : almo_scf_ks_blk_to_tv_blk, almo_scf_ks_to_ks_blk, almo_scf_ks_to_ks_xx, &
28 : almo_scf_ks_xx_to_tv_xx, almo_scf_p_blk_to_t_blk, almo_scf_t_rescaling, &
29 : almo_scf_t_to_proj, apply_domain_operators, apply_projector, &
30 : construct_domain_preconditioner, construct_domain_r_down, construct_domain_s_inv, &
31 : construct_domain_s_sqrt, fill_matrix_with_ones, get_overlap, orthogonalize_mos, &
32 : pseudo_invert_diagonal_blk, xalmo_initial_guess
33 : USE almo_scf_qs, ONLY: almo_dm_to_almo_ks,&
34 : almo_dm_to_qs_env,&
35 : almo_scf_update_ks_energy,&
36 : matrix_qs_to_almo
37 : USE almo_scf_types, ONLY: almo_scf_env_type,&
38 : optimizer_options_type
39 : USE cell_types, ONLY: cell_type
40 : USE cp_blacs_env, ONLY: cp_blacs_env_type
41 : USE cp_dbcsr_api, ONLY: &
42 : dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_desymmetrize, dbcsr_distribution_get, &
43 : dbcsr_distribution_type, dbcsr_filter, dbcsr_finalize, dbcsr_get_block_p, dbcsr_get_info, &
44 : dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, dbcsr_iterator_readonly_start, &
45 : dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, &
46 : dbcsr_p_type, dbcsr_put_block, dbcsr_release, dbcsr_scale, dbcsr_set, dbcsr_type, &
47 : dbcsr_type_no_symmetry, dbcsr_work_create
48 : USE cp_dbcsr_cholesky, ONLY: cp_dbcsr_cholesky_decompose,&
49 : cp_dbcsr_cholesky_invert,&
50 : cp_dbcsr_cholesky_restore
51 : USE cp_dbcsr_contrib, ONLY: dbcsr_add_on_diag,&
52 : dbcsr_dot,&
53 : dbcsr_frobenius_norm,&
54 : dbcsr_get_diag,&
55 : dbcsr_hadamard_product,&
56 : dbcsr_maxabs,&
57 : dbcsr_set_diag
58 : USE cp_external_control, ONLY: external_control
59 : USE cp_files, ONLY: close_file,&
60 : open_file
61 : USE cp_log_handling, ONLY: cp_get_default_logger,&
62 : cp_logger_get_default_unit_nr,&
63 : cp_logger_type,&
64 : cp_to_string
65 : USE cp_output_handling, ONLY: cp_print_key_finished_output,&
66 : cp_print_key_unit_nr
67 : USE ct_methods, ONLY: analytic_line_search,&
68 : ct_step_execute,&
69 : diagonalize_diagonal_blocks
70 : USE ct_types, ONLY: ct_step_env_clean,&
71 : ct_step_env_get,&
72 : ct_step_env_init,&
73 : ct_step_env_set,&
74 : ct_step_env_type
75 : USE domain_submatrix_methods, ONLY: construct_submatrices,&
76 : copy_submatrices,&
77 : init_submatrices,&
78 : maxnorm_submatrices,&
79 : release_submatrices
80 : USE domain_submatrix_types, ONLY: domain_map_type,&
81 : domain_submatrix_type,&
82 : select_row
83 : USE input_constants, ONLY: &
84 : almo_scf_diag, almo_scf_dm_sign, cg_dai_yuan, cg_fletcher, cg_fletcher_reeves, &
85 : cg_hager_zhang, cg_hestenes_stiefel, cg_liu_storey, cg_polak_ribiere, cg_zero, &
86 : op_loc_berry, op_loc_pipek, trustr_cauchy, trustr_dogleg, virt_full, &
87 : xalmo_case_block_diag, xalmo_case_fully_deloc, xalmo_case_normal, xalmo_prec_domain, &
88 : xalmo_prec_full, xalmo_prec_zero
89 : USE input_section_types, ONLY: section_vals_get_subs_vals,&
90 : section_vals_type
91 : USE iterate_matrix, ONLY: determinant,&
92 : invert_Hotelling,&
93 : matrix_sqrt_Newton_Schulz
94 : USE kinds, ONLY: dp
95 : USE machine, ONLY: m_flush,&
96 : m_walltime
97 : USE message_passing, ONLY: mp_comm_type,&
98 : mp_para_env_type
99 : USE particle_methods, ONLY: get_particle_set
100 : USE particle_types, ONLY: particle_type
101 : USE qs_energy_types, ONLY: qs_energy_type
102 : USE qs_environment_types, ONLY: get_qs_env,&
103 : qs_environment_type
104 : USE qs_kind_types, ONLY: qs_kind_type
105 : USE qs_loc_utils, ONLY: compute_berry_operator
106 : USE qs_localization_methods, ONLY: initialize_weights
107 : #include "./base/base_uses.f90"
108 :
109 : IMPLICIT NONE
110 :
111 : PRIVATE
112 :
113 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'almo_scf_optimizer'
114 :
115 : PUBLIC :: almo_scf_block_diagonal, &
116 : almo_scf_xalmo_eigensolver, &
117 : almo_scf_xalmo_trustr, &
118 : almo_scf_xalmo_pcg, &
119 : almo_scf_construct_nlmos
120 :
121 : LOGICAL, PARAMETER :: debug_mode = .FALSE.
122 : LOGICAL, PARAMETER :: safe_mode = .FALSE.
123 : LOGICAL, PARAMETER :: almo_mathematica = .FALSE.
124 : INTEGER, PARAMETER :: hessian_path_reuse = 1, &
125 : hessian_path_assemble = 2
126 :
127 : CONTAINS
128 :
129 : ! **************************************************************************************************
130 : !> \brief An SCF procedure that optimizes block-diagonal ALMOs using DIIS
131 : !> \param qs_env ...
132 : !> \param almo_scf_env ...
133 : !> \param optimizer ...
134 : !> \par History
135 : !> 2011.06 created [Rustam Z Khaliullin]
136 : !> 2018.09 smearing support [Ruben Staub]
137 : !> \author Rustam Z Khaliullin
138 : ! **************************************************************************************************
139 76 : SUBROUTINE almo_scf_block_diagonal(qs_env, almo_scf_env, optimizer)
140 : TYPE(qs_environment_type), POINTER :: qs_env
141 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
142 : TYPE(optimizer_options_type), INTENT(IN) :: optimizer
143 :
144 : CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_block_diagonal'
145 :
146 : INTEGER :: handle, iscf, ispin, nspin, unit_nr
147 76 : INTEGER, ALLOCATABLE, DIMENSION(:) :: local_nocc_of_domain
148 : LOGICAL :: converged, prepare_to_exit, should_stop, &
149 : use_diis, use_prev_as_guess
150 : REAL(KIND=dp) :: density_rec, energy_diff, energy_new, energy_old, error_norm, &
151 : error_norm_ispin, kTS_sum, prev_error_norm, t1, t2, true_mixing_fraction
152 76 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: local_mu
153 : TYPE(almo_scf_diis_type), ALLOCATABLE, &
154 76 : DIMENSION(:) :: almo_diis
155 : TYPE(cp_logger_type), POINTER :: logger
156 76 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: matrix_mixing_old_blk
157 : TYPE(qs_energy_type), POINTER :: qs_energy
158 :
159 76 : CALL timeset(routineN, handle)
160 :
161 : ! get a useful output_unit
162 76 : logger => cp_get_default_logger()
163 76 : IF (logger%para_env%is_source()) THEN
164 38 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
165 : ELSE
166 : unit_nr = -1
167 : END IF
168 :
169 : ! use DIIS, it's superior to simple mixing
170 76 : use_diis = .TRUE.
171 : use_prev_as_guess = .FALSE.
172 :
173 76 : nspin = almo_scf_env%nspins
174 228 : ALLOCATE (local_mu(almo_scf_env%ndomains))
175 228 : ALLOCATE (local_nocc_of_domain(almo_scf_env%ndomains))
176 :
177 : ! init mixing matrices
178 304 : ALLOCATE (matrix_mixing_old_blk(nspin))
179 304 : ALLOCATE (almo_diis(nspin))
180 152 : DO ispin = 1, nspin
181 : CALL dbcsr_create(matrix_mixing_old_blk(ispin), &
182 76 : template=almo_scf_env%matrix_ks_blk(ispin))
183 : CALL almo_scf_diis_init(diis_env=almo_diis(ispin), &
184 : sample_err=almo_scf_env%matrix_ks_blk(ispin), &
185 : sample_var=almo_scf_env%matrix_s_blk(1), &
186 : error_type=1, &
187 152 : max_length=optimizer%ndiis)
188 : END DO
189 :
190 76 : CALL get_qs_env(qs_env, energy=qs_energy)
191 76 : energy_old = qs_energy%total
192 :
193 76 : iscf = 0
194 76 : prepare_to_exit = .FALSE.
195 76 : true_mixing_fraction = 0.0_dp
196 76 : error_norm = 1.0E+10_dp ! arbitrary big step
197 :
198 76 : IF (unit_nr > 0) THEN
199 38 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 20), &
200 76 : " Optimization of block-diagonal ALMOs ", REPEAT("-", 21)
201 38 : WRITE (unit_nr, *)
202 38 : WRITE (unit_nr, '(T2,A13,A6,A23,A14,A14,A9)') "Method", "Iter", &
203 76 : "Total Energy", "Change", "Convergence", "Time"
204 38 : WRITE (unit_nr, '(T2,A)') REPEAT("-", 79)
205 : END IF
206 :
207 : ! the real SCF loop
208 76 : t1 = m_walltime()
209 424 : DO
210 :
211 424 : iscf = iscf + 1
212 :
213 : ! obtain projected KS matrix and the DIIS-error vector
214 424 : CALL almo_scf_ks_to_ks_blk(almo_scf_env)
215 :
216 : ! inform the DIIS handler about the new KS matrix and its error vector
217 : IF (use_diis) THEN
218 848 : DO ispin = 1, nspin
219 : CALL almo_scf_diis_push(diis_env=almo_diis(ispin), &
220 : var=almo_scf_env%matrix_ks_blk(ispin), &
221 848 : err=almo_scf_env%matrix_err_blk(ispin))
222 : END DO
223 : END IF
224 :
225 : ! get error_norm: choose the largest of the two spins
226 : prev_error_norm = error_norm
227 848 : DO ispin = 1, nspin
228 424 : error_norm_ispin = dbcsr_maxabs(almo_scf_env%matrix_err_blk(ispin))
229 424 : IF (ispin == 1) error_norm = error_norm_ispin
230 424 : IF (ispin > 1 .AND. error_norm_ispin > error_norm) THEN
231 0 : error_norm = error_norm_ispin
232 : END IF
233 : END DO
234 :
235 424 : IF (error_norm < almo_scf_env%eps_prev_guess) THEN
236 0 : use_prev_as_guess = .TRUE.
237 : ELSE
238 424 : use_prev_as_guess = .FALSE.
239 : END IF
240 :
241 : ! check convergence
242 424 : converged = .TRUE.
243 424 : IF (error_norm > optimizer%eps_error) converged = .FALSE.
244 :
245 : ! check other exit criteria: max SCF steps and timing
246 : CALL external_control(should_stop, "SCF", &
247 : start_time=qs_env%start_time, &
248 424 : target_time=qs_env%target_time)
249 424 : IF (should_stop .OR. iscf >= optimizer%max_iter .OR. converged) THEN
250 76 : prepare_to_exit = .TRUE.
251 76 : IF (iscf == 1) energy_new = energy_old
252 : END IF
253 :
254 : ! if early stopping is on do at least one iteration
255 424 : IF (optimizer%early_stopping_on .AND. iscf == 1) THEN
256 : prepare_to_exit = .FALSE.
257 : END IF
258 :
259 424 : IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix
260 :
261 : ! perform mixing of KS matrices
262 348 : IF (iscf /= 1) THEN
263 : IF (use_diis) THEN ! use diis instead of mixing
264 544 : DO ispin = 1, nspin
265 : CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), &
266 544 : extr_var=almo_scf_env%matrix_ks_blk(ispin))
267 : END DO
268 : ELSE ! use mixing
269 : true_mixing_fraction = almo_scf_env%mixing_fraction
270 : DO ispin = 1, nspin
271 : CALL dbcsr_add(almo_scf_env%matrix_ks_blk(ispin), &
272 : matrix_mixing_old_blk(ispin), &
273 : true_mixing_fraction, &
274 : 1.0_dp - true_mixing_fraction)
275 : END DO
276 : END IF
277 : END IF
278 : ! save the new matrix for the future mixing
279 696 : DO ispin = 1, nspin
280 : CALL dbcsr_copy(matrix_mixing_old_blk(ispin), &
281 696 : almo_scf_env%matrix_ks_blk(ispin))
282 : END DO
283 :
284 : ! obtain ALMOs from the new KS matrix
285 696 : SELECT CASE (almo_scf_env%almo_update_algorithm)
286 : CASE (almo_scf_diag)
287 :
288 348 : CALL almo_scf_ks_blk_to_tv_blk(almo_scf_env)
289 :
290 : CASE (almo_scf_dm_sign)
291 :
292 : ! update the density matrix
293 0 : DO ispin = 1, nspin
294 :
295 0 : local_nocc_of_domain(:) = almo_scf_env%nocc_of_domain(:, ispin)
296 0 : local_mu(:) = almo_scf_env%mu_of_domain(:, ispin)
297 0 : CPABORT("Density_matrix_sign has not been tested yet")
298 0 : almo_scf_env%mu_of_domain(:, ispin) = local_mu(:)
299 :
300 : END DO
301 :
302 : ! obtain ALMOs from matrix_p_blk: T_new = P_blk S_blk T_old
303 0 : CALL almo_scf_p_blk_to_t_blk(almo_scf_env, ionic=.FALSE.)
304 :
305 348 : DO ispin = 1, almo_scf_env%nspins
306 :
307 : CALL orthogonalize_mos(ket=almo_scf_env%matrix_t_blk(ispin), &
308 : overlap=almo_scf_env%matrix_sigma_blk(ispin), &
309 : metric=almo_scf_env%matrix_s_blk(1), &
310 : retain_locality=.TRUE., &
311 : only_normalize=.FALSE., &
312 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
313 : eps_filter=almo_scf_env%eps_filter, &
314 : order_lanczos=almo_scf_env%order_lanczos, &
315 : eps_lanczos=almo_scf_env%eps_lanczos, &
316 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
317 :
318 : END DO
319 :
320 : END SELECT
321 :
322 : ! obtain density matrix from ALMOs
323 696 : DO ispin = 1, almo_scf_env%nspins
324 :
325 : !! Application of an occupation-rescaling trick for smearing, if requested
326 348 : IF (almo_scf_env%smear) THEN
327 : CALL almo_scf_t_rescaling(matrix_t=almo_scf_env%matrix_t_blk(ispin), &
328 : mo_energies=almo_scf_env%mo_energies(:, ispin), &
329 : mu_of_domain=almo_scf_env%mu_of_domain(:, ispin), &
330 : real_ne_of_domain=almo_scf_env%real_ne_of_domain(:, ispin), &
331 : spin_kTS=almo_scf_env%kTS(ispin), &
332 : smear_e_temp=almo_scf_env%smear_e_temp, &
333 : ndomains=almo_scf_env%ndomains, &
334 16 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin))
335 : END IF
336 :
337 : CALL almo_scf_t_to_proj(t=almo_scf_env%matrix_t_blk(ispin), &
338 : p=almo_scf_env%matrix_p(ispin), &
339 : eps_filter=almo_scf_env%eps_filter, &
340 : orthog_orbs=.FALSE., &
341 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
342 : s=almo_scf_env%matrix_s(1), &
343 : sigma=almo_scf_env%matrix_sigma(ispin), &
344 : sigma_inv=almo_scf_env%matrix_sigma_inv(ispin), &
345 : use_guess=use_prev_as_guess, &
346 : smear=almo_scf_env%smear, &
347 : algorithm=almo_scf_env%sigma_inv_algorithm, &
348 : inverse_accelerator=almo_scf_env%order_lanczos, &
349 : inv_eps_factor=almo_scf_env%matrix_iter_eps_error_factor, &
350 : eps_lanczos=almo_scf_env%eps_lanczos, &
351 : max_iter_lanczos=almo_scf_env%max_iter_lanczos, &
352 : para_env=almo_scf_env%para_env, &
353 696 : blacs_env=almo_scf_env%blacs_env)
354 :
355 : END DO
356 :
357 348 : IF (almo_scf_env%nspins == 1) THEN
358 348 : CALL dbcsr_scale(almo_scf_env%matrix_p(1), 2.0_dp)
359 : !! Rescaling electronic entropy contribution by spin_factor
360 348 : IF (almo_scf_env%smear) THEN
361 16 : almo_scf_env%kTS(1) = almo_scf_env%kTS(1)*2.0_dp
362 : END IF
363 : END IF
364 :
365 348 : IF (almo_scf_env%smear) THEN
366 32 : kTS_sum = SUM(almo_scf_env%kTS)
367 : ELSE
368 332 : kTS_sum = 0.0_dp
369 : END IF
370 :
371 : ! compute the new KS matrix and new energy
372 : CALL almo_dm_to_almo_ks(qs_env, &
373 : almo_scf_env%matrix_p, &
374 : almo_scf_env%matrix_ks, &
375 : energy_new, &
376 : almo_scf_env%eps_filter, &
377 : almo_scf_env%mat_distr_aos, &
378 : smear=almo_scf_env%smear, &
379 348 : kTS_sum=kTS_sum)
380 :
381 : END IF ! prepare_to_exit
382 :
383 424 : energy_diff = energy_new - energy_old
384 424 : energy_old = energy_new
385 424 : almo_scf_env%almo_scf_energy = energy_new
386 :
387 424 : t2 = m_walltime()
388 : ! brief report on the current SCF loop
389 424 : IF (unit_nr > 0) THEN
390 212 : WRITE (unit_nr, '(T2,A13,I6,F23.10,E14.5,F14.9,F9.2)') "ALMO SCF DIIS", &
391 212 : iscf, &
392 424 : energy_new, energy_diff, error_norm, t2 - t1
393 : END IF
394 424 : t1 = m_walltime()
395 :
396 424 : IF (prepare_to_exit) EXIT
397 :
398 : END DO ! end scf cycle
399 :
400 : !! Print number of electrons recovered if smearing was requested
401 76 : IF (almo_scf_env%smear) THEN
402 8 : DO ispin = 1, nspin
403 4 : CALL dbcsr_dot(almo_scf_env%matrix_p(ispin), almo_scf_env%matrix_s(1), density_rec)
404 8 : IF (unit_nr > 0) THEN
405 2 : WRITE (unit_nr, '(T2,A20,F23.10)') "Electrons recovered:", density_rec
406 : END IF
407 : END DO
408 : END IF
409 :
410 76 : IF (.NOT. converged .AND. (.NOT. optimizer%early_stopping_on)) THEN
411 0 : IF (unit_nr > 0) THEN
412 0 : CPABORT("SCF for block-diagonal ALMOs not converged!")
413 : END IF
414 : END IF
415 :
416 152 : DO ispin = 1, nspin
417 76 : CALL dbcsr_release(matrix_mixing_old_blk(ispin))
418 152 : CALL almo_scf_diis_release(diis_env=almo_diis(ispin))
419 : END DO
420 152 : DEALLOCATE (almo_diis)
421 76 : DEALLOCATE (matrix_mixing_old_blk)
422 76 : DEALLOCATE (local_mu)
423 76 : DEALLOCATE (local_nocc_of_domain)
424 :
425 76 : CALL timestop(handle)
426 :
427 76 : END SUBROUTINE almo_scf_block_diagonal
428 :
429 : ! **************************************************************************************************
430 : !> \brief An eigensolver-based SCF to optimize extended ALMOs (i.e. ALMOs on
431 : !> overlapping domains)
432 : !> \param qs_env ...
433 : !> \param almo_scf_env ...
434 : !> \param optimizer ...
435 : !> \par History
436 : !> 2013.03 created [Rustam Z Khaliullin]
437 : !> 2018.09 smearing support [Ruben Staub]
438 : !> \author Rustam Z Khaliullin
439 : ! **************************************************************************************************
440 2 : SUBROUTINE almo_scf_xalmo_eigensolver(qs_env, almo_scf_env, optimizer)
441 : TYPE(qs_environment_type), POINTER :: qs_env
442 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
443 : TYPE(optimizer_options_type), INTENT(IN) :: optimizer
444 :
445 : CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_xalmo_eigensolver'
446 :
447 : INTEGER :: handle, iscf, ispin, nspin, unit_nr
448 : LOGICAL :: converged, prepare_to_exit, should_stop
449 : REAL(KIND=dp) :: denergy_tot, density_rec, energy_diff, energy_new, energy_old, error_norm, &
450 : error_norm_0, kTS_sum, spin_factor, t1, t2
451 : REAL(KIND=dp), DIMENSION(2) :: denergy_spin
452 : TYPE(almo_scf_diis_type), ALLOCATABLE, &
453 2 : DIMENSION(:) :: almo_diis
454 : TYPE(cp_logger_type), POINTER :: logger
455 : TYPE(dbcsr_type) :: matrix_p_almo_scf_converged
456 : TYPE(domain_submatrix_type), ALLOCATABLE, &
457 : DIMENSION(:, :) :: submatrix_mixing_old_blk
458 :
459 2 : CALL timeset(routineN, handle)
460 :
461 : ! get a useful output_unit
462 2 : logger => cp_get_default_logger()
463 2 : IF (logger%para_env%is_source()) THEN
464 1 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
465 : ELSE
466 1 : unit_nr = -1
467 : END IF
468 :
469 2 : nspin = almo_scf_env%nspins
470 2 : IF (nspin == 1) THEN
471 2 : spin_factor = 2.0_dp
472 : ELSE
473 0 : spin_factor = 1.0_dp
474 : END IF
475 :
476 : ! RZK-warning domain_s_sqrt and domain_s_sqrt_inv do not have spin
477 : ! components yet (may be used later)
478 2 : ispin = 1
479 : CALL construct_domain_s_sqrt( &
480 : matrix_s=almo_scf_env%matrix_s(1), &
481 : subm_s_sqrt=almo_scf_env%domain_s_sqrt(:, ispin), &
482 : subm_s_sqrt_inv=almo_scf_env%domain_s_sqrt_inv(:, ispin), &
483 : dpattern=almo_scf_env%quench_t(ispin), &
484 : map=almo_scf_env%domain_map(ispin), &
485 2 : node_of_domain=almo_scf_env%cpu_of_domain)
486 :
487 : ! construct the domain template for the occupied orbitals
488 4 : DO ispin = 1, nspin
489 : ! RZK-warning we need only the matrix structure, not data
490 : ! replace construct_submatrices with lighter procedure with
491 : ! no heavy communications
492 : CALL construct_submatrices( &
493 : matrix=almo_scf_env%quench_t(ispin), &
494 : submatrix=almo_scf_env%domain_t(:, ispin), &
495 : distr_pattern=almo_scf_env%quench_t(ispin), &
496 : domain_map=almo_scf_env%domain_map(ispin), &
497 : node_of_domain=almo_scf_env%cpu_of_domain, &
498 4 : job_type=select_row)
499 : END DO
500 :
501 : ! init mixing matrices
502 20 : ALLOCATE (submatrix_mixing_old_blk(almo_scf_env%ndomains, nspin))
503 2 : CALL init_submatrices(submatrix_mixing_old_blk)
504 8 : ALLOCATE (almo_diis(nspin))
505 :
506 4 : DO ispin = 1, nspin
507 : ! use s_sqrt since they are already properly constructed
508 : ! and have the same distributions as domain_err and domain_ks_xx
509 : CALL almo_scf_diis_init(diis_env=almo_diis(ispin), &
510 : sample_err=almo_scf_env%domain_s_sqrt(:, ispin), &
511 : error_type=1, &
512 4 : max_length=optimizer%ndiis)
513 : END DO
514 :
515 2 : denergy_tot = 0.0_dp
516 2 : energy_old = 0.0_dp
517 2 : iscf = 0
518 2 : prepare_to_exit = .FALSE.
519 :
520 : ! the SCF loop
521 2 : t1 = m_walltime()
522 2 : DO
523 :
524 2 : iscf = iscf + 1
525 :
526 : ! obtain projected KS matrix and the DIIS-error vector
527 2 : CALL almo_scf_ks_to_ks_xx(almo_scf_env)
528 :
529 : ! inform the DIIS handler about the new KS matrix and its error vector
530 4 : DO ispin = 1, nspin
531 : CALL almo_scf_diis_push(diis_env=almo_diis(ispin), &
532 : d_var=almo_scf_env%domain_ks_xx(:, ispin), &
533 4 : d_err=almo_scf_env%domain_err(:, ispin))
534 : END DO
535 :
536 : ! check convergence
537 2 : converged = .TRUE.
538 2 : DO ispin = 1, nspin
539 2 : error_norm = dbcsr_maxabs(almo_scf_env%matrix_err_xx(ispin))
540 : CALL maxnorm_submatrices(almo_scf_env%domain_err(:, ispin), &
541 2 : norm=error_norm_0)
542 2 : IF (error_norm > optimizer%eps_error) THEN
543 : converged = .FALSE.
544 : EXIT ! no need to check the other spin
545 : END IF
546 : END DO
547 : ! check other exit criteria: max SCF steps and timing
548 : CALL external_control(should_stop, "SCF", &
549 : start_time=qs_env%start_time, &
550 2 : target_time=qs_env%target_time)
551 2 : IF (should_stop .OR. iscf >= optimizer%max_iter .OR. converged) THEN
552 0 : prepare_to_exit = .TRUE.
553 : END IF
554 :
555 : ! if early stopping is on do at least one iteration
556 2 : IF (optimizer%early_stopping_on .AND. iscf == 1) THEN
557 : prepare_to_exit = .FALSE.
558 : END IF
559 :
560 2 : IF (.NOT. prepare_to_exit) THEN ! update the ALMOs and density matrix
561 :
562 : ! perform mixing of KS matrices
563 2 : IF (iscf /= 1) THEN
564 0 : DO ispin = 1, nspin
565 : CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin), &
566 0 : d_extr_var=almo_scf_env%domain_ks_xx(:, ispin))
567 : END DO
568 : END IF
569 : ! save the new matrix for the future mixing
570 4 : DO ispin = 1, nspin
571 : CALL copy_submatrices( &
572 : almo_scf_env%domain_ks_xx(:, ispin), &
573 : submatrix_mixing_old_blk(:, ispin), &
574 4 : copy_data=.TRUE.)
575 : END DO
576 :
577 : ! obtain a new set of ALMOs from the updated KS matrix
578 2 : CALL almo_scf_ks_xx_to_tv_xx(almo_scf_env)
579 :
580 : ! update the density matrix
581 4 : DO ispin = 1, nspin
582 :
583 : ! save the initial density matrix (to get the perturbative energy lowering)
584 2 : IF (iscf == 1) THEN
585 : CALL dbcsr_create(matrix_p_almo_scf_converged, &
586 2 : template=almo_scf_env%matrix_p(ispin))
587 : CALL dbcsr_copy(matrix_p_almo_scf_converged, &
588 2 : almo_scf_env%matrix_p(ispin))
589 : END IF
590 :
591 : !! Application of an occupation-rescaling trick for smearing, if requested
592 2 : IF (almo_scf_env%smear) THEN
593 : CALL almo_scf_t_rescaling(matrix_t=almo_scf_env%matrix_t_blk(ispin), &
594 : mo_energies=almo_scf_env%mo_energies(:, ispin), &
595 : mu_of_domain=almo_scf_env%mu_of_domain(:, ispin), &
596 : real_ne_of_domain=almo_scf_env%real_ne_of_domain(:, ispin), &
597 : spin_kTS=almo_scf_env%kTS(ispin), &
598 : smear_e_temp=almo_scf_env%smear_e_temp, &
599 : ndomains=almo_scf_env%ndomains, &
600 0 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin))
601 : END IF
602 :
603 : ! update now
604 : CALL almo_scf_t_to_proj( &
605 : t=almo_scf_env%matrix_t(ispin), &
606 : p=almo_scf_env%matrix_p(ispin), &
607 : eps_filter=almo_scf_env%eps_filter, &
608 : orthog_orbs=.FALSE., &
609 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
610 : s=almo_scf_env%matrix_s(1), &
611 : sigma=almo_scf_env%matrix_sigma(ispin), &
612 : sigma_inv=almo_scf_env%matrix_sigma_inv(ispin), &
613 : use_guess=.TRUE., &
614 : smear=almo_scf_env%smear, &
615 : algorithm=almo_scf_env%sigma_inv_algorithm, &
616 : inverse_accelerator=almo_scf_env%order_lanczos, &
617 : inv_eps_factor=almo_scf_env%matrix_iter_eps_error_factor, &
618 : eps_lanczos=almo_scf_env%eps_lanczos, &
619 : max_iter_lanczos=almo_scf_env%max_iter_lanczos, &
620 : para_env=almo_scf_env%para_env, &
621 2 : blacs_env=almo_scf_env%blacs_env)
622 2 : CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), spin_factor)
623 : !! Rescaling electronic entropy contribution by spin_factor
624 2 : IF (almo_scf_env%smear) THEN
625 0 : almo_scf_env%kTS(ispin) = almo_scf_env%kTS(ispin)*spin_factor
626 : END IF
627 :
628 : ! obtain perturbative estimate (at no additional cost)
629 : ! of the energy lowering relative to the block-diagonal ALMOs
630 4 : IF (iscf == 1) THEN
631 :
632 : CALL dbcsr_add(matrix_p_almo_scf_converged, &
633 2 : almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp)
634 : CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin), &
635 : matrix_p_almo_scf_converged, &
636 2 : denergy_spin(ispin))
637 :
638 2 : CALL dbcsr_release(matrix_p_almo_scf_converged)
639 :
640 : !! RS-WARNING: If smearing ALMO is requested, electronic entropy contribution should probably be included here
641 :
642 2 : denergy_tot = denergy_tot + denergy_spin(ispin)
643 :
644 : END IF ! iscf.eq.1
645 :
646 : END DO
647 :
648 : ! print out the energy lowering
649 2 : IF (iscf == 1) THEN
650 : CALL energy_lowering_report( &
651 : unit_nr=unit_nr, &
652 : ref_energy=almo_scf_env%almo_scf_energy, &
653 2 : energy_lowering=denergy_tot)
654 : CALL almo_scf_update_ks_energy(qs_env, &
655 : energy=almo_scf_env%almo_scf_energy, &
656 2 : energy_singles_corr=denergy_tot)
657 : END IF
658 :
659 : ! compute the new KS matrix and new energy
660 2 : IF (.NOT. almo_scf_env%perturbative_delocalization) THEN
661 :
662 0 : IF (almo_scf_env%smear) THEN
663 0 : kTS_sum = SUM(almo_scf_env%kTS)
664 : ELSE
665 0 : kTS_sum = 0.0_dp
666 : END IF
667 :
668 : CALL almo_dm_to_almo_ks(qs_env, &
669 : almo_scf_env%matrix_p, &
670 : almo_scf_env%matrix_ks, &
671 : energy_new, &
672 : almo_scf_env%eps_filter, &
673 : almo_scf_env%mat_distr_aos, &
674 : smear=almo_scf_env%smear, &
675 0 : kTS_sum=kTS_sum)
676 : END IF
677 :
678 : END IF ! prepare_to_exit
679 :
680 2 : IF (almo_scf_env%perturbative_delocalization) THEN
681 :
682 : ! exit after the first step if we do not need the SCF procedure
683 2 : CALL almo_dm_to_qs_env(qs_env, almo_scf_env%matrix_p, almo_scf_env%mat_distr_aos)
684 2 : converged = .TRUE.
685 2 : prepare_to_exit = .TRUE.
686 :
687 : ELSE ! not a perturbative treatment
688 :
689 0 : energy_diff = energy_new - energy_old
690 0 : energy_old = energy_new
691 0 : almo_scf_env%almo_scf_energy = energy_new
692 :
693 0 : t2 = m_walltime()
694 : ! brief report on the current SCF loop
695 0 : IF (unit_nr > 0) THEN
696 0 : WRITE (unit_nr, '(T2,A,I6,F20.9,E11.3,E11.3,E11.3,F8.2)') "ALMO SCF", &
697 0 : iscf, &
698 0 : energy_new, energy_diff, error_norm, error_norm_0, t2 - t1
699 : END IF
700 0 : t1 = m_walltime()
701 :
702 : END IF
703 :
704 2 : IF (prepare_to_exit) EXIT
705 :
706 : END DO ! end scf cycle
707 :
708 : !! Print number of electrons recovered if smearing was requested
709 2 : IF (almo_scf_env%smear) THEN
710 0 : DO ispin = 1, nspin
711 0 : CALL dbcsr_dot(almo_scf_env%matrix_p(ispin), almo_scf_env%matrix_s(1), density_rec)
712 0 : IF (unit_nr > 0) THEN
713 0 : WRITE (unit_nr, '(T2,A20,F23.10)') "Electrons recovered:", density_rec
714 : END IF
715 : END DO
716 : END IF
717 :
718 2 : IF (.NOT. converged .AND. .NOT. optimizer%early_stopping_on) THEN
719 0 : CPABORT("SCF for ALMOs on overlapping domains not converged!")
720 : END IF
721 :
722 4 : DO ispin = 1, nspin
723 2 : CALL release_submatrices(submatrix_mixing_old_blk(:, ispin))
724 4 : CALL almo_scf_diis_release(diis_env=almo_diis(ispin))
725 : END DO
726 4 : DEALLOCATE (almo_diis)
727 12 : DEALLOCATE (submatrix_mixing_old_blk)
728 :
729 2 : CALL timestop(handle)
730 :
731 2 : END SUBROUTINE almo_scf_xalmo_eigensolver
732 :
733 : ! **************************************************************************************************
734 : !> \brief Optimization of ALMOs using PCG-like minimizers
735 : !> \param qs_env ...
736 : !> \param almo_scf_env ...
737 : !> \param optimizer controls the optimization algorithm
738 : !> \param quench_t ...
739 : !> \param matrix_t_in ...
740 : !> \param matrix_t_out ...
741 : !> \param assume_t0_q0x - since it is extremely difficult to converge the iterative
742 : !> procedure using T as an optimized variable, assume
743 : !> T = T_0 + (1-R_0)*X and optimize X
744 : !> T_0 is assumed to be the zero-delocalization reference
745 : !> \param perturbation_only - perturbative (do not update Hamiltonian)
746 : !> \param special_case to reduce the overhead special cases are implemented:
747 : !> xalmo_case_normal - no special case (i.e. xALMOs)
748 : !> xalmo_case_block_diag
749 : !> xalmo_case_fully_deloc
750 : !> \par History
751 : !> 2011.11 created [Rustam Z Khaliullin]
752 : !> \author Rustam Z Khaliullin
753 : ! **************************************************************************************************
754 92 : SUBROUTINE almo_scf_xalmo_pcg(qs_env, almo_scf_env, optimizer, quench_t, &
755 : matrix_t_in, matrix_t_out, assume_t0_q0x, perturbation_only, &
756 : special_case)
757 :
758 : TYPE(qs_environment_type), POINTER :: qs_env
759 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
760 : TYPE(optimizer_options_type), INTENT(IN) :: optimizer
761 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:), &
762 : INTENT(INOUT) :: quench_t, matrix_t_in, matrix_t_out
763 : LOGICAL, INTENT(IN) :: assume_t0_q0x, perturbation_only
764 : INTEGER, INTENT(IN), OPTIONAL :: special_case
765 :
766 : CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_xalmo_pcg'
767 :
768 : CHARACTER(LEN=20) :: iter_type
769 : INTEGER :: cg_iteration, dim_op, fixed_line_search_niter, handle, idim0, ielem, ispin, &
770 : iteration, line_search_iteration, max_iter, my_special_case, ndomains, nmo, nspins, &
771 : outer_iteration, outer_max_iter, prec_type, reim, unit_nr
772 92 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nocc
773 : LOGICAL :: blissful_neglect, converged, just_started, line_search, normalize_orbitals, &
774 : optimize_theta, outer_prepare_to_exit, penalty_occ_local, penalty_occ_vol, &
775 : prepare_to_exit, reset_conjugator, skip_grad, use_guess
776 92 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: reim_diag, weights, z2
777 : REAL(kind=dp) :: appr_sec_der, beta, denom, denom2, e0, e1, energy_coeff, energy_diff, &
778 : energy_new, energy_old, eps_skip_gradients, fval, g0, g1, grad_norm, grad_norm_frob, &
779 : line_search_error, localiz_coeff, localization_obj_function, next_step_size_guess, &
780 : penalty_amplitude, penalty_func_new, spin_factor, step_size, t1, t2, tempreal
781 92 : REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: grad_norm_spin, &
782 92 : penalty_occ_vol_g_prefactor, &
783 92 : penalty_occ_vol_h_prefactor
784 : TYPE(cell_type), POINTER :: cell
785 : TYPE(cp_logger_type), POINTER :: logger
786 92 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: qs_matrix_s
787 92 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: op_sm_set_almo, op_sm_set_qs
788 92 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: FTsiginv, grad, m_sig_sqrti_ii, m_t_in_local, &
789 92 : m_theta, prec_vv, prev_grad, prev_minus_prec_grad, prev_step, siginvTFTsiginv, ST, step, &
790 92 : STsiginv_0, tempNOcc, tempNOcc_1, tempOccOcc
791 : TYPE(domain_submatrix_type), ALLOCATABLE, &
792 92 : DIMENSION(:, :) :: bad_modes_projector_down, domain_r_down
793 : TYPE(mp_comm_type) :: group
794 :
795 92 : CALL timeset(routineN, handle)
796 :
797 92 : my_special_case = xalmo_case_normal
798 92 : IF (PRESENT(special_case)) my_special_case = special_case
799 :
800 : ! get a useful output_unit
801 92 : logger => cp_get_default_logger()
802 92 : IF (logger%para_env%is_source()) THEN
803 46 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
804 : ELSE
805 : unit_nr = -1
806 : END IF
807 :
808 92 : nspins = almo_scf_env%nspins
809 :
810 : ! if unprojected XALMOs are optimized
811 : ! then we must use the "blissful_neglect" procedure
812 92 : blissful_neglect = .FALSE.
813 92 : IF (my_special_case == xalmo_case_normal .AND. .NOT. assume_t0_q0x) THEN
814 14 : blissful_neglect = .TRUE.
815 : END IF
816 :
817 92 : IF (unit_nr > 0) THEN
818 46 : WRITE (unit_nr, *)
819 5 : SELECT CASE (my_special_case)
820 : CASE (xalmo_case_block_diag)
821 5 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 20), &
822 10 : " Optimization of block-diagonal ALMOs ", REPEAT("-", 21)
823 : CASE (xalmo_case_fully_deloc)
824 22 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 20), &
825 44 : " Optimization of fully delocalized MOs ", REPEAT("-", 20)
826 : CASE (xalmo_case_normal)
827 46 : IF (blissful_neglect) THEN
828 7 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 25), &
829 14 : " LCP optimization of XALMOs ", REPEAT("-", 26)
830 : ELSE
831 12 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 27), &
832 24 : " Optimization of XALMOs ", REPEAT("-", 28)
833 : END IF
834 : END SELECT
835 46 : WRITE (unit_nr, *)
836 46 : WRITE (unit_nr, '(T2,A13,A6,A23,A14,A14,A9)') "Method", "Iter", &
837 92 : "Objective Function", "Change", "Convergence", "Time"
838 46 : WRITE (unit_nr, '(T2,A)') REPEAT("-", 79)
839 : END IF
840 :
841 : ! set local parameters using developer's keywords
842 : ! RZK-warning: change to normal keywords later
843 92 : optimize_theta = almo_scf_env%logical05
844 92 : eps_skip_gradients = almo_scf_env%real01
845 :
846 : ! penalty amplitude adjusts the strength of volume conservation
847 92 : energy_coeff = 1.0_dp
848 92 : localiz_coeff = 0.0_dp
849 92 : penalty_amplitude = 0.0_dp
850 92 : penalty_occ_vol = .FALSE.
851 92 : penalty_occ_local = .FALSE.
852 92 : normalize_orbitals = penalty_occ_vol .OR. penalty_occ_local
853 276 : ALLOCATE (penalty_occ_vol_g_prefactor(nspins))
854 184 : ALLOCATE (penalty_occ_vol_h_prefactor(nspins))
855 92 : penalty_occ_vol_g_prefactor(:) = 0.0_dp
856 92 : penalty_occ_vol_h_prefactor(:) = 0.0_dp
857 92 : penalty_func_new = 0.0_dp
858 :
859 : ! preconditioner control
860 92 : prec_type = optimizer%preconditioner
861 :
862 : ! control of the line search
863 92 : fixed_line_search_niter = 0 ! init to zero, change when eps is small enough
864 :
865 92 : IF (nspins == 1) THEN
866 86 : spin_factor = 2.0_dp
867 : ELSE
868 6 : spin_factor = 1.0_dp
869 : END IF
870 :
871 184 : ALLOCATE (grad_norm_spin(nspins))
872 276 : ALLOCATE (nocc(nspins))
873 :
874 : ! create a local copy of matrix_t_in because
875 : ! matrix_t_in and matrix_t_out can be the same matrix
876 : ! we need to make sure data in matrix_t_in is intact
877 : ! after we start writing to matrix_t_out
878 374 : ALLOCATE (m_t_in_local(nspins))
879 190 : DO ispin = 1, nspins
880 : CALL dbcsr_create(m_t_in_local(ispin), &
881 : template=matrix_t_in(ispin), &
882 98 : matrix_type=dbcsr_type_no_symmetry)
883 190 : CALL dbcsr_copy(m_t_in_local(ispin), matrix_t_in(ispin))
884 : END DO
885 :
886 : ! m_theta contains a set of variational parameters
887 : ! that define one-electron orbitals (simple, projected, etc.)
888 282 : ALLOCATE (m_theta(nspins))
889 190 : DO ispin = 1, nspins
890 : CALL dbcsr_create(m_theta(ispin), &
891 : template=matrix_t_out(ispin), &
892 190 : matrix_type=dbcsr_type_no_symmetry)
893 : END DO
894 :
895 : ! Compute localization matrices
896 : IF (penalty_occ_local) THEN
897 :
898 : CALL get_qs_env(qs_env=qs_env, &
899 : matrix_s=qs_matrix_s, &
900 : cell=cell)
901 :
902 : IF (cell%orthorhombic) THEN
903 : dim_op = 3
904 : ELSE
905 : dim_op = 6
906 : END IF
907 : ALLOCATE (weights(6))
908 : weights = 0.0_dp
909 :
910 : CALL initialize_weights(cell, weights)
911 :
912 : ALLOCATE (op_sm_set_qs(2, dim_op))
913 : ALLOCATE (op_sm_set_almo(2, dim_op))
914 :
915 : DO idim0 = 1, dim_op
916 : DO reim = 1, SIZE(op_sm_set_qs, 1)
917 : NULLIFY (op_sm_set_qs(reim, idim0)%matrix)
918 : ALLOCATE (op_sm_set_qs(reim, idim0)%matrix)
919 : CALL dbcsr_copy(op_sm_set_qs(reim, idim0)%matrix, qs_matrix_s(1)%matrix, &
920 : name="almo_scf_env%op_sm_"//TRIM(ADJUSTL(cp_to_string(reim)))//"-"//TRIM(ADJUSTL(cp_to_string(idim0))))
921 : NULLIFY (op_sm_set_almo(reim, idim0)%matrix)
922 : ALLOCATE (op_sm_set_almo(reim, idim0)%matrix)
923 : CALL dbcsr_copy(op_sm_set_almo(reim, idim0)%matrix, almo_scf_env%matrix_s(1), &
924 : name="almo_scf_env%op_sm_"//TRIM(ADJUSTL(cp_to_string(reim)))//"-"//TRIM(ADJUSTL(cp_to_string(idim0))))
925 : CALL dbcsr_set(op_sm_set_almo(reim, idim0)%matrix, 0.0_dp)
926 : END DO
927 : END DO
928 :
929 : CALL compute_berry_operator(qs_env, cell, op_sm_set_qs, dim_op)
930 :
931 : !CALL matrix_qs_to_almo(op_sm_set_qs, op_sm_set_almo, almo_scf_env%mat_distr_aos)
932 :
933 : END IF
934 :
935 : ! create initial guess from the initial orbitals
936 : CALL xalmo_initial_guess(m_guess=m_theta, &
937 : m_t_in=m_t_in_local, &
938 : m_t0=almo_scf_env%matrix_t_blk, &
939 : m_quench_t=quench_t, &
940 : m_overlap=almo_scf_env%matrix_s(1), &
941 : m_sigma_tmpl=almo_scf_env%matrix_sigma_inv, &
942 : nspins=nspins, &
943 : xalmo_history=almo_scf_env%xalmo_history, &
944 : assume_t0_q0x=assume_t0_q0x, &
945 : optimize_theta=optimize_theta, &
946 : envelope_amplitude=almo_scf_env%envelope_amplitude, &
947 : eps_filter=almo_scf_env%eps_filter, &
948 : order_lanczos=almo_scf_env%order_lanczos, &
949 : eps_lanczos=almo_scf_env%eps_lanczos, &
950 : max_iter_lanczos=almo_scf_env%max_iter_lanczos, &
951 92 : nocc_of_domain=almo_scf_env%nocc_of_domain)
952 :
953 92 : ndomains = almo_scf_env%ndomains
954 1088 : ALLOCATE (domain_r_down(ndomains, nspins))
955 92 : CALL init_submatrices(domain_r_down)
956 996 : ALLOCATE (bad_modes_projector_down(ndomains, nspins))
957 92 : CALL init_submatrices(bad_modes_projector_down)
958 :
959 282 : ALLOCATE (prec_vv(nspins))
960 282 : ALLOCATE (siginvTFTsiginv(nspins))
961 282 : ALLOCATE (STsiginv_0(nspins))
962 282 : ALLOCATE (FTsiginv(nspins))
963 282 : ALLOCATE (ST(nspins))
964 282 : ALLOCATE (prev_grad(nspins))
965 374 : ALLOCATE (grad(nspins))
966 282 : ALLOCATE (prev_step(nspins))
967 282 : ALLOCATE (step(nspins))
968 282 : ALLOCATE (prev_minus_prec_grad(nspins))
969 282 : ALLOCATE (m_sig_sqrti_ii(nspins))
970 282 : ALLOCATE (tempNOcc(nspins))
971 282 : ALLOCATE (tempNOcc_1(nspins))
972 282 : ALLOCATE (tempOccOcc(nspins))
973 190 : DO ispin = 1, nspins
974 :
975 : ! init temporary storage
976 : CALL dbcsr_create(prec_vv(ispin), &
977 : template=almo_scf_env%matrix_ks(ispin), &
978 98 : matrix_type=dbcsr_type_no_symmetry)
979 : CALL dbcsr_create(siginvTFTsiginv(ispin), &
980 : template=almo_scf_env%matrix_sigma(ispin), &
981 98 : matrix_type=dbcsr_type_no_symmetry)
982 : CALL dbcsr_create(STsiginv_0(ispin), &
983 : template=matrix_t_out(ispin), &
984 98 : matrix_type=dbcsr_type_no_symmetry)
985 : CALL dbcsr_create(FTsiginv(ispin), &
986 : template=matrix_t_out(ispin), &
987 98 : matrix_type=dbcsr_type_no_symmetry)
988 : CALL dbcsr_create(ST(ispin), &
989 : template=matrix_t_out(ispin), &
990 98 : matrix_type=dbcsr_type_no_symmetry)
991 : CALL dbcsr_create(prev_grad(ispin), &
992 : template=matrix_t_out(ispin), &
993 98 : matrix_type=dbcsr_type_no_symmetry)
994 : CALL dbcsr_create(grad(ispin), &
995 : template=matrix_t_out(ispin), &
996 98 : matrix_type=dbcsr_type_no_symmetry)
997 : CALL dbcsr_create(prev_step(ispin), &
998 : template=matrix_t_out(ispin), &
999 98 : matrix_type=dbcsr_type_no_symmetry)
1000 : CALL dbcsr_create(step(ispin), &
1001 : template=matrix_t_out(ispin), &
1002 98 : matrix_type=dbcsr_type_no_symmetry)
1003 : CALL dbcsr_create(prev_minus_prec_grad(ispin), &
1004 : template=matrix_t_out(ispin), &
1005 98 : matrix_type=dbcsr_type_no_symmetry)
1006 : CALL dbcsr_create(m_sig_sqrti_ii(ispin), &
1007 : template=almo_scf_env%matrix_sigma_inv(ispin), &
1008 98 : matrix_type=dbcsr_type_no_symmetry)
1009 : CALL dbcsr_create(tempNOcc(ispin), &
1010 : template=matrix_t_out(ispin), &
1011 98 : matrix_type=dbcsr_type_no_symmetry)
1012 : CALL dbcsr_create(tempNOcc_1(ispin), &
1013 : template=matrix_t_out(ispin), &
1014 98 : matrix_type=dbcsr_type_no_symmetry)
1015 : CALL dbcsr_create(tempOccOcc(ispin), &
1016 : template=almo_scf_env%matrix_sigma_inv(ispin), &
1017 98 : matrix_type=dbcsr_type_no_symmetry)
1018 :
1019 98 : CALL dbcsr_set(step(ispin), 0.0_dp)
1020 98 : CALL dbcsr_set(prev_step(ispin), 0.0_dp)
1021 :
1022 : CALL dbcsr_get_info(almo_scf_env%matrix_sigma_inv(ispin), &
1023 98 : nfullrows_total=nocc(ispin))
1024 :
1025 : ! invert S domains if necessary
1026 : ! Note: domains for alpha and beta electrons might be different
1027 : ! that is why the inversion of the AO overlap is inside the spin loop
1028 98 : IF (my_special_case == xalmo_case_normal) THEN
1029 : CALL construct_domain_s_inv( &
1030 : matrix_s=almo_scf_env%matrix_s(1), &
1031 : subm_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
1032 : dpattern=quench_t(ispin), &
1033 : map=almo_scf_env%domain_map(ispin), &
1034 38 : node_of_domain=almo_scf_env%cpu_of_domain)
1035 :
1036 : CALL construct_domain_s_sqrt( &
1037 : matrix_s=almo_scf_env%matrix_s(1), &
1038 : subm_s_sqrt=almo_scf_env%domain_s_sqrt(:, ispin), &
1039 : subm_s_sqrt_inv=almo_scf_env%domain_s_sqrt_inv(:, ispin), &
1040 : dpattern=almo_scf_env%quench_t(ispin), &
1041 : map=almo_scf_env%domain_map(ispin), &
1042 38 : node_of_domain=almo_scf_env%cpu_of_domain)
1043 :
1044 : END IF
1045 :
1046 98 : IF (assume_t0_q0x) THEN
1047 :
1048 : ! save S.T_0.siginv_0
1049 42 : IF (my_special_case == xalmo_case_fully_deloc) THEN
1050 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1051 : almo_scf_env%matrix_s(1), &
1052 : almo_scf_env%matrix_t_blk(ispin), &
1053 : 0.0_dp, ST(ispin), &
1054 18 : filter_eps=almo_scf_env%eps_filter)
1055 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1056 : ST(ispin), &
1057 : almo_scf_env%matrix_sigma_inv_0deloc(ispin), &
1058 : 0.0_dp, STsiginv_0(ispin), &
1059 18 : filter_eps=almo_scf_env%eps_filter)
1060 : END IF
1061 :
1062 : ! construct domain-projector
1063 42 : IF (my_special_case == xalmo_case_normal) THEN
1064 : CALL construct_domain_r_down( &
1065 : matrix_t=almo_scf_env%matrix_t_blk(ispin), &
1066 : matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin), &
1067 : matrix_s=almo_scf_env%matrix_s(1), &
1068 : subm_r_down=domain_r_down(:, ispin), &
1069 : dpattern=quench_t(ispin), &
1070 : map=almo_scf_env%domain_map(ispin), &
1071 : node_of_domain=almo_scf_env%cpu_of_domain, &
1072 24 : filter_eps=almo_scf_env%eps_filter)
1073 : END IF
1074 :
1075 : END IF ! assume_t0_q0x
1076 :
1077 : ! localization functional
1078 190 : IF (penalty_occ_local) THEN
1079 :
1080 : ! compute S.R0.B.R0.S
1081 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1082 : almo_scf_env%matrix_s(1), &
1083 : matrix_t_in(ispin), &
1084 : 0.0_dp, tempNOcc(ispin), &
1085 0 : filter_eps=almo_scf_env%eps_filter)
1086 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1087 : tempNOcc(ispin), &
1088 : almo_scf_env%matrix_sigma_inv(ispin), &
1089 : 0.0_dp, tempNOCC_1(ispin), &
1090 0 : filter_eps=almo_scf_env%eps_filter)
1091 :
1092 0 : DO idim0 = 1, SIZE(op_sm_set_qs, 2) ! this loop is over miller ind
1093 0 : DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im
1094 :
1095 : CALL matrix_qs_to_almo(op_sm_set_qs(reim, idim0)%matrix, &
1096 0 : op_sm_set_almo(reim, idim0)%matrix, almo_scf_env%mat_distr_aos)
1097 :
1098 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1099 : op_sm_set_almo(reim, idim0)%matrix, &
1100 : matrix_t_in(ispin), &
1101 : 0.0_dp, tempNOcc(ispin), &
1102 0 : filter_eps=almo_scf_env%eps_filter)
1103 :
1104 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
1105 : matrix_t_in(ispin), &
1106 : tempNOcc(ispin), &
1107 : 0.0_dp, tempOccOcc(ispin), &
1108 0 : filter_eps=almo_scf_env%eps_filter)
1109 :
1110 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1111 : tempNOCC_1(ispin), &
1112 : tempOccOcc(ispin), &
1113 : 0.0_dp, tempNOcc(ispin), &
1114 0 : filter_eps=almo_scf_env%eps_filter)
1115 :
1116 : CALL dbcsr_multiply("N", "T", 1.0_dp, &
1117 : tempNOcc(ispin), &
1118 : tempNOcc_1(ispin), &
1119 : 0.0_dp, op_sm_set_almo(reim, idim0)%matrix, &
1120 0 : filter_eps=almo_scf_env%eps_filter)
1121 :
1122 : END DO
1123 : END DO ! end loop over idim0
1124 :
1125 : END IF !penalty_occ_local
1126 :
1127 : END DO ! ispin
1128 :
1129 : ! start the outer SCF loop
1130 92 : outer_max_iter = optimizer%max_iter_outer_loop
1131 92 : outer_prepare_to_exit = .FALSE.
1132 92 : outer_iteration = 0
1133 92 : grad_norm = 0.0_dp
1134 92 : grad_norm_frob = 0.0_dp
1135 92 : use_guess = .FALSE.
1136 :
1137 : DO
1138 :
1139 : ! start the inner SCF loop
1140 98 : max_iter = optimizer%max_iter
1141 98 : prepare_to_exit = .FALSE.
1142 98 : line_search = .FALSE.
1143 98 : converged = .FALSE.
1144 98 : iteration = 0
1145 98 : cg_iteration = 0
1146 98 : line_search_iteration = 0
1147 : energy_new = 0.0_dp
1148 98 : energy_old = 0.0_dp
1149 98 : energy_diff = 0.0_dp
1150 : localization_obj_function = 0.0_dp
1151 98 : line_search_error = 0.0_dp
1152 :
1153 98 : t1 = m_walltime()
1154 :
1155 1060 : DO
1156 :
1157 1060 : just_started = (iteration == 0) .AND. (outer_iteration == 0)
1158 :
1159 : CALL main_var_to_xalmos_and_loss_func( &
1160 : almo_scf_env=almo_scf_env, &
1161 : qs_env=qs_env, &
1162 : m_main_var_in=m_theta, &
1163 : m_t_out=matrix_t_out, &
1164 : m_sig_sqrti_ii_out=m_sig_sqrti_ii, &
1165 : energy_out=energy_new, &
1166 : penalty_out=penalty_func_new, &
1167 : m_FTsiginv_out=FTsiginv, &
1168 : m_siginvTFTsiginv_out=siginvTFTsiginv, &
1169 : m_ST_out=ST, &
1170 : m_STsiginv0_in=STsiginv_0, &
1171 : m_quench_t_in=quench_t, &
1172 : domain_r_down_in=domain_r_down, &
1173 : assume_t0_q0x=assume_t0_q0x, &
1174 : just_started=just_started, &
1175 : optimize_theta=optimize_theta, &
1176 : normalize_orbitals=normalize_orbitals, &
1177 : perturbation_only=perturbation_only, &
1178 : do_penalty=penalty_occ_vol, &
1179 1060 : special_case=my_special_case)
1180 1060 : IF (penalty_occ_vol) THEN
1181 : ! this is not pure energy anymore
1182 0 : energy_new = energy_new + penalty_func_new
1183 : END IF
1184 2132 : DO ispin = 1, nspins
1185 2132 : IF (penalty_occ_vol) THEN
1186 : penalty_occ_vol_g_prefactor(ispin) = &
1187 0 : -2.0_dp*penalty_amplitude*spin_factor*nocc(ispin)
1188 0 : penalty_occ_vol_h_prefactor(ispin) = 0.0_dp
1189 : END IF
1190 : END DO
1191 :
1192 1060 : localization_obj_function = 0.0_dp
1193 : ! RZK-warning: This block must be combined with the loss function
1194 1060 : IF (penalty_occ_local) THEN
1195 0 : DO ispin = 1, nspins
1196 :
1197 : ! LzL insert localization penalty
1198 0 : localization_obj_function = 0.0_dp
1199 0 : CALL dbcsr_get_info(almo_scf_env%matrix_sigma_inv(ispin), nfullrows_total=nmo)
1200 0 : ALLOCATE (z2(nmo))
1201 0 : ALLOCATE (reim_diag(nmo))
1202 :
1203 0 : CALL dbcsr_get_info(tempOccOcc(ispin), group=group)
1204 :
1205 0 : DO idim0 = 1, SIZE(op_sm_set_qs, 2) ! this loop is over miller ind
1206 :
1207 0 : z2(:) = 0.0_dp
1208 :
1209 0 : DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im
1210 :
1211 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
1212 : op_sm_set_almo(reim, idim0)%matrix, &
1213 : matrix_t_out(ispin), &
1214 : 0.0_dp, tempNOcc(ispin), &
1215 0 : filter_eps=almo_scf_env%eps_filter)
1216 : !warning - save time by computing only the diagonal elements
1217 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
1218 : matrix_t_out(ispin), &
1219 : tempNOcc(ispin), &
1220 : 0.0_dp, tempOccOcc(ispin), &
1221 0 : filter_eps=almo_scf_env%eps_filter)
1222 :
1223 0 : reim_diag = 0.0_dp
1224 0 : CALL dbcsr_get_diag(tempOccOcc(ispin), reim_diag)
1225 0 : CALL group%sum(reim_diag)
1226 0 : z2(:) = z2(:) + reim_diag(:)*reim_diag(:)
1227 :
1228 : END DO
1229 :
1230 0 : DO ielem = 1, nmo
1231 : SELECT CASE (2) ! allows for selection of different spread functionals
1232 : CASE (1) ! functional = -W_I * log( |z_I|^2 )
1233 0 : fval = -weights(idim0)*LOG(ABS(z2(ielem)))
1234 : CASE (2) ! functional = W_I * ( 1 - |z_I|^2 )
1235 0 : fval = weights(idim0) - weights(idim0)*ABS(z2(ielem))
1236 : CASE (3) ! functional = W_I * ( 1 - |z_I| )
1237 : fval = weights(idim0) - weights(idim0)*SQRT(ABS(z2(ielem)))
1238 : END SELECT
1239 0 : localization_obj_function = localization_obj_function + fval
1240 : END DO
1241 :
1242 : END DO ! end loop over idim0
1243 :
1244 0 : DEALLOCATE (z2)
1245 0 : DEALLOCATE (reim_diag)
1246 :
1247 0 : energy_new = energy_new + localiz_coeff*localization_obj_function
1248 :
1249 : END DO ! ispin
1250 : END IF ! penalty_occ_local
1251 :
1252 2132 : DO ispin = 1, nspins
1253 :
1254 : IF (just_started .AND. almo_mathematica) THEN
1255 : CPWARN_IF(ispin > 1, "Mathematica files will be overwritten")
1256 : CALL print_mathematica_matrix(almo_scf_env%matrix_s(1), "matrixS.dat")
1257 : CALL print_mathematica_matrix(almo_scf_env%matrix_ks(ispin), "matrixF.dat")
1258 : CALL print_mathematica_matrix(matrix_t_out(ispin), "matrixT.dat")
1259 : CALL print_mathematica_matrix(quench_t(ispin), "matrixQ.dat")
1260 : END IF
1261 :
1262 : ! save the previous gradient to compute beta
1263 : ! do it only if the previous grad was computed
1264 : ! for .NOT.line_search
1265 2132 : IF (line_search_iteration == 0 .AND. iteration /= 0) THEN
1266 502 : CALL dbcsr_copy(prev_grad(ispin), grad(ispin))
1267 : END IF
1268 :
1269 : END DO ! ispin
1270 :
1271 : ! compute the energy gradient if necessary
1272 : skip_grad = (iteration > 0 .AND. &
1273 : fixed_line_search_niter /= 0 .AND. &
1274 1060 : line_search_iteration /= fixed_line_search_niter)
1275 :
1276 : IF (.NOT. skip_grad) THEN
1277 :
1278 2132 : DO ispin = 1, nspins
1279 :
1280 : CALL compute_gradient( &
1281 : m_grad_out=grad(ispin), &
1282 : m_ks=almo_scf_env%matrix_ks(ispin), &
1283 : m_s=almo_scf_env%matrix_s(1), &
1284 : m_t=matrix_t_out(ispin), &
1285 : m_t0=almo_scf_env%matrix_t_blk(ispin), &
1286 : m_siginv=almo_scf_env%matrix_sigma_inv(ispin), &
1287 : m_quench_t=quench_t(ispin), &
1288 : m_FTsiginv=FTsiginv(ispin), &
1289 : m_siginvTFTsiginv=siginvTFTsiginv(ispin), &
1290 : m_ST=ST(ispin), &
1291 : m_STsiginv0=STsiginv_0(ispin), &
1292 : m_theta=m_theta(ispin), &
1293 : m_sig_sqrti_ii=m_sig_sqrti_ii(ispin), &
1294 : domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
1295 : domain_r_down=domain_r_down(:, ispin), &
1296 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
1297 : domain_map=almo_scf_env%domain_map(ispin), &
1298 : assume_t0_q0x=assume_t0_q0x, &
1299 : optimize_theta=optimize_theta, &
1300 : normalize_orbitals=normalize_orbitals, &
1301 : penalty_occ_vol=penalty_occ_vol, &
1302 : penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), &
1303 : envelope_amplitude=almo_scf_env%envelope_amplitude, &
1304 : eps_filter=almo_scf_env%eps_filter, &
1305 : spin_factor=spin_factor, &
1306 : special_case=my_special_case, &
1307 : penalty_occ_local=penalty_occ_local, &
1308 : op_sm_set=op_sm_set_almo, &
1309 : weights=weights, &
1310 : energy_coeff=energy_coeff, &
1311 2132 : localiz_coeff=localiz_coeff)
1312 :
1313 : END DO ! ispin
1314 :
1315 : END IF ! skip_grad
1316 :
1317 : ! if unprojected XALMOs are optimized then compute both
1318 : ! HessianInv/preconditioner and the "bad-mode" projector
1319 :
1320 1060 : IF (blissful_neglect) THEN
1321 460 : DO ispin = 1, nspins
1322 : !compute the prec only for the first step,
1323 : !but project the gradient every step
1324 230 : IF (iteration == 0) THEN
1325 : CALL compute_preconditioner( &
1326 : domain_prec_out=almo_scf_env%domain_preconditioner(:, ispin), &
1327 : bad_modes_projector_down_out=bad_modes_projector_down(:, ispin), &
1328 : m_prec_out=prec_vv(ispin), &
1329 : m_ks=almo_scf_env%matrix_ks(ispin), &
1330 : m_s=almo_scf_env%matrix_s(1), &
1331 : m_siginv=almo_scf_env%matrix_sigma_inv(ispin), &
1332 : m_quench_t=quench_t(ispin), &
1333 : m_FTsiginv=FTsiginv(ispin), &
1334 : m_siginvTFTsiginv=siginvTFTsiginv(ispin), &
1335 : m_ST=ST(ispin), &
1336 : para_env=almo_scf_env%para_env, &
1337 : blacs_env=almo_scf_env%blacs_env, &
1338 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
1339 : domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
1340 : domain_s_inv_half=almo_scf_env%domain_s_sqrt_inv(:, ispin), &
1341 : domain_s_half=almo_scf_env%domain_s_sqrt(:, ispin), &
1342 : domain_r_down=domain_r_down(:, ispin), &
1343 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
1344 : domain_map=almo_scf_env%domain_map(ispin), &
1345 : assume_t0_q0x=assume_t0_q0x, &
1346 : penalty_occ_vol=penalty_occ_vol, &
1347 : penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), &
1348 : eps_filter=almo_scf_env%eps_filter, &
1349 : neg_thr=optimizer%neglect_threshold, &
1350 : spin_factor=spin_factor, &
1351 : skip_inversion=.FALSE., &
1352 18 : special_case=my_special_case)
1353 : END IF
1354 : ! remove bad modes from the gradient
1355 : CALL apply_domain_operators( &
1356 : matrix_in=grad(ispin), &
1357 : matrix_out=grad(ispin), &
1358 : operator1=almo_scf_env%domain_s_inv(:, ispin), &
1359 : operator2=bad_modes_projector_down(:, ispin), &
1360 : dpattern=quench_t(ispin), &
1361 : map=almo_scf_env%domain_map(ispin), &
1362 : node_of_domain=almo_scf_env%cpu_of_domain, &
1363 : my_action=1, &
1364 460 : filter_eps=almo_scf_env%eps_filter)
1365 :
1366 : END DO ! ispin
1367 :
1368 : END IF ! blissful neglect
1369 :
1370 : ! check convergence and other exit criteria
1371 2132 : DO ispin = 1, nspins
1372 2132 : grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin))
1373 : END DO ! ispin
1374 2132 : grad_norm = MAXVAL(grad_norm_spin)
1375 :
1376 1060 : converged = (grad_norm <= optimizer%eps_error)
1377 1060 : IF (converged .OR. (iteration >= max_iter)) THEN
1378 98 : prepare_to_exit = .TRUE.
1379 : END IF
1380 : ! if early stopping is on do at least one iteration
1381 1060 : IF (optimizer%early_stopping_on .AND. just_started) THEN
1382 0 : prepare_to_exit = .FALSE.
1383 : END IF
1384 :
1385 : IF (grad_norm < almo_scf_env%eps_prev_guess) THEN
1386 1060 : use_guess = .TRUE.
1387 : END IF
1388 :
1389 : ! it is not time to exit just yet
1390 1060 : IF (.NOT. prepare_to_exit) THEN
1391 :
1392 : ! check the gradient along the step direction
1393 : ! and decide whether to switch to the line-search mode
1394 : ! do not do this in the first iteration
1395 962 : IF (iteration /= 0) THEN
1396 :
1397 866 : IF (fixed_line_search_niter == 0) THEN
1398 :
1399 : ! enforce at least one line search
1400 : ! without even checking the error
1401 866 : IF (.NOT. line_search) THEN
1402 :
1403 424 : line_search = .TRUE.
1404 424 : line_search_iteration = line_search_iteration + 1
1405 :
1406 : ELSE
1407 :
1408 : ! check the line-search error and decide whether to
1409 : ! change the direction
1410 : line_search_error = 0.0_dp
1411 : denom = 0.0_dp
1412 : denom2 = 0.0_dp
1413 :
1414 884 : DO ispin = 1, nspins
1415 :
1416 442 : CALL dbcsr_dot(grad(ispin), step(ispin), tempreal)
1417 442 : line_search_error = line_search_error + tempreal
1418 442 : CALL dbcsr_dot(grad(ispin), grad(ispin), tempreal)
1419 442 : denom = denom + tempreal
1420 442 : CALL dbcsr_dot(step(ispin), step(ispin), tempreal)
1421 884 : denom2 = denom2 + tempreal
1422 :
1423 : END DO ! ispin
1424 :
1425 : ! cosine of the angle between the step and grad
1426 : ! (must be close to zero at convergence)
1427 442 : line_search_error = line_search_error/SQRT(denom)/SQRT(denom2)
1428 :
1429 442 : IF (ABS(line_search_error) > optimizer%lin_search_eps_error) THEN
1430 40 : line_search = .TRUE.
1431 40 : line_search_iteration = line_search_iteration + 1
1432 : ELSE
1433 402 : line_search = .FALSE.
1434 402 : line_search_iteration = 0
1435 402 : IF (grad_norm < eps_skip_gradients) THEN
1436 0 : fixed_line_search_niter = ABS(almo_scf_env%integer04)
1437 : END IF
1438 : END IF
1439 :
1440 : END IF
1441 :
1442 : ELSE ! decision for fixed_line_search_niter
1443 :
1444 0 : IF (.NOT. line_search) THEN
1445 0 : line_search = .TRUE.
1446 0 : line_search_iteration = line_search_iteration + 1
1447 : ELSE
1448 0 : IF (line_search_iteration == fixed_line_search_niter) THEN
1449 : line_search = .FALSE.
1450 : line_search_iteration = 0
1451 : line_search_iteration = line_search_iteration + 1
1452 : END IF
1453 : END IF
1454 :
1455 : END IF ! fixed_line_search_niter fork
1456 :
1457 : END IF ! iteration.ne.0
1458 :
1459 96 : IF (line_search) THEN
1460 464 : energy_diff = 0.0_dp
1461 : ELSE
1462 498 : energy_diff = energy_new - energy_old
1463 : energy_old = energy_new
1464 : END IF
1465 :
1466 : ! update the step direction
1467 498 : IF (.NOT. line_search) THEN
1468 :
1469 1000 : cg_iteration = cg_iteration + 1
1470 :
1471 : ! save the previous step
1472 1000 : DO ispin = 1, nspins
1473 1000 : CALL dbcsr_copy(prev_step(ispin), step(ispin))
1474 : END DO ! ispin
1475 :
1476 : ! compute the new step (apply preconditioner if available)
1477 0 : SELECT CASE (prec_type)
1478 : CASE (xalmo_prec_full)
1479 :
1480 : ! solving approximate Newton eq in the full (linearized) space
1481 : CALL newton_grad_to_step( &
1482 : optimizer=almo_scf_env%opt_xalmo_newton_pcg_solver, &
1483 : m_grad=grad(:), &
1484 : m_delta=step(:), &
1485 : m_s=almo_scf_env%matrix_s(:), &
1486 : m_ks=almo_scf_env%matrix_ks(:), &
1487 : m_siginv=almo_scf_env%matrix_sigma_inv(:), &
1488 : m_quench_t=quench_t(:), &
1489 : m_FTsiginv=FTsiginv(:), &
1490 : m_siginvTFTsiginv=siginvTFTsiginv(:), &
1491 : m_ST=ST(:), &
1492 : m_t=matrix_t_out(:), &
1493 : m_sig_sqrti_ii=m_sig_sqrti_ii(:), &
1494 : domain_s_inv=almo_scf_env%domain_s_inv(:, :), &
1495 : domain_r_down=domain_r_down(:, :), &
1496 : domain_map=almo_scf_env%domain_map(:), &
1497 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
1498 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, :), &
1499 : para_env=almo_scf_env%para_env, &
1500 : blacs_env=almo_scf_env%blacs_env, &
1501 : eps_filter=almo_scf_env%eps_filter, &
1502 : optimize_theta=optimize_theta, &
1503 : penalty_occ_vol=penalty_occ_vol, &
1504 : normalize_orbitals=normalize_orbitals, &
1505 : penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(:), &
1506 : penalty_occ_vol_pf2=penalty_occ_vol_h_prefactor(:), &
1507 : special_case=my_special_case &
1508 0 : )
1509 :
1510 : CASE (xalmo_prec_domain)
1511 :
1512 : ! compute and invert preconditioner?
1513 498 : IF (.NOT. blissful_neglect .AND. &
1514 : ((just_started .AND. perturbation_only) .OR. &
1515 : (iteration == 0 .AND. (.NOT. perturbation_only))) &
1516 : ) THEN
1517 :
1518 : ! computing preconditioner
1519 160 : DO ispin = 1, nspins
1520 : CALL compute_preconditioner( &
1521 : domain_prec_out=almo_scf_env%domain_preconditioner(:, ispin), &
1522 : m_prec_out=prec_vv(ispin), &
1523 : m_ks=almo_scf_env%matrix_ks(ispin), &
1524 : m_s=almo_scf_env%matrix_s(1), &
1525 : m_siginv=almo_scf_env%matrix_sigma_inv(ispin), &
1526 : m_quench_t=quench_t(ispin), &
1527 : m_FTsiginv=FTsiginv(ispin), &
1528 : m_siginvTFTsiginv=siginvTFTsiginv(ispin), &
1529 : m_ST=ST(ispin), &
1530 : para_env=almo_scf_env%para_env, &
1531 : blacs_env=almo_scf_env%blacs_env, &
1532 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
1533 : domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
1534 : domain_r_down=domain_r_down(:, ispin), &
1535 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
1536 : domain_map=almo_scf_env%domain_map(ispin), &
1537 : assume_t0_q0x=assume_t0_q0x, &
1538 : penalty_occ_vol=penalty_occ_vol, &
1539 : penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), &
1540 : eps_filter=almo_scf_env%eps_filter, &
1541 : neg_thr=0.5_dp, &
1542 : spin_factor=spin_factor, &
1543 : skip_inversion=.FALSE., &
1544 580 : special_case=my_special_case)
1545 : END DO ! ispin
1546 : END IF ! compute_prec
1547 :
1548 498 : IF (my_special_case == xalmo_case_block_diag .OR. &
1549 : my_special_case == xalmo_case_fully_deloc) THEN
1550 :
1551 500 : DO ispin = 1, nspins
1552 :
1553 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
1554 : prec_vv(ispin), &
1555 : grad(ispin), &
1556 : 0.0_dp, step(ispin), &
1557 500 : filter_eps=almo_scf_env%eps_filter)
1558 :
1559 : END DO ! ispin
1560 :
1561 : ELSE
1562 :
1563 : !!! RZK-warning Currently for non-theta only
1564 250 : IF (optimize_theta) THEN
1565 0 : CPABORT("theta is NYI")
1566 : END IF
1567 :
1568 500 : DO ispin = 1, nspins
1569 :
1570 : CALL apply_domain_operators( &
1571 : matrix_in=grad(ispin), &
1572 : matrix_out=step(ispin), &
1573 : operator1=almo_scf_env%domain_preconditioner(:, ispin), &
1574 : dpattern=quench_t(ispin), &
1575 : map=almo_scf_env%domain_map(ispin), &
1576 : node_of_domain=almo_scf_env%cpu_of_domain, &
1577 : my_action=0, &
1578 250 : filter_eps=almo_scf_env%eps_filter)
1579 500 : CALL dbcsr_scale(step(ispin), -1.0_dp)
1580 :
1581 : END DO ! ispin
1582 :
1583 : END IF ! special case
1584 :
1585 : CASE (xalmo_prec_zero)
1586 :
1587 : ! no preconditioner
1588 498 : DO ispin = 1, nspins
1589 :
1590 0 : CALL dbcsr_copy(step(ispin), grad(ispin))
1591 0 : CALL dbcsr_scale(step(ispin), -1.0_dp)
1592 :
1593 : END DO ! ispin
1594 :
1595 : END SELECT ! preconditioner type fork
1596 :
1597 : ! check whether we need to reset conjugate directions
1598 498 : IF (iteration == 0) THEN
1599 96 : reset_conjugator = .TRUE.
1600 : END IF
1601 :
1602 : ! compute the conjugation coefficient - beta
1603 498 : IF (.NOT. reset_conjugator) THEN
1604 :
1605 : CALL compute_cg_beta( &
1606 : beta=beta, &
1607 : reset_conjugator=reset_conjugator, &
1608 : conjugator=optimizer%conjugator, &
1609 : grad=grad(:), &
1610 : prev_grad=prev_grad(:), &
1611 : step=step(:), &
1612 : prev_step=prev_step(:), &
1613 : prev_minus_prec_grad=prev_minus_prec_grad(:) &
1614 402 : )
1615 :
1616 : END IF
1617 :
1618 498 : IF (reset_conjugator) THEN
1619 :
1620 96 : beta = 0.0_dp
1621 96 : IF (unit_nr > 0 .AND. (.NOT. just_started)) THEN
1622 3 : WRITE (unit_nr, '(T2,A35)') "Re-setting conjugator to zero"
1623 : END IF
1624 96 : reset_conjugator = .FALSE.
1625 :
1626 : END IF
1627 :
1628 : ! save the preconditioned gradient (useful for beta)
1629 1000 : DO ispin = 1, nspins
1630 :
1631 502 : CALL dbcsr_copy(prev_minus_prec_grad(ispin), step(ispin))
1632 :
1633 : ! conjugate the step direction
1634 1000 : CALL dbcsr_add(step(ispin), prev_step(ispin), 1.0_dp, beta)
1635 :
1636 : END DO ! ispin
1637 :
1638 : END IF ! update the step direction
1639 :
1640 : ! estimate the step size
1641 : IF (.NOT. line_search) THEN
1642 : ! we just changed the direction and
1643 : ! we have only E and grad from the current step
1644 : ! it is not enouhg to compute step_size - just guess it
1645 1000 : e0 = energy_new
1646 : g0 = 0.0_dp
1647 1000 : DO ispin = 1, nspins
1648 502 : CALL dbcsr_dot(grad(ispin), step(ispin), tempreal)
1649 1000 : g0 = g0 + tempreal
1650 : END DO ! ispin
1651 498 : IF (iteration == 0) THEN
1652 96 : step_size = optimizer%lin_search_step_size_guess
1653 : ELSE
1654 402 : IF (next_step_size_guess <= 0.0_dp) THEN
1655 2 : step_size = optimizer%lin_search_step_size_guess
1656 : ELSE
1657 : ! take the last value
1658 400 : step_size = next_step_size_guess*1.05_dp
1659 : END IF
1660 : END IF
1661 498 : next_step_size_guess = step_size
1662 : ELSE
1663 464 : IF (fixed_line_search_niter == 0) THEN
1664 464 : e1 = energy_new
1665 464 : g1 = 0.0_dp
1666 930 : DO ispin = 1, nspins
1667 466 : CALL dbcsr_dot(grad(ispin), step(ispin), tempreal)
1668 930 : g1 = g1 + tempreal
1669 : END DO ! ispin
1670 : ! we have accumulated some points along this direction
1671 : ! use only the most recent g0 (quadratic approximation)
1672 464 : appr_sec_der = (g1 - g0)/step_size
1673 464 : step_size = -g1/appr_sec_der
1674 464 : e0 = e1
1675 464 : g0 = g1
1676 : ELSE
1677 : ! use e0, g0 and e1 to compute g1 and make a step
1678 : ! if the next iteration is also line_search
1679 : ! use e1 and the calculated g1 as e0 and g0
1680 0 : e1 = energy_new
1681 0 : appr_sec_der = 2.0*((e1 - e0)/step_size - g0)/step_size
1682 0 : g1 = appr_sec_der*step_size + g0
1683 0 : step_size = -g1/appr_sec_der
1684 0 : e0 = e1
1685 0 : g0 = g1
1686 : END IF
1687 464 : next_step_size_guess = next_step_size_guess + step_size
1688 : END IF
1689 :
1690 : ! update theta
1691 1930 : DO ispin = 1, nspins
1692 1930 : CALL dbcsr_add(m_theta(ispin), step(ispin), 1.0_dp, step_size)
1693 : END DO ! ispin
1694 :
1695 : END IF ! not.prepare_to_exit
1696 :
1697 1060 : IF (line_search) THEN
1698 486 : iter_type = "LS"
1699 : ELSE
1700 574 : iter_type = "CG"
1701 : END IF
1702 :
1703 1060 : t2 = m_walltime()
1704 1060 : IF (unit_nr > 0) THEN
1705 530 : iter_type = TRIM("ALMO SCF "//iter_type)
1706 : WRITE (unit_nr, '(T2,A13,I6,F23.10,E14.5,F14.9,F9.2)') &
1707 530 : iter_type, iteration, &
1708 530 : energy_new, energy_diff, grad_norm, &
1709 1060 : t2 - t1
1710 530 : IF (penalty_occ_local .OR. penalty_occ_vol) THEN
1711 : WRITE (unit_nr, '(T2,A25,F23.10)') &
1712 0 : "Energy component:", (energy_new - penalty_func_new - localization_obj_function)
1713 : END IF
1714 530 : IF (penalty_occ_local) THEN
1715 : WRITE (unit_nr, '(T2,A25,F23.10)') &
1716 0 : "Localization component:", localization_obj_function
1717 : END IF
1718 530 : IF (penalty_occ_vol) THEN
1719 : WRITE (unit_nr, '(T2,A25,F23.10)') &
1720 0 : "Penalty component:", penalty_func_new
1721 : END IF
1722 : END IF
1723 :
1724 1060 : IF (my_special_case == xalmo_case_block_diag) THEN
1725 58 : IF (penalty_occ_vol) THEN
1726 0 : almo_scf_env%almo_scf_energy = energy_new - penalty_func_new - localization_obj_function
1727 : ELSE
1728 58 : almo_scf_env%almo_scf_energy = energy_new - localization_obj_function
1729 : END IF
1730 : END IF
1731 :
1732 1060 : t1 = m_walltime()
1733 :
1734 1060 : iteration = iteration + 1
1735 1060 : IF (prepare_to_exit) EXIT
1736 :
1737 : END DO ! inner SCF loop
1738 :
1739 98 : IF (converged .OR. (outer_iteration >= outer_max_iter)) THEN
1740 92 : outer_prepare_to_exit = .TRUE.
1741 : END IF
1742 :
1743 98 : outer_iteration = outer_iteration + 1
1744 98 : IF (outer_prepare_to_exit) EXIT
1745 :
1746 : END DO ! outer SCF loop
1747 :
1748 190 : DO ispin = 1, nspins
1749 92 : IF (converged .AND. almo_mathematica) THEN
1750 : CPWARN_IF(ispin > 1, "Mathematica files will be overwritten")
1751 : CALL print_mathematica_matrix(matrix_t_out(ispin), "matrixTf.dat")
1752 : END IF
1753 : END DO ! ispin
1754 :
1755 : ! post SCF-loop calculations
1756 92 : IF (converged) THEN
1757 :
1758 : CALL wrap_up_xalmo_scf( &
1759 : qs_env=qs_env, &
1760 : almo_scf_env=almo_scf_env, &
1761 : perturbation_in=perturbation_only, &
1762 : m_xalmo_in=matrix_t_out, &
1763 : m_quench_in=quench_t, &
1764 92 : energy_inout=energy_new)
1765 :
1766 : END IF ! if converged
1767 :
1768 190 : DO ispin = 1, nspins
1769 98 : CALL dbcsr_release(prec_vv(ispin))
1770 98 : CALL dbcsr_release(STsiginv_0(ispin))
1771 98 : CALL dbcsr_release(ST(ispin))
1772 98 : CALL dbcsr_release(FTsiginv(ispin))
1773 98 : CALL dbcsr_release(siginvTFTsiginv(ispin))
1774 98 : CALL dbcsr_release(prev_grad(ispin))
1775 98 : CALL dbcsr_release(prev_step(ispin))
1776 98 : CALL dbcsr_release(grad(ispin))
1777 98 : CALL dbcsr_release(step(ispin))
1778 98 : CALL dbcsr_release(prev_minus_prec_grad(ispin))
1779 98 : CALL dbcsr_release(m_theta(ispin))
1780 98 : CALL dbcsr_release(m_t_in_local(ispin))
1781 98 : CALL dbcsr_release(m_sig_sqrti_ii(ispin))
1782 98 : CALL release_submatrices(domain_r_down(:, ispin))
1783 98 : CALL release_submatrices(bad_modes_projector_down(:, ispin))
1784 98 : CALL dbcsr_release(tempNOcc(ispin))
1785 98 : CALL dbcsr_release(tempNOcc_1(ispin))
1786 190 : CALL dbcsr_release(tempOccOcc(ispin))
1787 : END DO ! ispin
1788 :
1789 92 : DEALLOCATE (tempNOcc)
1790 92 : DEALLOCATE (tempNOcc_1)
1791 92 : DEALLOCATE (tempOccOcc)
1792 92 : DEALLOCATE (prec_vv)
1793 92 : DEALLOCATE (siginvTFTsiginv)
1794 92 : DEALLOCATE (STsiginv_0)
1795 92 : DEALLOCATE (FTsiginv)
1796 92 : DEALLOCATE (ST)
1797 92 : DEALLOCATE (prev_grad)
1798 92 : DEALLOCATE (grad)
1799 92 : DEALLOCATE (prev_step)
1800 92 : DEALLOCATE (step)
1801 92 : DEALLOCATE (prev_minus_prec_grad)
1802 92 : DEALLOCATE (m_sig_sqrti_ii)
1803 :
1804 714 : DEALLOCATE (domain_r_down)
1805 714 : DEALLOCATE (bad_modes_projector_down)
1806 :
1807 92 : DEALLOCATE (penalty_occ_vol_g_prefactor)
1808 92 : DEALLOCATE (penalty_occ_vol_h_prefactor)
1809 92 : DEALLOCATE (grad_norm_spin)
1810 92 : DEALLOCATE (nocc)
1811 :
1812 92 : DEALLOCATE (m_theta, m_t_in_local)
1813 92 : IF (penalty_occ_local) THEN
1814 0 : DO idim0 = 1, dim_op
1815 0 : DO reim = 1, SIZE(op_sm_set_qs, 1)
1816 0 : DEALLOCATE (op_sm_set_qs(reim, idim0)%matrix)
1817 0 : DEALLOCATE (op_sm_set_almo(reim, idim0)%matrix)
1818 : END DO
1819 : END DO
1820 0 : DEALLOCATE (op_sm_set_qs)
1821 0 : DEALLOCATE (op_sm_set_almo)
1822 0 : DEALLOCATE (weights)
1823 : END IF
1824 :
1825 92 : IF (.NOT. converged .AND. .NOT. optimizer%early_stopping_on) THEN
1826 0 : CPABORT("Optimization not converged! ")
1827 : END IF
1828 :
1829 92 : CALL timestop(handle)
1830 :
1831 184 : END SUBROUTINE almo_scf_xalmo_pcg
1832 :
1833 : ! **************************************************************************************************
1834 : !> \brief Optimization of NLMOs using PCG minimizers
1835 : !> \param qs_env ...
1836 : !> \param optimizer controls the optimization algorithm
1837 : !> \param matrix_s - AO overlap (NAOs x NAOs)
1838 : !> \param matrix_mo_in - initial MOs (NAOs x NMOs)
1839 : !> \param matrix_mo_out - final MOs (NAOs x NMOs)
1840 : !> \param template_matrix_sigma - template (NMOs x NMOs)
1841 : !> \param overlap_determinant - the determinant of the MOs overlap
1842 : !> \param mat_distr_aos - info on the distribution of AOs
1843 : !> \param virtuals ...
1844 : !> \param eps_filter ...
1845 : !> \par History
1846 : !> 2018.10 created [Rustam Z Khaliullin]
1847 : !> \author Rustam Z Khaliullin
1848 : ! **************************************************************************************************
1849 8 : SUBROUTINE almo_scf_construct_nlmos(qs_env, optimizer, &
1850 : matrix_s, matrix_mo_in, matrix_mo_out, &
1851 : template_matrix_sigma, overlap_determinant, &
1852 : mat_distr_aos, virtuals, eps_filter)
1853 : TYPE(qs_environment_type), POINTER :: qs_env
1854 : TYPE(optimizer_options_type), INTENT(INOUT) :: optimizer
1855 : TYPE(dbcsr_type), INTENT(IN) :: matrix_s
1856 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:), &
1857 : INTENT(INOUT) :: matrix_mo_in, matrix_mo_out
1858 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:), &
1859 : INTENT(IN) :: template_matrix_sigma
1860 : REAL(KIND=dp), INTENT(INOUT) :: overlap_determinant
1861 : INTEGER, INTENT(IN) :: mat_distr_aos
1862 : LOGICAL, INTENT(IN) :: virtuals
1863 : REAL(KIND=dp), INTENT(IN) :: eps_filter
1864 :
1865 : CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_construct_nlmos'
1866 :
1867 : CHARACTER(LEN=30) :: iter_type, print_string
1868 : INTEGER :: cg_iteration, dim_op, handle, iatom, idim0, isgf, ispin, iteration, &
1869 : line_search_iteration, linear_search_type, max_iter, natom, ncol, nspins, &
1870 : outer_iteration, outer_max_iter, prec_type, reim, unit_nr
1871 16 : INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf, nocc, nsgf
1872 : LOGICAL :: converged, d_bfgs, just_started, l_bfgs, &
1873 : line_search, outer_prepare_to_exit, &
1874 : prepare_to_exit, reset_conjugator
1875 : REAL(KIND=dp) :: appr_sec_der, beta, bfgs_rho, bfgs_sum, denom, denom2, e0, e1, g0, g0sign, &
1876 : g1, g1sign, grad_norm, line_search_error, localization_obj_function, &
1877 : localization_obj_function_ispin, next_step_size_guess, obj_function_ispin, objf_diff, &
1878 : objf_new, objf_old, penalty_amplitude, penalty_func_ispin, penalty_func_new, spin_factor, &
1879 : step_size, t1, t2, tempreal
1880 8 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: diagonal, grad_norm_spin, &
1881 8 : penalty_vol_prefactor, &
1882 8 : suggested_vol_penalty, weights
1883 : TYPE(cell_type), POINTER :: cell
1884 : TYPE(cp_logger_type), POINTER :: logger
1885 8 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: qs_matrix_s
1886 8 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: op_sm_set_almo, op_sm_set_qs
1887 8 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: approx_inv_hessian, bfgs_s, bfgs_y, grad, &
1888 8 : m_S0, m_sig_sqrti_ii, m_siginv, m_sigma, m_t_mo_local, m_theta, m_theta_normalized, &
1889 8 : prev_grad, prev_m_theta, prev_minus_prec_grad, prev_step, step, tempNOcc1, tempOccOcc1, &
1890 8 : tempOccOcc2, tempOccOcc3
1891 8 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:, :, :) :: m_B0
1892 24 : TYPE(lbfgs_history_type) :: nlmo_lbfgs_history
1893 : TYPE(mp_comm_type) :: group
1894 8 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1895 8 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1896 :
1897 8 : CALL timeset(routineN, handle)
1898 :
1899 : ! get a useful output_unit
1900 8 : logger => cp_get_default_logger()
1901 8 : IF (logger%para_env%is_source()) THEN
1902 4 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
1903 : ELSE
1904 : unit_nr = -1
1905 : END IF
1906 :
1907 8 : nspins = SIZE(matrix_mo_in)
1908 :
1909 8 : IF (unit_nr > 0) THEN
1910 4 : WRITE (unit_nr, *)
1911 4 : IF (.NOT. virtuals) THEN
1912 4 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 24), &
1913 8 : " Optimization of occupied NLMOs ", REPEAT("-", 23)
1914 : ELSE
1915 0 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 24), &
1916 0 : " Optimization of virtual NLMOs ", REPEAT("-", 24)
1917 : END IF
1918 4 : WRITE (unit_nr, *)
1919 4 : WRITE (unit_nr, '(T2,A13,A6,A23,A14,A14,A9)') "Method", "Iter", &
1920 8 : "Objective Function", "Change", "Convergence", "Time"
1921 4 : WRITE (unit_nr, '(T2,A)') REPEAT("-", 79)
1922 : END IF
1923 :
1924 8 : NULLIFY (particle_set)
1925 :
1926 : CALL get_qs_env(qs_env=qs_env, &
1927 : matrix_s=qs_matrix_s, &
1928 : cell=cell, &
1929 : particle_set=particle_set, &
1930 8 : qs_kind_set=qs_kind_set)
1931 :
1932 8 : natom = SIZE(particle_set, 1)
1933 24 : ALLOCATE (first_sgf(natom))
1934 16 : ALLOCATE (last_sgf(natom))
1935 16 : ALLOCATE (nsgf(natom))
1936 : ! construction of
1937 : CALL get_particle_set(particle_set, qs_kind_set, &
1938 8 : first_sgf=first_sgf, last_sgf=last_sgf, nsgf=nsgf)
1939 :
1940 : ! m_theta contains a set of variational parameters
1941 : ! that define one-electron orbitals
1942 32 : ALLOCATE (m_theta(nspins))
1943 16 : DO ispin = 1, nspins
1944 : CALL dbcsr_create(m_theta(ispin), &
1945 : template=template_matrix_sigma(ispin), &
1946 8 : matrix_type=dbcsr_type_no_symmetry)
1947 : ! create initial guess for the main variable - identity matrix
1948 8 : CALL dbcsr_set(m_theta(ispin), 0.0_dp)
1949 16 : CALL dbcsr_add_on_diag(m_theta(ispin), 1.0_dp)
1950 : END DO
1951 :
1952 8 : SELECT CASE (optimizer%opt_penalty%operator_type)
1953 : CASE (op_loc_berry)
1954 :
1955 0 : IF (cell%orthorhombic) THEN
1956 0 : dim_op = 3
1957 : ELSE
1958 0 : dim_op = 6
1959 : END IF
1960 0 : ALLOCATE (weights(6))
1961 0 : weights = 0.0_dp
1962 0 : CALL initialize_weights(cell, weights)
1963 0 : ALLOCATE (op_sm_set_qs(2, dim_op))
1964 0 : ALLOCATE (op_sm_set_almo(2, dim_op))
1965 : ! allocate space for T0^t.B.T0
1966 0 : ALLOCATE (m_B0(2, dim_op, nspins))
1967 0 : DO idim0 = 1, dim_op
1968 0 : DO reim = 1, SIZE(op_sm_set_qs, 1)
1969 0 : NULLIFY (op_sm_set_qs(reim, idim0)%matrix, op_sm_set_almo(reim, idim0)%matrix)
1970 0 : ALLOCATE (op_sm_set_qs(reim, idim0)%matrix)
1971 0 : ALLOCATE (op_sm_set_almo(reim, idim0)%matrix)
1972 : CALL dbcsr_copy(op_sm_set_qs(reim, idim0)%matrix, qs_matrix_s(1)%matrix, &
1973 0 : name="almo_scf_env%op_sm_"//TRIM(ADJUSTL(cp_to_string(reim)))//"-"//TRIM(ADJUSTL(cp_to_string(idim0))))
1974 : CALL dbcsr_copy(op_sm_set_almo(reim, idim0)%matrix, matrix_s, &
1975 0 : name="almo_scf_env%op_sm_"//TRIM(ADJUSTL(cp_to_string(reim)))//"-"//TRIM(ADJUSTL(cp_to_string(idim0))))
1976 0 : CALL dbcsr_set(op_sm_set_almo(reim, idim0)%matrix, 0.0_dp)
1977 0 : DO ispin = 1, nspins
1978 : CALL dbcsr_create(m_B0(reim, idim0, ispin), &
1979 : template=m_theta(ispin), &
1980 0 : matrix_type=dbcsr_type_no_symmetry)
1981 0 : CALL dbcsr_set(m_B0(reim, idim0, ispin), 0.0_dp)
1982 : END DO
1983 : END DO
1984 : END DO
1985 :
1986 0 : CALL compute_berry_operator(qs_env, cell, op_sm_set_qs, dim_op)
1987 :
1988 : CASE (op_loc_pipek)
1989 :
1990 8 : dim_op = natom
1991 24 : ALLOCATE (weights(dim_op))
1992 80 : weights = 1.0_dp
1993 :
1994 184 : ALLOCATE (m_B0(1, dim_op, nspins))
1995 : !m_B0 first dim is 1 now!
1996 88 : DO idim0 = 1, dim_op
1997 152 : DO reim = 1, 1
1998 216 : DO ispin = 1, nspins
1999 : CALL dbcsr_create(m_B0(reim, idim0, ispin), &
2000 : template=m_theta(ispin), &
2001 72 : matrix_type=dbcsr_type_no_symmetry)
2002 144 : CALL dbcsr_set(m_B0(reim, idim0, ispin), 0.0_dp)
2003 : END DO
2004 : END DO
2005 : END DO
2006 :
2007 : END SELECT
2008 :
2009 : ! penalty amplitude adjusts the strenght of volume conservation
2010 8 : penalty_amplitude = optimizer%opt_penalty%penalty_strength
2011 :
2012 : ! preconditioner control
2013 8 : prec_type = optimizer%preconditioner
2014 :
2015 : ! use diagonal BFGS if preconditioner is set
2016 8 : d_bfgs = .FALSE.
2017 8 : l_bfgs = .FALSE.
2018 8 : IF (prec_type /= xalmo_prec_zero) l_bfgs = .TRUE.
2019 8 : IF (l_bfgs .AND. (optimizer%conjugator /= cg_zero)) THEN
2020 0 : CPABORT("Cannot use conjugators with BFGS")
2021 : END IF
2022 8 : IF (l_bfgs) THEN
2023 8 : CALL lbfgs_create(nlmo_lbfgs_history, nspins, nstore=10)
2024 : END IF
2025 :
2026 : IF (nspins == 1) THEN
2027 : spin_factor = 2.0_dp
2028 : ELSE
2029 : spin_factor = 1.0_dp
2030 : END IF
2031 :
2032 24 : ALLOCATE (grad_norm_spin(nspins))
2033 24 : ALLOCATE (nocc(nspins))
2034 16 : ALLOCATE (penalty_vol_prefactor(nspins))
2035 16 : ALLOCATE (suggested_vol_penalty(nspins))
2036 :
2037 : ! create a local copy of matrix_mo_in because
2038 : ! matrix_mo_in and matrix_mo_out can be the same matrix
2039 : ! we need to make sure data in matrix_mo_in is intact
2040 : ! after we start writing to matrix_mo_out
2041 24 : ALLOCATE (m_t_mo_local(nspins))
2042 16 : DO ispin = 1, nspins
2043 : CALL dbcsr_create(m_t_mo_local(ispin), &
2044 : template=matrix_mo_in(ispin), &
2045 8 : matrix_type=dbcsr_type_no_symmetry)
2046 16 : CALL dbcsr_copy(m_t_mo_local(ispin), matrix_mo_in(ispin))
2047 : END DO
2048 :
2049 24 : ALLOCATE (approx_inv_hessian(nspins))
2050 24 : ALLOCATE (m_theta_normalized(nspins))
2051 32 : ALLOCATE (prev_m_theta(nspins))
2052 24 : ALLOCATE (m_S0(nspins))
2053 24 : ALLOCATE (prev_grad(nspins))
2054 24 : ALLOCATE (grad(nspins))
2055 24 : ALLOCATE (prev_step(nspins))
2056 24 : ALLOCATE (step(nspins))
2057 24 : ALLOCATE (prev_minus_prec_grad(nspins))
2058 24 : ALLOCATE (m_sig_sqrti_ii(nspins))
2059 24 : ALLOCATE (m_sigma(nspins))
2060 24 : ALLOCATE (m_siginv(nspins))
2061 32 : ALLOCATE (tempNOcc1(nspins))
2062 24 : ALLOCATE (tempOccOcc1(nspins))
2063 24 : ALLOCATE (tempOccOcc2(nspins))
2064 24 : ALLOCATE (tempOccOcc3(nspins))
2065 24 : ALLOCATE (bfgs_y(nspins))
2066 24 : ALLOCATE (bfgs_s(nspins))
2067 :
2068 16 : DO ispin = 1, nspins
2069 :
2070 : ! init temporary storage
2071 : CALL dbcsr_create(tempNOcc1(ispin), &
2072 : template=matrix_mo_out(ispin), &
2073 8 : matrix_type=dbcsr_type_no_symmetry)
2074 : CALL dbcsr_create(approx_inv_hessian(ispin), &
2075 : template=m_theta(ispin), &
2076 8 : matrix_type=dbcsr_type_no_symmetry)
2077 : CALL dbcsr_create(m_theta_normalized(ispin), &
2078 : template=m_theta(ispin), &
2079 8 : matrix_type=dbcsr_type_no_symmetry)
2080 : CALL dbcsr_create(prev_m_theta(ispin), &
2081 : template=m_theta(ispin), &
2082 8 : matrix_type=dbcsr_type_no_symmetry)
2083 : CALL dbcsr_create(m_S0(ispin), &
2084 : template=m_theta(ispin), &
2085 8 : matrix_type=dbcsr_type_no_symmetry)
2086 : CALL dbcsr_create(prev_grad(ispin), &
2087 : template=m_theta(ispin), &
2088 8 : matrix_type=dbcsr_type_no_symmetry)
2089 : CALL dbcsr_create(grad(ispin), &
2090 : template=m_theta(ispin), &
2091 8 : matrix_type=dbcsr_type_no_symmetry)
2092 : CALL dbcsr_create(prev_step(ispin), &
2093 : template=m_theta(ispin), &
2094 8 : matrix_type=dbcsr_type_no_symmetry)
2095 : CALL dbcsr_create(step(ispin), &
2096 : template=m_theta(ispin), &
2097 8 : matrix_type=dbcsr_type_no_symmetry)
2098 : CALL dbcsr_create(prev_minus_prec_grad(ispin), &
2099 : template=m_theta(ispin), &
2100 8 : matrix_type=dbcsr_type_no_symmetry)
2101 : CALL dbcsr_create(m_sig_sqrti_ii(ispin), &
2102 : template=m_theta(ispin), &
2103 8 : matrix_type=dbcsr_type_no_symmetry)
2104 : CALL dbcsr_create(m_sigma(ispin), &
2105 : template=m_theta(ispin), &
2106 8 : matrix_type=dbcsr_type_no_symmetry)
2107 : CALL dbcsr_create(m_siginv(ispin), &
2108 : template=m_theta(ispin), &
2109 8 : matrix_type=dbcsr_type_no_symmetry)
2110 : CALL dbcsr_create(tempOccOcc1(ispin), &
2111 : template=m_theta(ispin), &
2112 8 : matrix_type=dbcsr_type_no_symmetry)
2113 : CALL dbcsr_create(tempOccOcc2(ispin), &
2114 : template=m_theta(ispin), &
2115 8 : matrix_type=dbcsr_type_no_symmetry)
2116 : CALL dbcsr_create(tempOccOcc3(ispin), &
2117 : template=m_theta(ispin), &
2118 8 : matrix_type=dbcsr_type_no_symmetry)
2119 : CALL dbcsr_create(bfgs_s(ispin), &
2120 : template=m_theta(ispin), &
2121 8 : matrix_type=dbcsr_type_no_symmetry)
2122 : CALL dbcsr_create(bfgs_y(ispin), &
2123 : template=m_theta(ispin), &
2124 8 : matrix_type=dbcsr_type_no_symmetry)
2125 :
2126 8 : CALL dbcsr_set(step(ispin), 0.0_dp)
2127 8 : CALL dbcsr_set(prev_step(ispin), 0.0_dp)
2128 :
2129 : CALL dbcsr_get_info(template_matrix_sigma(ispin), &
2130 8 : nfullrows_total=nocc(ispin))
2131 :
2132 8 : penalty_vol_prefactor(ispin) = -penalty_amplitude !KEEP: * spin_factor * nocc(ispin)
2133 :
2134 : ! compute m_S0=T0^t.S.T0
2135 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2136 : matrix_s, &
2137 : m_t_mo_local(ispin), &
2138 : 0.0_dp, tempNOcc1(ispin), &
2139 8 : filter_eps=eps_filter)
2140 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
2141 : m_t_mo_local(ispin), &
2142 : tempNOcc1(ispin), &
2143 : 0.0_dp, m_S0(ispin), &
2144 8 : filter_eps=eps_filter)
2145 :
2146 8 : SELECT CASE (optimizer%opt_penalty%operator_type)
2147 :
2148 : CASE (op_loc_berry)
2149 :
2150 : ! compute m_B0=T0^t.B.T0
2151 0 : DO idim0 = 1, SIZE(op_sm_set_qs, 2) ! this loop is over miller ind
2152 :
2153 0 : DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im
2154 :
2155 : CALL matrix_qs_to_almo(op_sm_set_qs(reim, idim0)%matrix, &
2156 0 : op_sm_set_almo(reim, idim0)%matrix, mat_distr_aos)
2157 :
2158 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2159 : op_sm_set_almo(reim, idim0)%matrix, &
2160 : m_t_mo_local(ispin), &
2161 : 0.0_dp, tempNOcc1(ispin), &
2162 0 : filter_eps=eps_filter)
2163 :
2164 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
2165 : m_t_mo_local(ispin), &
2166 : tempNOcc1(ispin), &
2167 : 0.0_dp, m_B0(reim, idim0, ispin), &
2168 0 : filter_eps=eps_filter)
2169 :
2170 0 : DEALLOCATE (op_sm_set_qs(reim, idim0)%matrix)
2171 0 : DEALLOCATE (op_sm_set_almo(reim, idim0)%matrix)
2172 :
2173 : END DO
2174 :
2175 : END DO ! end loop over idim0
2176 :
2177 : CASE (op_loc_pipek)
2178 :
2179 : ! compute m_B0=T0^t.B.T0
2180 80 : DO iatom = 1, natom ! this loop is over "miller" ind
2181 :
2182 72 : isgf = first_sgf(iatom)
2183 72 : ncol = nsgf(iatom)
2184 :
2185 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2186 : matrix_s, &
2187 : m_t_mo_local(ispin), &
2188 : 0.0_dp, tempNOcc1(ispin), &
2189 72 : filter_eps=eps_filter)
2190 :
2191 : CALL dbcsr_multiply("T", "N", 0.5_dp, &
2192 : m_t_mo_local(ispin), &
2193 : tempNOcc1(ispin), &
2194 : 0.0_dp, m_B0(1, iatom, ispin), &
2195 : first_k=isgf, last_k=isgf + ncol - 1, &
2196 72 : filter_eps=eps_filter)
2197 :
2198 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2199 : matrix_s, &
2200 : m_t_mo_local(ispin), &
2201 : 0.0_dp, tempNOcc1(ispin), &
2202 : first_k=isgf, last_k=isgf + ncol - 1, &
2203 72 : filter_eps=eps_filter)
2204 :
2205 : CALL dbcsr_multiply("T", "N", 0.5_dp, &
2206 : m_t_mo_local(ispin), &
2207 : tempNOcc1(ispin), &
2208 : 1.0_dp, m_B0(1, iatom, ispin), &
2209 80 : filter_eps=eps_filter)
2210 :
2211 : END DO ! end loop over iatom
2212 :
2213 : END SELECT
2214 :
2215 : END DO ! ispin
2216 :
2217 8 : IF (optimizer%opt_penalty%operator_type == op_loc_berry) THEN
2218 0 : DO idim0 = 1, SIZE(op_sm_set_qs, 2) ! this loop is over miller ind
2219 0 : DO reim = 1, SIZE(op_sm_set_qs, 1) ! this loop is over Re/Im
2220 0 : DEALLOCATE (op_sm_set_qs(reim, idim0)%matrix)
2221 0 : DEALLOCATE (op_sm_set_almo(reim, idim0)%matrix)
2222 : END DO
2223 : END DO
2224 0 : DEALLOCATE (op_sm_set_qs, op_sm_set_almo)
2225 : END IF
2226 :
2227 : ! start the outer SCF loop
2228 8 : outer_max_iter = optimizer%max_iter_outer_loop
2229 8 : outer_prepare_to_exit = .FALSE.
2230 8 : outer_iteration = 0
2231 : grad_norm = 0.0_dp
2232 : penalty_func_new = 0.0_dp
2233 8 : linear_search_type = 1 ! safe restart, no quadratic assumption, takes more steps
2234 : localization_obj_function = 0.0_dp
2235 : penalty_func_new = 0.0_dp
2236 :
2237 : DO
2238 :
2239 : ! start the inner SCF loop
2240 8 : max_iter = optimizer%max_iter
2241 8 : prepare_to_exit = .FALSE.
2242 8 : line_search = .FALSE.
2243 8 : converged = .FALSE.
2244 8 : iteration = 0
2245 8 : cg_iteration = 0
2246 8 : line_search_iteration = 0
2247 8 : obj_function_ispin = 0.0_dp
2248 : objf_new = 0.0_dp
2249 8 : objf_old = 0.0_dp
2250 8 : objf_diff = 0.0_dp
2251 8 : line_search_error = 0.0_dp
2252 8 : t1 = m_walltime()
2253 8 : next_step_size_guess = 0.0_dp
2254 :
2255 : DO
2256 :
2257 82 : just_started = (iteration == 0) .AND. (outer_iteration == 0)
2258 :
2259 164 : DO ispin = 1, nspins
2260 :
2261 82 : CALL dbcsr_get_info(m_sig_sqrti_ii(ispin), group=group)
2262 :
2263 : ! compute diagonal (a^t.sigma0.a)^(-1/2)
2264 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2265 : m_S0(ispin), m_theta(ispin), 0.0_dp, &
2266 : tempOccOcc1(ispin), &
2267 82 : filter_eps=eps_filter)
2268 82 : CALL dbcsr_set(m_sig_sqrti_ii(ispin), 0.0_dp)
2269 82 : CALL dbcsr_add_on_diag(m_sig_sqrti_ii(ispin), 1.0_dp)
2270 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
2271 : m_theta(ispin), tempOccOcc1(ispin), 0.0_dp, &
2272 : m_sig_sqrti_ii(ispin), &
2273 82 : retain_sparsity=.TRUE.)
2274 246 : ALLOCATE (diagonal(nocc(ispin)))
2275 82 : CALL dbcsr_get_diag(m_sig_sqrti_ii(ispin), diagonal)
2276 82 : CALL group%sum(diagonal)
2277 : ! TODO: works for zero diagonal elements?
2278 1368 : diagonal(:) = 1.0_dp/SQRT(diagonal(:))
2279 82 : CALL dbcsr_set(m_sig_sqrti_ii(ispin), 0.0_dp)
2280 82 : CALL dbcsr_set_diag(m_sig_sqrti_ii(ispin), diagonal)
2281 82 : DEALLOCATE (diagonal)
2282 :
2283 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2284 : m_theta(ispin), &
2285 : m_sig_sqrti_ii(ispin), &
2286 : 0.0_dp, m_theta_normalized(ispin), &
2287 82 : filter_eps=eps_filter)
2288 :
2289 : ! compute new orbitals
2290 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2291 : m_t_mo_local(ispin), &
2292 : m_theta_normalized(ispin), &
2293 : 0.0_dp, matrix_mo_out(ispin), &
2294 246 : filter_eps=eps_filter)
2295 :
2296 : END DO
2297 :
2298 : ! compute objective function
2299 82 : localization_obj_function = 0.0_dp
2300 82 : penalty_func_new = 0.0_dp
2301 164 : DO ispin = 1, nspins
2302 :
2303 : CALL compute_obj_nlmos( &
2304 : localization_obj_function_ispin=localization_obj_function_ispin, &
2305 : penalty_func_ispin=penalty_func_ispin, &
2306 : overlap_determinant=overlap_determinant, &
2307 : m_sigma=m_sigma(ispin), &
2308 : nocc=nocc(ispin), &
2309 : m_B0=m_B0(:, :, ispin), &
2310 : m_theta_normalized=m_theta_normalized(ispin), &
2311 : template_matrix_mo=matrix_mo_out(ispin), &
2312 : weights=weights, &
2313 : m_S0=m_S0(ispin), &
2314 : just_started=just_started, &
2315 : penalty_vol_prefactor=penalty_vol_prefactor(ispin), &
2316 : penalty_amplitude=penalty_amplitude, &
2317 82 : eps_filter=eps_filter)
2318 :
2319 82 : localization_obj_function = localization_obj_function + localization_obj_function_ispin
2320 164 : penalty_func_new = penalty_func_new + penalty_func_ispin
2321 :
2322 : END DO ! ispin
2323 82 : objf_new = penalty_func_new + localization_obj_function
2324 :
2325 164 : DO ispin = 1, nspins
2326 : ! save the previous gradient to compute beta
2327 : ! do it only if the previous grad was computed
2328 : ! for .NOT.line_search
2329 164 : IF (line_search_iteration == 0 .AND. iteration /= 0) THEN
2330 30 : CALL dbcsr_copy(prev_grad(ispin), grad(ispin))
2331 : END IF
2332 :
2333 : END DO ! ispin
2334 :
2335 : ! compute the gradient
2336 164 : DO ispin = 1, nspins
2337 :
2338 : CALL invert_Hotelling( &
2339 : matrix_inverse=m_siginv(ispin), &
2340 : matrix=m_sigma(ispin), &
2341 : threshold=eps_filter*10.0_dp, &
2342 : filter_eps=eps_filter, &
2343 82 : silent=.FALSE.)
2344 :
2345 : CALL compute_gradient_nlmos( &
2346 : m_grad_out=grad(ispin), &
2347 : m_B0=m_B0(:, :, ispin), &
2348 : weights=weights, &
2349 : m_S0=m_S0(ispin), &
2350 : m_theta_normalized=m_theta_normalized(ispin), &
2351 : m_siginv=m_siginv(ispin), &
2352 : m_sig_sqrti_ii=m_sig_sqrti_ii(ispin), &
2353 : penalty_vol_prefactor=penalty_vol_prefactor(ispin), &
2354 : eps_filter=eps_filter, &
2355 164 : suggested_vol_penalty=suggested_vol_penalty(ispin))
2356 :
2357 : END DO ! ispin
2358 :
2359 : ! check convergence and other exit criteria
2360 164 : DO ispin = 1, nspins
2361 164 : grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin))
2362 : END DO ! ispin
2363 164 : grad_norm = MAXVAL(grad_norm_spin)
2364 :
2365 82 : converged = (grad_norm <= optimizer%eps_error)
2366 82 : IF (converged .OR. (iteration >= max_iter)) THEN
2367 : prepare_to_exit = .TRUE.
2368 : END IF
2369 :
2370 : ! it is not time to exit just yet
2371 74 : IF (.NOT. prepare_to_exit) THEN
2372 :
2373 : ! check the gradient along the step direction
2374 : ! and decide whether to switch to the line-search mode
2375 : ! do not do this in the first iteration
2376 74 : IF (iteration /= 0) THEN
2377 :
2378 : ! enforce at least one line search
2379 : ! without even checking the error
2380 68 : IF (.NOT. line_search) THEN
2381 :
2382 30 : line_search = .TRUE.
2383 30 : line_search_iteration = line_search_iteration + 1
2384 :
2385 : ELSE
2386 :
2387 : ! check the line-search error and decide whether to
2388 : ! change the direction
2389 : line_search_error = 0.0_dp
2390 : denom = 0.0_dp
2391 : denom2 = 0.0_dp
2392 :
2393 76 : DO ispin = 1, nspins
2394 :
2395 38 : CALL dbcsr_dot(grad(ispin), step(ispin), tempreal)
2396 38 : line_search_error = line_search_error + tempreal
2397 38 : CALL dbcsr_dot(grad(ispin), grad(ispin), tempreal)
2398 38 : denom = denom + tempreal
2399 38 : CALL dbcsr_dot(step(ispin), step(ispin), tempreal)
2400 76 : denom2 = denom2 + tempreal
2401 :
2402 : END DO ! ispin
2403 :
2404 : ! cosine of the angle between the step and grad
2405 : ! (must be close to zero at convergence)
2406 38 : line_search_error = line_search_error/SQRT(denom)/SQRT(denom2)
2407 :
2408 38 : IF (ABS(line_search_error) > optimizer%lin_search_eps_error) THEN
2409 14 : line_search = .TRUE.
2410 14 : line_search_iteration = line_search_iteration + 1
2411 : ELSE
2412 : line_search = .FALSE.
2413 : line_search_iteration = 0
2414 : END IF
2415 :
2416 : END IF
2417 :
2418 : END IF ! iteration.ne.0
2419 :
2420 6 : IF (line_search) THEN
2421 44 : objf_diff = 0.0_dp
2422 : ELSE
2423 30 : objf_diff = objf_new - objf_old
2424 : objf_old = objf_new
2425 : END IF
2426 :
2427 : ! update the step direction
2428 30 : IF (.NOT. line_search) THEN
2429 :
2430 60 : cg_iteration = cg_iteration + 1
2431 :
2432 : ! save the previous step
2433 60 : DO ispin = 1, nspins
2434 60 : CALL dbcsr_copy(prev_step(ispin), step(ispin))
2435 : END DO ! ispin
2436 :
2437 : ! compute the new step:
2438 : ! if available use second derivative info - bfgs, hessian, preconditioner
2439 30 : IF (prec_type == xalmo_prec_zero) THEN ! no second derivatives
2440 :
2441 : ! no preconditioner
2442 0 : DO ispin = 1, nspins
2443 :
2444 0 : CALL dbcsr_copy(step(ispin), grad(ispin))
2445 0 : CALL dbcsr_scale(step(ispin), -1.0_dp)
2446 :
2447 : END DO ! ispin
2448 :
2449 : ELSE ! use second derivatives
2450 :
2451 : ! compute and invert hessian/precond?
2452 30 : IF (iteration == 0) THEN
2453 :
2454 : IF (d_bfgs) THEN
2455 :
2456 : ! create matrix filled with 1.0 here
2457 : CALL fill_matrix_with_ones(approx_inv_hessian(1))
2458 : IF (nspins > 1) THEN
2459 : DO ispin = 2, nspins
2460 : CALL dbcsr_copy(approx_inv_hessian(ispin), approx_inv_hessian(1))
2461 : END DO
2462 : END IF
2463 :
2464 6 : ELSE IF (l_bfgs) THEN
2465 :
2466 6 : CALL lbfgs_seed(nlmo_lbfgs_history, m_theta, grad)
2467 12 : DO ispin = 1, nspins
2468 6 : CALL dbcsr_copy(step(ispin), grad(ispin))
2469 12 : CALL dbcsr_scale(step(ispin), -1.0_dp)
2470 : END DO ! ispin
2471 :
2472 : ELSE
2473 :
2474 : ! computing preconditioner
2475 0 : DO ispin = 1, nspins
2476 :
2477 : ! TODO: write preconditioner code later
2478 : ! For now, create matrix filled with 1.0 here
2479 0 : CALL fill_matrix_with_ones(approx_inv_hessian(ispin))
2480 : END DO ! ispin
2481 :
2482 : END IF
2483 :
2484 : ELSE ! not iteration zero
2485 :
2486 : ! update approx inverse hessian
2487 : IF (d_bfgs) THEN ! diagonal BFGS
2488 :
2489 : DO ispin = 1, nspins
2490 :
2491 : ! compute s and y
2492 : CALL dbcsr_copy(bfgs_y(ispin), grad(ispin))
2493 : CALL dbcsr_add(bfgs_y(ispin), prev_grad(ispin), 1.0_dp, -1.0_dp)
2494 : CALL dbcsr_copy(bfgs_s(ispin), m_theta(ispin))
2495 : CALL dbcsr_add(bfgs_s(ispin), prev_m_theta(ispin), 1.0_dp, -1.0_dp)
2496 :
2497 : ! compute rho
2498 : CALL dbcsr_dot(grad(ispin), step(ispin), bfgs_rho)
2499 : bfgs_rho = 1.0_dp/bfgs_rho
2500 :
2501 : ! compute the sum of the squared elements of bfgs_y
2502 : CALL dbcsr_dot(bfgs_y(ispin), bfgs_y(ispin), bfgs_sum)
2503 :
2504 : ! first term: start collecting new inv hessian in this temp matrix
2505 : CALL dbcsr_copy(tempOccOcc2(ispin), approx_inv_hessian(ispin))
2506 :
2507 : ! second term: + rho * s * s
2508 : CALL dbcsr_hadamard_product(bfgs_s(ispin), bfgs_s(ispin), tempOccOcc1(ispin))
2509 : CALL dbcsr_add(tempOccOcc2(ispin), tempOccOcc1(ispin), 1.0_dp, bfgs_rho)
2510 :
2511 : ! third term: + rho^2 * s * s * H * sum_(y * y)
2512 : CALL dbcsr_hadamard_product(tempOccOcc1(ispin), &
2513 : approx_inv_hessian(ispin), tempOccOcc3(ispin))
2514 : CALL dbcsr_add(tempOccOcc2(ispin), tempOccOcc3(ispin), &
2515 : 1.0_dp, bfgs_rho*bfgs_rho*bfgs_sum)
2516 :
2517 : ! fourth term: - 2 * rho * s * y * H
2518 : CALL dbcsr_hadamard_product(bfgs_y(ispin), &
2519 : approx_inv_hessian(ispin), tempOccOcc1(ispin))
2520 : CALL dbcsr_hadamard_product(bfgs_s(ispin), tempOccOcc1(ispin), tempOccOcc3(ispin))
2521 : CALL dbcsr_add(tempOccOcc2(ispin), tempOccOcc3(ispin), &
2522 : 1.0_dp, -2.0_dp*bfgs_rho)
2523 :
2524 : CALL dbcsr_copy(approx_inv_hessian(ispin), tempOccOcc2(ispin))
2525 :
2526 : END DO
2527 :
2528 24 : ELSE IF (l_bfgs) THEN
2529 :
2530 24 : CALL lbfgs_get_direction(nlmo_lbfgs_history, m_theta, grad, step)
2531 :
2532 : END IF ! which method?
2533 :
2534 : END IF ! compute approximate inverse hessian
2535 :
2536 30 : IF (.NOT. l_bfgs) THEN
2537 :
2538 0 : DO ispin = 1, nspins
2539 :
2540 : CALL dbcsr_hadamard_product(approx_inv_hessian(ispin), &
2541 0 : grad(ispin), step(ispin))
2542 0 : CALL dbcsr_scale(step(ispin), -1.0_dp)
2543 :
2544 : END DO ! ispin
2545 :
2546 : END IF
2547 :
2548 : END IF ! second derivative type fork
2549 :
2550 : ! check whether we need to reset conjugate directions
2551 30 : IF (iteration == 0) THEN
2552 6 : reset_conjugator = .TRUE.
2553 : END IF
2554 :
2555 : ! compute the conjugation coefficient - beta
2556 30 : IF (.NOT. reset_conjugator) THEN
2557 : CALL compute_cg_beta( &
2558 : beta=beta, &
2559 : reset_conjugator=reset_conjugator, &
2560 : conjugator=optimizer%conjugator, &
2561 : grad=grad(:), &
2562 : prev_grad=prev_grad(:), &
2563 : step=step(:), &
2564 : prev_step=prev_step(:), &
2565 : prev_minus_prec_grad=prev_minus_prec_grad(:) &
2566 24 : )
2567 :
2568 : END IF
2569 :
2570 30 : IF (reset_conjugator) THEN
2571 :
2572 6 : beta = 0.0_dp
2573 6 : IF (unit_nr > 0 .AND. (.NOT. just_started)) THEN
2574 0 : WRITE (unit_nr, '(T2,A35)') "Re-setting conjugator to zero"
2575 : END IF
2576 6 : reset_conjugator = .FALSE.
2577 :
2578 : END IF
2579 :
2580 : ! save the preconditioned gradient (useful for beta)
2581 60 : DO ispin = 1, nspins
2582 :
2583 30 : CALL dbcsr_copy(prev_minus_prec_grad(ispin), step(ispin))
2584 :
2585 : ! conjugate the step direction
2586 60 : CALL dbcsr_add(step(ispin), prev_step(ispin), 1.0_dp, beta)
2587 :
2588 : END DO ! ispin
2589 :
2590 : END IF ! update the step direction
2591 :
2592 : ! estimate the step size
2593 : IF (.NOT. line_search) THEN
2594 : ! we just changed the direction and
2595 : ! we have only E and grad from the current step
2596 : ! it is not enough to compute step_size - just guess it
2597 30 : e0 = objf_new
2598 30 : g0 = 0.0_dp
2599 60 : DO ispin = 1, nspins
2600 30 : CALL dbcsr_dot(grad(ispin), step(ispin), tempreal)
2601 60 : g0 = g0 + tempreal
2602 : END DO ! ispin
2603 : g0sign = SIGN(1.0_dp, g0) ! sign of g0
2604 : IF (linear_search_type == 1) THEN ! this is quadratic LS
2605 30 : IF (iteration == 0) THEN
2606 6 : step_size = optimizer%lin_search_step_size_guess
2607 : ELSE
2608 24 : IF (next_step_size_guess <= 0.0_dp) THEN
2609 0 : step_size = optimizer%lin_search_step_size_guess
2610 : ELSE
2611 : ! take the last value
2612 24 : step_size = optimizer%lin_search_step_size_guess
2613 : !step_size = next_step_size_guess*1.05_dp
2614 : END IF
2615 : END IF
2616 : ELSE IF (linear_search_type == 2) THEN ! this is cautious LS
2617 : ! this LS type is designed not to trust quadratic appr
2618 : ! so it always restarts from a safe step size
2619 : step_size = optimizer%lin_search_step_size_guess
2620 : END IF
2621 30 : IF (unit_nr > 0) THEN
2622 15 : WRITE (unit_nr, '(T21,3A19)') "Line position", "Line grad", "Next line step"
2623 15 : WRITE (unit_nr, '(T2,A19,3F19.5)') "Line search", 0.0_dp, g0, step_size
2624 : END IF
2625 30 : next_step_size_guess = step_size
2626 : ELSE ! this is not the first line search
2627 44 : e1 = objf_new
2628 44 : g1 = 0.0_dp
2629 88 : DO ispin = 1, nspins
2630 44 : CALL dbcsr_dot(grad(ispin), step(ispin), tempreal)
2631 88 : g1 = g1 + tempreal
2632 : END DO ! ispin
2633 44 : g1sign = SIGN(1.0_dp, g1) ! sign of g1
2634 : IF (linear_search_type == 1) THEN
2635 : ! we have accumulated some points along this direction
2636 : ! use only the most recent g0 (quadratic approximation)
2637 44 : appr_sec_der = (g1 - g0)/step_size
2638 44 : step_size = -g1/appr_sec_der
2639 : ELSE IF (linear_search_type == 2) THEN
2640 : ! alternative method for finding step size
2641 : ! do not use quadratic approximation, only gradient signs
2642 : IF (g1sign /= g0sign) THEN
2643 : step_size = -step_size/2.0
2644 : ELSE
2645 : step_size = step_size*1.5
2646 : END IF
2647 : END IF
2648 : ! end alternative LS types
2649 44 : IF (unit_nr > 0) THEN
2650 22 : WRITE (unit_nr, '(T21,3A19)') "Line position", "Line grad", "Next line step"
2651 22 : WRITE (unit_nr, '(T2,A19,3F19.5)') "Line search", next_step_size_guess, g1, step_size
2652 : END IF
2653 44 : e0 = e1
2654 44 : g0 = g1
2655 : g0sign = g1sign
2656 44 : next_step_size_guess = next_step_size_guess + step_size
2657 : END IF
2658 :
2659 : ! update theta
2660 148 : DO ispin = 1, nspins
2661 74 : IF (.NOT. line_search) THEN ! we prepared to perform the first line search
2662 : ! "previous" refers to the previous CG step, not the previous LS step
2663 30 : CALL dbcsr_copy(prev_m_theta(ispin), m_theta(ispin))
2664 : END IF
2665 148 : CALL dbcsr_add(m_theta(ispin), step(ispin), 1.0_dp, step_size)
2666 : END DO ! ispin
2667 :
2668 : END IF ! not.prepare_to_exit
2669 :
2670 82 : IF (line_search) THEN
2671 50 : iter_type = "LS"
2672 : ELSE
2673 32 : iter_type = "CG"
2674 : END IF
2675 :
2676 82 : t2 = m_walltime()
2677 82 : IF (unit_nr > 0) THEN
2678 41 : iter_type = TRIM("NLMO OPT "//iter_type)
2679 : WRITE (unit_nr, '(T2,A13,I6,F23.10,E14.5,F14.9,F9.2)') &
2680 41 : iter_type, iteration, &
2681 41 : objf_new, objf_diff, grad_norm, &
2682 82 : t2 - t1
2683 : WRITE (unit_nr, '(T2,A19,F23.10)') &
2684 41 : "Localization:", localization_obj_function
2685 : WRITE (unit_nr, '(T2,A19,F23.10)') &
2686 41 : "Orthogonalization:", penalty_func_new
2687 : END IF
2688 82 : t1 = m_walltime()
2689 :
2690 82 : iteration = iteration + 1
2691 82 : IF (prepare_to_exit) EXIT
2692 :
2693 : END DO ! inner loop
2694 :
2695 8 : IF (converged .OR. (outer_iteration >= outer_max_iter)) THEN
2696 8 : outer_prepare_to_exit = .TRUE.
2697 : END IF
2698 :
2699 8 : outer_iteration = outer_iteration + 1
2700 8 : IF (outer_prepare_to_exit) EXIT
2701 :
2702 : END DO ! outer loop
2703 :
2704 : ! return the optimal determinant penalty
2705 8 : optimizer%opt_penalty%penalty_strength = 0.0_dp
2706 16 : DO ispin = 1, nspins
2707 : optimizer%opt_penalty%penalty_strength = optimizer%opt_penalty%penalty_strength + &
2708 16 : (-1.0_dp)*penalty_vol_prefactor(ispin)
2709 : END DO
2710 8 : optimizer%opt_penalty%penalty_strength = optimizer%opt_penalty%penalty_strength/nspins
2711 :
2712 8 : IF (converged) THEN
2713 8 : iter_type = "Final"
2714 : ELSE
2715 0 : iter_type = "Unconverged"
2716 : END IF
2717 :
2718 8 : IF (unit_nr > 0) THEN
2719 4 : WRITE (unit_nr, '()')
2720 4 : print_string = TRIM(iter_type)//" localization:"
2721 : WRITE (unit_nr, '(T2,A29,F30.10)') &
2722 4 : print_string, localization_obj_function
2723 4 : print_string = TRIM(iter_type)//" determinant:"
2724 : WRITE (unit_nr, '(T2,A29,F30.10)') &
2725 4 : print_string, overlap_determinant
2726 4 : print_string = TRIM(iter_type)//" penalty strength:"
2727 : WRITE (unit_nr, '(T2,A29,F30.10)') &
2728 4 : print_string, optimizer%opt_penalty%penalty_strength
2729 : END IF
2730 :
2731 : ! clean up
2732 8 : IF (l_bfgs) THEN
2733 8 : CALL lbfgs_release(nlmo_lbfgs_history)
2734 : END IF
2735 16 : DO ispin = 1, nspins
2736 80 : DO idim0 = 1, SIZE(m_B0, 2)
2737 152 : DO reim = 1, SIZE(m_B0, 1)
2738 144 : CALL dbcsr_release(m_B0(reim, idim0, ispin))
2739 : END DO
2740 : END DO
2741 8 : CALL dbcsr_release(m_theta(ispin))
2742 8 : CALL dbcsr_release(m_t_mo_local(ispin))
2743 8 : CALL dbcsr_release(tempNOcc1(ispin))
2744 8 : CALL dbcsr_release(approx_inv_hessian(ispin))
2745 8 : CALL dbcsr_release(prev_m_theta(ispin))
2746 8 : CALL dbcsr_release(m_theta_normalized(ispin))
2747 8 : CALL dbcsr_release(m_S0(ispin))
2748 8 : CALL dbcsr_release(prev_grad(ispin))
2749 8 : CALL dbcsr_release(grad(ispin))
2750 8 : CALL dbcsr_release(prev_step(ispin))
2751 8 : CALL dbcsr_release(step(ispin))
2752 8 : CALL dbcsr_release(prev_minus_prec_grad(ispin))
2753 8 : CALL dbcsr_release(m_sig_sqrti_ii(ispin))
2754 8 : CALL dbcsr_release(m_sigma(ispin))
2755 8 : CALL dbcsr_release(m_siginv(ispin))
2756 8 : CALL dbcsr_release(tempOccOcc1(ispin))
2757 8 : CALL dbcsr_release(tempOccOcc2(ispin))
2758 8 : CALL dbcsr_release(tempOccOcc3(ispin))
2759 8 : CALL dbcsr_release(bfgs_y(ispin))
2760 16 : CALL dbcsr_release(bfgs_s(ispin))
2761 : END DO ! ispin
2762 :
2763 8 : DEALLOCATE (grad_norm_spin)
2764 8 : DEALLOCATE (nocc)
2765 8 : DEALLOCATE (penalty_vol_prefactor)
2766 8 : DEALLOCATE (suggested_vol_penalty)
2767 :
2768 8 : DEALLOCATE (approx_inv_hessian)
2769 8 : DEALLOCATE (prev_m_theta)
2770 8 : DEALLOCATE (m_theta_normalized)
2771 8 : DEALLOCATE (m_S0)
2772 8 : DEALLOCATE (prev_grad)
2773 8 : DEALLOCATE (grad)
2774 8 : DEALLOCATE (prev_step)
2775 8 : DEALLOCATE (step)
2776 8 : DEALLOCATE (prev_minus_prec_grad)
2777 8 : DEALLOCATE (m_sig_sqrti_ii)
2778 8 : DEALLOCATE (m_sigma)
2779 8 : DEALLOCATE (m_siginv)
2780 8 : DEALLOCATE (tempNOcc1)
2781 8 : DEALLOCATE (tempOccOcc1)
2782 8 : DEALLOCATE (tempOccOcc2)
2783 8 : DEALLOCATE (tempOccOcc3)
2784 8 : DEALLOCATE (bfgs_y)
2785 8 : DEALLOCATE (bfgs_s)
2786 :
2787 8 : DEALLOCATE (m_theta, m_t_mo_local)
2788 8 : DEALLOCATE (m_B0)
2789 8 : DEALLOCATE (weights)
2790 8 : DEALLOCATE (first_sgf, last_sgf, nsgf)
2791 :
2792 8 : IF (.NOT. converged) THEN
2793 0 : CPABORT("Optimization not converged! ")
2794 : END IF
2795 :
2796 8 : CALL timestop(handle)
2797 :
2798 24 : END SUBROUTINE almo_scf_construct_nlmos
2799 :
2800 : ! **************************************************************************************************
2801 : !> \brief Analysis of the orbitals
2802 : !> \param detailed_analysis ...
2803 : !> \param eps_filter ...
2804 : !> \param m_T_in ...
2805 : !> \param m_T0_in ...
2806 : !> \param m_siginv_in ...
2807 : !> \param m_siginv0_in ...
2808 : !> \param m_S_in ...
2809 : !> \param m_KS0_in ...
2810 : !> \param m_quench_t_in ...
2811 : !> \param energy_out ...
2812 : !> \param m_eda_out ...
2813 : !> \param m_cta_out ...
2814 : !> \par History
2815 : !> 2017.07 created [Rustam Z Khaliullin]
2816 : !> \author Rustam Z Khaliullin
2817 : ! **************************************************************************************************
2818 24 : SUBROUTINE xalmo_analysis(detailed_analysis, eps_filter, m_T_in, m_T0_in, &
2819 24 : m_siginv_in, m_siginv0_in, m_S_in, m_KS0_in, m_quench_t_in, energy_out, &
2820 24 : m_eda_out, m_cta_out)
2821 :
2822 : LOGICAL, INTENT(IN) :: detailed_analysis
2823 : REAL(KIND=dp), INTENT(IN) :: eps_filter
2824 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_T_in, m_T0_in, m_siginv_in, &
2825 : m_siginv0_in, m_S_in, m_KS0_in, &
2826 : m_quench_t_in
2827 : REAL(KIND=dp), INTENT(INOUT) :: energy_out
2828 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: m_eda_out, m_cta_out
2829 :
2830 : CHARACTER(len=*), PARAMETER :: routineN = 'xalmo_analysis'
2831 :
2832 : INTEGER :: handle, ispin, nspins
2833 : REAL(KIND=dp) :: energy_ispin, spin_factor
2834 : TYPE(dbcsr_type) :: FTsiginv0, Fvo0, m_X, siginvTFTsiginv0, &
2835 : ST0
2836 :
2837 24 : CALL timeset(routineN, handle)
2838 :
2839 24 : nspins = SIZE(m_T_in)
2840 :
2841 24 : IF (nspins == 1) THEN
2842 24 : spin_factor = 2.0_dp
2843 : ELSE
2844 0 : spin_factor = 1.0_dp
2845 : END IF
2846 :
2847 24 : energy_out = 0.0_dp
2848 48 : DO ispin = 1, nspins
2849 :
2850 : ! create temporary matrices
2851 : CALL dbcsr_create(Fvo0, &
2852 : template=m_T_in(ispin), &
2853 24 : matrix_type=dbcsr_type_no_symmetry)
2854 : CALL dbcsr_create(FTsiginv0, &
2855 : template=m_T_in(ispin), &
2856 24 : matrix_type=dbcsr_type_no_symmetry)
2857 : CALL dbcsr_create(ST0, &
2858 : template=m_T_in(ispin), &
2859 24 : matrix_type=dbcsr_type_no_symmetry)
2860 : CALL dbcsr_create(m_X, &
2861 : template=m_T_in(ispin), &
2862 24 : matrix_type=dbcsr_type_no_symmetry)
2863 : CALL dbcsr_create(siginvTFTsiginv0, &
2864 : template=m_siginv0_in(ispin), &
2865 24 : matrix_type=dbcsr_type_no_symmetry)
2866 :
2867 : ! compute F_{virt,occ} for the zero-delocalization state
2868 : CALL compute_frequently_used_matrices( &
2869 : filter_eps=eps_filter, &
2870 : m_T_in=m_T0_in(ispin), &
2871 : m_siginv_in=m_siginv0_in(ispin), &
2872 : m_S_in=m_S_in(1), &
2873 : m_F_in=m_KS0_in(ispin), &
2874 : m_FTsiginv_out=FTsiginv0, &
2875 : m_siginvTFTsiginv_out=siginvTFTsiginv0, &
2876 24 : m_ST_out=ST0)
2877 24 : CALL dbcsr_copy(Fvo0, m_quench_t_in(ispin))
2878 24 : CALL dbcsr_copy(Fvo0, FTsiginv0, keep_sparsity=.TRUE.)
2879 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
2880 : ST0, &
2881 : siginvTFTsiginv0, &
2882 : 1.0_dp, Fvo0, &
2883 24 : retain_sparsity=.TRUE.)
2884 :
2885 : ! get single excitation amplitudes
2886 24 : CALL dbcsr_copy(m_X, m_T0_in(ispin))
2887 24 : CALL dbcsr_add(m_X, m_T_in(ispin), -1.0_dp, 1.0_dp)
2888 :
2889 24 : CALL dbcsr_dot(m_X, Fvo0, energy_ispin)
2890 24 : energy_out = energy_out + energy_ispin*spin_factor
2891 :
2892 24 : IF (detailed_analysis) THEN
2893 :
2894 2 : CALL dbcsr_hadamard_product(m_X, Fvo0, m_eda_out(ispin))
2895 2 : CALL dbcsr_scale(m_eda_out(ispin), spin_factor)
2896 2 : CALL dbcsr_filter(m_eda_out(ispin), eps_filter)
2897 :
2898 : ! first, compute [QR'R]_mu^i = [(S-SRS).X.siginv']_mu^i
2899 : ! a. FTsiginv0 = S.T0*siginv0
2900 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2901 : ST0, &
2902 : m_siginv0_in(ispin), &
2903 : 0.0_dp, FTsiginv0, &
2904 2 : filter_eps=eps_filter)
2905 : ! c. tmp1(use ST0) = S.X
2906 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2907 : m_S_in(1), &
2908 : m_X, &
2909 : 0.0_dp, ST0, &
2910 2 : filter_eps=eps_filter)
2911 : ! d. tmp2 = tr(T0).tmp1 = tr(T0).S.X
2912 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
2913 : m_T0_in(ispin), &
2914 : ST0, &
2915 : 0.0_dp, siginvTFTsiginv0, &
2916 2 : filter_eps=eps_filter)
2917 : ! e. tmp1 = tmp1 - tmp3.tmp2 = S.X - S.T0.siginv0*tr(T0).S.X
2918 : ! = (1-S.R0).S.X
2919 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
2920 : FTsiginv0, &
2921 : siginvTFTsiginv0, &
2922 : 1.0_dp, ST0, &
2923 2 : filter_eps=eps_filter)
2924 : ! f. tmp2(use FTsiginv0) = tmp1*siginv
2925 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2926 : ST0, &
2927 : m_siginv_in(ispin), &
2928 : 0.0_dp, FTsiginv0, &
2929 2 : filter_eps=eps_filter)
2930 : ! second, compute traces of blocks [RR'Q]^x_y * [X]^y_x
2931 : CALL dbcsr_hadamard_product(m_X, &
2932 2 : FTsiginv0, m_cta_out(ispin))
2933 2 : CALL dbcsr_scale(m_cta_out(ispin), spin_factor)
2934 2 : CALL dbcsr_filter(m_cta_out(ispin), eps_filter)
2935 :
2936 : END IF ! do ALMO EDA/CTA
2937 :
2938 24 : CALL dbcsr_release(Fvo0)
2939 24 : CALL dbcsr_release(FTsiginv0)
2940 24 : CALL dbcsr_release(ST0)
2941 24 : CALL dbcsr_release(m_X)
2942 72 : CALL dbcsr_release(siginvTFTsiginv0)
2943 :
2944 : END DO ! ispin
2945 :
2946 24 : CALL timestop(handle)
2947 :
2948 24 : END SUBROUTINE xalmo_analysis
2949 :
2950 : ! **************************************************************************************************
2951 : !> \brief Compute matrices that are used often in various parts of the
2952 : !> optimization procedure
2953 : !> \param filter_eps ...
2954 : !> \param m_T_in ...
2955 : !> \param m_siginv_in ...
2956 : !> \param m_S_in ...
2957 : !> \param m_F_in ...
2958 : !> \param m_FTsiginv_out ...
2959 : !> \param m_siginvTFTsiginv_out ...
2960 : !> \param m_ST_out ...
2961 : !> \par History
2962 : !> 2016.12 created [Rustam Z Khaliullin]
2963 : !> \author Rustam Z Khaliullin
2964 : ! **************************************************************************************************
2965 1522 : SUBROUTINE compute_frequently_used_matrices(filter_eps, &
2966 : m_T_in, m_siginv_in, m_S_in, m_F_in, m_FTsiginv_out, &
2967 : m_siginvTFTsiginv_out, m_ST_out)
2968 :
2969 : REAL(KIND=dp), INTENT(IN) :: filter_eps
2970 : TYPE(dbcsr_type), INTENT(IN) :: m_T_in, m_siginv_in, m_S_in, m_F_in
2971 : TYPE(dbcsr_type), INTENT(INOUT) :: m_FTsiginv_out, m_siginvTFTsiginv_out, &
2972 : m_ST_out
2973 :
2974 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_frequently_used_matrices'
2975 :
2976 : INTEGER :: handle
2977 : TYPE(dbcsr_type) :: m_tmp_no_1, m_tmp_oo_1
2978 :
2979 1522 : CALL timeset(routineN, handle)
2980 :
2981 : CALL dbcsr_create(m_tmp_no_1, &
2982 : template=m_T_in, &
2983 1522 : matrix_type=dbcsr_type_no_symmetry)
2984 : CALL dbcsr_create(m_tmp_oo_1, &
2985 : template=m_siginv_in, &
2986 1522 : matrix_type=dbcsr_type_no_symmetry)
2987 :
2988 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2989 : m_F_in, &
2990 : m_T_in, &
2991 : 0.0_dp, m_tmp_no_1, &
2992 1522 : filter_eps=filter_eps)
2993 :
2994 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
2995 : m_tmp_no_1, &
2996 : m_siginv_in, &
2997 : 0.0_dp, m_FTsiginv_out, &
2998 1522 : filter_eps=filter_eps)
2999 :
3000 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
3001 : m_T_in, &
3002 : m_FTsiginv_out, &
3003 : 0.0_dp, m_tmp_oo_1, &
3004 1522 : filter_eps=filter_eps)
3005 :
3006 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
3007 : m_siginv_in, &
3008 : m_tmp_oo_1, &
3009 : 0.0_dp, m_siginvTFTsiginv_out, &
3010 1522 : filter_eps=filter_eps)
3011 :
3012 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
3013 : m_S_in, &
3014 : m_T_in, &
3015 : 0.0_dp, m_ST_out, &
3016 1522 : filter_eps=filter_eps)
3017 :
3018 1522 : CALL dbcsr_release(m_tmp_no_1)
3019 1522 : CALL dbcsr_release(m_tmp_oo_1)
3020 :
3021 1522 : CALL timestop(handle)
3022 :
3023 1522 : END SUBROUTINE compute_frequently_used_matrices
3024 :
3025 : ! **************************************************************************************************
3026 : !> \brief Split the matrix of virtual orbitals into two:
3027 : !> retained orbs and discarded
3028 : !> \param almo_scf_env ...
3029 : !> \par History
3030 : !> 2011.09 created [Rustam Z Khaliullin]
3031 : !> \author Rustam Z Khaliullin
3032 : ! **************************************************************************************************
3033 0 : SUBROUTINE split_v_blk(almo_scf_env)
3034 :
3035 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
3036 :
3037 : CHARACTER(len=*), PARAMETER :: routineN = 'split_v_blk'
3038 :
3039 : INTEGER :: discarded_v, handle, iblock_col, &
3040 : iblock_col_size, iblock_row, &
3041 : iblock_row_size, ispin, retained_v
3042 0 : REAL(kind=dp), DIMENSION(:, :), POINTER :: data_p
3043 : TYPE(dbcsr_iterator_type) :: iter
3044 :
3045 0 : CALL timeset(routineN, handle)
3046 :
3047 0 : DO ispin = 1, almo_scf_env%nspins
3048 :
3049 : CALL dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin), &
3050 0 : work_mutable=.TRUE.)
3051 : CALL dbcsr_work_create(almo_scf_env%matrix_v_disc_blk(ispin), &
3052 0 : work_mutable=.TRUE.)
3053 :
3054 0 : CALL dbcsr_iterator_start(iter, almo_scf_env%matrix_v_full_blk(ispin))
3055 :
3056 0 : DO WHILE (dbcsr_iterator_blocks_left(iter))
3057 :
3058 : CALL dbcsr_iterator_next_block(iter, iblock_row, iblock_col, data_p, &
3059 0 : row_size=iblock_row_size, col_size=iblock_col_size)
3060 :
3061 0 : IF (iblock_row /= iblock_col) THEN
3062 0 : CPABORT("off-diagonal block found")
3063 : END IF
3064 :
3065 0 : retained_v = almo_scf_env%nvirt_of_domain(iblock_col, ispin)
3066 0 : discarded_v = almo_scf_env%nvirt_disc_of_domain(iblock_col, ispin)
3067 0 : CPASSERT(retained_v > 0)
3068 0 : CPASSERT(discarded_v > 0)
3069 : CALL dbcsr_put_block(almo_scf_env%matrix_v_disc_blk(ispin), iblock_row, iblock_col, &
3070 0 : block=data_p(:, (retained_v + 1):iblock_col_size))
3071 : CALL dbcsr_put_block(almo_scf_env%matrix_v_blk(ispin), iblock_row, iblock_col, &
3072 0 : block=data_p(:, 1:retained_v))
3073 :
3074 : END DO ! iterator
3075 0 : CALL dbcsr_iterator_stop(iter)
3076 :
3077 0 : CALL dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin))
3078 0 : CALL dbcsr_finalize(almo_scf_env%matrix_v_disc_blk(ispin))
3079 :
3080 : END DO ! ispin
3081 :
3082 0 : CALL timestop(handle)
3083 :
3084 0 : END SUBROUTINE split_v_blk
3085 :
3086 : ! **************************************************************************************************
3087 : !> \brief various methods for calculating the Harris-Foulkes correction
3088 : !> \param almo_scf_env ...
3089 : !> \par History
3090 : !> 2011.06 created [Rustam Z Khaliullin]
3091 : !> \author Rustam Z Khaliullin
3092 : ! **************************************************************************************************
3093 0 : SUBROUTINE harris_foulkes_correction(almo_scf_env)
3094 :
3095 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
3096 :
3097 : CHARACTER(len=*), PARAMETER :: routineN = 'harris_foulkes_correction'
3098 : INTEGER, PARAMETER :: cayley_transform = 1, dm_ls_step = 2
3099 :
3100 : INTEGER :: algorithm_id, handle, handle1, handle2, handle3, handle4, handle5, handle6, &
3101 : handle7, handle8, ispin, iteration, n, nmins, nspin, opt_k_max_iter, &
3102 : outer_opt_k_iteration, outer_opt_k_max_iter, unit_nr
3103 : INTEGER, DIMENSION(1) :: fake, nelectron_spin_real
3104 : LOGICAL :: converged, line_search, md_in_k_space, outer_opt_k_prepare_to_exit, &
3105 : prepare_to_exit, reset_conjugator, reset_step_size, use_cubic_approximation, &
3106 : use_quadratic_approximation
3107 : REAL(KIND=dp) :: aa, bb, beta, conjugacy_error, conjugacy_error_threshold, &
3108 : delta_obj_function, denom, energy_correction_final, frob_matrix, frob_matrix_base, fun0, &
3109 : fun1, gfun0, gfun1, grad_norm, grad_norm_frob, kappa, kin_energy, line_search_error, &
3110 : line_search_error_threshold, num_threshold, numer, obj_function, quadratic_approx_error, &
3111 : quadratic_approx_error_threshold, safety_multiplier, spin_factor, step_size, &
3112 : step_size_quadratic_approx, step_size_quadratic_approx2, t1, t1a, t1cholesky, t2, t2a, &
3113 : t2cholesky, tau, time_step, x_opt_eps_adaptive, x_opt_eps_adaptive_factor
3114 : REAL(KIND=dp), DIMENSION(1) :: local_mu
3115 : REAL(KIND=dp), DIMENSION(2) :: energy_correction
3116 : REAL(KIND=dp), DIMENSION(3) :: minima
3117 : TYPE(cp_logger_type), POINTER :: logger
3118 : TYPE(ct_step_env_type) :: ct_step_env
3119 : TYPE(dbcsr_type) :: grad, k_vd_index_down, k_vr_index_down, matrix_k_central, matrix_tmp1, &
3120 : matrix_tmp2, prec, prev_grad, prev_minus_prec_grad, prev_step, sigma_oo_curr, &
3121 : sigma_oo_curr_inv, sigma_vv_sqrt, sigma_vv_sqrt_guess, sigma_vv_sqrt_inv, &
3122 : sigma_vv_sqrt_inv_guess, step, t_curr, tmp1_n_vr, tmp2_n_o, tmp3_vd_vr, tmp4_o_vr, &
3123 : tmp_k_blk, vd_fixed, vd_index_sqrt, vd_index_sqrt_inv, velocity, vr_fixed, vr_index_sqrt, &
3124 : vr_index_sqrt_inv
3125 0 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: matrix_p_almo_scf_converged
3126 :
3127 0 : CALL timeset(routineN, handle)
3128 :
3129 : ! get a useful output_unit
3130 0 : logger => cp_get_default_logger()
3131 0 : IF (logger%para_env%is_source()) THEN
3132 0 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
3133 : ELSE
3134 0 : unit_nr = -1
3135 : END IF
3136 :
3137 0 : nspin = almo_scf_env%nspins
3138 0 : energy_correction_final = 0.0_dp
3139 0 : IF (nspin == 1) THEN
3140 0 : spin_factor = 2.0_dp
3141 : ELSE
3142 0 : spin_factor = 1.0_dp
3143 : END IF
3144 :
3145 0 : IF (almo_scf_env%deloc_use_occ_orbs) THEN
3146 : algorithm_id = cayley_transform
3147 : ELSE
3148 0 : algorithm_id = dm_ls_step
3149 : END IF
3150 :
3151 0 : t1 = m_walltime()
3152 :
3153 0 : SELECT CASE (algorithm_id)
3154 : CASE (cayley_transform)
3155 :
3156 : ! rescale density matrix by spin factor
3157 : ! so the orbitals and density are consistent with each other
3158 0 : IF (almo_scf_env%nspins == 1) THEN
3159 0 : CALL dbcsr_scale(almo_scf_env%matrix_p(1), 1.0_dp/spin_factor)
3160 : END IF
3161 :
3162 : ! transform matrix_t not matrix_t_blk (we might need ALMOs later)
3163 0 : DO ispin = 1, nspin
3164 :
3165 : CALL dbcsr_copy(almo_scf_env%matrix_t(ispin), &
3166 0 : almo_scf_env%matrix_t_blk(ispin))
3167 :
3168 : ! obtain orthogonalization matrices for ALMOs
3169 : ! RZK-warning - remove this sqrt(sigma) and inv(sqrt(sigma))
3170 : ! ideally ALMO scf should use sigma and sigma_inv in
3171 : ! the tensor_up_down representation
3172 :
3173 0 : IF (unit_nr > 0) THEN
3174 0 : WRITE (unit_nr, *) "sqrt and inv(sqrt) of MO overlap matrix"
3175 : END IF
3176 : CALL dbcsr_create(almo_scf_env%matrix_sigma_sqrt(ispin), &
3177 : template=almo_scf_env%matrix_sigma(ispin), &
3178 0 : matrix_type=dbcsr_type_no_symmetry)
3179 : CALL dbcsr_create(almo_scf_env%matrix_sigma_sqrt_inv(ispin), &
3180 : template=almo_scf_env%matrix_sigma(ispin), &
3181 0 : matrix_type=dbcsr_type_no_symmetry)
3182 :
3183 : CALL matrix_sqrt_Newton_Schulz(almo_scf_env%matrix_sigma_sqrt(ispin), &
3184 : almo_scf_env%matrix_sigma_sqrt_inv(ispin), &
3185 : almo_scf_env%matrix_sigma(ispin), &
3186 : threshold=almo_scf_env%eps_filter, &
3187 : order=almo_scf_env%order_lanczos, &
3188 : eps_lanczos=almo_scf_env%eps_lanczos, &
3189 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
3190 :
3191 0 : IF (safe_mode) THEN
3192 : CALL dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_sigma(ispin), &
3193 : matrix_type=dbcsr_type_no_symmetry)
3194 : CALL dbcsr_create(matrix_tmp2, template=almo_scf_env%matrix_sigma(ispin), &
3195 : matrix_type=dbcsr_type_no_symmetry)
3196 :
3197 : CALL dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_sigma_sqrt_inv(ispin), &
3198 : almo_scf_env%matrix_sigma(ispin), &
3199 : 0.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
3200 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, &
3201 : almo_scf_env%matrix_sigma_sqrt_inv(ispin), &
3202 : 0.0_dp, matrix_tmp2, filter_eps=almo_scf_env%eps_filter)
3203 :
3204 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp2)
3205 : CALL dbcsr_add_on_diag(matrix_tmp2, -1.0_dp)
3206 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp2)
3207 : IF (unit_nr > 0) THEN
3208 : WRITE (unit_nr, *) "Error for (inv(sqrt(SIG))*SIG*inv(sqrt(SIG))-I)", frob_matrix/frob_matrix_base
3209 : END IF
3210 :
3211 : CALL dbcsr_release(matrix_tmp1)
3212 : CALL dbcsr_release(matrix_tmp2)
3213 : END IF
3214 : END DO
3215 :
3216 0 : IF (almo_scf_env%almo_update_algorithm == almo_scf_diag) THEN
3217 :
3218 0 : DO ispin = 1, nspin
3219 :
3220 0 : t1a = m_walltime()
3221 :
3222 0 : line_search_error_threshold = almo_scf_env%real01
3223 0 : conjugacy_error_threshold = almo_scf_env%real02
3224 0 : quadratic_approx_error_threshold = almo_scf_env%real03
3225 0 : x_opt_eps_adaptive_factor = almo_scf_env%real04
3226 :
3227 : !! the outer loop for k optimization
3228 0 : outer_opt_k_max_iter = almo_scf_env%opt_k_outer_max_iter
3229 0 : outer_opt_k_prepare_to_exit = .FALSE.
3230 0 : outer_opt_k_iteration = 0
3231 0 : grad_norm = 0.0_dp
3232 0 : grad_norm_frob = 0.0_dp
3233 0 : CALL dbcsr_set(almo_scf_env%matrix_x(ispin), 0.0_dp)
3234 0 : IF (almo_scf_env%deloc_truncate_virt == virt_full) outer_opt_k_max_iter = 0
3235 :
3236 0 : DO
3237 :
3238 : ! obtain proper retained virtuals (1-R)|ALMO_vr>
3239 : CALL apply_projector(psi_in=almo_scf_env%matrix_v_blk(ispin), &
3240 : psi_out=almo_scf_env%matrix_v(ispin), &
3241 : psi_projector=almo_scf_env%matrix_t_blk(ispin), &
3242 : metric=almo_scf_env%matrix_s(1), &
3243 : project_out=.TRUE., &
3244 : psi_projector_orthogonal=.FALSE., &
3245 : proj_in_template=almo_scf_env%matrix_ov(ispin), &
3246 : eps_filter=almo_scf_env%eps_filter, &
3247 0 : sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin))
3248 :
3249 : ! save initial retained virtuals
3250 : CALL dbcsr_create(vr_fixed, &
3251 0 : template=almo_scf_env%matrix_v(ispin))
3252 0 : CALL dbcsr_copy(vr_fixed, almo_scf_env%matrix_v(ispin))
3253 :
3254 : ! init matrices common for optimized and non-optimized virts
3255 : CALL dbcsr_create(sigma_vv_sqrt, &
3256 : template=almo_scf_env%matrix_sigma_vv(ispin), &
3257 0 : matrix_type=dbcsr_type_no_symmetry)
3258 : CALL dbcsr_create(sigma_vv_sqrt_inv, &
3259 : template=almo_scf_env%matrix_sigma_vv(ispin), &
3260 0 : matrix_type=dbcsr_type_no_symmetry)
3261 : CALL dbcsr_create(sigma_vv_sqrt_inv_guess, &
3262 : template=almo_scf_env%matrix_sigma_vv(ispin), &
3263 0 : matrix_type=dbcsr_type_no_symmetry)
3264 : CALL dbcsr_create(sigma_vv_sqrt_guess, &
3265 : template=almo_scf_env%matrix_sigma_vv(ispin), &
3266 0 : matrix_type=dbcsr_type_no_symmetry)
3267 0 : CALL dbcsr_set(sigma_vv_sqrt_guess, 0.0_dp)
3268 0 : CALL dbcsr_add_on_diag(sigma_vv_sqrt_guess, 1.0_dp)
3269 0 : CALL dbcsr_filter(sigma_vv_sqrt_guess, almo_scf_env%eps_filter)
3270 0 : CALL dbcsr_set(sigma_vv_sqrt_inv_guess, 0.0_dp)
3271 0 : CALL dbcsr_add_on_diag(sigma_vv_sqrt_inv_guess, 1.0_dp)
3272 0 : CALL dbcsr_filter(sigma_vv_sqrt_inv_guess, almo_scf_env%eps_filter)
3273 :
3274 : ! do things required to optimize virtuals
3275 0 : IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN
3276 :
3277 : ! project retained virtuals out of discarded block-by-block
3278 : ! (1-Q^VR_ALMO)|ALMO_vd>
3279 : ! this is probably not necessary, do it just to be safe
3280 :
3281 : ! construct discarded virtuals (1-R)|ALMO_vd>
3282 : CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin), &
3283 : psi_out=almo_scf_env%matrix_v_disc(ispin), &
3284 : psi_projector=almo_scf_env%matrix_t_blk(ispin), &
3285 : metric=almo_scf_env%matrix_s(1), &
3286 : project_out=.TRUE., &
3287 : psi_projector_orthogonal=.FALSE., &
3288 : proj_in_template=almo_scf_env%matrix_ov_disc(ispin), &
3289 : eps_filter=almo_scf_env%eps_filter, &
3290 0 : sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin))
3291 : !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),&
3292 :
3293 : ! save initial discarded
3294 : CALL dbcsr_create(vd_fixed, &
3295 0 : template=almo_scf_env%matrix_v_disc(ispin))
3296 0 : CALL dbcsr_copy(vd_fixed, almo_scf_env%matrix_v_disc(ispin))
3297 :
3298 : !! create the down metric in the retained k-subspace
3299 : CALL dbcsr_create(k_vr_index_down, &
3300 : template=almo_scf_env%matrix_sigma_vv_blk(ispin), &
3301 0 : matrix_type=dbcsr_type_no_symmetry)
3302 :
3303 : !! create the up metric in the discarded k-subspace
3304 : CALL dbcsr_create(k_vd_index_down, &
3305 : template=almo_scf_env%matrix_vv_disc_blk(ispin), &
3306 0 : matrix_type=dbcsr_type_no_symmetry)
3307 :
3308 : ! init matrices necessary for optimization of truncated virts
3309 : ! init blocked gradient before setting K to zero
3310 : ! otherwise the block structure might be lost
3311 : CALL dbcsr_create(grad, &
3312 0 : template=almo_scf_env%matrix_k_blk(ispin))
3313 0 : CALL dbcsr_copy(grad, almo_scf_env%matrix_k_blk(ispin))
3314 :
3315 : ! init MD in the k-space
3316 0 : md_in_k_space = almo_scf_env%logical01
3317 0 : IF (md_in_k_space) THEN
3318 : CALL dbcsr_create(velocity, &
3319 0 : template=almo_scf_env%matrix_k_blk(ispin))
3320 0 : CALL dbcsr_copy(velocity, almo_scf_env%matrix_k_blk(ispin))
3321 0 : CALL dbcsr_set(velocity, 0.0_dp)
3322 0 : time_step = almo_scf_env%opt_k_trial_step_size
3323 : END IF
3324 :
3325 : CALL dbcsr_create(prev_step, &
3326 0 : template=almo_scf_env%matrix_k_blk(ispin))
3327 :
3328 : CALL dbcsr_create(prev_minus_prec_grad, &
3329 0 : template=almo_scf_env%matrix_k_blk(ispin))
3330 :
3331 : ! initialize diagonal blocks of the preconditioner to 1.0_dp
3332 : CALL dbcsr_create(prec, &
3333 0 : template=almo_scf_env%matrix_k_blk(ispin))
3334 0 : CALL dbcsr_copy(prec, almo_scf_env%matrix_k_blk(ispin))
3335 0 : CALL dbcsr_set(prec, 1.0_dp)
3336 :
3337 : ! generate initial K (extrapolate if previous values are available)
3338 0 : CALL dbcsr_set(almo_scf_env%matrix_k_blk(ispin), 0.0_dp)
3339 : ! matrix_k_central stores current k because matrix_k_blk is updated
3340 : ! during linear search
3341 : CALL dbcsr_create(matrix_k_central, &
3342 0 : template=almo_scf_env%matrix_k_blk(ispin))
3343 : CALL dbcsr_copy(matrix_k_central, &
3344 0 : almo_scf_env%matrix_k_blk(ispin))
3345 : CALL dbcsr_create(tmp_k_blk, &
3346 0 : template=almo_scf_env%matrix_k_blk(ispin))
3347 : CALL dbcsr_create(step, &
3348 0 : template=almo_scf_env%matrix_k_blk(ispin))
3349 0 : CALL dbcsr_set(step, 0.0_dp)
3350 : CALL dbcsr_create(t_curr, &
3351 0 : template=almo_scf_env%matrix_t(ispin))
3352 : CALL dbcsr_create(sigma_oo_curr, &
3353 : template=almo_scf_env%matrix_sigma(ispin), &
3354 0 : matrix_type=dbcsr_type_no_symmetry)
3355 : CALL dbcsr_create(sigma_oo_curr_inv, &
3356 : template=almo_scf_env%matrix_sigma(ispin), &
3357 0 : matrix_type=dbcsr_type_no_symmetry)
3358 : CALL dbcsr_create(tmp1_n_vr, &
3359 0 : template=almo_scf_env%matrix_v(ispin))
3360 : CALL dbcsr_create(tmp3_vd_vr, &
3361 0 : template=almo_scf_env%matrix_k_blk(ispin))
3362 : CALL dbcsr_create(tmp2_n_o, &
3363 0 : template=almo_scf_env%matrix_t(ispin))
3364 : CALL dbcsr_create(tmp4_o_vr, &
3365 0 : template=almo_scf_env%matrix_ov(ispin))
3366 : CALL dbcsr_create(prev_grad, &
3367 0 : template=almo_scf_env%matrix_k_blk(ispin))
3368 0 : CALL dbcsr_set(prev_grad, 0.0_dp)
3369 :
3370 : END IF ! done constructing discarded virtuals
3371 :
3372 : ! init variables
3373 0 : opt_k_max_iter = almo_scf_env%opt_k_max_iter
3374 0 : iteration = 0
3375 0 : converged = .FALSE.
3376 0 : prepare_to_exit = .FALSE.
3377 0 : beta = 0.0_dp
3378 0 : line_search = .FALSE.
3379 0 : obj_function = 0.0_dp
3380 0 : conjugacy_error = 0.0_dp
3381 0 : line_search_error = 0.0_dp
3382 0 : fun0 = 0.0_dp
3383 0 : fun1 = 0.0_dp
3384 0 : gfun0 = 0.0_dp
3385 0 : gfun1 = 0.0_dp
3386 0 : step_size_quadratic_approx = 0.0_dp
3387 0 : reset_step_size = .TRUE.
3388 0 : IF (almo_scf_env%deloc_truncate_virt == virt_full) opt_k_max_iter = 0
3389 :
3390 : ! start cg iterations to optimize matrix_k_blk
3391 0 : DO
3392 :
3393 0 : CALL timeset('k_opt_vr', handle1)
3394 :
3395 0 : IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN
3396 :
3397 : ! construct k-excited virtuals
3398 : CALL dbcsr_multiply("N", "N", 1.0_dp, vd_fixed, &
3399 : almo_scf_env%matrix_k_blk(ispin), &
3400 : 0.0_dp, almo_scf_env%matrix_v(ispin), &
3401 0 : filter_eps=almo_scf_env%eps_filter)
3402 : CALL dbcsr_add(almo_scf_env%matrix_v(ispin), vr_fixed, &
3403 0 : +1.0_dp, +1.0_dp)
3404 : END IF
3405 :
3406 : ! decompose the overlap matrix of the current retained orbitals
3407 : CALL get_overlap(bra=almo_scf_env%matrix_v(ispin), &
3408 : ket=almo_scf_env%matrix_v(ispin), &
3409 : overlap=almo_scf_env%matrix_sigma_vv(ispin), &
3410 : metric=almo_scf_env%matrix_s(1), &
3411 : retain_overlap_sparsity=.FALSE., &
3412 0 : eps_filter=almo_scf_env%eps_filter)
3413 : ! use either cholesky or sqrt
3414 : !! RZK-warning: strangely, cholesky does not work with k-optimization
3415 0 : IF (almo_scf_env%deloc_truncate_virt == virt_full) THEN
3416 0 : CALL timeset('cholesky', handle2)
3417 0 : t1cholesky = m_walltime()
3418 :
3419 : ! re-create sigma_vv_sqrt because desymmetrize is buggy -
3420 : ! it will create multiple copies of blocks
3421 : CALL dbcsr_create(sigma_vv_sqrt, &
3422 : template=almo_scf_env%matrix_sigma_vv(ispin), &
3423 0 : matrix_type=dbcsr_type_no_symmetry)
3424 : CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma_vv(ispin), &
3425 0 : sigma_vv_sqrt)
3426 : CALL cp_dbcsr_cholesky_decompose(sigma_vv_sqrt, &
3427 : para_env=almo_scf_env%para_env, &
3428 0 : blacs_env=almo_scf_env%blacs_env)
3429 0 : CALL make_triu(sigma_vv_sqrt)
3430 0 : CALL dbcsr_filter(sigma_vv_sqrt, almo_scf_env%eps_filter)
3431 : ! apply SOLVE to compute U^(-1) : U*U^(-1)=I
3432 0 : CALL dbcsr_get_info(sigma_vv_sqrt, nfullrows_total=n)
3433 : CALL dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_sigma_vv(ispin), &
3434 0 : matrix_type=dbcsr_type_no_symmetry)
3435 0 : CALL dbcsr_set(matrix_tmp1, 0.0_dp)
3436 0 : CALL dbcsr_add_on_diag(matrix_tmp1, 1.0_dp)
3437 : CALL cp_dbcsr_cholesky_restore(matrix_tmp1, n, sigma_vv_sqrt, &
3438 : sigma_vv_sqrt_inv, op="SOLVE", pos="RIGHT", &
3439 : para_env=almo_scf_env%para_env, &
3440 0 : blacs_env=almo_scf_env%blacs_env)
3441 0 : CALL dbcsr_filter(sigma_vv_sqrt_inv, almo_scf_env%eps_filter)
3442 0 : CALL dbcsr_release(matrix_tmp1)
3443 : IF (safe_mode) THEN
3444 : CALL dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_sigma_vv(ispin), &
3445 : matrix_type=dbcsr_type_no_symmetry)
3446 : CALL dbcsr_desymmetrize(almo_scf_env%matrix_sigma_vv(ispin), &
3447 : matrix_tmp1)
3448 : CALL dbcsr_multiply("T", "N", 1.0_dp, sigma_vv_sqrt, &
3449 : sigma_vv_sqrt, &
3450 : -1.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
3451 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp1)
3452 : CALL dbcsr_add_on_diag(matrix_tmp1, 1.0_dp)
3453 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1)
3454 : IF (unit_nr > 0) THEN
3455 : WRITE (unit_nr, *) "Error for ( U^T * U - Sig )", &
3456 : frob_matrix/frob_matrix_base
3457 : END IF
3458 : CALL dbcsr_multiply("N", "N", 1.0_dp, sigma_vv_sqrt_inv, &
3459 : sigma_vv_sqrt, &
3460 : 0.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
3461 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1)
3462 : CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp)
3463 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp1)
3464 : IF (unit_nr > 0) THEN
3465 : WRITE (unit_nr, *) "Error for ( inv(U) * U - I )", &
3466 : frob_matrix/frob_matrix_base
3467 : END IF
3468 : CALL dbcsr_release(matrix_tmp1)
3469 : END IF ! safe_mode
3470 0 : t2cholesky = m_walltime()
3471 0 : IF (unit_nr > 0) THEN
3472 0 : WRITE (unit_nr, *) "Cholesky+inverse wall-time: ", t2cholesky - t1cholesky
3473 : END IF
3474 0 : CALL timestop(handle2)
3475 : ELSE
3476 : CALL matrix_sqrt_Newton_Schulz(sigma_vv_sqrt, &
3477 : sigma_vv_sqrt_inv, &
3478 : almo_scf_env%matrix_sigma_vv(ispin), &
3479 : threshold=almo_scf_env%eps_filter, &
3480 : order=almo_scf_env%order_lanczos, &
3481 : eps_lanczos=almo_scf_env%eps_lanczos, &
3482 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
3483 0 : CALL dbcsr_copy(sigma_vv_sqrt_inv_guess, sigma_vv_sqrt_inv)
3484 0 : CALL dbcsr_copy(sigma_vv_sqrt_guess, sigma_vv_sqrt)
3485 : IF (safe_mode) THEN
3486 : CALL dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_sigma_vv(ispin), &
3487 : matrix_type=dbcsr_type_no_symmetry)
3488 : CALL dbcsr_create(matrix_tmp2, template=almo_scf_env%matrix_sigma_vv(ispin), &
3489 : matrix_type=dbcsr_type_no_symmetry)
3490 :
3491 : CALL dbcsr_multiply("N", "N", 1.0_dp, sigma_vv_sqrt_inv, &
3492 : almo_scf_env%matrix_sigma_vv(ispin), &
3493 : 0.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
3494 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, &
3495 : sigma_vv_sqrt_inv, &
3496 : 0.0_dp, matrix_tmp2, filter_eps=almo_scf_env%eps_filter)
3497 :
3498 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp2)
3499 : CALL dbcsr_add_on_diag(matrix_tmp2, -1.0_dp)
3500 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp2)
3501 : IF (unit_nr > 0) THEN
3502 : WRITE (unit_nr, *) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)", &
3503 : frob_matrix/frob_matrix_base
3504 : END IF
3505 :
3506 : CALL dbcsr_release(matrix_tmp1)
3507 : CALL dbcsr_release(matrix_tmp2)
3508 : END IF
3509 : END IF
3510 0 : CALL timestop(handle1)
3511 :
3512 : ! compute excitation amplitudes (to the current set of retained virtuals)
3513 : ! set convergence criterion for x-optimization
3514 0 : IF ((iteration == 0) .AND. (.NOT. line_search) .AND. &
3515 : (outer_opt_k_iteration == 0)) THEN
3516 : x_opt_eps_adaptive = &
3517 0 : almo_scf_env%deloc_cayley_eps_convergence
3518 : ELSE
3519 : x_opt_eps_adaptive = &
3520 : MAX(ABS(almo_scf_env%deloc_cayley_eps_convergence), &
3521 0 : ABS(x_opt_eps_adaptive_factor*grad_norm))
3522 : END IF
3523 0 : CALL ct_step_env_init(ct_step_env)
3524 : CALL ct_step_env_set(ct_step_env, &
3525 : para_env=almo_scf_env%para_env, &
3526 : blacs_env=almo_scf_env%blacs_env, &
3527 : use_occ_orbs=.TRUE., &
3528 : use_virt_orbs=.TRUE., &
3529 : occ_orbs_orthogonal=.FALSE., &
3530 : virt_orbs_orthogonal=.FALSE., &
3531 : pp_preconditioner_full=almo_scf_env%deloc_cayley_occ_precond, &
3532 : qq_preconditioner_full=almo_scf_env%deloc_cayley_vir_precond, &
3533 : tensor_type=almo_scf_env%deloc_cayley_tensor_type, &
3534 : neglect_quadratic_term=almo_scf_env%deloc_cayley_linear, &
3535 : conjugator=almo_scf_env%deloc_cayley_conjugator, &
3536 : max_iter=almo_scf_env%deloc_cayley_max_iter, &
3537 : calculate_energy_corr=.TRUE., &
3538 : update_p=.FALSE., &
3539 : update_q=.FALSE., &
3540 : eps_convergence=x_opt_eps_adaptive, &
3541 : eps_filter=almo_scf_env%eps_filter, &
3542 : !nspins=1,&
3543 : q_index_up=sigma_vv_sqrt_inv, &
3544 : q_index_down=sigma_vv_sqrt, &
3545 : p_index_up=almo_scf_env%matrix_sigma_sqrt_inv(ispin), &
3546 : p_index_down=almo_scf_env%matrix_sigma_sqrt(ispin), &
3547 : matrix_ks=almo_scf_env%matrix_ks_0deloc(ispin), &
3548 : matrix_t=almo_scf_env%matrix_t(ispin), &
3549 : matrix_qp_template=almo_scf_env%matrix_vo(ispin), &
3550 : matrix_pq_template=almo_scf_env%matrix_ov(ispin), &
3551 : matrix_v=almo_scf_env%matrix_v(ispin), &
3552 0 : matrix_x_guess=almo_scf_env%matrix_x(ispin))
3553 : ! perform calculations
3554 0 : CALL ct_step_execute(ct_step_env)
3555 : ! get the energy correction
3556 : CALL ct_step_env_get(ct_step_env, &
3557 : energy_correction=energy_correction(ispin), &
3558 0 : copy_matrix_x=almo_scf_env%matrix_x(ispin))
3559 0 : CALL ct_step_env_clean(ct_step_env)
3560 : ! RZK-warning matrix_x is being transformed
3561 : ! back and forth between orth and up_down representations
3562 0 : energy_correction(1) = energy_correction(1)*spin_factor
3563 :
3564 0 : IF (opt_k_max_iter /= 0) THEN
3565 :
3566 0 : CALL timeset('k_opt_t_curr', handle3)
3567 :
3568 : ! construct current occupied orbitals T_blk + V_r*X
3569 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
3570 : almo_scf_env%matrix_v(ispin), &
3571 : almo_scf_env%matrix_x(ispin), &
3572 : 0.0_dp, t_curr, &
3573 0 : filter_eps=almo_scf_env%eps_filter)
3574 : CALL dbcsr_add(t_curr, almo_scf_env%matrix_t_blk(ispin), &
3575 0 : +1.0_dp, +1.0_dp)
3576 :
3577 : ! calculate current occupied overlap
3578 : CALL get_overlap(bra=t_curr, &
3579 : ket=t_curr, &
3580 : overlap=sigma_oo_curr, &
3581 : metric=almo_scf_env%matrix_s(1), &
3582 : retain_overlap_sparsity=.FALSE., &
3583 0 : eps_filter=almo_scf_env%eps_filter)
3584 0 : IF (iteration == 0) THEN
3585 : CALL invert_Hotelling(sigma_oo_curr_inv, &
3586 : sigma_oo_curr, &
3587 : threshold=almo_scf_env%eps_filter, &
3588 0 : use_inv_as_guess=.FALSE.)
3589 : ELSE
3590 : CALL invert_Hotelling(sigma_oo_curr_inv, &
3591 : sigma_oo_curr, &
3592 : threshold=almo_scf_env%eps_filter, &
3593 0 : use_inv_as_guess=.TRUE.)
3594 : END IF
3595 : IF (safe_mode) THEN
3596 : CALL dbcsr_create(matrix_tmp1, template=sigma_oo_curr, &
3597 : matrix_type=dbcsr_type_no_symmetry)
3598 : CALL dbcsr_multiply("N", "N", 1.0_dp, sigma_oo_curr, &
3599 : sigma_oo_curr_inv, &
3600 : 0.0_dp, matrix_tmp1, &
3601 : filter_eps=almo_scf_env%eps_filter)
3602 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1)
3603 : CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp)
3604 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp1)
3605 : IF (unit_nr > 0) THEN
3606 : WRITE (unit_nr, *) "Error for (SIG*inv(SIG)-I)", &
3607 : frob_matrix/frob_matrix_base, frob_matrix_base
3608 : END IF
3609 : CALL dbcsr_release(matrix_tmp1)
3610 : END IF
3611 : IF (safe_mode) THEN
3612 : CALL dbcsr_create(matrix_tmp1, template=sigma_oo_curr, &
3613 : matrix_type=dbcsr_type_no_symmetry)
3614 : CALL dbcsr_multiply("N", "N", 1.0_dp, sigma_oo_curr_inv, &
3615 : sigma_oo_curr, &
3616 : 0.0_dp, matrix_tmp1, &
3617 : filter_eps=almo_scf_env%eps_filter)
3618 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1)
3619 : CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp)
3620 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp1)
3621 : IF (unit_nr > 0) THEN
3622 : WRITE (unit_nr, *) "Error for (inv(SIG)*SIG-I)", &
3623 : frob_matrix/frob_matrix_base, frob_matrix_base
3624 : END IF
3625 : CALL dbcsr_release(matrix_tmp1)
3626 : END IF
3627 :
3628 0 : CALL timestop(handle3)
3629 0 : CALL timeset('k_opt_vd', handle4)
3630 :
3631 : ! construct current discarded virtuals:
3632 : ! (1-R_curr)(1-Q^VR_curr)|ALMO_vd_basis> =
3633 : ! = (1-Q^VR_curr)|ALMO_vd_basis>
3634 : ! use sigma_vv_sqrt to store the inverse of the overlap
3635 : ! sigma_vv_inv is computed from sqrt/cholesky
3636 : CALL dbcsr_multiply("N", "T", 1.0_dp, &
3637 : sigma_vv_sqrt_inv, &
3638 : sigma_vv_sqrt_inv, &
3639 : 0.0_dp, sigma_vv_sqrt, &
3640 0 : filter_eps=almo_scf_env%eps_filter)
3641 : CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin), &
3642 : psi_out=almo_scf_env%matrix_v_disc(ispin), &
3643 : psi_projector=almo_scf_env%matrix_v(ispin), &
3644 : metric=almo_scf_env%matrix_s(1), &
3645 : project_out=.FALSE., &
3646 : psi_projector_orthogonal=.FALSE., &
3647 : proj_in_template=almo_scf_env%matrix_k_tr(ispin), &
3648 : eps_filter=almo_scf_env%eps_filter, &
3649 0 : sig_inv_projector=sigma_vv_sqrt)
3650 : !sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin),&
3651 : CALL dbcsr_add(almo_scf_env%matrix_v_disc(ispin), &
3652 0 : vd_fixed, -1.0_dp, +1.0_dp)
3653 :
3654 0 : CALL timestop(handle4)
3655 0 : CALL timeset('k_opt_grad', handle5)
3656 :
3657 : ! evaluate the gradient from the assembled components
3658 : ! grad_xx = c0 [ (Vd_curr^tr)*F*T_curr*sigma_oo_curr_inv*(X^tr)]_xx
3659 : ! save previous gradient to calculate conjugation coef
3660 0 : IF (line_search) THEN
3661 0 : CALL dbcsr_copy(prev_grad, grad)
3662 : END IF
3663 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
3664 : almo_scf_env%matrix_ks_0deloc(ispin), &
3665 : t_curr, &
3666 : 0.0_dp, tmp2_n_o, &
3667 0 : filter_eps=almo_scf_env%eps_filter)
3668 : CALL dbcsr_multiply("N", "T", 1.0_dp, &
3669 : sigma_oo_curr_inv, &
3670 : almo_scf_env%matrix_x(ispin), &
3671 : 0.0_dp, tmp4_o_vr, &
3672 0 : filter_eps=almo_scf_env%eps_filter)
3673 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
3674 : tmp2_n_o, &
3675 : tmp4_o_vr, &
3676 : 0.0_dp, tmp1_n_vr, &
3677 0 : filter_eps=almo_scf_env%eps_filter)
3678 : CALL dbcsr_multiply("T", "N", 2.0_dp*spin_factor, &
3679 : almo_scf_env%matrix_v_disc(ispin), &
3680 : tmp1_n_vr, &
3681 : 0.0_dp, grad, &
3682 0 : retain_sparsity=.TRUE.)
3683 : ! keep tmp2_n_o for the next step
3684 : ! keep tmp4_o_vr for the preconditioner
3685 :
3686 : ! check convergence and other exit criteria
3687 0 : grad_norm_frob = dbcsr_frobenius_norm(grad)
3688 0 : grad_norm = dbcsr_maxabs(grad)
3689 0 : converged = (grad_norm < almo_scf_env%opt_k_eps_convergence)
3690 0 : IF (converged .OR. (iteration >= opt_k_max_iter)) THEN
3691 0 : prepare_to_exit = .TRUE.
3692 : END IF
3693 0 : CALL timestop(handle5)
3694 :
3695 0 : IF (.NOT. prepare_to_exit) THEN
3696 :
3697 0 : CALL timeset('k_opt_energy', handle6)
3698 :
3699 : ! compute "energy" c0*Tr[sig_inv_oo*t*F*t]
3700 : CALL dbcsr_multiply("T", "N", spin_factor, &
3701 : t_curr, &
3702 : tmp2_n_o, &
3703 : 0.0_dp, sigma_oo_curr, &
3704 0 : filter_eps=almo_scf_env%eps_filter)
3705 : delta_obj_function = fun0
3706 0 : CALL dbcsr_dot(sigma_oo_curr_inv, sigma_oo_curr, obj_function)
3707 0 : delta_obj_function = obj_function - delta_obj_function
3708 0 : IF (line_search) THEN
3709 : fun1 = obj_function
3710 : ELSE
3711 0 : fun0 = obj_function
3712 : END IF
3713 :
3714 0 : CALL timestop(handle6)
3715 :
3716 : ! update the step direction
3717 0 : IF (.NOT. line_search) THEN
3718 :
3719 0 : CALL timeset('k_opt_step', handle7)
3720 :
3721 0 : IF ((.NOT. md_in_k_space) .AND. &
3722 : (iteration >= MAX(0, almo_scf_env%opt_k_prec_iter_start) .AND. &
3723 : MOD(iteration - almo_scf_env%opt_k_prec_iter_start, &
3724 : almo_scf_env%opt_k_prec_iter_freq) == 0)) THEN
3725 :
3726 : !IF ((iteration.eq.0).AND.(.NOT.md_in_k_space)) THEN
3727 :
3728 : ! compute the preconditioner
3729 0 : IF (unit_nr > 0) THEN
3730 0 : WRITE (unit_nr, *) "Computing preconditioner"
3731 : END IF
3732 : CALL opt_k_create_preconditioner_blk(almo_scf_env, &
3733 : almo_scf_env%matrix_v_disc(ispin), &
3734 : tmp4_o_vr, &
3735 : t_curr, &
3736 : ispin, &
3737 0 : spin_factor)
3738 :
3739 : END IF
3740 :
3741 : ! save the previous step
3742 0 : CALL dbcsr_copy(prev_step, step)
3743 :
3744 : ! compute the new step
3745 : CALL opt_k_apply_preconditioner_blk(almo_scf_env, &
3746 0 : step, grad, ispin)
3747 0 : CALL dbcsr_scale(step, -1.0_dp)
3748 :
3749 : ! check whether we need to reset conjugate directions
3750 0 : reset_conjugator = .FALSE.
3751 : ! first check if manual reset is active
3752 0 : IF (iteration < MAX(almo_scf_env%opt_k_conj_iter_start, 1) .OR. &
3753 : MOD(iteration - almo_scf_env%opt_k_conj_iter_start, &
3754 : almo_scf_env%opt_k_conj_iter_freq) == 0) THEN
3755 :
3756 : reset_conjugator = .TRUE.
3757 :
3758 : ELSE
3759 :
3760 : ! check for the errors in the cg algorithm
3761 0 : CALL dbcsr_dot(grad, prev_minus_prec_grad, numer)
3762 0 : CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom)
3763 0 : conjugacy_error = numer/denom
3764 :
3765 0 : IF (conjugacy_error > MIN(0.5_dp, conjugacy_error_threshold)) THEN
3766 0 : reset_conjugator = .TRUE.
3767 0 : IF (unit_nr > 0) THEN
3768 0 : WRITE (unit_nr, *) "Lack of progress, conjugacy error is ", conjugacy_error
3769 : END IF
3770 : END IF
3771 :
3772 : ! check the gradient along the previous direction
3773 0 : IF ((iteration /= 0) .AND. (.NOT. reset_conjugator)) THEN
3774 0 : CALL dbcsr_dot(grad, prev_step, numer)
3775 0 : CALL dbcsr_dot(prev_grad, prev_step, denom)
3776 0 : line_search_error = numer/denom
3777 0 : IF (line_search_error > line_search_error_threshold) THEN
3778 0 : reset_conjugator = .TRUE.
3779 0 : IF (unit_nr > 0) THEN
3780 0 : WRITE (unit_nr, *) "Bad line search, line search error is ", line_search_error
3781 : END IF
3782 : END IF
3783 : END IF
3784 :
3785 : END IF
3786 :
3787 : ! compute the conjugation coefficient - beta
3788 0 : IF (.NOT. reset_conjugator) THEN
3789 :
3790 0 : SELECT CASE (almo_scf_env%opt_k_conjugator)
3791 : CASE (cg_hestenes_stiefel)
3792 0 : CALL dbcsr_copy(tmp_k_blk, grad)
3793 0 : CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp)
3794 0 : CALL dbcsr_dot(tmp_k_blk, step, numer)
3795 0 : CALL dbcsr_dot(tmp_k_blk, prev_step, denom)
3796 0 : beta = -1.0_dp*numer/denom
3797 : CASE (cg_fletcher_reeves)
3798 0 : CALL dbcsr_dot(grad, step, numer)
3799 0 : CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom)
3800 0 : beta = numer/denom
3801 : CASE (cg_polak_ribiere)
3802 0 : CALL dbcsr_dot(prev_grad, prev_minus_prec_grad, denom)
3803 0 : CALL dbcsr_copy(tmp_k_blk, grad)
3804 0 : CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp)
3805 0 : CALL dbcsr_dot(tmp_k_blk, step, numer)
3806 0 : beta = numer/denom
3807 : CASE (cg_fletcher)
3808 0 : CALL dbcsr_dot(grad, step, numer)
3809 0 : CALL dbcsr_dot(prev_grad, prev_step, denom)
3810 0 : beta = numer/denom
3811 : CASE (cg_liu_storey)
3812 0 : CALL dbcsr_dot(prev_grad, prev_step, denom)
3813 0 : CALL dbcsr_copy(tmp_k_blk, grad)
3814 0 : CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp)
3815 0 : CALL dbcsr_dot(tmp_k_blk, step, numer)
3816 0 : beta = numer/denom
3817 : CASE (cg_dai_yuan)
3818 0 : CALL dbcsr_dot(grad, step, numer)
3819 0 : CALL dbcsr_copy(tmp_k_blk, grad)
3820 0 : CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp)
3821 0 : CALL dbcsr_dot(tmp_k_blk, prev_step, denom)
3822 0 : beta = -1.0_dp*numer/denom
3823 : CASE (cg_hager_zhang)
3824 0 : CALL dbcsr_copy(tmp_k_blk, grad)
3825 0 : CALL dbcsr_add(tmp_k_blk, prev_grad, 1.0_dp, -1.0_dp)
3826 0 : CALL dbcsr_dot(tmp_k_blk, prev_step, denom)
3827 0 : CALL dbcsr_dot(tmp_k_blk, prev_minus_prec_grad, numer)
3828 0 : kappa = -2.0_dp*numer/denom
3829 0 : CALL dbcsr_dot(tmp_k_blk, step, numer)
3830 0 : tau = -1.0_dp*numer/denom
3831 0 : CALL dbcsr_dot(prev_step, grad, numer)
3832 0 : beta = tau - kappa*numer/denom
3833 : CASE (cg_zero)
3834 0 : beta = 0.0_dp
3835 : CASE DEFAULT
3836 0 : CPABORT("illegal conjugator")
3837 : END SELECT
3838 :
3839 0 : IF (beta < 0.0_dp) THEN
3840 0 : IF (unit_nr > 0) THEN
3841 0 : WRITE (unit_nr, *) "Beta is negative, ", beta
3842 : END IF
3843 : reset_conjugator = .TRUE.
3844 : END IF
3845 :
3846 : END IF
3847 :
3848 0 : IF (md_in_k_space) THEN
3849 : reset_conjugator = .TRUE.
3850 : END IF
3851 :
3852 0 : IF (reset_conjugator) THEN
3853 :
3854 0 : beta = 0.0_dp
3855 :
3856 0 : IF (unit_nr > 0) THEN
3857 0 : WRITE (unit_nr, *) "(Re)-setting conjugator to zero"
3858 : END IF
3859 :
3860 : END IF
3861 :
3862 : ! save the preconditioned gradient
3863 0 : CALL dbcsr_copy(prev_minus_prec_grad, step)
3864 :
3865 : ! conjugate the step direction
3866 0 : CALL dbcsr_add(step, prev_step, 1.0_dp, beta)
3867 :
3868 0 : CALL timestop(handle7)
3869 :
3870 : ! update the step direction
3871 : ELSE ! step update
3872 0 : conjugacy_error = 0.0_dp
3873 : END IF
3874 :
3875 : ! compute the gradient with respect to the step size in the curr direction
3876 0 : IF (line_search) THEN
3877 0 : CALL dbcsr_dot(grad, step, gfun1)
3878 0 : line_search_error = gfun1/gfun0
3879 : ELSE
3880 0 : CALL dbcsr_dot(grad, step, gfun0)
3881 : END IF
3882 :
3883 : ! make a step - update k
3884 0 : IF (line_search) THEN
3885 :
3886 : ! check if the trial step provides enough numerical accuracy
3887 0 : safety_multiplier = 1.0E+1_dp ! must be more than one
3888 : num_threshold = MAX(EPSILON(1.0_dp), &
3889 0 : safety_multiplier*(almo_scf_env%eps_filter**2)*almo_scf_env%ndomains)
3890 0 : IF (ABS(fun1 - fun0 - gfun0*step_size) < num_threshold) THEN
3891 0 : IF (unit_nr > 0) THEN
3892 : WRITE (unit_nr, '(T3,A,1X,E17.7)') &
3893 0 : "Numerical accuracy is too low to observe non-linear behavior", &
3894 0 : ABS(fun1 - fun0 - gfun0*step_size)
3895 0 : WRITE (unit_nr, '(T3,A,1X,E17.7,A,1X,E12.3)') "Error computing ", &
3896 0 : ABS(gfun0), &
3897 0 : " is smaller than the threshold", num_threshold
3898 : END IF
3899 0 : CPABORT("Unable to continue with low numerical accuracy")
3900 : END IF
3901 0 : IF (ABS(gfun0) < num_threshold) THEN
3902 0 : IF (unit_nr > 0) THEN
3903 0 : WRITE (unit_nr, '(T3,A,1X,E17.7,A,1X,E12.3)') "Linear gradient", &
3904 0 : ABS(gfun0), &
3905 0 : " is smaller than the threshold", num_threshold
3906 : END IF
3907 0 : CPABORT("Unable to continue with low numerical accuracy")
3908 : END IF
3909 :
3910 0 : use_quadratic_approximation = .TRUE.
3911 0 : use_cubic_approximation = .FALSE.
3912 :
3913 : ! find the minimum assuming quadratic form
3914 : ! use f0, f1, g0
3915 0 : step_size_quadratic_approx = -(gfun0*step_size*step_size)/(2.0_dp*(fun1 - fun0 - gfun0*step_size))
3916 : ! use f0, f1, g1
3917 0 : step_size_quadratic_approx2 = -(fun1 - fun0 - step_size*gfun1/2.0_dp)/(gfun1 - (fun1 - fun0)/step_size)
3918 :
3919 0 : IF ((step_size_quadratic_approx < 0.0_dp) .AND. &
3920 : (step_size_quadratic_approx2 < 0.0_dp)) THEN
3921 0 : IF (unit_nr > 0) THEN
3922 : WRITE (unit_nr, '(T3,A,1X,E17.7,1X,E17.7,1X,A)') &
3923 0 : "Quadratic approximation gives negative steps", &
3924 0 : step_size_quadratic_approx, step_size_quadratic_approx2, &
3925 0 : "trying cubic..."
3926 : END IF
3927 : use_cubic_approximation = .TRUE.
3928 : use_quadratic_approximation = .FALSE.
3929 : ELSE
3930 0 : IF (step_size_quadratic_approx < 0.0_dp) THEN
3931 0 : step_size_quadratic_approx = step_size_quadratic_approx2
3932 : END IF
3933 0 : IF (step_size_quadratic_approx2 < 0.0_dp) THEN
3934 0 : step_size_quadratic_approx2 = step_size_quadratic_approx
3935 : END IF
3936 : END IF
3937 :
3938 : ! check accuracy of the quadratic approximation
3939 : IF (use_quadratic_approximation) THEN
3940 : quadratic_approx_error = ABS(step_size_quadratic_approx - &
3941 0 : step_size_quadratic_approx2)/step_size_quadratic_approx
3942 0 : IF (quadratic_approx_error > quadratic_approx_error_threshold) THEN
3943 0 : IF (unit_nr > 0) THEN
3944 0 : WRITE (unit_nr, '(T3,A,1X,E17.7,1X,E17.7,1X,A)') "Quadratic approximation is poor", &
3945 0 : step_size_quadratic_approx, step_size_quadratic_approx2, &
3946 0 : "Try cubic approximation"
3947 : END IF
3948 : use_cubic_approximation = .TRUE.
3949 : use_quadratic_approximation = .FALSE.
3950 : END IF
3951 : END IF
3952 :
3953 : ! check if numerics is fine enough to capture the cubic form
3954 0 : IF (use_cubic_approximation) THEN
3955 :
3956 : ! if quadratic approximation is not accurate enough
3957 : ! try to find the minimum assuming cubic form
3958 : ! aa*x**3 + bb*x**2 + cc*x + dd = f(x)
3959 0 : bb = (-step_size*gfun1 + 3.0_dp*(fun1 - fun0) - 2.0_dp*step_size*gfun0)/(step_size*step_size)
3960 0 : aa = (gfun1 - 2.0_dp*step_size*bb - gfun0)/(3.0_dp*step_size*step_size)
3961 :
3962 0 : IF (ABS(gfun1 - 2.0_dp*step_size*bb - gfun0) < num_threshold) THEN
3963 0 : IF (unit_nr > 0) THEN
3964 : WRITE (unit_nr, '(T3,A,1X,E17.7)') &
3965 0 : "Numerical accuracy is too low to observe cubic behavior", &
3966 0 : ABS(gfun1 - 2.0_dp*step_size*bb - gfun0)
3967 : END IF
3968 : use_cubic_approximation = .FALSE.
3969 : use_quadratic_approximation = .TRUE.
3970 : END IF
3971 0 : IF (ABS(gfun1) < num_threshold) THEN
3972 0 : IF (unit_nr > 0) THEN
3973 0 : WRITE (unit_nr, '(T3,A,1X,E17.7,A,1X,E12.3)') "Linear gradient", &
3974 0 : ABS(gfun1), &
3975 0 : " is smaller than the threshold", num_threshold
3976 : END IF
3977 : use_cubic_approximation = .FALSE.
3978 : use_quadratic_approximation = .TRUE.
3979 : END IF
3980 : END IF
3981 :
3982 : ! find the step assuming cubic approximation
3983 0 : IF (use_cubic_approximation) THEN
3984 : ! to obtain the minimum of the cubic function solve the quadratic equation
3985 : ! 0.0*x**3 + 3.0*aa*x**2 + 2.0*bb*x + cc = 0
3986 0 : CALL analytic_line_search(0.0_dp, 3.0_dp*aa, 2.0_dp*bb, gfun0, minima, nmins)
3987 0 : IF (nmins < 1) THEN
3988 0 : IF (unit_nr > 0) THEN
3989 : WRITE (unit_nr, '(T3,A)') &
3990 0 : "Cubic approximation gives zero soultions! Use quadratic approximation"
3991 : END IF
3992 : use_quadratic_approximation = .TRUE.
3993 : use_cubic_approximation = .TRUE.
3994 : ELSE
3995 0 : step_size = minima(1)
3996 0 : IF (nmins > 1) THEN
3997 0 : IF (unit_nr > 0) THEN
3998 : WRITE (unit_nr, '(T3,A)') &
3999 0 : "More than one solution found! Use quadratic approximation"
4000 : END IF
4001 : use_quadratic_approximation = .TRUE.
4002 0 : use_cubic_approximation = .TRUE.
4003 : END IF
4004 : END IF
4005 : END IF
4006 :
4007 0 : IF (use_quadratic_approximation) THEN ! use quadratic approximation
4008 0 : IF (unit_nr > 0) THEN
4009 0 : WRITE (unit_nr, '(T3,A)') "Use quadratic approximation"
4010 : END IF
4011 0 : step_size = (step_size_quadratic_approx + step_size_quadratic_approx2)*0.5_dp
4012 : END IF
4013 :
4014 : ! one more check on the step size
4015 0 : IF (step_size < 0.0_dp) THEN
4016 0 : CPABORT("Negative step proposed")
4017 : END IF
4018 :
4019 : CALL dbcsr_copy(almo_scf_env%matrix_k_blk(ispin), &
4020 0 : matrix_k_central)
4021 : CALL dbcsr_add(almo_scf_env%matrix_k_blk(ispin), &
4022 0 : step, 1.0_dp, step_size)
4023 : CALL dbcsr_copy(matrix_k_central, &
4024 0 : almo_scf_env%matrix_k_blk(ispin))
4025 0 : line_search = .FALSE.
4026 :
4027 : ELSE
4028 :
4029 0 : IF (md_in_k_space) THEN
4030 :
4031 : ! update velocities v(i) = v(i-1) + 0.5*dT*(a(i-1) + a(i))
4032 0 : IF (iteration /= 0) THEN
4033 : CALL dbcsr_add(velocity, &
4034 0 : step, 1.0_dp, 0.5_dp*time_step)
4035 : CALL dbcsr_add(velocity, &
4036 0 : prev_step, 1.0_dp, 0.5_dp*time_step)
4037 : END IF
4038 0 : kin_energy = dbcsr_frobenius_norm(velocity)
4039 0 : kin_energy = 0.5_dp*kin_energy*kin_energy
4040 :
4041 : ! update positions k(i) = k(i-1) + dT*v(i-1) + 0.5*dT*dT*a(i-1)
4042 : CALL dbcsr_add(almo_scf_env%matrix_k_blk(ispin), &
4043 0 : velocity, 1.0_dp, time_step)
4044 : CALL dbcsr_add(almo_scf_env%matrix_k_blk(ispin), &
4045 0 : step, 1.0_dp, 0.5_dp*time_step*time_step)
4046 :
4047 : ELSE
4048 :
4049 0 : IF (reset_step_size) THEN
4050 0 : step_size = almo_scf_env%opt_k_trial_step_size
4051 0 : reset_step_size = .FALSE.
4052 : ELSE
4053 0 : step_size = step_size*almo_scf_env%opt_k_trial_step_size_multiplier
4054 : END IF
4055 : CALL dbcsr_copy(almo_scf_env%matrix_k_blk(ispin), &
4056 0 : matrix_k_central)
4057 : CALL dbcsr_add(almo_scf_env%matrix_k_blk(ispin), &
4058 0 : step, 1.0_dp, step_size)
4059 0 : line_search = .TRUE.
4060 : END IF
4061 :
4062 : END IF
4063 :
4064 : END IF ! .NOT.prepare_to_exit
4065 :
4066 : ! print the status of the optimization
4067 0 : t2a = m_walltime()
4068 0 : IF (unit_nr > 0) THEN
4069 0 : IF (md_in_k_space) THEN
4070 : WRITE (unit_nr, '(T6,A,1X,I5,1X,E12.3,E16.7,F15.9,F15.9,F15.9,E12.3,F15.9,F15.9,F8.3)') &
4071 0 : "K iter CG", iteration, time_step, time_step*iteration, &
4072 0 : energy_correction(ispin), obj_function, delta_obj_function, grad_norm, &
4073 0 : kin_energy, kin_energy + obj_function, beta
4074 : ELSE
4075 0 : IF (line_search .OR. prepare_to_exit) THEN
4076 : WRITE (unit_nr, '(T6,A,1X,I3,1X,E12.3,F16.10,F16.10,E12.3,E12.3,E12.3,F8.3,F8.3,F10.3)') &
4077 0 : "K iter CG", iteration, step_size, &
4078 0 : energy_correction(ispin), delta_obj_function, grad_norm, &
4079 0 : gfun0, line_search_error, beta, conjugacy_error, t2a - t1a
4080 : ELSE
4081 : WRITE (unit_nr, '(T6,A,1X,I3,1X,E12.3,F16.10,F16.10,E12.3,E12.3,E12.3,F8.3,F8.3,F10.3)') &
4082 0 : "K iter LS", iteration, step_size, &
4083 0 : energy_correction(ispin), delta_obj_function, grad_norm, &
4084 0 : gfun1, line_search_error, beta, conjugacy_error, t2a - t1a
4085 : END IF
4086 : END IF
4087 0 : CALL m_flush(unit_nr)
4088 : END IF
4089 0 : t1a = m_walltime()
4090 :
4091 : ELSE ! opt_k_max_iter .eq. 0
4092 : prepare_to_exit = .TRUE.
4093 : END IF ! opt_k_max_iter .ne. 0
4094 :
4095 0 : IF (.NOT. line_search) iteration = iteration + 1
4096 :
4097 0 : IF (prepare_to_exit) EXIT
4098 :
4099 : END DO ! end iterations on K
4100 :
4101 0 : IF (converged .OR. (outer_opt_k_iteration >= outer_opt_k_max_iter)) THEN
4102 0 : outer_opt_k_prepare_to_exit = .TRUE.
4103 : END IF
4104 :
4105 0 : IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN
4106 :
4107 0 : IF (unit_nr > 0) THEN
4108 0 : WRITE (unit_nr, *) "Updating ALMO virtuals"
4109 : END IF
4110 :
4111 0 : CALL timeset('k_opt_v0_update', handle8)
4112 :
4113 : ! update retained ALMO virtuals to restart the cg iterations
4114 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4115 : almo_scf_env%matrix_v_disc_blk(ispin), &
4116 : almo_scf_env%matrix_k_blk(ispin), &
4117 : 0.0_dp, vr_fixed, &
4118 0 : filter_eps=almo_scf_env%eps_filter)
4119 : CALL dbcsr_add(vr_fixed, almo_scf_env%matrix_v_blk(ispin), &
4120 0 : +1.0_dp, +1.0_dp)
4121 :
4122 : ! update discarded ALMO virtuals to restart the cg iterations
4123 : CALL dbcsr_multiply("N", "T", 1.0_dp, &
4124 : almo_scf_env%matrix_v_blk(ispin), &
4125 : almo_scf_env%matrix_k_blk(ispin), &
4126 : 0.0_dp, vd_fixed, &
4127 0 : filter_eps=almo_scf_env%eps_filter)
4128 : CALL dbcsr_add(vd_fixed, almo_scf_env%matrix_v_disc_blk(ispin), &
4129 0 : -1.0_dp, +1.0_dp)
4130 :
4131 : ! orthogonalize new orbitals on fragments
4132 : CALL get_overlap(bra=vr_fixed, &
4133 : ket=vr_fixed, &
4134 : overlap=k_vr_index_down, &
4135 : metric=almo_scf_env%matrix_s_blk(1), &
4136 : retain_overlap_sparsity=.FALSE., &
4137 0 : eps_filter=almo_scf_env%eps_filter)
4138 : CALL dbcsr_create(vr_index_sqrt_inv, template=k_vr_index_down, &
4139 0 : matrix_type=dbcsr_type_no_symmetry)
4140 : CALL dbcsr_create(vr_index_sqrt, template=k_vr_index_down, &
4141 0 : matrix_type=dbcsr_type_no_symmetry)
4142 : CALL matrix_sqrt_Newton_Schulz(vr_index_sqrt, &
4143 : vr_index_sqrt_inv, &
4144 : k_vr_index_down, &
4145 : threshold=almo_scf_env%eps_filter, &
4146 : order=almo_scf_env%order_lanczos, &
4147 : eps_lanczos=almo_scf_env%eps_lanczos, &
4148 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
4149 : IF (safe_mode) THEN
4150 : CALL dbcsr_create(matrix_tmp1, template=k_vr_index_down, &
4151 : matrix_type=dbcsr_type_no_symmetry)
4152 : CALL dbcsr_create(matrix_tmp2, template=k_vr_index_down, &
4153 : matrix_type=dbcsr_type_no_symmetry)
4154 :
4155 : CALL dbcsr_multiply("N", "N", 1.0_dp, vr_index_sqrt_inv, &
4156 : k_vr_index_down, &
4157 : 0.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
4158 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, &
4159 : vr_index_sqrt_inv, &
4160 : 0.0_dp, matrix_tmp2, filter_eps=almo_scf_env%eps_filter)
4161 :
4162 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp2)
4163 : CALL dbcsr_add_on_diag(matrix_tmp2, -1.0_dp)
4164 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp2)
4165 : IF (unit_nr > 0) THEN
4166 : WRITE (unit_nr, *) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)", &
4167 : frob_matrix/frob_matrix_base
4168 : END IF
4169 :
4170 : CALL dbcsr_release(matrix_tmp1)
4171 : CALL dbcsr_release(matrix_tmp2)
4172 : END IF
4173 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4174 : vr_fixed, &
4175 : vr_index_sqrt_inv, &
4176 : 0.0_dp, almo_scf_env%matrix_v_blk(ispin), &
4177 0 : filter_eps=almo_scf_env%eps_filter)
4178 :
4179 : CALL get_overlap(bra=vd_fixed, &
4180 : ket=vd_fixed, &
4181 : overlap=k_vd_index_down, &
4182 : metric=almo_scf_env%matrix_s_blk(1), &
4183 : retain_overlap_sparsity=.FALSE., &
4184 0 : eps_filter=almo_scf_env%eps_filter)
4185 : CALL dbcsr_create(vd_index_sqrt_inv, template=k_vd_index_down, &
4186 0 : matrix_type=dbcsr_type_no_symmetry)
4187 : CALL dbcsr_create(vd_index_sqrt, template=k_vd_index_down, &
4188 0 : matrix_type=dbcsr_type_no_symmetry)
4189 : CALL matrix_sqrt_Newton_Schulz(vd_index_sqrt, &
4190 : vd_index_sqrt_inv, &
4191 : k_vd_index_down, &
4192 : threshold=almo_scf_env%eps_filter, &
4193 : order=almo_scf_env%order_lanczos, &
4194 : eps_lanczos=almo_scf_env%eps_lanczos, &
4195 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
4196 : IF (safe_mode) THEN
4197 : CALL dbcsr_create(matrix_tmp1, template=k_vd_index_down, &
4198 : matrix_type=dbcsr_type_no_symmetry)
4199 : CALL dbcsr_create(matrix_tmp2, template=k_vd_index_down, &
4200 : matrix_type=dbcsr_type_no_symmetry)
4201 :
4202 : CALL dbcsr_multiply("N", "N", 1.0_dp, vd_index_sqrt_inv, &
4203 : k_vd_index_down, &
4204 : 0.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
4205 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, &
4206 : vd_index_sqrt_inv, &
4207 : 0.0_dp, matrix_tmp2, filter_eps=almo_scf_env%eps_filter)
4208 :
4209 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp2)
4210 : CALL dbcsr_add_on_diag(matrix_tmp2, -1.0_dp)
4211 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp2)
4212 : IF (unit_nr > 0) THEN
4213 : WRITE (unit_nr, *) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)", &
4214 : frob_matrix/frob_matrix_base
4215 : END IF
4216 :
4217 : CALL dbcsr_release(matrix_tmp1)
4218 : CALL dbcsr_release(matrix_tmp2)
4219 : END IF
4220 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4221 : vd_fixed, &
4222 : vd_index_sqrt_inv, &
4223 : 0.0_dp, almo_scf_env%matrix_v_disc_blk(ispin), &
4224 0 : filter_eps=almo_scf_env%eps_filter)
4225 :
4226 0 : CALL dbcsr_release(vr_index_sqrt_inv)
4227 0 : CALL dbcsr_release(vr_index_sqrt)
4228 0 : CALL dbcsr_release(vd_index_sqrt_inv)
4229 0 : CALL dbcsr_release(vd_index_sqrt)
4230 :
4231 0 : CALL timestop(handle8)
4232 :
4233 : END IF ! ne.virt_full
4234 :
4235 : ! RZK-warning released outside the outer loop
4236 0 : CALL dbcsr_release(sigma_vv_sqrt)
4237 0 : CALL dbcsr_release(sigma_vv_sqrt_inv)
4238 0 : IF (almo_scf_env%deloc_truncate_virt /= virt_full) THEN
4239 0 : CALL dbcsr_release(k_vr_index_down)
4240 0 : CALL dbcsr_release(k_vd_index_down)
4241 0 : CALL dbcsr_release(matrix_k_central)
4242 0 : CALL dbcsr_release(vr_fixed)
4243 0 : CALL dbcsr_release(vd_fixed)
4244 0 : CALL dbcsr_release(grad)
4245 0 : CALL dbcsr_release(prec)
4246 0 : CALL dbcsr_release(prev_grad)
4247 0 : CALL dbcsr_release(tmp3_vd_vr)
4248 0 : CALL dbcsr_release(tmp1_n_vr)
4249 0 : CALL dbcsr_release(tmp_k_blk)
4250 0 : CALL dbcsr_release(t_curr)
4251 0 : CALL dbcsr_release(sigma_oo_curr)
4252 0 : CALL dbcsr_release(sigma_oo_curr_inv)
4253 0 : CALL dbcsr_release(step)
4254 0 : CALL dbcsr_release(tmp2_n_o)
4255 0 : CALL dbcsr_release(tmp4_o_vr)
4256 0 : CALL dbcsr_release(prev_step)
4257 0 : CALL dbcsr_release(prev_minus_prec_grad)
4258 0 : IF (md_in_k_space) THEN
4259 0 : CALL dbcsr_release(velocity)
4260 : END IF
4261 :
4262 : END IF
4263 :
4264 0 : outer_opt_k_iteration = outer_opt_k_iteration + 1
4265 0 : IF (outer_opt_k_prepare_to_exit) EXIT
4266 :
4267 : END DO ! outer loop for k
4268 :
4269 : END DO ! ispin
4270 :
4271 : ! RZK-warning update mo orbitals
4272 :
4273 : ELSE ! virtual orbitals might not be available use projected AOs
4274 :
4275 : ! compute sqrt(S) and inv(sqrt(S))
4276 : ! RZK-warning - remove this sqrt(S) and inv(sqrt(S))
4277 : ! ideally ALMO scf should use sigma and sigma_inv in
4278 : ! the tensor_up_down representation
4279 0 : IF (.NOT. almo_scf_env%s_sqrt_done) THEN
4280 :
4281 0 : IF (unit_nr > 0) THEN
4282 0 : WRITE (unit_nr, *) "sqrt and inv(sqrt) of AO overlap matrix"
4283 : END IF
4284 : CALL dbcsr_create(almo_scf_env%matrix_s_sqrt(1), &
4285 : template=almo_scf_env%matrix_s(1), &
4286 0 : matrix_type=dbcsr_type_no_symmetry)
4287 : CALL dbcsr_create(almo_scf_env%matrix_s_sqrt_inv(1), &
4288 : template=almo_scf_env%matrix_s(1), &
4289 0 : matrix_type=dbcsr_type_no_symmetry)
4290 :
4291 : CALL matrix_sqrt_Newton_Schulz(almo_scf_env%matrix_s_sqrt(1), &
4292 : almo_scf_env%matrix_s_sqrt_inv(1), &
4293 : almo_scf_env%matrix_s(1), &
4294 : threshold=almo_scf_env%eps_filter, &
4295 : order=almo_scf_env%order_lanczos, &
4296 : eps_lanczos=almo_scf_env%eps_lanczos, &
4297 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
4298 :
4299 : IF (safe_mode) THEN
4300 : CALL dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_s(1), &
4301 : matrix_type=dbcsr_type_no_symmetry)
4302 : CALL dbcsr_create(matrix_tmp2, template=almo_scf_env%matrix_s(1), &
4303 : matrix_type=dbcsr_type_no_symmetry)
4304 :
4305 : CALL dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s_sqrt_inv(1), &
4306 : almo_scf_env%matrix_s(1), &
4307 : 0.0_dp, matrix_tmp1, filter_eps=almo_scf_env%eps_filter)
4308 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, almo_scf_env%matrix_s_sqrt_inv(1), &
4309 : 0.0_dp, matrix_tmp2, filter_eps=almo_scf_env%eps_filter)
4310 :
4311 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp2)
4312 : CALL dbcsr_add_on_diag(matrix_tmp2, -1.0_dp)
4313 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp2)
4314 : IF (unit_nr > 0) THEN
4315 : WRITE (unit_nr, *) "Error for (inv(sqrt(S))*S*inv(sqrt(S))-I)", frob_matrix/frob_matrix_base
4316 : END IF
4317 :
4318 : CALL dbcsr_release(matrix_tmp1)
4319 : CALL dbcsr_release(matrix_tmp2)
4320 : END IF
4321 :
4322 0 : almo_scf_env%s_sqrt_done = .TRUE.
4323 :
4324 : END IF
4325 :
4326 0 : DO ispin = 1, nspin
4327 :
4328 0 : CALL ct_step_env_init(ct_step_env)
4329 : CALL ct_step_env_set(ct_step_env, &
4330 : para_env=almo_scf_env%para_env, &
4331 : blacs_env=almo_scf_env%blacs_env, &
4332 : use_occ_orbs=.TRUE., &
4333 : use_virt_orbs=almo_scf_env%deloc_cayley_use_virt_orbs, &
4334 : occ_orbs_orthogonal=.FALSE., &
4335 : virt_orbs_orthogonal=almo_scf_env%orthogonal_basis, &
4336 : tensor_type=almo_scf_env%deloc_cayley_tensor_type, &
4337 : neglect_quadratic_term=almo_scf_env%deloc_cayley_linear, &
4338 : calculate_energy_corr=.TRUE., &
4339 : update_p=.TRUE., &
4340 : update_q=.FALSE., &
4341 : pp_preconditioner_full=almo_scf_env%deloc_cayley_occ_precond, &
4342 : qq_preconditioner_full=almo_scf_env%deloc_cayley_vir_precond, &
4343 : eps_convergence=almo_scf_env%deloc_cayley_eps_convergence, &
4344 : eps_filter=almo_scf_env%eps_filter, &
4345 : !nspins=almo_scf_env%nspins,&
4346 : q_index_up=almo_scf_env%matrix_s_sqrt_inv(1), &
4347 : q_index_down=almo_scf_env%matrix_s_sqrt(1), &
4348 : p_index_up=almo_scf_env%matrix_sigma_sqrt_inv(ispin), &
4349 : p_index_down=almo_scf_env%matrix_sigma_sqrt(ispin), &
4350 : matrix_ks=almo_scf_env%matrix_ks_0deloc(ispin), &
4351 : matrix_p=almo_scf_env%matrix_p(ispin), &
4352 : matrix_qp_template=almo_scf_env%matrix_t(ispin), &
4353 : matrix_pq_template=almo_scf_env%matrix_t_tr(ispin), &
4354 : matrix_t=almo_scf_env%matrix_t(ispin), &
4355 : conjugator=almo_scf_env%deloc_cayley_conjugator, &
4356 0 : max_iter=almo_scf_env%deloc_cayley_max_iter)
4357 :
4358 : ! perform calculations
4359 0 : CALL ct_step_execute(ct_step_env)
4360 :
4361 : ! for now we do not need the new set of orbitals
4362 : ! just get the energy correction
4363 : CALL ct_step_env_get(ct_step_env, &
4364 0 : energy_correction=energy_correction(ispin))
4365 :
4366 0 : CALL ct_step_env_clean(ct_step_env)
4367 :
4368 : END DO
4369 :
4370 0 : energy_correction(1) = energy_correction(1)*spin_factor
4371 :
4372 : END IF
4373 :
4374 : ! print the energy correction and exit
4375 0 : DO ispin = 1, nspin
4376 :
4377 0 : IF (unit_nr > 0) THEN
4378 0 : WRITE (unit_nr, *)
4379 0 : WRITE (unit_nr, '(T2,A,I6,F20.9)') "ECORR", ispin, &
4380 0 : energy_correction(ispin)
4381 0 : WRITE (unit_nr, *)
4382 : END IF
4383 0 : energy_correction_final = energy_correction_final + energy_correction(ispin)
4384 :
4385 : ! obtain density matrix from updated MOs
4386 : ! RZK-later sigma and sigma_inv are lost here
4387 : CALL almo_scf_t_to_proj(t=almo_scf_env%matrix_t(ispin), &
4388 : p=almo_scf_env%matrix_p(ispin), &
4389 : eps_filter=almo_scf_env%eps_filter, &
4390 : orthog_orbs=.FALSE., &
4391 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
4392 : s=almo_scf_env%matrix_s(1), &
4393 : sigma=almo_scf_env%matrix_sigma(ispin), &
4394 : sigma_inv=almo_scf_env%matrix_sigma_inv(ispin), &
4395 : !use_guess=use_guess, &
4396 : algorithm=almo_scf_env%sigma_inv_algorithm, &
4397 : inverse_accelerator=almo_scf_env%order_lanczos, &
4398 : inv_eps_factor=almo_scf_env%matrix_iter_eps_error_factor, &
4399 : eps_lanczos=almo_scf_env%eps_lanczos, &
4400 : max_iter_lanczos=almo_scf_env%max_iter_lanczos, &
4401 : para_env=almo_scf_env%para_env, &
4402 0 : blacs_env=almo_scf_env%blacs_env)
4403 :
4404 0 : IF (almo_scf_env%nspins == 1) THEN
4405 : CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), &
4406 0 : spin_factor)
4407 : END IF
4408 :
4409 : END DO
4410 :
4411 : CASE (dm_ls_step)
4412 :
4413 : ! compute the inverse of S
4414 0 : IF (.NOT. almo_scf_env%s_inv_done) THEN
4415 0 : IF (unit_nr > 0) THEN
4416 0 : WRITE (unit_nr, *) "Inverting AO overlap matrix"
4417 : END IF
4418 : CALL dbcsr_create(almo_scf_env%matrix_s_inv(1), &
4419 : template=almo_scf_env%matrix_s(1), &
4420 0 : matrix_type=dbcsr_type_no_symmetry)
4421 0 : IF (.NOT. almo_scf_env%s_sqrt_done) THEN
4422 : CALL invert_Hotelling(almo_scf_env%matrix_s_inv(1), &
4423 : almo_scf_env%matrix_s(1), &
4424 0 : threshold=almo_scf_env%eps_filter)
4425 : ELSE
4426 : CALL dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s_sqrt_inv(1), &
4427 : almo_scf_env%matrix_s_sqrt_inv(1), &
4428 : 0.0_dp, almo_scf_env%matrix_s_inv(1), &
4429 0 : filter_eps=almo_scf_env%eps_filter)
4430 : END IF
4431 :
4432 : IF (safe_mode) THEN
4433 : CALL dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_s(1), &
4434 : matrix_type=dbcsr_type_no_symmetry)
4435 : CALL dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s_inv(1), &
4436 : almo_scf_env%matrix_s(1), &
4437 : 0.0_dp, matrix_tmp1, &
4438 : filter_eps=almo_scf_env%eps_filter)
4439 : frob_matrix_base = dbcsr_frobenius_norm(matrix_tmp1)
4440 : CALL dbcsr_add_on_diag(matrix_tmp1, -1.0_dp)
4441 : frob_matrix = dbcsr_frobenius_norm(matrix_tmp1)
4442 : IF (unit_nr > 0) THEN
4443 : WRITE (unit_nr, *) "Error for (inv(S)*S-I)", &
4444 : frob_matrix/frob_matrix_base
4445 : END IF
4446 : CALL dbcsr_release(matrix_tmp1)
4447 : END IF
4448 :
4449 0 : almo_scf_env%s_inv_done = .TRUE.
4450 :
4451 : END IF
4452 :
4453 0 : ALLOCATE (matrix_p_almo_scf_converged(nspin))
4454 0 : DO ispin = 1, nspin
4455 : CALL dbcsr_create(matrix_p_almo_scf_converged(ispin), &
4456 0 : template=almo_scf_env%matrix_p(ispin))
4457 : CALL dbcsr_copy(matrix_p_almo_scf_converged(ispin), &
4458 0 : almo_scf_env%matrix_p(ispin))
4459 : END DO
4460 :
4461 : ! update the density matrix
4462 0 : DO ispin = 1, nspin
4463 :
4464 0 : nelectron_spin_real(1) = almo_scf_env%nelectrons_spin(ispin)
4465 0 : IF (almo_scf_env%nspins == 1) THEN
4466 0 : nelectron_spin_real(1) = nelectron_spin_real(1)/2
4467 : END IF
4468 :
4469 0 : local_mu(1) = SUM(almo_scf_env%mu_of_domain(:, ispin))/almo_scf_env%ndomains
4470 0 : fake(1) = 123523
4471 :
4472 0 : CPABORT("CVS only: density_matrix_sign has not been updated in SVN")
4473 :
4474 0 : IF (almo_scf_env%nspins == 1) THEN
4475 : CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), &
4476 0 : spin_factor)
4477 : END IF
4478 : CALL dbcsr_add(matrix_p_almo_scf_converged(ispin), &
4479 0 : almo_scf_env%matrix_p(ispin), -1.0_dp, 1.0_dp)
4480 : CALL dbcsr_dot(almo_scf_env%matrix_ks_0deloc(ispin), &
4481 : matrix_p_almo_scf_converged(ispin), &
4482 0 : energy_correction(ispin))
4483 :
4484 0 : energy_correction_final = energy_correction_final + energy_correction(ispin)
4485 :
4486 0 : IF (unit_nr > 0) THEN
4487 0 : WRITE (unit_nr, *)
4488 0 : WRITE (unit_nr, '(T2,A,I6,F20.9)') "ECORR", ispin, &
4489 0 : energy_correction(ispin)
4490 0 : WRITE (unit_nr, *)
4491 : END IF
4492 :
4493 : END DO
4494 :
4495 0 : DO ispin = 1, nspin
4496 0 : CALL dbcsr_release(matrix_p_almo_scf_converged(ispin))
4497 : END DO
4498 0 : DEALLOCATE (matrix_p_almo_scf_converged)
4499 :
4500 : END SELECT ! algorithm selection
4501 :
4502 0 : t2 = m_walltime()
4503 :
4504 0 : IF (unit_nr > 0) THEN
4505 0 : WRITE (unit_nr, *)
4506 0 : WRITE (unit_nr, '(T2,A,F18.9,F18.9,F18.9,F12.6)') "ETOT", &
4507 0 : almo_scf_env%almo_scf_energy, &
4508 0 : energy_correction_final, &
4509 0 : almo_scf_env%almo_scf_energy + energy_correction_final, &
4510 0 : t2 - t1
4511 0 : WRITE (unit_nr, *)
4512 : END IF
4513 :
4514 0 : CALL timestop(handle)
4515 :
4516 0 : END SUBROUTINE harris_foulkes_correction
4517 :
4518 : ! **************************************************************************************************
4519 : !> \brief triu of a dbcsr matrix
4520 : !> \param matrix ...
4521 : ! **************************************************************************************************
4522 0 : SUBROUTINE make_triu(matrix)
4523 : TYPE(dbcsr_type), INTENT(INOUT) :: matrix
4524 :
4525 : CHARACTER(len=*), PARAMETER :: routineN = 'make_triu'
4526 :
4527 : INTEGER :: col, handle, i, j, row
4528 0 : REAL(dp), DIMENSION(:, :), POINTER :: block
4529 : TYPE(dbcsr_iterator_type) :: iter
4530 :
4531 0 : CALL timeset(routineN, handle)
4532 :
4533 0 : CALL dbcsr_iterator_start(iter, matrix)
4534 0 : DO WHILE (dbcsr_iterator_blocks_left(iter))
4535 0 : CALL dbcsr_iterator_next_block(iter, row, col, block)
4536 0 : IF (row > col) block(:, :) = 0.0_dp
4537 0 : IF (row == col) THEN
4538 0 : DO j = 1, SIZE(block, 2)
4539 0 : DO i = j + 1, SIZE(block, 1)
4540 0 : block(i, j) = 0.0_dp
4541 : END DO
4542 : END DO
4543 : END IF
4544 : END DO
4545 0 : CALL dbcsr_iterator_stop(iter)
4546 0 : CALL dbcsr_filter(matrix, eps=0.0_dp)
4547 :
4548 0 : CALL timestop(handle)
4549 0 : END SUBROUTINE make_triu
4550 :
4551 : ! **************************************************************************************************
4552 : !> \brief Computes a diagonal preconditioner for the cg optimization of k matrix
4553 : !> \param prec ...
4554 : !> \param vd_prop ...
4555 : !> \param f ...
4556 : !> \param x ...
4557 : !> \param oo_inv_x_tr ...
4558 : !> \param s ...
4559 : !> \param grad ...
4560 : !> \param vd_blk ...
4561 : !> \param t ...
4562 : !> \param template_vd_vd_blk ...
4563 : !> \param template_vr_vr_blk ...
4564 : !> \param template_n_vr ...
4565 : !> \param spin_factor ...
4566 : !> \param eps_filter ...
4567 : !> \par History
4568 : !> 2011.09 created [Rustam Z Khaliullin]
4569 : !> \author Rustam Z Khaliullin
4570 : ! **************************************************************************************************
4571 0 : SUBROUTINE opt_k_create_preconditioner(prec, vd_prop, f, x, oo_inv_x_tr, s, grad, &
4572 : vd_blk, t, template_vd_vd_blk, template_vr_vr_blk, template_n_vr, &
4573 : spin_factor, eps_filter)
4574 :
4575 : TYPE(dbcsr_type), INTENT(INOUT) :: prec
4576 : TYPE(dbcsr_type), INTENT(IN) :: vd_prop, f, x, oo_inv_x_tr, s
4577 : TYPE(dbcsr_type), INTENT(INOUT) :: grad
4578 : TYPE(dbcsr_type), INTENT(IN) :: vd_blk, t, template_vd_vd_blk, &
4579 : template_vr_vr_blk, template_n_vr
4580 : REAL(KIND=dp), INTENT(IN) :: spin_factor, eps_filter
4581 :
4582 : CHARACTER(len=*), PARAMETER :: routineN = 'opt_k_create_preconditioner'
4583 :
4584 : INTEGER :: handle, p_nrows, q_nrows
4585 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: p_diagonal, q_diagonal
4586 : TYPE(dbcsr_type) :: pp_diag, qq_diag, t1, t2, tmp, &
4587 : tmp1_n_vr, tmp2_n_vr, tmp_n_vd, &
4588 : tmp_vd_vd_blk, tmp_vr_vr_blk
4589 :
4590 0 : CALL timeset(routineN, handle)
4591 :
4592 : ! initialize a matrix to 1.0
4593 0 : CALL dbcsr_create(tmp, template=prec)
4594 : ! in order to use dbcsr_set matrix blocks must exist
4595 0 : CALL dbcsr_copy(tmp, prec)
4596 0 : CALL dbcsr_set(tmp, 1.0_dp)
4597 :
4598 : ! compute qq = (Vd^tr)*F*Vd
4599 0 : CALL dbcsr_create(tmp_n_vd, template=vd_prop)
4600 : CALL dbcsr_multiply("N", "N", 1.0_dp, f, vd_prop, &
4601 0 : 0.0_dp, tmp_n_vd, filter_eps=eps_filter)
4602 : CALL dbcsr_create(tmp_vd_vd_blk, &
4603 0 : template=template_vd_vd_blk)
4604 0 : CALL dbcsr_copy(tmp_vd_vd_blk, template_vd_vd_blk)
4605 : CALL dbcsr_multiply("T", "N", 1.0_dp, vd_prop, tmp_n_vd, &
4606 : 0.0_dp, tmp_vd_vd_blk, &
4607 : retain_sparsity=.TRUE., &
4608 0 : filter_eps=eps_filter)
4609 : ! copy diagonal elements of the result into rows of a matrix
4610 0 : CALL dbcsr_get_info(tmp_vd_vd_blk, nfullrows_total=q_nrows)
4611 0 : ALLOCATE (q_diagonal(q_nrows))
4612 0 : CALL dbcsr_get_diag(tmp_vd_vd_blk, q_diagonal)
4613 : CALL dbcsr_create(qq_diag, &
4614 0 : template=template_vd_vd_blk)
4615 0 : CALL dbcsr_add_on_diag(qq_diag, 1.0_dp)
4616 0 : CALL dbcsr_set_diag(qq_diag, q_diagonal)
4617 0 : CALL dbcsr_create(t1, template=prec)
4618 : CALL dbcsr_multiply("N", "N", 1.0_dp, qq_diag, tmp, &
4619 0 : 0.0_dp, t1, filter_eps=eps_filter)
4620 :
4621 : ! compute pp = X*sigma_oo_inv*X^tr
4622 0 : CALL dbcsr_create(tmp_vr_vr_blk, template=template_vr_vr_blk)
4623 0 : CALL dbcsr_copy(tmp_vr_vr_blk, template_vr_vr_blk)
4624 : CALL dbcsr_multiply("N", "N", 1.0_dp, x, oo_inv_x_tr, &
4625 : 0.0_dp, tmp_vr_vr_blk, &
4626 : retain_sparsity=.TRUE., &
4627 0 : filter_eps=eps_filter)
4628 : ! copy diagonal elements of the result into cols of a matrix
4629 0 : CALL dbcsr_get_info(tmp_vr_vr_blk, nfullrows_total=p_nrows)
4630 0 : ALLOCATE (p_diagonal(p_nrows))
4631 0 : CALL dbcsr_get_diag(tmp_vr_vr_blk, p_diagonal)
4632 0 : CALL dbcsr_create(pp_diag, template=template_vr_vr_blk)
4633 0 : CALL dbcsr_add_on_diag(pp_diag, 1.0_dp)
4634 0 : CALL dbcsr_set_diag(pp_diag, p_diagonal)
4635 0 : CALL dbcsr_set(tmp, 1.0_dp)
4636 0 : CALL dbcsr_create(t2, template=prec)
4637 : CALL dbcsr_multiply("N", "N", 1.0_dp, tmp, pp_diag, &
4638 0 : 0.0_dp, t2, filter_eps=eps_filter)
4639 :
4640 0 : CALL dbcsr_hadamard_product(t1, t2, prec)
4641 :
4642 : ! compute qq = (Vd^tr)*S*Vd
4643 : CALL dbcsr_multiply("N", "N", 1.0_dp, s, vd_prop, &
4644 0 : 0.0_dp, tmp_n_vd, filter_eps=eps_filter)
4645 : CALL dbcsr_multiply("T", "N", 1.0_dp, vd_prop, tmp_n_vd, &
4646 : 0.0_dp, tmp_vd_vd_blk, &
4647 : retain_sparsity=.TRUE., &
4648 0 : filter_eps=eps_filter)
4649 : ! copy diagonal elements of the result into rows of a matrix
4650 0 : CALL dbcsr_get_diag(tmp_vd_vd_blk, q_diagonal)
4651 0 : CALL dbcsr_add_on_diag(qq_diag, 1.0_dp)
4652 0 : CALL dbcsr_set_diag(qq_diag, q_diagonal)
4653 0 : CALL dbcsr_set(tmp, 1.0_dp)
4654 : CALL dbcsr_multiply("N", "N", 1.0_dp, qq_diag, tmp, &
4655 0 : 0.0_dp, t1, filter_eps=eps_filter)
4656 :
4657 : ! compute pp = X*sig_oo_inv*(T^tr)*F*T*sig_oo_inv*(X^tr)
4658 0 : CALL dbcsr_create(tmp1_n_vr, template=template_n_vr)
4659 0 : CALL dbcsr_create(tmp2_n_vr, template=template_n_vr)
4660 : CALL dbcsr_multiply("N", "N", 1.0_dp, t, oo_inv_x_tr, &
4661 0 : 0.0_dp, tmp1_n_vr, filter_eps=eps_filter)
4662 : CALL dbcsr_multiply("N", "N", 1.0_dp, f, tmp1_n_vr, &
4663 0 : 0.0_dp, tmp2_n_vr, filter_eps=eps_filter)
4664 : CALL dbcsr_multiply("T", "N", 1.0_dp, tmp1_n_vr, tmp2_n_vr, &
4665 : 0.0_dp, tmp_vr_vr_blk, &
4666 : retain_sparsity=.TRUE., &
4667 0 : filter_eps=eps_filter)
4668 : ! copy diagonal elements of the result into cols of a matrix
4669 0 : CALL dbcsr_get_diag(tmp_vr_vr_blk, p_diagonal)
4670 0 : CALL dbcsr_add_on_diag(pp_diag, 1.0_dp)
4671 0 : CALL dbcsr_set_diag(pp_diag, p_diagonal)
4672 0 : CALL dbcsr_set(tmp, 1.0_dp)
4673 : CALL dbcsr_multiply("N", "N", 1.0_dp, tmp, pp_diag, &
4674 0 : 0.0_dp, t2, filter_eps=eps_filter)
4675 :
4676 0 : CALL dbcsr_hadamard_product(t1, t2, tmp)
4677 0 : CALL dbcsr_add(prec, tmp, 1.0_dp, -1.0_dp)
4678 0 : CALL dbcsr_scale(prec, 2.0_dp*spin_factor)
4679 :
4680 : ! compute qp = X*sig_oo_inv*(T^tr)*S*Vd
4681 : CALL dbcsr_multiply("N", "N", 1.0_dp, s, vd_blk, &
4682 0 : 0.0_dp, tmp_n_vd, filter_eps=eps_filter)
4683 : CALL dbcsr_multiply("T", "N", 1.0_dp, tmp_n_vd, tmp1_n_vr, &
4684 : 0.0_dp, tmp, retain_sparsity=.TRUE., &
4685 0 : filter_eps=eps_filter)
4686 0 : CALL dbcsr_hadamard_product(grad, tmp, t1)
4687 : ! gradient already contains 2.0*spin_factor
4688 0 : CALL dbcsr_scale(t1, -2.0_dp)
4689 :
4690 0 : CALL dbcsr_add(prec, t1, 1.0_dp, 1.0_dp)
4691 :
4692 0 : CALL inverse_of_elements(prec)
4693 0 : CALL dbcsr_filter(prec, eps_filter)
4694 :
4695 0 : DEALLOCATE (q_diagonal)
4696 0 : DEALLOCATE (p_diagonal)
4697 0 : CALL dbcsr_release(tmp)
4698 0 : CALL dbcsr_release(qq_diag)
4699 0 : CALL dbcsr_release(t1)
4700 0 : CALL dbcsr_release(pp_diag)
4701 0 : CALL dbcsr_release(t2)
4702 0 : CALL dbcsr_release(tmp_n_vd)
4703 0 : CALL dbcsr_release(tmp_vd_vd_blk)
4704 0 : CALL dbcsr_release(tmp_vr_vr_blk)
4705 0 : CALL dbcsr_release(tmp1_n_vr)
4706 0 : CALL dbcsr_release(tmp2_n_vr)
4707 :
4708 0 : CALL timestop(handle)
4709 :
4710 0 : END SUBROUTINE opt_k_create_preconditioner
4711 :
4712 : ! **************************************************************************************************
4713 : !> \brief Computes a block-diagonal preconditioner for the optimization of
4714 : !> k matrix
4715 : !> \param almo_scf_env ...
4716 : !> \param vd_prop ...
4717 : !> \param oo_inv_x_tr ...
4718 : !> \param t_curr ...
4719 : !> \param ispin ...
4720 : !> \param spin_factor ...
4721 : !> \par History
4722 : !> 2011.10 created [Rustam Z Khaliullin]
4723 : !> \author Rustam Z Khaliullin
4724 : ! **************************************************************************************************
4725 0 : SUBROUTINE opt_k_create_preconditioner_blk(almo_scf_env, vd_prop, oo_inv_x_tr, &
4726 : t_curr, ispin, spin_factor)
4727 :
4728 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
4729 : TYPE(dbcsr_type), INTENT(IN) :: vd_prop, oo_inv_x_tr, t_curr
4730 : INTEGER, INTENT(IN) :: ispin
4731 : REAL(KIND=dp), INTENT(IN) :: spin_factor
4732 :
4733 : CHARACTER(len=*), PARAMETER :: routineN = 'opt_k_create_preconditioner_blk'
4734 :
4735 : INTEGER :: handle
4736 : REAL(KIND=dp) :: eps_filter
4737 : TYPE(dbcsr_type) :: opt_k_e_dd, opt_k_e_rr, s_dd_sqrt, &
4738 : s_rr_sqrt, t1, tmp, tmp1_n_vr, &
4739 : tmp2_n_vr, tmp_n_vd, tmp_vd_vd_blk, &
4740 : tmp_vr_vr_blk
4741 :
4742 : ! matrices that has been computed outside the routine already
4743 :
4744 0 : CALL timeset(routineN, handle)
4745 :
4746 0 : eps_filter = almo_scf_env%eps_filter
4747 :
4748 : ! compute S_qq = (Vd^tr)*S*Vd
4749 0 : CALL dbcsr_create(tmp_n_vd, template=almo_scf_env%matrix_v_disc(ispin))
4750 : CALL dbcsr_create(tmp_vd_vd_blk, &
4751 : template=almo_scf_env%matrix_vv_disc_blk(ispin), &
4752 0 : matrix_type=dbcsr_type_no_symmetry)
4753 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4754 : almo_scf_env%matrix_s(1), &
4755 : vd_prop, &
4756 0 : 0.0_dp, tmp_n_vd, filter_eps=eps_filter)
4757 : CALL dbcsr_copy(tmp_vd_vd_blk, &
4758 0 : almo_scf_env%matrix_vv_disc_blk(ispin))
4759 : CALL dbcsr_multiply("T", "N", 1.0_dp, vd_prop, tmp_n_vd, &
4760 : 0.0_dp, tmp_vd_vd_blk, &
4761 0 : retain_sparsity=.TRUE.)
4762 :
4763 : CALL dbcsr_create(s_dd_sqrt, &
4764 : template=almo_scf_env%matrix_vv_disc_blk(ispin), &
4765 0 : matrix_type=dbcsr_type_no_symmetry)
4766 : CALL matrix_sqrt_Newton_Schulz(s_dd_sqrt, &
4767 : almo_scf_env%opt_k_t_dd(ispin), &
4768 : tmp_vd_vd_blk, &
4769 : threshold=eps_filter, &
4770 : order=almo_scf_env%order_lanczos, &
4771 : eps_lanczos=almo_scf_env%eps_lanczos, &
4772 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
4773 :
4774 : ! compute F_qq = (Vd^tr)*F*Vd
4775 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4776 : almo_scf_env%matrix_ks_0deloc(ispin), &
4777 : vd_prop, &
4778 0 : 0.0_dp, tmp_n_vd, filter_eps=eps_filter)
4779 : CALL dbcsr_copy(tmp_vd_vd_blk, &
4780 0 : almo_scf_env%matrix_vv_disc_blk(ispin))
4781 : CALL dbcsr_multiply("T", "N", 1.0_dp, vd_prop, tmp_n_vd, &
4782 : 0.0_dp, tmp_vd_vd_blk, &
4783 0 : retain_sparsity=.TRUE.)
4784 0 : CALL dbcsr_release(tmp_n_vd)
4785 :
4786 : ! bring to the blocked-orthogonalized basis
4787 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4788 : tmp_vd_vd_blk, &
4789 : almo_scf_env%opt_k_t_dd(ispin), &
4790 0 : 0.0_dp, s_dd_sqrt, filter_eps=eps_filter)
4791 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4792 : almo_scf_env%opt_k_t_dd(ispin), &
4793 : s_dd_sqrt, &
4794 0 : 0.0_dp, tmp_vd_vd_blk, filter_eps=eps_filter)
4795 :
4796 : ! diagonalize the matrix
4797 : CALL dbcsr_create(opt_k_e_dd, &
4798 0 : template=almo_scf_env%matrix_vv_disc_blk(ispin))
4799 0 : CALL dbcsr_release(s_dd_sqrt)
4800 : CALL dbcsr_create(s_dd_sqrt, &
4801 : template=almo_scf_env%matrix_vv_disc_blk(ispin), &
4802 0 : matrix_type=dbcsr_type_no_symmetry)
4803 : CALL diagonalize_diagonal_blocks(tmp_vd_vd_blk, &
4804 : s_dd_sqrt, &
4805 0 : opt_k_e_dd)
4806 :
4807 : ! obtain the transformation matrix in the discarded subspace
4808 : ! T = S^{-1/2}.U
4809 : CALL dbcsr_copy(tmp_vd_vd_blk, &
4810 0 : almo_scf_env%opt_k_t_dd(ispin))
4811 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4812 : tmp_vd_vd_blk, &
4813 : s_dd_sqrt, &
4814 : 0.0_dp, almo_scf_env%opt_k_t_dd(ispin), &
4815 0 : filter_eps=eps_filter)
4816 0 : CALL dbcsr_release(s_dd_sqrt)
4817 0 : CALL dbcsr_release(tmp_vd_vd_blk)
4818 :
4819 : ! copy diagonal elements of the result into rows of a matrix
4820 : CALL dbcsr_create(tmp, &
4821 0 : template=almo_scf_env%matrix_k_blk_ones(ispin))
4822 : CALL dbcsr_copy(tmp, &
4823 0 : almo_scf_env%matrix_k_blk_ones(ispin))
4824 : CALL dbcsr_create(t1, &
4825 0 : template=almo_scf_env%matrix_k_blk_ones(ispin))
4826 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4827 : opt_k_e_dd, tmp, &
4828 0 : 0.0_dp, t1, filter_eps=eps_filter)
4829 0 : CALL dbcsr_release(opt_k_e_dd)
4830 :
4831 : ! compute S_pp = X*sigma_oo_inv*X^tr
4832 : CALL dbcsr_create(tmp_vr_vr_blk, &
4833 : template=almo_scf_env%matrix_sigma_vv_blk(ispin), &
4834 0 : matrix_type=dbcsr_type_no_symmetry)
4835 : CALL dbcsr_copy(tmp_vr_vr_blk, &
4836 0 : almo_scf_env%matrix_sigma_vv_blk(ispin))
4837 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4838 : almo_scf_env%matrix_x(ispin), &
4839 : oo_inv_x_tr, &
4840 : 0.0_dp, tmp_vr_vr_blk, &
4841 0 : retain_sparsity=.TRUE.)
4842 :
4843 : ! obtain the orthogonalization matrix
4844 : CALL dbcsr_create(s_rr_sqrt, &
4845 : template=almo_scf_env%matrix_sigma_vv_blk(ispin), &
4846 0 : matrix_type=dbcsr_type_no_symmetry)
4847 : CALL matrix_sqrt_Newton_Schulz(s_rr_sqrt, &
4848 : almo_scf_env%opt_k_t_rr(ispin), &
4849 : tmp_vr_vr_blk, &
4850 : threshold=eps_filter, &
4851 : order=almo_scf_env%order_lanczos, &
4852 : eps_lanczos=almo_scf_env%eps_lanczos, &
4853 0 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
4854 :
4855 : ! compute F_pp = X*sig_oo_inv*(T^tr)*F*T*sig_oo_inv*(X^tr)
4856 : CALL dbcsr_create(tmp1_n_vr, &
4857 0 : template=almo_scf_env%matrix_v(ispin))
4858 : CALL dbcsr_create(tmp2_n_vr, &
4859 0 : template=almo_scf_env%matrix_v(ispin))
4860 : CALL dbcsr_multiply("N", "N", 1.0_dp, t_curr, oo_inv_x_tr, &
4861 0 : 0.0_dp, tmp1_n_vr, filter_eps=eps_filter)
4862 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4863 : almo_scf_env%matrix_ks_0deloc(ispin), &
4864 : tmp1_n_vr, &
4865 0 : 0.0_dp, tmp2_n_vr, filter_eps=eps_filter)
4866 : CALL dbcsr_multiply("T", "N", 1.0_dp, tmp1_n_vr, tmp2_n_vr, &
4867 : 0.0_dp, tmp_vr_vr_blk, &
4868 0 : retain_sparsity=.TRUE.)
4869 0 : CALL dbcsr_release(tmp1_n_vr)
4870 0 : CALL dbcsr_release(tmp2_n_vr)
4871 :
4872 : ! bring to the blocked-orthogonalized basis
4873 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4874 : tmp_vr_vr_blk, &
4875 : almo_scf_env%opt_k_t_rr(ispin), &
4876 0 : 0.0_dp, s_rr_sqrt, filter_eps=eps_filter)
4877 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4878 : almo_scf_env%opt_k_t_rr(ispin), &
4879 : s_rr_sqrt, &
4880 0 : 0.0_dp, tmp_vr_vr_blk, filter_eps=eps_filter)
4881 :
4882 : ! diagonalize the matrix
4883 : CALL dbcsr_create(opt_k_e_rr, &
4884 0 : template=almo_scf_env%matrix_sigma_vv_blk(ispin))
4885 0 : CALL dbcsr_release(s_rr_sqrt)
4886 : CALL dbcsr_create(s_rr_sqrt, &
4887 : template=almo_scf_env%matrix_sigma_vv_blk(ispin), &
4888 0 : matrix_type=dbcsr_type_no_symmetry)
4889 : CALL diagonalize_diagonal_blocks(tmp_vr_vr_blk, &
4890 : s_rr_sqrt, &
4891 0 : opt_k_e_rr)
4892 :
4893 : ! obtain the transformation matrix in the retained subspace
4894 : ! T = S^{-1/2}.U
4895 : CALL dbcsr_copy(tmp_vr_vr_blk, &
4896 0 : almo_scf_env%opt_k_t_rr(ispin))
4897 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4898 : tmp_vr_vr_blk, &
4899 : s_rr_sqrt, &
4900 : 0.0_dp, almo_scf_env%opt_k_t_rr(ispin), &
4901 0 : filter_eps=eps_filter)
4902 0 : CALL dbcsr_release(s_rr_sqrt)
4903 0 : CALL dbcsr_release(tmp_vr_vr_blk)
4904 :
4905 : ! copy diagonal elements of the result into cols of a matrix
4906 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4907 : tmp, opt_k_e_rr, &
4908 : 0.0_dp, almo_scf_env%opt_k_denom(ispin), &
4909 0 : filter_eps=eps_filter)
4910 0 : CALL dbcsr_release(opt_k_e_rr)
4911 0 : CALL dbcsr_release(tmp)
4912 :
4913 : ! form the denominator matrix
4914 : CALL dbcsr_add(almo_scf_env%opt_k_denom(ispin), t1, &
4915 0 : -1.0_dp, 1.0_dp)
4916 0 : CALL dbcsr_release(t1)
4917 : CALL dbcsr_scale(almo_scf_env%opt_k_denom(ispin), &
4918 0 : 2.0_dp*spin_factor)
4919 :
4920 0 : CALL inverse_of_elements(almo_scf_env%opt_k_denom(ispin))
4921 : CALL dbcsr_filter(almo_scf_env%opt_k_denom(ispin), &
4922 0 : eps_filter)
4923 :
4924 0 : CALL timestop(handle)
4925 :
4926 0 : END SUBROUTINE opt_k_create_preconditioner_blk
4927 :
4928 : ! **************************************************************************************************
4929 : !> \brief Applies a block-diagonal preconditioner for the optimization of
4930 : !> k matrix (preconditioner matrices must be calculated and stored
4931 : !> beforehand)
4932 : !> \param almo_scf_env ...
4933 : !> \param step ...
4934 : !> \param grad ...
4935 : !> \param ispin ...
4936 : !> \par History
4937 : !> 2011.10 created [Rustam Z Khaliullin]
4938 : !> \author Rustam Z Khaliullin
4939 : ! **************************************************************************************************
4940 0 : SUBROUTINE opt_k_apply_preconditioner_blk(almo_scf_env, step, grad, ispin)
4941 :
4942 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
4943 : TYPE(dbcsr_type), INTENT(OUT) :: step
4944 : TYPE(dbcsr_type), INTENT(IN) :: grad
4945 : INTEGER, INTENT(IN) :: ispin
4946 :
4947 : CHARACTER(len=*), PARAMETER :: routineN = 'opt_k_apply_preconditioner_blk'
4948 :
4949 : INTEGER :: handle
4950 : REAL(KIND=dp) :: eps_filter
4951 : TYPE(dbcsr_type) :: tmp_k
4952 :
4953 0 : CALL timeset(routineN, handle)
4954 :
4955 0 : eps_filter = almo_scf_env%eps_filter
4956 :
4957 0 : CALL dbcsr_create(tmp_k, template=almo_scf_env%matrix_k_blk(ispin))
4958 :
4959 : ! transform gradient to the correct "diagonal" basis
4960 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4961 : grad, almo_scf_env%opt_k_t_rr(ispin), &
4962 0 : 0.0_dp, tmp_k, filter_eps=eps_filter)
4963 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
4964 : almo_scf_env%opt_k_t_dd(ispin), tmp_k, &
4965 0 : 0.0_dp, step, filter_eps=eps_filter)
4966 :
4967 : ! apply diagonal preconditioner
4968 : CALL dbcsr_hadamard_product(step, &
4969 0 : almo_scf_env%opt_k_denom(ispin), tmp_k)
4970 :
4971 : ! back-transform the result to the initial basis
4972 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
4973 : almo_scf_env%opt_k_t_dd(ispin), tmp_k, &
4974 0 : 0.0_dp, step, filter_eps=eps_filter)
4975 : CALL dbcsr_multiply("N", "T", 1.0_dp, &
4976 : step, almo_scf_env%opt_k_t_rr(ispin), &
4977 0 : 0.0_dp, tmp_k, filter_eps=eps_filter)
4978 :
4979 0 : CALL dbcsr_copy(step, tmp_k)
4980 :
4981 0 : CALL dbcsr_release(tmp_k)
4982 :
4983 0 : CALL timestop(handle)
4984 :
4985 0 : END SUBROUTINE opt_k_apply_preconditioner_blk
4986 :
4987 : ! **************************************************************************************************
4988 : !> \brief Compute the gradient wrt the main variable (e.g. Theta, X)
4989 : !> \param m_grad_out ...
4990 : !> \param m_ks ...
4991 : !> \param m_s ...
4992 : !> \param m_t ...
4993 : !> \param m_t0 ...
4994 : !> \param m_siginv ...
4995 : !> \param m_quench_t ...
4996 : !> \param m_FTsiginv ...
4997 : !> \param m_siginvTFTsiginv ...
4998 : !> \param m_ST ...
4999 : !> \param m_STsiginv0 ...
5000 : !> \param m_theta ...
5001 : !> \param domain_s_inv ...
5002 : !> \param domain_r_down ...
5003 : !> \param cpu_of_domain ...
5004 : !> \param domain_map ...
5005 : !> \param assume_t0_q0x ...
5006 : !> \param optimize_theta ...
5007 : !> \param normalize_orbitals ...
5008 : !> \param penalty_occ_vol ...
5009 : !> \param penalty_occ_local ...
5010 : !> \param penalty_occ_vol_prefactor ...
5011 : !> \param envelope_amplitude ...
5012 : !> \param eps_filter ...
5013 : !> \param spin_factor ...
5014 : !> \param special_case ...
5015 : !> \param m_sig_sqrti_ii ...
5016 : !> \param op_sm_set ...
5017 : !> \param weights ...
5018 : !> \param energy_coeff ...
5019 : !> \param localiz_coeff ...
5020 : !> \par History
5021 : !> 2015.03 created [Rustam Z Khaliullin]
5022 : !> \author Rustam Z Khaliullin
5023 : ! **************************************************************************************************
5024 1498 : SUBROUTINE compute_gradient(m_grad_out, m_ks, m_s, m_t, m_t0, &
5025 : m_siginv, m_quench_t, m_FTsiginv, m_siginvTFTsiginv, m_ST, m_STsiginv0, &
5026 1498 : m_theta, domain_s_inv, domain_r_down, &
5027 1498 : cpu_of_domain, domain_map, assume_t0_q0x, optimize_theta, &
5028 : normalize_orbitals, penalty_occ_vol, penalty_occ_local, &
5029 : penalty_occ_vol_prefactor, envelope_amplitude, eps_filter, spin_factor, &
5030 1498 : special_case, m_sig_sqrti_ii, op_sm_set, weights, energy_coeff, &
5031 : localiz_coeff)
5032 :
5033 : TYPE(dbcsr_type), INTENT(INOUT) :: m_grad_out, m_ks, m_s, m_t, m_t0, &
5034 : m_siginv, m_quench_t, m_FTsiginv, &
5035 : m_siginvTFTsiginv, m_ST, m_STsiginv0, &
5036 : m_theta
5037 : TYPE(domain_submatrix_type), DIMENSION(:), &
5038 : INTENT(IN) :: domain_s_inv, domain_r_down
5039 : INTEGER, DIMENSION(:), INTENT(IN) :: cpu_of_domain
5040 : TYPE(domain_map_type), INTENT(IN) :: domain_map
5041 : LOGICAL, INTENT(IN) :: assume_t0_q0x, optimize_theta, &
5042 : normalize_orbitals, penalty_occ_vol
5043 : LOGICAL, INTENT(IN), OPTIONAL :: penalty_occ_local
5044 : REAL(KIND=dp), INTENT(IN) :: penalty_occ_vol_prefactor, &
5045 : envelope_amplitude, eps_filter, &
5046 : spin_factor
5047 : INTEGER, INTENT(IN) :: special_case
5048 : TYPE(dbcsr_type), INTENT(IN), OPTIONAL :: m_sig_sqrti_ii
5049 : TYPE(dbcsr_p_type), DIMENSION(:, :), OPTIONAL, &
5050 : POINTER :: op_sm_set
5051 : REAL(KIND=dp), DIMENSION(:), INTENT(IN), OPTIONAL :: weights
5052 : REAL(KIND=dp), INTENT(IN), OPTIONAL :: energy_coeff, localiz_coeff
5053 :
5054 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_gradient'
5055 :
5056 : INTEGER :: dim0, handle, idim0, nao, reim
5057 : LOGICAL :: my_penalty_local
5058 : REAL(KIND=dp) :: coeff, energy_g_norm, my_energy_coeff, &
5059 : my_localiz_coeff, &
5060 : penalty_occ_vol_g_norm
5061 1498 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tg_diagonal
5062 : TYPE(dbcsr_type) :: m_tmp_no_1, m_tmp_no_2, m_tmp_no_3, &
5063 : m_tmp_oo_1, m_tmp_oo_2, temp1, temp2, &
5064 : tempNOcc1, tempOccOcc1
5065 :
5066 1498 : CALL timeset(routineN, handle)
5067 :
5068 1498 : IF (normalize_orbitals .AND. (.NOT. PRESENT(m_sig_sqrti_ii))) THEN
5069 0 : CPABORT("Normalization matrix is required")
5070 : END IF
5071 :
5072 1498 : my_penalty_local = .FALSE.
5073 1498 : my_localiz_coeff = 1.0_dp
5074 1498 : my_energy_coeff = 0.0_dp
5075 1498 : IF (PRESENT(localiz_coeff)) THEN
5076 1072 : my_localiz_coeff = localiz_coeff
5077 : END IF
5078 1498 : IF (PRESENT(energy_coeff)) THEN
5079 1072 : my_energy_coeff = energy_coeff
5080 : END IF
5081 1498 : IF (PRESENT(penalty_occ_local)) THEN
5082 1072 : my_penalty_local = penalty_occ_local
5083 : END IF
5084 :
5085 : ! use this otherways unused variables
5086 1498 : CALL dbcsr_get_info(matrix=m_ks, nfullrows_total=nao)
5087 1498 : CALL dbcsr_get_info(matrix=m_s, nfullrows_total=nao)
5088 1498 : CALL dbcsr_get_info(matrix=m_t, nfullrows_total=nao)
5089 :
5090 : CALL dbcsr_create(m_tmp_no_1, &
5091 : template=m_quench_t, &
5092 1498 : matrix_type=dbcsr_type_no_symmetry)
5093 : CALL dbcsr_create(m_tmp_no_2, &
5094 : template=m_quench_t, &
5095 1498 : matrix_type=dbcsr_type_no_symmetry)
5096 : CALL dbcsr_create(m_tmp_no_3, &
5097 : template=m_quench_t, &
5098 1498 : matrix_type=dbcsr_type_no_symmetry)
5099 : CALL dbcsr_create(m_tmp_oo_1, &
5100 : template=m_siginv, &
5101 1498 : matrix_type=dbcsr_type_no_symmetry)
5102 : CALL dbcsr_create(m_tmp_oo_2, &
5103 : template=m_siginv, &
5104 1498 : matrix_type=dbcsr_type_no_symmetry)
5105 : CALL dbcsr_create(tempNOcc1, &
5106 : template=m_t, &
5107 1498 : matrix_type=dbcsr_type_no_symmetry)
5108 : CALL dbcsr_create(tempOccOcc1, &
5109 : template=m_siginv, &
5110 1498 : matrix_type=dbcsr_type_no_symmetry)
5111 : CALL dbcsr_create(temp1, &
5112 : template=m_t, &
5113 1498 : matrix_type=dbcsr_type_no_symmetry)
5114 : CALL dbcsr_create(temp2, &
5115 : template=m_t, &
5116 1498 : matrix_type=dbcsr_type_no_symmetry)
5117 :
5118 1498 : CALL dbcsr_copy(m_tmp_no_2, m_quench_t)
5119 1498 : CALL dbcsr_copy(m_tmp_no_2, m_FTsiginv, keep_sparsity=.TRUE.)
5120 :
5121 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
5122 : m_ST, &
5123 : m_siginvTFTsiginv, &
5124 : 1.0_dp, m_tmp_no_2, &
5125 1498 : retain_sparsity=.TRUE.)
5126 1498 : CALL dbcsr_scale(m_tmp_no_2, 2.0_dp*spin_factor)
5127 :
5128 : ! LzL Add gradient for Localization
5129 1498 : IF (my_penalty_local) THEN
5130 :
5131 0 : CALL dbcsr_set(temp2, 0.0_dp) ! accumulate the localization gradient here
5132 :
5133 0 : DO idim0 = 1, SIZE(op_sm_set, 2) ! this loop is over miller ind
5134 :
5135 0 : DO reim = 1, SIZE(op_sm_set, 1) ! this loop is over Re/Im
5136 :
5137 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5138 : op_sm_set(reim, idim0)%matrix, &
5139 : m_t, &
5140 : 0.0_dp, tempNOcc1, &
5141 0 : filter_eps=eps_filter)
5142 :
5143 : ! warning - save time by computing only the diagonal elements
5144 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5145 : m_t, &
5146 : tempNOcc1, &
5147 : 0.0_dp, tempOccOcc1, &
5148 0 : filter_eps=eps_filter)
5149 :
5150 0 : CALL dbcsr_get_info(tempOccOcc1, nfullrows_total=dim0)
5151 0 : ALLOCATE (tg_diagonal(dim0))
5152 0 : CALL dbcsr_get_diag(tempOccOcc1, tg_diagonal)
5153 0 : CALL dbcsr_set(tempOccOcc1, 0.0_dp)
5154 0 : CALL dbcsr_set_diag(tempOccOcc1, tg_diagonal)
5155 0 : DEALLOCATE (tg_diagonal)
5156 :
5157 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5158 : tempNOcc1, &
5159 : tempOccOcc1, &
5160 : 0.0_dp, temp1, &
5161 0 : filter_eps=eps_filter)
5162 :
5163 : END DO
5164 :
5165 : SELECT CASE (2) ! allows for selection of different spread functionals
5166 : CASE (1) ! functional = -W_I * log( |z_I|^2 )
5167 0 : CPABORT("Localization function is not implemented")
5168 : CASE (2) ! functional = W_I * ( 1 - |z_I|^2 )
5169 0 : coeff = -weights(idim0)
5170 : CASE (3) ! functional = W_I * ( 1 - |z_I| )
5171 : CPABORT("Localization function is not implemented")
5172 : END SELECT
5173 0 : CALL dbcsr_add(temp2, temp1, 1.0_dp, coeff)
5174 :
5175 : END DO ! end loop over idim0
5176 0 : CALL dbcsr_add(m_tmp_no_2, temp2, my_energy_coeff, my_localiz_coeff*4.0_dp)
5177 : END IF
5178 :
5179 : ! add penalty on the occupied volume: det(sigma)
5180 1498 : IF (penalty_occ_vol) THEN
5181 0 : CALL dbcsr_copy(m_tmp_no_1, m_quench_t)
5182 : CALL dbcsr_multiply("N", "N", &
5183 : penalty_occ_vol_prefactor, &
5184 : m_ST, &
5185 : m_siginv, &
5186 : 0.0_dp, m_tmp_no_1, &
5187 0 : retain_sparsity=.TRUE.)
5188 : ! this norm does not contain the normalization factors
5189 0 : penalty_occ_vol_g_norm = dbcsr_maxabs(m_tmp_no_1)
5190 0 : energy_g_norm = dbcsr_maxabs(m_tmp_no_2)
5191 0 : CALL dbcsr_add(m_tmp_no_2, m_tmp_no_1, 1.0_dp, 1.0_dp)
5192 : END IF
5193 :
5194 : ! take into account the factor from the normalization constraint
5195 1498 : IF (normalize_orbitals) THEN
5196 :
5197 : ! G = ( G - ST.[tr(T).G]_ii ) . [sig_sqrti]_ii
5198 : ! this expression can be simplified to
5199 : ! G = ( G - c0*ST ) . [sig_sqrti]_ii
5200 : ! where c0 = penalty_occ_vol_prefactor
5201 : ! This is because tr(T).G_Energy = 0 and
5202 : ! tr(T).G_Penalty = c0*I
5203 :
5204 : ! slower way of taking the norm into account
5205 0 : CALL dbcsr_copy(m_tmp_no_1, m_quench_t)
5206 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5207 : m_tmp_no_2, &
5208 : m_sig_sqrti_ii, &
5209 : 0.0_dp, m_tmp_no_1, &
5210 0 : retain_sparsity=.TRUE.)
5211 :
5212 : ! get [tr(T).G]_ii
5213 0 : CALL dbcsr_copy(m_tmp_oo_1, m_sig_sqrti_ii)
5214 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5215 : m_t, &
5216 : m_tmp_no_2, &
5217 : 0.0_dp, m_tmp_oo_1, &
5218 0 : retain_sparsity=.TRUE.)
5219 :
5220 0 : CALL dbcsr_get_info(m_sig_sqrti_ii, nfullrows_total=dim0)
5221 0 : ALLOCATE (tg_diagonal(dim0))
5222 0 : CALL dbcsr_get_diag(m_tmp_oo_1, tg_diagonal)
5223 0 : CALL dbcsr_set(m_tmp_oo_1, 0.0_dp)
5224 0 : CALL dbcsr_set_diag(m_tmp_oo_1, tg_diagonal)
5225 0 : DEALLOCATE (tg_diagonal)
5226 :
5227 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5228 : m_sig_sqrti_ii, &
5229 : m_tmp_oo_1, &
5230 : 0.0_dp, m_tmp_oo_2, &
5231 0 : filter_eps=eps_filter)
5232 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
5233 : m_ST, &
5234 : m_tmp_oo_2, &
5235 : 1.0_dp, m_tmp_no_1, &
5236 0 : retain_sparsity=.TRUE.)
5237 :
5238 : ELSE
5239 :
5240 1498 : CALL dbcsr_copy(m_tmp_no_1, m_tmp_no_2)
5241 :
5242 : END IF ! normalize_orbitals
5243 :
5244 : ! project out the occupied space from the gradient
5245 1498 : IF (assume_t0_q0x) THEN
5246 466 : IF (special_case == xalmo_case_fully_deloc) THEN
5247 160 : CALL dbcsr_copy(m_grad_out, m_tmp_no_1)
5248 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5249 : m_t0, &
5250 : m_grad_out, &
5251 : 0.0_dp, m_tmp_oo_1, &
5252 160 : filter_eps=eps_filter)
5253 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
5254 : m_STsiginv0, &
5255 : m_tmp_oo_1, &
5256 : 1.0_dp, m_grad_out, &
5257 160 : filter_eps=eps_filter)
5258 306 : ELSE IF (special_case == xalmo_case_block_diag) THEN
5259 0 : CPABORT("Cannot project the zero-order space from itself")
5260 : ELSE
5261 : ! no special case: normal xALMOs
5262 : CALL apply_domain_operators( &
5263 : matrix_in=m_tmp_no_1, &
5264 : matrix_out=m_grad_out, &
5265 : operator2=domain_r_down(:), &
5266 : operator1=domain_s_inv(:), &
5267 : dpattern=m_quench_t, &
5268 : map=domain_map, &
5269 : node_of_domain=cpu_of_domain, &
5270 : my_action=1, &
5271 : filter_eps=eps_filter, &
5272 : !matrix_trimmer=,&
5273 306 : use_trimmer=.FALSE.)
5274 : END IF ! my_special_case
5275 466 : CALL dbcsr_copy(m_tmp_no_1, m_grad_out)
5276 : END IF
5277 :
5278 : ! transform d_E/d_T to d_E/d_theta
5279 1498 : IF (optimize_theta) THEN
5280 0 : CALL dbcsr_copy(m_tmp_no_2, m_theta)
5281 0 : CALL dtanh_of_elements(m_tmp_no_2, alpha=1.0_dp/envelope_amplitude)
5282 0 : CALL dbcsr_scale(m_tmp_no_2, envelope_amplitude)
5283 0 : CALL dbcsr_set(m_tmp_no_3, 0.0_dp)
5284 0 : CALL dbcsr_filter(m_tmp_no_3, eps_filter)
5285 : CALL dbcsr_hadamard_product(m_tmp_no_1, &
5286 : m_tmp_no_2, &
5287 0 : m_tmp_no_3)
5288 : CALL dbcsr_hadamard_product(m_tmp_no_3, &
5289 : m_quench_t, &
5290 0 : m_grad_out)
5291 : ELSE ! simply copy
5292 : CALL dbcsr_hadamard_product(m_tmp_no_1, &
5293 : m_quench_t, &
5294 1498 : m_grad_out)
5295 : END IF
5296 1498 : CALL dbcsr_filter(m_grad_out, eps_filter)
5297 :
5298 1498 : CALL dbcsr_release(m_tmp_no_1)
5299 1498 : CALL dbcsr_release(m_tmp_no_2)
5300 1498 : CALL dbcsr_release(m_tmp_no_3)
5301 1498 : CALL dbcsr_release(m_tmp_oo_1)
5302 1498 : CALL dbcsr_release(m_tmp_oo_2)
5303 1498 : CALL dbcsr_release(tempNOcc1)
5304 1498 : CALL dbcsr_release(tempOccOcc1)
5305 1498 : CALL dbcsr_release(temp1)
5306 1498 : CALL dbcsr_release(temp2)
5307 :
5308 1498 : CALL timestop(handle)
5309 :
5310 2996 : END SUBROUTINE compute_gradient
5311 :
5312 : ! **************************************************************************************************
5313 : !> \brief Serial code that prints matrices readable by Mathematica
5314 : !> \param matrix - matrix to print
5315 : !> \param filename ...
5316 : !> \par History
5317 : !> 2015.05 created [Rustam Z. Khaliullin]
5318 : !> \author Rustam Z. Khaliullin
5319 : ! **************************************************************************************************
5320 0 : SUBROUTINE print_mathematica_matrix(matrix, filename)
5321 :
5322 : TYPE(dbcsr_type), INTENT(IN) :: matrix
5323 : CHARACTER(len=*), INTENT(IN) :: filename
5324 :
5325 : CHARACTER(len=*), PARAMETER :: routineN = 'print_mathematica_matrix'
5326 :
5327 : CHARACTER(LEN=20) :: formatstr, Scols
5328 : INTEGER :: col, fiunit, handle, hori_offset, jj, &
5329 : nblkcols_tot, nblkrows_tot, Ncols, &
5330 : ncores, Nrows, row, unit_nr, &
5331 : vert_offset
5332 0 : INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_block_sizes, mo_block_sizes
5333 0 : INTEGER, DIMENSION(:), POINTER :: ao_blk_sizes, mo_blk_sizes
5334 : LOGICAL :: found
5335 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: H
5336 0 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: block_p
5337 : TYPE(cp_logger_type), POINTER :: logger
5338 : TYPE(dbcsr_distribution_type) :: dist
5339 : TYPE(dbcsr_type) :: matrix_asym
5340 :
5341 0 : CALL timeset(routineN, handle)
5342 :
5343 : ! get a useful output_unit
5344 0 : logger => cp_get_default_logger()
5345 0 : IF (logger%para_env%is_source()) THEN
5346 0 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
5347 : ELSE
5348 : unit_nr = -1
5349 : END IF
5350 :
5351 : ! serial code only
5352 0 : CALL dbcsr_get_info(matrix, distribution=dist)
5353 0 : CALL dbcsr_distribution_get(dist, numnodes=ncores)
5354 0 : IF (ncores > 1) THEN
5355 0 : CPABORT("mathematica files: serial code only")
5356 : END IF
5357 :
5358 : CALL dbcsr_get_info(matrix, row_blk_size=ao_blk_sizes, col_blk_size=mo_blk_sizes, &
5359 0 : nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot)
5360 0 : CPASSERT(nblkrows_tot == nblkcols_tot)
5361 0 : ALLOCATE (mo_block_sizes(nblkcols_tot), ao_block_sizes(nblkcols_tot))
5362 0 : mo_block_sizes(:) = mo_blk_sizes(:)
5363 0 : ao_block_sizes(:) = ao_blk_sizes(:)
5364 :
5365 : CALL dbcsr_create(matrix_asym, &
5366 : template=matrix, &
5367 0 : matrix_type=dbcsr_type_no_symmetry)
5368 0 : CALL dbcsr_desymmetrize(matrix, matrix_asym)
5369 :
5370 0 : Ncols = SUM(mo_block_sizes)
5371 0 : Nrows = SUM(ao_block_sizes)
5372 0 : ALLOCATE (H(Nrows, Ncols))
5373 0 : H(:, :) = 0.0_dp
5374 :
5375 0 : hori_offset = 0
5376 0 : DO col = 1, nblkcols_tot
5377 :
5378 0 : vert_offset = 0
5379 0 : DO row = 1, nblkrows_tot
5380 :
5381 0 : CALL dbcsr_get_block_p(matrix_asym, row, col, block_p, found)
5382 0 : IF (found) THEN
5383 :
5384 : H(vert_offset + 1:vert_offset + ao_block_sizes(row), &
5385 : hori_offset + 1:hori_offset + mo_block_sizes(col)) &
5386 0 : = block_p(:, :)
5387 :
5388 : END IF
5389 :
5390 0 : vert_offset = vert_offset + ao_block_sizes(row)
5391 :
5392 : END DO
5393 :
5394 0 : hori_offset = hori_offset + mo_block_sizes(col)
5395 :
5396 : END DO ! loop over electron blocks
5397 :
5398 0 : CALL dbcsr_release(matrix_asym)
5399 :
5400 0 : IF (unit_nr > 0) THEN
5401 0 : CALL open_file(filename, unit_number=fiunit, file_status='REPLACE')
5402 0 : WRITE (Scols, "(I10)") Ncols
5403 0 : formatstr = "("//TRIM(Scols)//"E27.17)"
5404 0 : DO jj = 1, Nrows
5405 0 : WRITE (fiunit, formatstr) H(jj, :)
5406 : END DO
5407 0 : CALL close_file(fiunit)
5408 : END IF
5409 :
5410 0 : DEALLOCATE (mo_block_sizes)
5411 0 : DEALLOCATE (ao_block_sizes)
5412 0 : DEALLOCATE (H)
5413 :
5414 0 : CALL timestop(handle)
5415 :
5416 0 : END SUBROUTINE print_mathematica_matrix
5417 :
5418 : ! **************************************************************************************************
5419 : !> \brief Compute the objective functional of NLMOs
5420 : !> \param localization_obj_function_ispin ...
5421 : !> \param penalty_func_ispin ...
5422 : !> \param penalty_vol_prefactor ...
5423 : !> \param overlap_determinant ...
5424 : !> \param m_sigma ...
5425 : !> \param nocc ...
5426 : !> \param m_B0 ...
5427 : !> \param m_theta_normalized ...
5428 : !> \param template_matrix_mo ...
5429 : !> \param weights ...
5430 : !> \param m_S0 ...
5431 : !> \param just_started ...
5432 : !> \param penalty_amplitude ...
5433 : !> \param eps_filter ...
5434 : !> \par History
5435 : !> 2020.01 created [Ziling Luo]
5436 : !> \author Ziling Luo
5437 : ! **************************************************************************************************
5438 82 : SUBROUTINE compute_obj_nlmos(localization_obj_function_ispin, penalty_func_ispin, &
5439 82 : penalty_vol_prefactor, overlap_determinant, m_sigma, nocc, m_B0, &
5440 82 : m_theta_normalized, template_matrix_mo, weights, m_S0, just_started, &
5441 : penalty_amplitude, eps_filter)
5442 :
5443 : REAL(KIND=dp), INTENT(INOUT) :: localization_obj_function_ispin, penalty_func_ispin, &
5444 : penalty_vol_prefactor, overlap_determinant
5445 : TYPE(dbcsr_type), INTENT(INOUT) :: m_sigma
5446 : INTEGER, INTENT(IN) :: nocc
5447 : TYPE(dbcsr_type), DIMENSION(:, :), INTENT(IN) :: m_B0
5448 : TYPE(dbcsr_type), INTENT(IN) :: m_theta_normalized, template_matrix_mo
5449 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: weights
5450 : TYPE(dbcsr_type), INTENT(IN) :: m_S0
5451 : LOGICAL, INTENT(IN) :: just_started
5452 : REAL(KIND=dp), INTENT(IN) :: penalty_amplitude, eps_filter
5453 :
5454 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_obj_nlmos'
5455 :
5456 : INTEGER :: handle, idim0, ielem, reim
5457 : REAL(KIND=dp) :: det1, fval
5458 82 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: reim_diag, z2
5459 : TYPE(dbcsr_type) :: tempNOcc1, tempOccOcc1, tempOccOcc2
5460 : TYPE(mp_comm_type) :: group
5461 :
5462 82 : CALL timeset(routineN, handle)
5463 :
5464 : CALL dbcsr_create(tempNOcc1, &
5465 : template=template_matrix_mo, &
5466 82 : matrix_type=dbcsr_type_no_symmetry)
5467 : CALL dbcsr_create(tempOccOcc1, &
5468 : template=m_theta_normalized, &
5469 82 : matrix_type=dbcsr_type_no_symmetry)
5470 : CALL dbcsr_create(tempOccOcc2, &
5471 : template=m_theta_normalized, &
5472 82 : matrix_type=dbcsr_type_no_symmetry)
5473 :
5474 82 : localization_obj_function_ispin = 0.0_dp
5475 82 : penalty_func_ispin = 0.0_dp
5476 246 : ALLOCATE (z2(nocc))
5477 164 : ALLOCATE (reim_diag(nocc))
5478 :
5479 82 : CALL dbcsr_get_info(tempOccOcc2, group=group)
5480 :
5481 842 : DO idim0 = 1, SIZE(m_B0, 2) ! this loop is over miller ind
5482 :
5483 760 : z2(:) = 0.0_dp
5484 :
5485 1520 : DO reim = 1, SIZE(m_B0, 1) ! this loop is over Re/Im
5486 :
5487 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5488 : m_B0(reim, idim0), &
5489 : m_theta_normalized, &
5490 : 0.0_dp, tempOccOcc1, &
5491 760 : filter_eps=eps_filter)
5492 760 : CALL dbcsr_set(tempOccOcc2, 0.0_dp)
5493 760 : CALL dbcsr_add_on_diag(tempOccOcc2, 1.0_dp)
5494 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5495 : m_theta_normalized, &
5496 : tempOccOcc1, &
5497 : 0.0_dp, tempOccOcc2, &
5498 760 : retain_sparsity=.TRUE.)
5499 :
5500 760 : reim_diag = 0.0_dp
5501 760 : CALL dbcsr_get_diag(tempOccOcc2, reim_diag)
5502 760 : CALL group%sum(reim_diag)
5503 13368 : z2(:) = z2(:) + reim_diag(:)*reim_diag(:)
5504 :
5505 : END DO
5506 :
5507 12690 : DO ielem = 1, nocc
5508 : SELECT CASE (2) ! allows for selection of different spread functionals
5509 : CASE (1) ! functional = -W_I * log( |z_I|^2 )
5510 11848 : fval = -weights(idim0)*LOG(ABS(z2(ielem)))
5511 : CASE (2) ! functional = W_I * ( 1 - |z_I|^2 )
5512 11848 : fval = weights(idim0) - weights(idim0)*ABS(z2(ielem))
5513 : CASE (3) ! functional = W_I * ( 1 - |z_I| )
5514 : fval = weights(idim0) - weights(idim0)*SQRT(ABS(z2(ielem)))
5515 : END SELECT
5516 12608 : localization_obj_function_ispin = localization_obj_function_ispin + fval
5517 : END DO
5518 :
5519 : END DO ! end loop over idim0
5520 :
5521 82 : DEALLOCATE (z2)
5522 82 : DEALLOCATE (reim_diag)
5523 :
5524 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5525 : m_S0, &
5526 : m_theta_normalized, &
5527 : 0.0_dp, tempOccOcc1, &
5528 82 : filter_eps=eps_filter)
5529 : ! compute current sigma
5530 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5531 : m_theta_normalized, &
5532 : tempOccOcc1, &
5533 : 0.0_dp, m_sigma, &
5534 82 : filter_eps=eps_filter)
5535 :
5536 : CALL determinant(m_sigma, det1, &
5537 82 : eps_filter)
5538 : ! save the current determinant
5539 82 : overlap_determinant = det1
5540 :
5541 82 : IF (just_started .AND. penalty_amplitude < 0.0_dp) THEN
5542 4 : penalty_vol_prefactor = -(-penalty_amplitude)*localization_obj_function_ispin
5543 : END IF
5544 82 : penalty_func_ispin = penalty_func_ispin + penalty_vol_prefactor*LOG(det1)
5545 :
5546 82 : CALL dbcsr_release(tempNOcc1)
5547 82 : CALL dbcsr_release(tempOccOcc1)
5548 82 : CALL dbcsr_release(tempOccOcc2)
5549 :
5550 82 : CALL timestop(handle)
5551 :
5552 164 : END SUBROUTINE compute_obj_nlmos
5553 :
5554 : ! **************************************************************************************************
5555 : !> \brief Compute the gradient wrt the main variable
5556 : !> \param m_grad_out ...
5557 : !> \param m_B0 ...
5558 : !> \param weights ...
5559 : !> \param m_S0 ...
5560 : !> \param m_theta_normalized ...
5561 : !> \param m_siginv ...
5562 : !> \param m_sig_sqrti_ii ...
5563 : !> \param penalty_vol_prefactor ...
5564 : !> \param eps_filter ...
5565 : !> \param suggested_vol_penalty ...
5566 : !> \par History
5567 : !> 2018.10 created [Ziling Luo]
5568 : !> \author Ziling Luo
5569 : ! **************************************************************************************************
5570 82 : SUBROUTINE compute_gradient_nlmos(m_grad_out, m_B0, weights, &
5571 : m_S0, m_theta_normalized, m_siginv, m_sig_sqrti_ii, &
5572 : penalty_vol_prefactor, eps_filter, suggested_vol_penalty)
5573 :
5574 : TYPE(dbcsr_type), INTENT(INOUT) :: m_grad_out
5575 : TYPE(dbcsr_type), DIMENSION(:, :), INTENT(IN) :: m_B0
5576 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: weights
5577 : TYPE(dbcsr_type), INTENT(IN) :: m_S0, m_theta_normalized, m_siginv, &
5578 : m_sig_sqrti_ii
5579 : REAL(KIND=dp), INTENT(IN) :: penalty_vol_prefactor, eps_filter
5580 : REAL(KIND=dp), INTENT(INOUT) :: suggested_vol_penalty
5581 :
5582 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_gradient_nlmos'
5583 :
5584 : INTEGER :: dim0, handle, idim0, reim
5585 : REAL(KIND=dp) :: norm_loc, norm_vol
5586 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tg_diagonal, z2
5587 : TYPE(dbcsr_type) :: m_temp_oo_1, m_temp_oo_2, m_temp_oo_3, &
5588 : m_temp_oo_4
5589 :
5590 82 : CALL timeset(routineN, handle)
5591 :
5592 : CALL dbcsr_create(m_temp_oo_1, &
5593 : template=m_theta_normalized, &
5594 82 : matrix_type=dbcsr_type_no_symmetry)
5595 : CALL dbcsr_create(m_temp_oo_2, &
5596 : template=m_theta_normalized, &
5597 82 : matrix_type=dbcsr_type_no_symmetry)
5598 : CALL dbcsr_create(m_temp_oo_3, &
5599 : template=m_theta_normalized, &
5600 82 : matrix_type=dbcsr_type_no_symmetry)
5601 : CALL dbcsr_create(m_temp_oo_4, &
5602 : template=m_theta_normalized, &
5603 82 : matrix_type=dbcsr_type_no_symmetry)
5604 :
5605 82 : CALL dbcsr_get_info(m_siginv, nfullrows_total=dim0)
5606 246 : ALLOCATE (tg_diagonal(dim0))
5607 164 : ALLOCATE (z2(dim0))
5608 82 : CALL dbcsr_set(m_temp_oo_1, 0.0_dp) ! accumulate the gradient wrt a_norm here
5609 :
5610 : ! do d_Omega/d_a_normalized first
5611 842 : DO idim0 = 1, SIZE(m_B0, 2) ! this loop is over miller ind
5612 :
5613 760 : z2(:) = 0.0_dp
5614 760 : CALL dbcsr_set(m_temp_oo_2, 0.0_dp) ! accumulate index gradient here
5615 1520 : DO reim = 1, SIZE(m_B0, 1) ! this loop is over Re/Im
5616 :
5617 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5618 : m_B0(reim, idim0), &
5619 : m_theta_normalized, &
5620 : 0.0_dp, m_temp_oo_3, &
5621 760 : filter_eps=eps_filter)
5622 :
5623 : ! result contain Re/Im part of Z for the current Miller index
5624 : ! warning - save time by computing only the diagonal elements
5625 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5626 : m_theta_normalized, &
5627 : m_temp_oo_3, &
5628 : 0.0_dp, m_temp_oo_4, &
5629 760 : filter_eps=eps_filter)
5630 :
5631 760 : tg_diagonal(:) = 0.0_dp
5632 760 : CALL dbcsr_get_diag(m_temp_oo_4, tg_diagonal)
5633 760 : CALL dbcsr_set(m_temp_oo_4, 0.0_dp)
5634 760 : CALL dbcsr_set_diag(m_temp_oo_4, tg_diagonal)
5635 12608 : z2(:) = z2(:) + tg_diagonal(:)*tg_diagonal(:)
5636 :
5637 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5638 : m_temp_oo_3, &
5639 : m_temp_oo_4, &
5640 : 1.0_dp, m_temp_oo_2, &
5641 1520 : filter_eps=eps_filter)
5642 :
5643 : END DO
5644 :
5645 : ! TODO: because some elements are zeros on some MPI tasks the
5646 : ! gradient evaluation will fail for CASE 1 and 3
5647 : SELECT CASE (2) ! allows for selection of different spread functionals
5648 : CASE (1) ! functional = -W_I * log( |z_I|^2 )
5649 : z2(:) = -weights(idim0)/z2(:)
5650 : CASE (2) ! functional = W_I * ( 1 - |z_I|^2 )
5651 12608 : z2(:) = -weights(idim0)
5652 : CASE (3) ! functional = W_I * ( 1 - |z_I| )
5653 : z2(:) = -weights(idim0)/(2*SQRT(z2(:)))
5654 : END SELECT
5655 760 : CALL dbcsr_set(m_temp_oo_3, 0.0_dp)
5656 760 : CALL dbcsr_set_diag(m_temp_oo_3, z2)
5657 : ! TODO: print this matrix to make sure its block structure is fine
5658 : ! and there are no unecessary elements
5659 :
5660 : CALL dbcsr_multiply("N", "N", 4.0_dp, &
5661 : m_temp_oo_2, &
5662 : m_temp_oo_3, &
5663 : 1.0_dp, m_temp_oo_1, &
5664 842 : filter_eps=eps_filter)
5665 :
5666 : END DO ! end loop over idim0
5667 82 : DEALLOCATE (z2)
5668 :
5669 : ! sigma0.a_norm is necessary for the volume penalty and normalization
5670 : CALL dbcsr_multiply("N", "N", &
5671 : 1.0_dp, &
5672 : m_S0, &
5673 : m_theta_normalized, &
5674 : 0.0_dp, m_temp_oo_2, &
5675 82 : filter_eps=eps_filter)
5676 :
5677 : ! add gradient of the penalty functional log[det(sigma)]
5678 : ! G = 2*prefactor*sigma0.a_norm.sigma_inv
5679 : CALL dbcsr_multiply("N", "N", &
5680 : 1.0_dp, &
5681 : m_temp_oo_2, &
5682 : m_siginv, &
5683 : 0.0_dp, m_temp_oo_3, &
5684 82 : filter_eps=eps_filter)
5685 82 : norm_vol = dbcsr_maxabs(m_temp_oo_3)
5686 82 : norm_loc = dbcsr_maxabs(m_temp_oo_1)
5687 82 : suggested_vol_penalty = norm_loc/norm_vol
5688 : CALL dbcsr_add(m_temp_oo_1, m_temp_oo_3, &
5689 82 : 1.0_dp, 2.0_dp*penalty_vol_prefactor)
5690 :
5691 : ! take into account the factor from the normalization constraint
5692 : ! G = ( G - sigma0.a_norm.[tr(a_norm).G]_ii ) . [sig_sqrti]_ii
5693 : ! 1. get G.[sig_sqrti]_ii
5694 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5695 : m_temp_oo_1, &
5696 : m_sig_sqrti_ii, &
5697 : 0.0_dp, m_grad_out, &
5698 82 : filter_eps=eps_filter)
5699 :
5700 : ! 2. get [tr(a_norm).G]_ii
5701 : ! it is possible to save time by computing only the diagonal elements
5702 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5703 : m_theta_normalized, &
5704 : m_temp_oo_1, &
5705 : 0.0_dp, m_temp_oo_3, &
5706 82 : filter_eps=eps_filter)
5707 82 : CALL dbcsr_get_diag(m_temp_oo_3, tg_diagonal)
5708 82 : CALL dbcsr_set(m_temp_oo_3, 0.0_dp)
5709 82 : CALL dbcsr_set_diag(m_temp_oo_3, tg_diagonal)
5710 :
5711 : ! 3. [X]_ii . [sig_sqrti]_ii
5712 : ! it is possible to save time by computing only the diagonal elements
5713 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5714 : m_sig_sqrti_ii, &
5715 : m_temp_oo_3, &
5716 : 0.0_dp, m_temp_oo_1, &
5717 82 : filter_eps=eps_filter)
5718 : ! 4. (sigma0*a_norm) .[X]_ii
5719 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
5720 : m_temp_oo_2, &
5721 : m_temp_oo_1, &
5722 : 1.0_dp, m_grad_out, &
5723 82 : filter_eps=eps_filter)
5724 :
5725 82 : DEALLOCATE (tg_diagonal)
5726 82 : CALL dbcsr_release(m_temp_oo_1)
5727 82 : CALL dbcsr_release(m_temp_oo_2)
5728 82 : CALL dbcsr_release(m_temp_oo_3)
5729 82 : CALL dbcsr_release(m_temp_oo_4)
5730 :
5731 82 : CALL timestop(handle)
5732 :
5733 164 : END SUBROUTINE compute_gradient_nlmos
5734 :
5735 : ! **************************************************************************************************
5736 : !> \brief Compute MO coeffs from the main optimized variable (e.g. Theta, X)
5737 : !> \param m_var_in ...
5738 : !> \param m_t_out ...
5739 : !> \param m_quench_t ...
5740 : !> \param m_t0 ...
5741 : !> \param m_oo_template ...
5742 : !> \param m_STsiginv0 ...
5743 : !> \param m_s ...
5744 : !> \param m_sig_sqrti_ii_out ...
5745 : !> \param domain_r_down ...
5746 : !> \param domain_s_inv ...
5747 : !> \param domain_map ...
5748 : !> \param cpu_of_domain ...
5749 : !> \param assume_t0_q0x ...
5750 : !> \param just_started ...
5751 : !> \param optimize_theta ...
5752 : !> \param normalize_orbitals ...
5753 : !> \param envelope_amplitude ...
5754 : !> \param eps_filter ...
5755 : !> \param special_case ...
5756 : !> \param nocc_of_domain ...
5757 : !> \param order_lanczos ...
5758 : !> \param eps_lanczos ...
5759 : !> \param max_iter_lanczos ...
5760 : !> \par History
5761 : !> 2015.03 created [Rustam Z Khaliullin]
5762 : !> \author Rustam Z Khaliullin
5763 : ! **************************************************************************************************
5764 2996 : SUBROUTINE compute_xalmos_from_main_var(m_var_in, m_t_out, m_quench_t, &
5765 1498 : m_t0, m_oo_template, m_STsiginv0, m_s, m_sig_sqrti_ii_out, domain_r_down, &
5766 1498 : domain_s_inv, domain_map, cpu_of_domain, assume_t0_q0x, just_started, &
5767 : optimize_theta, normalize_orbitals, envelope_amplitude, eps_filter, &
5768 1498 : special_case, nocc_of_domain, order_lanczos, eps_lanczos, max_iter_lanczos)
5769 :
5770 : TYPE(dbcsr_type), INTENT(IN) :: m_var_in
5771 : TYPE(dbcsr_type), INTENT(INOUT) :: m_t_out, m_quench_t, m_t0, &
5772 : m_oo_template, m_STsiginv0, m_s, &
5773 : m_sig_sqrti_ii_out
5774 : TYPE(domain_submatrix_type), DIMENSION(:), &
5775 : INTENT(IN) :: domain_r_down, domain_s_inv
5776 : TYPE(domain_map_type), INTENT(IN) :: domain_map
5777 : INTEGER, DIMENSION(:), INTENT(IN) :: cpu_of_domain
5778 : LOGICAL, INTENT(IN) :: assume_t0_q0x, just_started, &
5779 : optimize_theta, normalize_orbitals
5780 : REAL(KIND=dp), INTENT(IN) :: envelope_amplitude, eps_filter
5781 : INTEGER, INTENT(IN) :: special_case
5782 : INTEGER, DIMENSION(:), INTENT(IN) :: nocc_of_domain
5783 : INTEGER, INTENT(IN) :: order_lanczos
5784 : REAL(KIND=dp), INTENT(IN) :: eps_lanczos
5785 : INTEGER, INTENT(IN) :: max_iter_lanczos
5786 :
5787 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_xalmos_from_main_var'
5788 :
5789 : INTEGER :: handle, unit_nr
5790 : REAL(KIND=dp) :: t_norm
5791 : TYPE(cp_logger_type), POINTER :: logger
5792 : TYPE(dbcsr_type) :: m_tmp_no_1, m_tmp_oo_1
5793 :
5794 1498 : CALL timeset(routineN, handle)
5795 :
5796 : ! get a useful output_unit
5797 1498 : logger => cp_get_default_logger()
5798 1498 : IF (logger%para_env%is_source()) THEN
5799 749 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
5800 : ELSE
5801 : unit_nr = -1
5802 : END IF
5803 :
5804 : CALL dbcsr_create(m_tmp_no_1, &
5805 : template=m_quench_t, &
5806 1498 : matrix_type=dbcsr_type_no_symmetry)
5807 : CALL dbcsr_create(m_tmp_oo_1, &
5808 : template=m_oo_template, &
5809 1498 : matrix_type=dbcsr_type_no_symmetry)
5810 :
5811 1498 : CALL dbcsr_copy(m_tmp_no_1, m_var_in)
5812 1498 : IF (optimize_theta) THEN
5813 : ! check that all MO coefficients of the guess are less
5814 : ! than the maximum allowed amplitude
5815 0 : t_norm = dbcsr_maxabs(m_tmp_no_1)
5816 0 : IF (unit_nr > 0) THEN
5817 0 : WRITE (unit_nr, *) "Maximum norm of the initial guess: ", t_norm
5818 0 : WRITE (unit_nr, *) "Maximum allowed amplitude: ", &
5819 0 : envelope_amplitude
5820 : END IF
5821 0 : IF (t_norm > envelope_amplitude .AND. just_started) THEN
5822 0 : CPABORT("Max norm of the initial guess is too large")
5823 : END IF
5824 : ! use artanh to tame MOs
5825 0 : CALL tanh_of_elements(m_tmp_no_1, alpha=1.0_dp/envelope_amplitude)
5826 0 : CALL dbcsr_scale(m_tmp_no_1, envelope_amplitude)
5827 : END IF
5828 : CALL dbcsr_hadamard_product(m_tmp_no_1, m_quench_t, &
5829 1498 : m_t_out)
5830 :
5831 : ! project out R_0
5832 1498 : IF (assume_t0_q0x) THEN
5833 466 : IF (special_case == xalmo_case_fully_deloc) THEN
5834 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
5835 : m_STsiginv0, &
5836 : m_t_out, &
5837 : 0.0_dp, m_tmp_oo_1, &
5838 160 : filter_eps=eps_filter)
5839 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
5840 : m_t0, &
5841 : m_tmp_oo_1, &
5842 : 1.0_dp, m_t_out, &
5843 160 : filter_eps=eps_filter)
5844 306 : ELSE IF (special_case == xalmo_case_block_diag) THEN
5845 0 : CPABORT("cannot use projector with block-daigonal ALMOs")
5846 : ELSE
5847 : ! no special case
5848 : CALL apply_domain_operators( &
5849 : matrix_in=m_t_out, &
5850 : matrix_out=m_tmp_no_1, &
5851 : operator1=domain_r_down, &
5852 : operator2=domain_s_inv, &
5853 : dpattern=m_quench_t, &
5854 : map=domain_map, &
5855 : node_of_domain=cpu_of_domain, &
5856 : my_action=1, &
5857 : filter_eps=eps_filter, &
5858 306 : use_trimmer=.FALSE.)
5859 : CALL dbcsr_copy(m_t_out, &
5860 306 : m_tmp_no_1)
5861 : END IF ! special case
5862 : CALL dbcsr_add(m_t_out, &
5863 466 : m_t0, 1.0_dp, 1.0_dp)
5864 : END IF
5865 :
5866 1498 : IF (normalize_orbitals) THEN
5867 : CALL orthogonalize_mos( &
5868 : ket=m_t_out, &
5869 : overlap=m_tmp_oo_1, &
5870 : metric=m_s, &
5871 : retain_locality=.TRUE., &
5872 : only_normalize=.TRUE., &
5873 : nocc_of_domain=nocc_of_domain(:), &
5874 : eps_filter=eps_filter, &
5875 : order_lanczos=order_lanczos, &
5876 : eps_lanczos=eps_lanczos, &
5877 : max_iter_lanczos=max_iter_lanczos, &
5878 0 : overlap_sqrti=m_sig_sqrti_ii_out)
5879 : END IF
5880 :
5881 1498 : CALL dbcsr_filter(m_t_out, eps_filter)
5882 :
5883 1498 : CALL dbcsr_release(m_tmp_no_1)
5884 1498 : CALL dbcsr_release(m_tmp_oo_1)
5885 :
5886 1498 : CALL timestop(handle)
5887 :
5888 1498 : END SUBROUTINE compute_xalmos_from_main_var
5889 :
5890 : ! **************************************************************************************************
5891 : !> \brief Compute the preconditioner matrices and invert them if necessary
5892 : !> \param domain_prec_out ...
5893 : !> \param m_prec_out ...
5894 : !> \param m_ks ...
5895 : !> \param m_s ...
5896 : !> \param m_siginv ...
5897 : !> \param m_quench_t ...
5898 : !> \param m_FTsiginv ...
5899 : !> \param m_siginvTFTsiginv ...
5900 : !> \param m_ST ...
5901 : !> \param m_STsiginv_out ...
5902 : !> \param m_s_vv_out ...
5903 : !> \param m_f_vv_out ...
5904 : !> \param para_env ...
5905 : !> \param blacs_env ...
5906 : !> \param nocc_of_domain ...
5907 : !> \param domain_s_inv ...
5908 : !> \param domain_s_inv_half ...
5909 : !> \param domain_s_half ...
5910 : !> \param domain_r_down ...
5911 : !> \param cpu_of_domain ...
5912 : !> \param domain_map ...
5913 : !> \param assume_t0_q0x ...
5914 : !> \param penalty_occ_vol ...
5915 : !> \param penalty_occ_vol_prefactor ...
5916 : !> \param eps_filter ...
5917 : !> \param neg_thr ...
5918 : !> \param spin_factor ...
5919 : !> \param special_case ...
5920 : !> \param bad_modes_projector_down_out ...
5921 : !> \param skip_inversion ...
5922 : !> \par History
5923 : !> 2015.03 created [Rustam Z Khaliullin]
5924 : !> \author Rustam Z Khaliullin
5925 : ! **************************************************************************************************
5926 1524 : SUBROUTINE compute_preconditioner(domain_prec_out, m_prec_out, m_ks, m_s, &
5927 : m_siginv, m_quench_t, m_FTsiginv, m_siginvTFTsiginv, m_ST, &
5928 : m_STsiginv_out, m_s_vv_out, m_f_vv_out, para_env, &
5929 1016 : blacs_env, nocc_of_domain, domain_s_inv, domain_s_inv_half, domain_s_half, &
5930 508 : domain_r_down, cpu_of_domain, &
5931 : domain_map, assume_t0_q0x, penalty_occ_vol, penalty_occ_vol_prefactor, &
5932 508 : eps_filter, neg_thr, spin_factor, special_case, bad_modes_projector_down_out, &
5933 : skip_inversion)
5934 :
5935 : TYPE(domain_submatrix_type), DIMENSION(:), &
5936 : INTENT(INOUT) :: domain_prec_out
5937 : TYPE(dbcsr_type), INTENT(INOUT) :: m_prec_out, m_ks, m_s
5938 : TYPE(dbcsr_type), INTENT(IN) :: m_siginv, m_quench_t, m_FTsiginv, &
5939 : m_siginvTFTsiginv, m_ST
5940 : TYPE(dbcsr_type), INTENT(INOUT), OPTIONAL :: m_STsiginv_out, m_s_vv_out, m_f_vv_out
5941 : TYPE(mp_para_env_type), POINTER :: para_env
5942 : TYPE(cp_blacs_env_type), POINTER :: blacs_env
5943 : INTEGER, DIMENSION(:), INTENT(IN) :: nocc_of_domain
5944 : TYPE(domain_submatrix_type), DIMENSION(:), &
5945 : INTENT(IN) :: domain_s_inv
5946 : TYPE(domain_submatrix_type), DIMENSION(:), &
5947 : INTENT(IN), OPTIONAL :: domain_s_inv_half, domain_s_half
5948 : TYPE(domain_submatrix_type), DIMENSION(:), &
5949 : INTENT(IN) :: domain_r_down
5950 : INTEGER, DIMENSION(:), INTENT(IN) :: cpu_of_domain
5951 : TYPE(domain_map_type), INTENT(IN) :: domain_map
5952 : LOGICAL, INTENT(IN) :: assume_t0_q0x, penalty_occ_vol
5953 : REAL(KIND=dp), INTENT(IN) :: penalty_occ_vol_prefactor, eps_filter, &
5954 : neg_thr, spin_factor
5955 : INTEGER, INTENT(IN) :: special_case
5956 : TYPE(domain_submatrix_type), DIMENSION(:), &
5957 : INTENT(INOUT), OPTIONAL :: bad_modes_projector_down_out
5958 : LOGICAL, INTENT(IN) :: skip_inversion
5959 :
5960 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_preconditioner'
5961 :
5962 : INTEGER :: handle, ndim, precond_domain_projector
5963 508 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: nn_diagonal
5964 : TYPE(dbcsr_type) :: m_tmp_nn_1, m_tmp_no_3
5965 :
5966 508 : CALL timeset(routineN, handle)
5967 :
5968 : CALL dbcsr_create(m_tmp_nn_1, &
5969 : template=m_s, &
5970 508 : matrix_type=dbcsr_type_no_symmetry)
5971 : CALL dbcsr_create(m_tmp_no_3, &
5972 : template=m_quench_t, &
5973 508 : matrix_type=dbcsr_type_no_symmetry)
5974 :
5975 : ! calculate (1-R)F(1-R) and S-SRS
5976 : ! RZK-warning take advantage: some elements will be removed by the quencher
5977 : ! RZK-warning S operations can be performed outside the spin loop to save time
5978 : ! IT IS REQUIRED THAT PRECONDITIONER DOES NOT BREAK THE LOCALITY!!!!
5979 : ! RZK-warning: further optimization is ABSOLUTELY NECESSARY
5980 :
5981 : ! First S-SRS
5982 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
5983 : m_ST, &
5984 : m_siginv, &
5985 : 0.0_dp, m_tmp_no_3, &
5986 508 : filter_eps=eps_filter)
5987 508 : CALL dbcsr_desymmetrize(m_s, m_tmp_nn_1)
5988 : ! return STsiginv if necessary
5989 508 : IF (PRESENT(m_STsiginv_out)) THEN
5990 0 : CALL dbcsr_copy(m_STsiginv_out, m_tmp_no_3)
5991 : END IF
5992 508 : IF (special_case == xalmo_case_fully_deloc) THEN
5993 : ! use S instead of S-SRS
5994 : ELSE
5995 : CALL dbcsr_multiply("N", "T", -1.0_dp, &
5996 : m_ST, &
5997 : m_tmp_no_3, &
5998 : 1.0_dp, m_tmp_nn_1, &
5999 464 : filter_eps=eps_filter)
6000 : END IF
6001 : ! return S_vv = (S or S-SRS) if necessary
6002 508 : IF (PRESENT(m_s_vv_out)) THEN
6003 0 : CALL dbcsr_copy(m_s_vv_out, m_tmp_nn_1)
6004 : END IF
6005 :
6006 : ! Second (1-R)F(1-R)
6007 : ! re-create matrix because desymmetrize is buggy -
6008 : ! it will create multiple copies of blocks
6009 508 : CALL dbcsr_desymmetrize(m_ks, m_prec_out)
6010 : CALL dbcsr_multiply("N", "T", -1.0_dp, &
6011 : m_FTsiginv, &
6012 : m_ST, &
6013 : 1.0_dp, m_prec_out, &
6014 508 : filter_eps=eps_filter)
6015 : CALL dbcsr_multiply("N", "T", -1.0_dp, &
6016 : m_ST, &
6017 : m_FTsiginv, &
6018 : 1.0_dp, m_prec_out, &
6019 508 : filter_eps=eps_filter)
6020 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6021 : m_ST, &
6022 : m_siginvTFTsiginv, &
6023 : 0.0_dp, m_tmp_no_3, &
6024 508 : filter_eps=eps_filter)
6025 : CALL dbcsr_multiply("N", "T", 1.0_dp, &
6026 : m_tmp_no_3, &
6027 : m_ST, &
6028 : 1.0_dp, m_prec_out, &
6029 508 : filter_eps=eps_filter)
6030 : ! return F_vv = (I-SR)F(I-RS) if necessary
6031 508 : IF (PRESENT(m_f_vv_out)) THEN
6032 0 : CALL dbcsr_copy(m_f_vv_out, m_prec_out)
6033 : END IF
6034 :
6035 : ! sum up the F_vv and S_vv terms
6036 : CALL dbcsr_add(m_prec_out, m_tmp_nn_1, &
6037 508 : 1.0_dp, 1.0_dp)
6038 : ! Scale to obtain unit step length
6039 508 : CALL dbcsr_scale(m_prec_out, 2.0_dp*spin_factor)
6040 :
6041 : ! add the contribution from the penalty on the occupied volume
6042 508 : IF (penalty_occ_vol) THEN
6043 : CALL dbcsr_add(m_prec_out, m_tmp_nn_1, &
6044 0 : 1.0_dp, penalty_occ_vol_prefactor)
6045 : END IF
6046 :
6047 508 : CALL dbcsr_copy(m_tmp_nn_1, m_prec_out)
6048 :
6049 : ! invert using various algorithms
6050 508 : IF (special_case == xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks
6051 :
6052 104 : IF (skip_inversion) THEN
6053 :
6054 : ! impose block-diagonal structure
6055 92 : CALL dbcsr_get_info(m_s, nfullrows_total=ndim)
6056 276 : ALLOCATE (nn_diagonal(ndim))
6057 92 : CALL dbcsr_get_diag(m_s, nn_diagonal)
6058 92 : CALL dbcsr_set(m_prec_out, 0.0_dp)
6059 92 : CALL dbcsr_set_diag(m_prec_out, nn_diagonal)
6060 92 : CALL dbcsr_filter(m_prec_out, eps_filter)
6061 92 : DEALLOCATE (nn_diagonal)
6062 :
6063 184 : CALL dbcsr_copy(m_prec_out, m_tmp_nn_1, keep_sparsity=.TRUE.)
6064 :
6065 : ELSE
6066 :
6067 : CALL pseudo_invert_diagonal_blk( &
6068 : matrix_in=m_tmp_nn_1, &
6069 : matrix_out=m_prec_out, &
6070 : nocc=nocc_of_domain(:) &
6071 12 : )
6072 :
6073 : END IF
6074 :
6075 404 : ELSE IF (special_case == xalmo_case_fully_deloc) THEN ! the entire system is a block
6076 :
6077 44 : IF (skip_inversion) THEN
6078 0 : CALL dbcsr_copy(m_prec_out, m_tmp_nn_1)
6079 : ELSE
6080 :
6081 : ! invert using cholesky (works with S matrix, will not work with S-SRS matrix)
6082 : CALL cp_dbcsr_cholesky_decompose(m_prec_out, &
6083 : para_env=para_env, &
6084 44 : blacs_env=blacs_env)
6085 : CALL cp_dbcsr_cholesky_invert(m_prec_out, &
6086 : para_env=para_env, &
6087 : blacs_env=blacs_env, &
6088 44 : uplo_to_full=.TRUE.)
6089 : END IF !skip_inversion
6090 :
6091 44 : CALL dbcsr_filter(m_prec_out, eps_filter)
6092 :
6093 : ELSE
6094 :
6095 : !!! use a true domain preconditioner with overlapping domains
6096 360 : IF (assume_t0_q0x) THEN
6097 26 : precond_domain_projector = -1
6098 : ELSE
6099 334 : precond_domain_projector = 0
6100 : END IF
6101 : !! RZK-warning: use PRESENT to make two nearly-identical calls
6102 : !! this is done because intel compiler does not seem to conform
6103 : !! to the FORTRAN standard for passing through optional arguments
6104 360 : IF (PRESENT(bad_modes_projector_down_out)) THEN
6105 : CALL construct_domain_preconditioner( &
6106 : matrix_main=m_tmp_nn_1, &
6107 : subm_s_inv=domain_s_inv(:), &
6108 : subm_s_inv_half=domain_s_inv_half(:), &
6109 : subm_s_half=domain_s_half(:), &
6110 : subm_r_down=domain_r_down(:), &
6111 : matrix_trimmer=m_quench_t, &
6112 : dpattern=m_quench_t, &
6113 : map=domain_map, &
6114 : node_of_domain=cpu_of_domain, &
6115 : preconditioner=domain_prec_out(:), &
6116 : use_trimmer=.FALSE., &
6117 : bad_modes_projector_down=bad_modes_projector_down_out(:), &
6118 : eps_zero_eigenvalues=neg_thr, &
6119 : my_action=precond_domain_projector, &
6120 : skip_inversion=skip_inversion &
6121 18 : )
6122 : ELSE
6123 : CALL construct_domain_preconditioner( &
6124 : matrix_main=m_tmp_nn_1, &
6125 : subm_s_inv=domain_s_inv(:), &
6126 : subm_r_down=domain_r_down(:), &
6127 : matrix_trimmer=m_quench_t, &
6128 : dpattern=m_quench_t, &
6129 : map=domain_map, &
6130 : node_of_domain=cpu_of_domain, &
6131 : preconditioner=domain_prec_out(:), &
6132 : use_trimmer=.FALSE., &
6133 : !eps_zero_eigenvalues=neg_thr,&
6134 : my_action=precond_domain_projector, &
6135 : skip_inversion=skip_inversion &
6136 342 : )
6137 : END IF
6138 :
6139 : END IF ! special_case
6140 :
6141 508 : CALL dbcsr_release(m_tmp_nn_1)
6142 508 : CALL dbcsr_release(m_tmp_no_3)
6143 :
6144 508 : CALL timestop(handle)
6145 :
6146 1016 : END SUBROUTINE compute_preconditioner
6147 :
6148 : ! **************************************************************************************************
6149 : !> \brief Compute beta for conjugate gradient algorithms
6150 : !> \param beta ...
6151 : !> \param numer ...
6152 : !> \param denom ...
6153 : !> \param reset_conjugator ...
6154 : !> \param conjugator ...
6155 : !> \param grad ...
6156 : !> \param prev_grad ...
6157 : !> \param step ...
6158 : !> \param prev_step ...
6159 : !> \param prev_minus_prec_grad ...
6160 : !> \par History
6161 : !> 2015.04 created [Rustam Z Khaliullin]
6162 : !> \author Rustam Z Khaliullin
6163 : ! **************************************************************************************************
6164 1016 : SUBROUTINE compute_cg_beta(beta, numer, denom, reset_conjugator, conjugator, &
6165 508 : grad, prev_grad, step, prev_step, prev_minus_prec_grad)
6166 :
6167 : REAL(KIND=dp), INTENT(INOUT) :: beta
6168 : REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: numer, denom
6169 : LOGICAL, INTENT(INOUT) :: reset_conjugator
6170 : INTEGER, INTENT(IN) :: conjugator
6171 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: grad, prev_grad, step, prev_step
6172 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT), &
6173 : OPTIONAL :: prev_minus_prec_grad
6174 :
6175 : CHARACTER(len=*), PARAMETER :: routineN = 'compute_cg_beta'
6176 :
6177 : INTEGER :: handle, i, nsize, unit_nr
6178 : REAL(KIND=dp) :: den, kappa, my_denom, my_numer, &
6179 : my_numer2, my_numer3, num, num2, num3, &
6180 : tau
6181 : TYPE(cp_logger_type), POINTER :: logger
6182 : TYPE(dbcsr_type) :: m_tmp_no_1
6183 :
6184 508 : CALL timeset(routineN, handle)
6185 :
6186 : ! get a useful output_unit
6187 508 : logger => cp_get_default_logger()
6188 508 : IF (logger%para_env%is_source()) THEN
6189 254 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
6190 : ELSE
6191 : unit_nr = -1
6192 : END IF
6193 :
6194 508 : IF (.NOT. PRESENT(prev_minus_prec_grad)) THEN
6195 : IF (conjugator == cg_fletcher_reeves .OR. &
6196 82 : conjugator == cg_polak_ribiere .OR. &
6197 : conjugator == cg_hager_zhang) THEN
6198 0 : CPABORT("conjugator needs more input")
6199 : END IF
6200 : END IF
6201 :
6202 : ! return num denom so beta can be calculated spin-by-spin
6203 508 : IF (PRESENT(numer) .OR. PRESENT(denom)) THEN
6204 : IF (conjugator == cg_hestenes_stiefel .OR. &
6205 0 : conjugator == cg_dai_yuan .OR. &
6206 : conjugator == cg_hager_zhang) THEN
6207 0 : CPABORT("cannot return numer/denom")
6208 : END IF
6209 : END IF
6210 :
6211 508 : nsize = SIZE(grad)
6212 :
6213 508 : my_numer = 0.0_dp
6214 508 : my_numer2 = 0.0_dp
6215 508 : my_numer3 = 0.0_dp
6216 508 : my_denom = 0.0_dp
6217 :
6218 1016 : DO i = 1, nsize
6219 :
6220 : CALL dbcsr_create(m_tmp_no_1, &
6221 : template=grad(i), &
6222 508 : matrix_type=dbcsr_type_no_symmetry)
6223 :
6224 570 : SELECT CASE (conjugator)
6225 : CASE (cg_hestenes_stiefel)
6226 62 : CALL dbcsr_copy(m_tmp_no_1, grad(i))
6227 : CALL dbcsr_add(m_tmp_no_1, prev_grad(i), &
6228 62 : 1.0_dp, -1.0_dp)
6229 62 : CALL dbcsr_dot(m_tmp_no_1, step(i), num)
6230 156 : CALL dbcsr_dot(m_tmp_no_1, prev_step(i), den)
6231 : CASE (cg_fletcher_reeves)
6232 94 : CALL dbcsr_dot(grad(i), step(i), num)
6233 124 : CALL dbcsr_dot(prev_grad(i), prev_minus_prec_grad(i), den)
6234 : CASE (cg_polak_ribiere)
6235 30 : CALL dbcsr_dot(prev_grad(i), prev_minus_prec_grad(i), den)
6236 30 : CALL dbcsr_copy(m_tmp_no_1, grad(i))
6237 30 : CALL dbcsr_add(m_tmp_no_1, prev_grad(i), 1.0_dp, -1.0_dp)
6238 202 : CALL dbcsr_dot(m_tmp_no_1, step(i), num)
6239 : CASE (cg_fletcher)
6240 172 : CALL dbcsr_dot(grad(i), step(i), num)
6241 192 : CALL dbcsr_dot(prev_grad(i), prev_step(i), den)
6242 : CASE (cg_liu_storey)
6243 20 : CALL dbcsr_dot(prev_grad(i), prev_step(i), den)
6244 20 : CALL dbcsr_copy(m_tmp_no_1, grad(i))
6245 20 : CALL dbcsr_add(m_tmp_no_1, prev_grad(i), 1.0_dp, -1.0_dp)
6246 54 : CALL dbcsr_dot(m_tmp_no_1, step(i), num)
6247 : CASE (cg_dai_yuan)
6248 34 : CALL dbcsr_dot(grad(i), step(i), num)
6249 34 : CALL dbcsr_copy(m_tmp_no_1, grad(i))
6250 34 : CALL dbcsr_add(m_tmp_no_1, prev_grad(i), 1.0_dp, -1.0_dp)
6251 106 : CALL dbcsr_dot(m_tmp_no_1, prev_step(i), den)
6252 : CASE (cg_hager_zhang)
6253 72 : CALL dbcsr_copy(m_tmp_no_1, grad(i))
6254 72 : CALL dbcsr_add(m_tmp_no_1, prev_grad(i), 1.0_dp, -1.0_dp)
6255 72 : CALL dbcsr_dot(m_tmp_no_1, prev_step(i), den)
6256 72 : CALL dbcsr_dot(m_tmp_no_1, prev_minus_prec_grad(i), num)
6257 72 : CALL dbcsr_dot(m_tmp_no_1, step(i), num2)
6258 72 : CALL dbcsr_dot(prev_step(i), grad(i), num3)
6259 72 : my_numer2 = my_numer2 + num2
6260 72 : my_numer3 = my_numer3 + num3
6261 : CASE (cg_zero)
6262 24 : num = 0.0_dp
6263 24 : den = 1.0_dp
6264 : CASE DEFAULT
6265 726 : CPABORT("illegal conjugator")
6266 : END SELECT
6267 508 : my_numer = my_numer + num
6268 508 : my_denom = my_denom + den
6269 :
6270 1016 : CALL dbcsr_release(m_tmp_no_1)
6271 :
6272 : END DO ! i - nsize
6273 :
6274 1016 : DO i = 1, nsize
6275 :
6276 508 : SELECT CASE (conjugator)
6277 : CASE (cg_hestenes_stiefel, cg_dai_yuan)
6278 96 : beta = -1.0_dp*my_numer/my_denom
6279 : CASE (cg_fletcher_reeves, cg_polak_ribiere, cg_fletcher, cg_liu_storey)
6280 316 : beta = my_numer/my_denom
6281 : CASE (cg_hager_zhang)
6282 72 : kappa = -2.0_dp*my_numer/my_denom
6283 72 : tau = -1.0_dp*my_numer2/my_denom
6284 72 : beta = tau - kappa*my_numer3/my_denom
6285 : CASE (cg_zero)
6286 24 : beta = 0.0_dp
6287 : CASE DEFAULT
6288 508 : CPABORT("illegal conjugator")
6289 : END SELECT
6290 :
6291 : END DO ! i - nsize
6292 :
6293 508 : IF (beta < 0.0_dp) THEN
6294 0 : IF (unit_nr > 0) THEN
6295 0 : WRITE (unit_nr, *) " Resetting conjugator because beta is negative: ", beta
6296 : END IF
6297 0 : reset_conjugator = .TRUE.
6298 : END IF
6299 :
6300 508 : IF (PRESENT(numer)) THEN
6301 0 : numer = my_numer
6302 : END IF
6303 508 : IF (PRESENT(denom)) THEN
6304 0 : denom = my_denom
6305 : END IF
6306 :
6307 508 : CALL timestop(handle)
6308 :
6309 508 : END SUBROUTINE compute_cg_beta
6310 :
6311 : ! **************************************************************************************************
6312 : !> \brief computes the step matrix from the gradient and Hessian using the Newton-Raphson method
6313 : !> \param optimizer ...
6314 : !> \param m_grad ...
6315 : !> \param m_delta ...
6316 : !> \param m_s ...
6317 : !> \param m_ks ...
6318 : !> \param m_siginv ...
6319 : !> \param m_quench_t ...
6320 : !> \param m_FTsiginv ...
6321 : !> \param m_siginvTFTsiginv ...
6322 : !> \param m_ST ...
6323 : !> \param m_t ...
6324 : !> \param m_sig_sqrti_ii ...
6325 : !> \param domain_s_inv ...
6326 : !> \param domain_r_down ...
6327 : !> \param domain_map ...
6328 : !> \param cpu_of_domain ...
6329 : !> \param nocc_of_domain ...
6330 : !> \param para_env ...
6331 : !> \param blacs_env ...
6332 : !> \param eps_filter ...
6333 : !> \param optimize_theta ...
6334 : !> \param penalty_occ_vol ...
6335 : !> \param normalize_orbitals ...
6336 : !> \param penalty_occ_vol_prefactor ...
6337 : !> \param penalty_occ_vol_pf2 ...
6338 : !> \param special_case ...
6339 : !> \par History
6340 : !> 2015.04 created [Rustam Z. Khaliullin]
6341 : !> \author Rustam Z. Khaliullin
6342 : ! **************************************************************************************************
6343 0 : SUBROUTINE newton_grad_to_step(optimizer, m_grad, m_delta, m_s, m_ks, &
6344 0 : m_siginv, m_quench_t, m_FTsiginv, m_siginvTFTsiginv, m_ST, m_t, &
6345 0 : m_sig_sqrti_ii, domain_s_inv, domain_r_down, domain_map, cpu_of_domain, &
6346 0 : nocc_of_domain, para_env, blacs_env, eps_filter, optimize_theta, &
6347 0 : penalty_occ_vol, normalize_orbitals, penalty_occ_vol_prefactor, &
6348 0 : penalty_occ_vol_pf2, special_case)
6349 :
6350 : TYPE(optimizer_options_type), INTENT(IN) :: optimizer
6351 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_grad
6352 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: m_delta, m_s, m_ks, m_siginv, m_quench_t
6353 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_FTsiginv, m_siginvTFTsiginv, m_ST, &
6354 : m_t, m_sig_sqrti_ii
6355 : TYPE(domain_submatrix_type), DIMENSION(:, :), &
6356 : INTENT(IN) :: domain_s_inv, domain_r_down
6357 : TYPE(domain_map_type), DIMENSION(:), INTENT(IN) :: domain_map
6358 : INTEGER, DIMENSION(:), INTENT(IN) :: cpu_of_domain
6359 : INTEGER, DIMENSION(:, :), INTENT(IN) :: nocc_of_domain
6360 : TYPE(mp_para_env_type), POINTER :: para_env
6361 : TYPE(cp_blacs_env_type), POINTER :: blacs_env
6362 : REAL(KIND=dp), INTENT(IN) :: eps_filter
6363 : LOGICAL, INTENT(IN) :: optimize_theta, penalty_occ_vol, &
6364 : normalize_orbitals
6365 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: penalty_occ_vol_prefactor, &
6366 : penalty_occ_vol_pf2
6367 : INTEGER, INTENT(IN) :: special_case
6368 :
6369 : CHARACTER(len=*), PARAMETER :: routineN = 'newton_grad_to_step'
6370 :
6371 : CHARACTER(LEN=20) :: iter_type
6372 : INTEGER :: handle, ispin, iteration, max_iter, &
6373 : ndomains, nspins, outer_iteration, &
6374 : outer_max_iter, unit_nr
6375 : LOGICAL :: converged, do_exact_inversion, outer_prepare_to_exit, prepare_to_exit, &
6376 : reset_conjugator, use_preconditioner
6377 : REAL(KIND=dp) :: alpha, beta, denom, denom_ispin, &
6378 : eps_error_target, numer, numer_ispin, &
6379 : residue_norm, spin_factor, t1, t2
6380 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: residue_max_norm
6381 : TYPE(cp_logger_type), POINTER :: logger
6382 : TYPE(dbcsr_type) :: m_tmp_oo_1, m_tmp_oo_2
6383 0 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: m_f_vo, m_f_vv, m_Hstep, m_prec, &
6384 0 : m_residue, m_residue_prev, m_s_vv, &
6385 0 : m_step, m_STsiginv, m_zet, m_zet_prev
6386 : TYPE(domain_submatrix_type), ALLOCATABLE, &
6387 : DIMENSION(:, :) :: domain_prec
6388 :
6389 0 : CALL timeset(routineN, handle)
6390 :
6391 : ! get a useful output_unit
6392 0 : logger => cp_get_default_logger()
6393 0 : IF (logger%para_env%is_source()) THEN
6394 0 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
6395 : ELSE
6396 : unit_nr = -1
6397 : END IF
6398 :
6399 : !!! Currently for non-theta only
6400 0 : IF (optimize_theta) THEN
6401 0 : CPABORT("theta is NYI")
6402 : END IF
6403 :
6404 : ! set optimizer options
6405 0 : use_preconditioner = (optimizer%preconditioner /= xalmo_prec_zero)
6406 0 : outer_max_iter = optimizer%max_iter_outer_loop
6407 0 : max_iter = optimizer%max_iter
6408 0 : eps_error_target = optimizer%eps_error
6409 :
6410 : ! set key dimensions
6411 0 : nspins = SIZE(m_ks)
6412 0 : ndomains = SIZE(domain_s_inv, 1)
6413 :
6414 0 : IF (nspins == 1) THEN
6415 0 : spin_factor = 2.0_dp
6416 : ELSE
6417 0 : spin_factor = 1.0_dp
6418 : END IF
6419 :
6420 0 : ALLOCATE (domain_prec(ndomains, nspins))
6421 0 : CALL init_submatrices(domain_prec)
6422 :
6423 : ! allocate matrices
6424 0 : ALLOCATE (m_residue(nspins))
6425 0 : ALLOCATE (m_residue_prev(nspins))
6426 0 : ALLOCATE (m_step(nspins))
6427 0 : ALLOCATE (m_zet(nspins))
6428 0 : ALLOCATE (m_zet_prev(nspins))
6429 0 : ALLOCATE (m_Hstep(nspins))
6430 0 : ALLOCATE (m_prec(nspins))
6431 0 : ALLOCATE (m_s_vv(nspins))
6432 0 : ALLOCATE (m_f_vv(nspins))
6433 0 : ALLOCATE (m_f_vo(nspins))
6434 0 : ALLOCATE (m_STsiginv(nspins))
6435 :
6436 0 : ALLOCATE (residue_max_norm(nspins))
6437 :
6438 : ! initiate objects before iterations
6439 0 : DO ispin = 1, nspins
6440 :
6441 : ! init matrices
6442 : CALL dbcsr_create(m_residue(ispin), &
6443 : template=m_quench_t(ispin), &
6444 0 : matrix_type=dbcsr_type_no_symmetry)
6445 : CALL dbcsr_create(m_residue_prev(ispin), &
6446 : template=m_quench_t(ispin), &
6447 0 : matrix_type=dbcsr_type_no_symmetry)
6448 : CALL dbcsr_create(m_step(ispin), &
6449 : template=m_quench_t(ispin), &
6450 0 : matrix_type=dbcsr_type_no_symmetry)
6451 : CALL dbcsr_create(m_zet_prev(ispin), &
6452 : template=m_quench_t(ispin), &
6453 0 : matrix_type=dbcsr_type_no_symmetry)
6454 : CALL dbcsr_create(m_zet(ispin), &
6455 : template=m_quench_t(ispin), &
6456 0 : matrix_type=dbcsr_type_no_symmetry)
6457 : CALL dbcsr_create(m_Hstep(ispin), &
6458 : template=m_quench_t(ispin), &
6459 0 : matrix_type=dbcsr_type_no_symmetry)
6460 : CALL dbcsr_create(m_f_vo(ispin), &
6461 : template=m_quench_t(ispin), &
6462 0 : matrix_type=dbcsr_type_no_symmetry)
6463 : CALL dbcsr_create(m_STsiginv(ispin), &
6464 : template=m_quench_t(ispin), &
6465 0 : matrix_type=dbcsr_type_no_symmetry)
6466 : CALL dbcsr_create(m_f_vv(ispin), &
6467 : template=m_ks(ispin), &
6468 0 : matrix_type=dbcsr_type_no_symmetry)
6469 : CALL dbcsr_create(m_s_vv(ispin), &
6470 : template=m_s(1), &
6471 0 : matrix_type=dbcsr_type_no_symmetry)
6472 : CALL dbcsr_create(m_prec(ispin), &
6473 : template=m_ks(ispin), &
6474 0 : matrix_type=dbcsr_type_no_symmetry)
6475 :
6476 : ! compute the full "gradient" - it is necessary to
6477 : ! evaluate Hessian.X
6478 0 : CALL dbcsr_copy(m_f_vo(ispin), m_FTsiginv(ispin))
6479 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
6480 : m_ST(ispin), &
6481 : m_siginvTFTsiginv(ispin), &
6482 : 1.0_dp, m_f_vo(ispin), &
6483 0 : filter_eps=eps_filter)
6484 :
6485 : ! RZK-warning
6486 :
6487 : ! domain_s_inv and domain_r_down are never used with assume_t0_q0x=FALSE
6488 : CALL compute_preconditioner( &
6489 : domain_prec_out=domain_prec(:, ispin), &
6490 : m_prec_out=m_prec(ispin), &
6491 : m_ks=m_ks(ispin), &
6492 : m_s=m_s(1), &
6493 : m_siginv=m_siginv(ispin), &
6494 : m_quench_t=m_quench_t(ispin), &
6495 : m_FTsiginv=m_FTsiginv(ispin), &
6496 : m_siginvTFTsiginv=m_siginvTFTsiginv(ispin), &
6497 : m_ST=m_ST(ispin), &
6498 : m_STsiginv_out=m_STsiginv(ispin), &
6499 : m_s_vv_out=m_s_vv(ispin), &
6500 : m_f_vv_out=m_f_vv(ispin), &
6501 : para_env=para_env, &
6502 : blacs_env=blacs_env, &
6503 : nocc_of_domain=nocc_of_domain(:, ispin), &
6504 : domain_s_inv=domain_s_inv(:, ispin), &
6505 : domain_r_down=domain_r_down(:, ispin), &
6506 : cpu_of_domain=cpu_of_domain(:), &
6507 : domain_map=domain_map(ispin), &
6508 : assume_t0_q0x=.FALSE., &
6509 : penalty_occ_vol=penalty_occ_vol, &
6510 : penalty_occ_vol_prefactor=penalty_occ_vol_prefactor(ispin), &
6511 : eps_filter=eps_filter, &
6512 : neg_thr=0.5_dp, &
6513 : spin_factor=spin_factor, &
6514 : special_case=special_case, &
6515 : skip_inversion=.FALSE. &
6516 0 : )
6517 :
6518 : ! initial guess
6519 0 : CALL dbcsr_copy(m_delta(ispin), m_quench_t(ispin))
6520 : ! in order to use dbcsr_set matrix blocks must exist
6521 0 : CALL dbcsr_set(m_delta(ispin), 0.0_dp)
6522 0 : CALL dbcsr_copy(m_residue(ispin), m_grad(ispin))
6523 0 : CALL dbcsr_scale(m_residue(ispin), -1.0_dp)
6524 :
6525 0 : do_exact_inversion = .FALSE.
6526 : IF (do_exact_inversion) THEN
6527 :
6528 : ! copy grad to m_step temporarily
6529 : ! use m_step as input to the inversion routine
6530 : CALL dbcsr_copy(m_step(ispin), m_grad(ispin))
6531 :
6532 : ! expensive "exact" inversion of the "nearly-exact" Hessian
6533 : ! hopefully returns Z=-H^(-1).G
6534 : CALL hessian_diag_apply( &
6535 : matrix_grad=m_step(ispin), &
6536 : matrix_step=m_zet(ispin), &
6537 : matrix_S_ao=m_s_vv(ispin), &
6538 : matrix_F_ao=m_f_vv(ispin), &
6539 : !matrix_S_ao=m_s(ispin),&
6540 : !matrix_F_ao=m_ks(ispin),&
6541 : matrix_S_mo=m_siginv(ispin), &
6542 : matrix_F_mo=m_siginvTFTsiginv(ispin), &
6543 : matrix_S_vo=m_STsiginv(ispin), &
6544 : matrix_F_vo=m_f_vo(ispin), &
6545 : quench_t=m_quench_t(ispin), &
6546 : spin_factor=spin_factor, &
6547 : eps_zero=eps_filter*10.0_dp, &
6548 : penalty_occ_vol=penalty_occ_vol, &
6549 : penalty_occ_vol_prefactor=penalty_occ_vol_prefactor(ispin), &
6550 : penalty_occ_vol_pf2=penalty_occ_vol_pf2(ispin), &
6551 : m_s=m_s(1), &
6552 : para_env=para_env, &
6553 : blacs_env=blacs_env)
6554 :
6555 : ELSE ! use PCG to solve H.D=-G
6556 :
6557 0 : IF (use_preconditioner) THEN
6558 :
6559 0 : IF (special_case == xalmo_case_block_diag .OR. &
6560 : special_case == xalmo_case_fully_deloc) THEN
6561 :
6562 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6563 : m_prec(ispin), &
6564 : m_residue(ispin), &
6565 : 0.0_dp, m_zet(ispin), &
6566 0 : filter_eps=eps_filter)
6567 :
6568 : ELSE
6569 :
6570 : CALL apply_domain_operators( &
6571 : matrix_in=m_residue(ispin), &
6572 : matrix_out=m_zet(ispin), &
6573 : operator1=domain_prec(:, ispin), &
6574 : dpattern=m_quench_t(ispin), &
6575 : map=domain_map(ispin), &
6576 : node_of_domain=cpu_of_domain(:), &
6577 : my_action=0, &
6578 0 : filter_eps=eps_filter)
6579 :
6580 : END IF ! special_case
6581 :
6582 : ELSE ! do not use preconditioner
6583 :
6584 0 : CALL dbcsr_copy(m_zet(ispin), m_residue(ispin))
6585 :
6586 : END IF ! use_preconditioner
6587 :
6588 : END IF ! do_exact_inversion
6589 :
6590 0 : CALL dbcsr_copy(m_step(ispin), m_zet(ispin))
6591 :
6592 : END DO !ispin
6593 :
6594 : ! start the outer SCF loop
6595 : outer_prepare_to_exit = .FALSE.
6596 : outer_iteration = 0
6597 : residue_norm = 0.0_dp
6598 :
6599 : DO
6600 :
6601 : ! start the inner SCF loop
6602 0 : prepare_to_exit = .FALSE.
6603 0 : converged = .FALSE.
6604 0 : iteration = 0
6605 0 : t1 = m_walltime()
6606 :
6607 : DO
6608 :
6609 : ! apply hessian to the step matrix
6610 : CALL apply_hessian( &
6611 : m_x_in=m_step, &
6612 : m_x_out=m_Hstep, &
6613 : m_ks=m_ks, &
6614 : m_s=m_s, &
6615 : m_siginv=m_siginv, &
6616 : m_quench_t=m_quench_t, &
6617 : m_FTsiginv=m_FTsiginv, &
6618 : m_siginvTFTsiginv=m_siginvTFTsiginv, &
6619 : m_ST=m_ST, &
6620 : m_STsiginv=m_STsiginv, &
6621 : m_s_vv=m_s_vv, &
6622 : m_ks_vv=m_f_vv, &
6623 : !m_s_vv=m_s,&
6624 : !m_ks_vv=m_ks,&
6625 : m_g_full=m_f_vo, &
6626 : m_t=m_t, &
6627 : m_sig_sqrti_ii=m_sig_sqrti_ii, &
6628 : penalty_occ_vol=penalty_occ_vol, &
6629 : normalize_orbitals=normalize_orbitals, &
6630 : penalty_occ_vol_prefactor=penalty_occ_vol_prefactor, &
6631 : eps_filter=eps_filter, &
6632 0 : path_num=hessian_path_reuse)
6633 :
6634 : ! alpha is computed outside the spin loop
6635 0 : numer = 0.0_dp
6636 0 : denom = 0.0_dp
6637 0 : DO ispin = 1, nspins
6638 :
6639 0 : CALL dbcsr_dot(m_residue(ispin), m_zet(ispin), numer_ispin)
6640 0 : CALL dbcsr_dot(m_step(ispin), m_Hstep(ispin), denom_ispin)
6641 :
6642 0 : numer = numer + numer_ispin
6643 0 : denom = denom + denom_ispin
6644 :
6645 : END DO !ispin
6646 :
6647 0 : alpha = numer/denom
6648 :
6649 0 : DO ispin = 1, nspins
6650 :
6651 : ! update the variable
6652 0 : CALL dbcsr_add(m_delta(ispin), m_step(ispin), 1.0_dp, alpha)
6653 0 : CALL dbcsr_copy(m_residue_prev(ispin), m_residue(ispin))
6654 : CALL dbcsr_add(m_residue(ispin), m_Hstep(ispin), &
6655 0 : 1.0_dp, -1.0_dp*alpha)
6656 0 : residue_max_norm(ispin) = dbcsr_maxabs(m_residue(ispin))
6657 :
6658 : END DO ! ispin
6659 :
6660 : ! check convergence and other exit criteria
6661 0 : residue_norm = MAXVAL(residue_max_norm)
6662 0 : converged = (residue_norm < eps_error_target)
6663 0 : IF (converged .OR. (iteration >= max_iter)) THEN
6664 : prepare_to_exit = .TRUE.
6665 : END IF
6666 :
6667 0 : IF (.NOT. prepare_to_exit) THEN
6668 :
6669 0 : DO ispin = 1, nspins
6670 :
6671 : ! save current z before the update
6672 0 : CALL dbcsr_copy(m_zet_prev(ispin), m_zet(ispin))
6673 :
6674 : ! compute the new step (apply preconditioner if available)
6675 0 : IF (use_preconditioner) THEN
6676 :
6677 0 : IF (special_case == xalmo_case_block_diag .OR. &
6678 : special_case == xalmo_case_fully_deloc) THEN
6679 :
6680 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6681 : m_prec(ispin), &
6682 : m_residue(ispin), &
6683 : 0.0_dp, m_zet(ispin), &
6684 0 : filter_eps=eps_filter)
6685 :
6686 : ELSE
6687 :
6688 : CALL apply_domain_operators( &
6689 : matrix_in=m_residue(ispin), &
6690 : matrix_out=m_zet(ispin), &
6691 : operator1=domain_prec(:, ispin), &
6692 : dpattern=m_quench_t(ispin), &
6693 : map=domain_map(ispin), &
6694 : node_of_domain=cpu_of_domain(:), &
6695 : my_action=0, &
6696 0 : filter_eps=eps_filter)
6697 :
6698 : END IF ! special case
6699 :
6700 : ELSE
6701 :
6702 0 : CALL dbcsr_copy(m_zet(ispin), m_residue(ispin))
6703 :
6704 : END IF
6705 :
6706 : END DO !ispin
6707 :
6708 : ! compute the conjugation coefficient - beta
6709 : CALL compute_cg_beta( &
6710 : beta=beta, &
6711 : reset_conjugator=reset_conjugator, &
6712 : conjugator=cg_fletcher, &
6713 : grad=m_residue, &
6714 : prev_grad=m_residue_prev, &
6715 : step=m_zet, &
6716 0 : prev_step=m_zet_prev)
6717 :
6718 0 : DO ispin = 1, nspins
6719 :
6720 : ! conjugate the step direction
6721 0 : CALL dbcsr_add(m_step(ispin), m_zet(ispin), beta, 1.0_dp)
6722 :
6723 : END DO !ispin
6724 :
6725 : END IF ! not.prepare_to_exit
6726 :
6727 0 : t2 = m_walltime()
6728 0 : IF (unit_nr > 0) THEN
6729 0 : iter_type = TRIM("NR STEP")
6730 : WRITE (unit_nr, '(T6,A9,I6,F14.5,F14.5,F15.10,F9.2)') &
6731 0 : iter_type, iteration, &
6732 0 : alpha, beta, residue_norm, &
6733 0 : t2 - t1
6734 : END IF
6735 0 : t1 = m_walltime()
6736 :
6737 0 : iteration = iteration + 1
6738 0 : IF (prepare_to_exit) EXIT
6739 :
6740 : END DO ! inner loop
6741 :
6742 0 : IF (converged .OR. (outer_iteration >= outer_max_iter)) THEN
6743 0 : outer_prepare_to_exit = .TRUE.
6744 : END IF
6745 :
6746 0 : outer_iteration = outer_iteration + 1
6747 0 : IF (outer_prepare_to_exit) EXIT
6748 :
6749 : END DO ! outer loop
6750 :
6751 0 : DO ispin = 1, nspins
6752 :
6753 : ! check whether the step lies entirely in R or Q
6754 : CALL dbcsr_create(m_tmp_oo_1, &
6755 : template=m_siginv(ispin), &
6756 0 : matrix_type=dbcsr_type_no_symmetry)
6757 : CALL dbcsr_create(m_tmp_oo_2, &
6758 : template=m_siginv(ispin), &
6759 0 : matrix_type=dbcsr_type_no_symmetry)
6760 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
6761 : m_ST(ispin), &
6762 : m_delta(ispin), &
6763 : 0.0_dp, m_tmp_oo_1, &
6764 0 : filter_eps=eps_filter)
6765 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6766 : m_siginv(ispin), &
6767 : m_tmp_oo_1, &
6768 : 0.0_dp, m_tmp_oo_2, &
6769 0 : filter_eps=eps_filter)
6770 0 : CALL dbcsr_copy(m_zet(ispin), m_quench_t(ispin))
6771 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6772 : m_t(ispin), &
6773 : m_tmp_oo_2, &
6774 : 0.0_dp, m_zet(ispin), &
6775 0 : retain_sparsity=.TRUE.)
6776 0 : alpha = dbcsr_maxabs(m_zet(ispin))
6777 0 : WRITE (unit_nr, "(A50,2F20.10)") "Occupied-space projection of the step", alpha
6778 0 : CALL dbcsr_add(m_zet(ispin), m_delta(ispin), -1.0_dp, 1.0_dp)
6779 0 : alpha = dbcsr_maxabs(m_zet(ispin))
6780 0 : WRITE (unit_nr, "(A50,2F20.10)") "Virtual-space projection of the step", alpha
6781 0 : alpha = dbcsr_maxabs(m_delta(ispin))
6782 0 : WRITE (unit_nr, "(A50,2F20.10)") "Full step", alpha
6783 0 : CALL dbcsr_release(m_tmp_oo_1)
6784 0 : CALL dbcsr_release(m_tmp_oo_2)
6785 :
6786 : END DO
6787 :
6788 : ! clean up
6789 0 : DO ispin = 1, nspins
6790 0 : CALL release_submatrices(domain_prec(:, ispin))
6791 0 : CALL dbcsr_release(m_residue(ispin))
6792 0 : CALL dbcsr_release(m_residue_prev(ispin))
6793 0 : CALL dbcsr_release(m_step(ispin))
6794 0 : CALL dbcsr_release(m_zet(ispin))
6795 0 : CALL dbcsr_release(m_zet_prev(ispin))
6796 0 : CALL dbcsr_release(m_Hstep(ispin))
6797 0 : CALL dbcsr_release(m_f_vo(ispin))
6798 0 : CALL dbcsr_release(m_f_vv(ispin))
6799 0 : CALL dbcsr_release(m_s_vv(ispin))
6800 0 : CALL dbcsr_release(m_prec(ispin))
6801 0 : CALL dbcsr_release(m_STsiginv(ispin))
6802 : END DO !ispin
6803 0 : DEALLOCATE (domain_prec)
6804 0 : DEALLOCATE (m_residue)
6805 0 : DEALLOCATE (m_residue_prev)
6806 0 : DEALLOCATE (m_step)
6807 0 : DEALLOCATE (m_zet)
6808 0 : DEALLOCATE (m_zet_prev)
6809 0 : DEALLOCATE (m_prec)
6810 0 : DEALLOCATE (m_Hstep)
6811 0 : DEALLOCATE (m_s_vv)
6812 0 : DEALLOCATE (m_f_vv)
6813 0 : DEALLOCATE (m_f_vo)
6814 0 : DEALLOCATE (m_STsiginv)
6815 0 : DEALLOCATE (residue_max_norm)
6816 :
6817 0 : IF (.NOT. converged) THEN
6818 0 : CPABORT("Optimization not converged!")
6819 : END IF
6820 :
6821 : ! check that the step satisfies H.step=-grad
6822 :
6823 0 : CALL timestop(handle)
6824 :
6825 0 : END SUBROUTINE newton_grad_to_step
6826 :
6827 : ! *****************************************************************************
6828 : !> \brief Computes Hessian.X
6829 : !> \param m_x_in ...
6830 : !> \param m_x_out ...
6831 : !> \param m_ks ...
6832 : !> \param m_s ...
6833 : !> \param m_siginv ...
6834 : !> \param m_quench_t ...
6835 : !> \param m_FTsiginv ...
6836 : !> \param m_siginvTFTsiginv ...
6837 : !> \param m_ST ...
6838 : !> \param m_STsiginv ...
6839 : !> \param m_s_vv ...
6840 : !> \param m_ks_vv ...
6841 : !> \param m_g_full ...
6842 : !> \param m_t ...
6843 : !> \param m_sig_sqrti_ii ...
6844 : !> \param penalty_occ_vol ...
6845 : !> \param normalize_orbitals ...
6846 : !> \param penalty_occ_vol_prefactor ...
6847 : !> \param eps_filter ...
6848 : !> \param path_num ...
6849 : !> \par History
6850 : !> 2015.04 created [Rustam Z Khaliullin]
6851 : !> \author Rustam Z Khaliullin
6852 : ! **************************************************************************************************
6853 0 : SUBROUTINE apply_hessian(m_x_in, m_x_out, m_ks, m_s, m_siginv, &
6854 0 : m_quench_t, m_FTsiginv, m_siginvTFTsiginv, m_ST, m_STsiginv, m_s_vv, &
6855 0 : m_ks_vv, m_g_full, m_t, m_sig_sqrti_ii, penalty_occ_vol, &
6856 0 : normalize_orbitals, penalty_occ_vol_prefactor, eps_filter, path_num)
6857 :
6858 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: m_x_in, m_x_out, m_ks, m_s
6859 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_siginv, m_quench_t, m_FTsiginv, &
6860 : m_siginvTFTsiginv, m_ST, m_STsiginv
6861 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: m_s_vv, m_ks_vv, m_g_full
6862 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_t, m_sig_sqrti_ii
6863 : LOGICAL, INTENT(IN) :: penalty_occ_vol, normalize_orbitals
6864 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: penalty_occ_vol_prefactor
6865 : REAL(KIND=dp), INTENT(IN) :: eps_filter
6866 : INTEGER, INTENT(IN) :: path_num
6867 :
6868 : CHARACTER(len=*), PARAMETER :: routineN = 'apply_hessian'
6869 :
6870 : INTEGER :: dim0, handle, ispin, nspins
6871 : REAL(KIND=dp) :: penalty_prefactor_local, spin_factor
6872 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tg_diagonal
6873 : TYPE(dbcsr_type) :: m_tmp_no_1, m_tmp_no_2, m_tmp_oo_1, &
6874 : m_tmp_x_in
6875 :
6876 0 : CALL timeset(routineN, handle)
6877 :
6878 : !JHU: test and use for unused debug variables
6879 0 : IF (penalty_occ_vol) penalty_prefactor_local = 1._dp
6880 0 : CPASSERT(SIZE(m_STsiginv) >= 0)
6881 0 : CPASSERT(SIZE(m_siginvTFTsiginv) >= 0)
6882 0 : CPASSERT(SIZE(m_s) >= 0)
6883 0 : CPASSERT(SIZE(m_g_full) >= 0)
6884 0 : CPASSERT(SIZE(m_FTsiginv) >= 0)
6885 : MARK_USED(m_siginvTFTsiginv)
6886 : MARK_USED(m_STsiginv)
6887 : MARK_USED(m_FTsiginv)
6888 : MARK_USED(m_g_full)
6889 : MARK_USED(m_s)
6890 :
6891 0 : nspins = SIZE(m_ks)
6892 :
6893 0 : IF (nspins == 1) THEN
6894 : spin_factor = 2.0_dp
6895 : ELSE
6896 0 : spin_factor = 1.0_dp
6897 : END IF
6898 :
6899 0 : DO ispin = 1, nspins
6900 :
6901 0 : penalty_prefactor_local = penalty_occ_vol_prefactor(ispin)/(2.0_dp*spin_factor)
6902 :
6903 : CALL dbcsr_create(m_tmp_oo_1, &
6904 : template=m_siginv(ispin), &
6905 0 : matrix_type=dbcsr_type_no_symmetry)
6906 : CALL dbcsr_create(m_tmp_no_1, &
6907 : template=m_quench_t(ispin), &
6908 0 : matrix_type=dbcsr_type_no_symmetry)
6909 : CALL dbcsr_create(m_tmp_no_2, &
6910 : template=m_quench_t(ispin), &
6911 0 : matrix_type=dbcsr_type_no_symmetry)
6912 : CALL dbcsr_create(m_tmp_x_in, &
6913 : template=m_quench_t(ispin), &
6914 0 : matrix_type=dbcsr_type_no_symmetry)
6915 :
6916 : ! transform the input X to take into account the normalization constraint
6917 0 : IF (normalize_orbitals) THEN
6918 :
6919 : ! H.D = ( (H.D) - ST.[tr(T).(H.D)]_ii ) . [sig_sqrti]_ii
6920 :
6921 : ! get [tr(T).HD]_ii
6922 0 : CALL dbcsr_copy(m_tmp_oo_1, m_sig_sqrti_ii(ispin))
6923 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
6924 : m_x_in(ispin), &
6925 : m_ST(ispin), &
6926 : 0.0_dp, m_tmp_oo_1, &
6927 0 : retain_sparsity=.TRUE.)
6928 0 : CALL dbcsr_get_info(m_sig_sqrti_ii(ispin), nfullrows_total=dim0)
6929 0 : ALLOCATE (tg_diagonal(dim0))
6930 0 : CALL dbcsr_get_diag(m_tmp_oo_1, tg_diagonal)
6931 0 : CALL dbcsr_set(m_tmp_oo_1, 0.0_dp)
6932 0 : CALL dbcsr_set_diag(m_tmp_oo_1, tg_diagonal)
6933 0 : DEALLOCATE (tg_diagonal)
6934 :
6935 0 : CALL dbcsr_copy(m_tmp_no_1, m_x_in(ispin))
6936 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
6937 : m_t(ispin), &
6938 : m_tmp_oo_1, &
6939 : 1.0_dp, m_tmp_no_1, &
6940 0 : filter_eps=eps_filter)
6941 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6942 : m_tmp_no_1, &
6943 : m_sig_sqrti_ii(ispin), &
6944 : 0.0_dp, m_tmp_x_in, &
6945 0 : filter_eps=eps_filter)
6946 :
6947 : ELSE
6948 :
6949 0 : CALL dbcsr_copy(m_tmp_x_in, m_x_in(ispin))
6950 :
6951 : END IF ! normalize_orbitals
6952 :
6953 0 : IF (path_num == hessian_path_reuse) THEN
6954 :
6955 : ! apply pre-computed F_vv and S_vv to X
6956 :
6957 : ! debugging: only vv matrices, oo matrices are kronecker
6958 0 : CALL dbcsr_copy(m_x_out(ispin), m_quench_t(ispin))
6959 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6960 : m_ks_vv(ispin), &
6961 : m_tmp_x_in, &
6962 : 0.0_dp, m_x_out(ispin), &
6963 0 : retain_sparsity=.TRUE.)
6964 :
6965 0 : CALL dbcsr_copy(m_tmp_no_2, m_quench_t(ispin))
6966 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
6967 : m_s_vv(ispin), &
6968 : m_tmp_x_in, &
6969 : 0.0_dp, m_tmp_no_2, &
6970 0 : retain_sparsity=.TRUE.)
6971 : CALL dbcsr_add(m_x_out(ispin), m_tmp_no_2, &
6972 0 : 1.0_dp, -4.0_dp*penalty_prefactor_local + 1.0_dp)
6973 :
6974 0 : ELSE IF (path_num == hessian_path_assemble) THEN
6975 :
6976 : ! compute F_vv.X and S_vv.X directly
6977 : ! this path will be advantageous if the number
6978 : ! of PCG iterations is small
6979 0 : CPABORT("path is NYI")
6980 :
6981 : ELSE
6982 0 : CPABORT("illegal path")
6983 : END IF ! path
6984 :
6985 : ! transform the output to take into account the normalization constraint
6986 0 : IF (normalize_orbitals) THEN
6987 :
6988 : ! H.D = ( (H.D) - ST.[tr(T).(H.D)]_ii ) . [sig_sqrti]_ii
6989 :
6990 : ! get [tr(T).HD]_ii
6991 0 : CALL dbcsr_copy(m_tmp_oo_1, m_sig_sqrti_ii(ispin))
6992 : CALL dbcsr_multiply("T", "N", 1.0_dp, &
6993 : m_t(ispin), &
6994 : m_x_out(ispin), &
6995 : 0.0_dp, m_tmp_oo_1, &
6996 0 : retain_sparsity=.TRUE.)
6997 0 : CALL dbcsr_get_info(m_sig_sqrti_ii(ispin), nfullrows_total=dim0)
6998 0 : ALLOCATE (tg_diagonal(dim0))
6999 0 : CALL dbcsr_get_diag(m_tmp_oo_1, tg_diagonal)
7000 0 : CALL dbcsr_set(m_tmp_oo_1, 0.0_dp)
7001 0 : CALL dbcsr_set_diag(m_tmp_oo_1, tg_diagonal)
7002 0 : DEALLOCATE (tg_diagonal)
7003 :
7004 : CALL dbcsr_multiply("N", "N", -1.0_dp, &
7005 : m_ST(ispin), &
7006 : m_tmp_oo_1, &
7007 : 1.0_dp, m_x_out(ispin), &
7008 0 : retain_sparsity=.TRUE.)
7009 0 : CALL dbcsr_copy(m_tmp_no_1, m_x_out(ispin))
7010 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
7011 : m_tmp_no_1, &
7012 : m_sig_sqrti_ii(ispin), &
7013 : 0.0_dp, m_x_out(ispin), &
7014 0 : retain_sparsity=.TRUE.)
7015 :
7016 : END IF ! normalize_orbitals
7017 :
7018 : CALL dbcsr_scale(m_x_out(ispin), &
7019 0 : 2.0_dp*spin_factor)
7020 :
7021 0 : CALL dbcsr_release(m_tmp_oo_1)
7022 0 : CALL dbcsr_release(m_tmp_no_1)
7023 0 : CALL dbcsr_release(m_tmp_no_2)
7024 0 : CALL dbcsr_release(m_tmp_x_in)
7025 :
7026 : END DO !ispin
7027 :
7028 : ! there is one more part of the hessian that comes
7029 : ! from T-dependence of the KS matrix
7030 : ! it is neglected here
7031 :
7032 0 : CALL timestop(handle)
7033 :
7034 0 : END SUBROUTINE apply_hessian
7035 :
7036 : ! *****************************************************************************
7037 : !> \brief Serial code that constructs an approximate Hessian
7038 : !> \param matrix_grad ...
7039 : !> \param matrix_step ...
7040 : !> \param matrix_S_ao ...
7041 : !> \param matrix_F_ao ...
7042 : !> \param matrix_S_mo ...
7043 : !> \param matrix_F_mo ...
7044 : !> \param matrix_S_vo ...
7045 : !> \param matrix_F_vo ...
7046 : !> \param quench_t ...
7047 : !> \param penalty_occ_vol ...
7048 : !> \param penalty_occ_vol_prefactor ...
7049 : !> \param penalty_occ_vol_pf2 ...
7050 : !> \param spin_factor ...
7051 : !> \param eps_zero ...
7052 : !> \param m_s ...
7053 : !> \param para_env ...
7054 : !> \param blacs_env ...
7055 : !> \par History
7056 : !> 2012.02 created [Rustam Z. Khaliullin]
7057 : !> \author Rustam Z. Khaliullin
7058 : ! **************************************************************************************************
7059 0 : SUBROUTINE hessian_diag_apply(matrix_grad, matrix_step, matrix_S_ao, &
7060 : matrix_F_ao, matrix_S_mo, matrix_F_mo, matrix_S_vo, matrix_F_vo, quench_t, &
7061 : penalty_occ_vol, penalty_occ_vol_prefactor, penalty_occ_vol_pf2, &
7062 : spin_factor, eps_zero, m_s, para_env, blacs_env)
7063 :
7064 : TYPE(dbcsr_type), INTENT(INOUT) :: matrix_grad, matrix_step, matrix_S_ao, &
7065 : matrix_F_ao, matrix_S_mo
7066 : TYPE(dbcsr_type), INTENT(IN) :: matrix_F_mo
7067 : TYPE(dbcsr_type), INTENT(INOUT) :: matrix_S_vo, matrix_F_vo, quench_t
7068 : LOGICAL, INTENT(IN) :: penalty_occ_vol
7069 : REAL(KIND=dp), INTENT(IN) :: penalty_occ_vol_prefactor, &
7070 : penalty_occ_vol_pf2, spin_factor, &
7071 : eps_zero
7072 : TYPE(dbcsr_type), INTENT(IN) :: m_s
7073 : TYPE(mp_para_env_type), POINTER :: para_env
7074 : TYPE(cp_blacs_env_type), POINTER :: blacs_env
7075 :
7076 : CHARACTER(len=*), PARAMETER :: routineN = 'hessian_diag_apply'
7077 :
7078 : INTEGER :: ao_hori_offset, ao_vert_offset, block_col, block_row, col, H_size, handle, ii, &
7079 : INFO, jj, lev1_hori_offset, lev1_vert_offset, lev2_hori_offset, lev2_vert_offset, LWORK, &
7080 : nblkcols_tot, nblkrows_tot, ncores, orb_i, orb_j, row, unit_nr, zero_neg_eiv
7081 0 : INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_block_sizes, ao_domain_sizes, &
7082 0 : mo_block_sizes
7083 0 : INTEGER, DIMENSION(:), POINTER :: ao_blk_sizes, mo_blk_sizes
7084 : LOGICAL :: found, found_col, found_row
7085 : REAL(KIND=dp) :: penalty_prefactor_local, test_error
7086 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eigenvalues, Grad_vec, Step_vec, tmp, &
7087 0 : tmpr, work
7088 0 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: F_ao_block, F_mo_block, H, Hinv, &
7089 0 : new_block, S_ao_block, S_mo_block, &
7090 0 : test, test2
7091 0 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: block_p
7092 : TYPE(cp_logger_type), POINTER :: logger
7093 : TYPE(dbcsr_distribution_type) :: main_dist
7094 : TYPE(dbcsr_type) :: matrix_F_ao_sym, matrix_F_mo_sym, &
7095 : matrix_S_ao_sym, matrix_S_mo_sym
7096 :
7097 0 : CALL timeset(routineN, handle)
7098 :
7099 : ! get a useful output_unit
7100 0 : logger => cp_get_default_logger()
7101 0 : IF (logger%para_env%is_source()) THEN
7102 0 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
7103 : ELSE
7104 : unit_nr = -1
7105 : END IF
7106 :
7107 : !JHU use and test for unused debug variables
7108 0 : CPASSERT(ASSOCIATED(blacs_env))
7109 0 : CPASSERT(ASSOCIATED(para_env))
7110 : MARK_USED(blacs_env)
7111 : MARK_USED(para_env)
7112 :
7113 0 : CALL dbcsr_get_info(m_s, row_blk_size=ao_blk_sizes)
7114 0 : CALL dbcsr_get_info(matrix_S_vo, row_blk_size=ao_blk_sizes)
7115 0 : CALL dbcsr_get_info(matrix_F_vo, row_blk_size=ao_blk_sizes)
7116 :
7117 : ! serial code only
7118 0 : CALL dbcsr_get_info(matrix=matrix_S_ao, distribution=main_dist)
7119 0 : CALL dbcsr_distribution_get(main_dist, numnodes=ncores)
7120 0 : IF (ncores > 1) THEN
7121 0 : CPABORT("serial code only")
7122 : END IF
7123 :
7124 : CALL dbcsr_get_info(quench_t, row_blk_size=ao_blk_sizes, col_blk_size=mo_blk_sizes, &
7125 0 : nblkrows_total=nblkrows_tot, nblkcols_total=nblkcols_tot)
7126 0 : CPASSERT(nblkrows_tot == nblkcols_tot)
7127 0 : ALLOCATE (mo_block_sizes(nblkcols_tot), ao_block_sizes(nblkcols_tot))
7128 0 : ALLOCATE (ao_domain_sizes(nblkcols_tot))
7129 0 : mo_block_sizes(:) = mo_blk_sizes(:)
7130 0 : ao_block_sizes(:) = ao_blk_sizes(:)
7131 0 : ao_domain_sizes(:) = 0
7132 :
7133 : CALL dbcsr_create(matrix_S_ao_sym, &
7134 : template=matrix_S_ao, &
7135 0 : matrix_type=dbcsr_type_no_symmetry)
7136 0 : CALL dbcsr_desymmetrize(matrix_S_ao, matrix_S_ao_sym)
7137 0 : CALL dbcsr_scale(matrix_S_ao_sym, 2.0_dp*spin_factor)
7138 :
7139 : CALL dbcsr_create(matrix_F_ao_sym, &
7140 : template=matrix_F_ao, &
7141 0 : matrix_type=dbcsr_type_no_symmetry)
7142 0 : CALL dbcsr_desymmetrize(matrix_F_ao, matrix_F_ao_sym)
7143 0 : CALL dbcsr_scale(matrix_F_ao_sym, 2.0_dp*spin_factor)
7144 :
7145 : CALL dbcsr_create(matrix_S_mo_sym, &
7146 : template=matrix_S_mo, &
7147 0 : matrix_type=dbcsr_type_no_symmetry)
7148 0 : CALL dbcsr_desymmetrize(matrix_S_mo, matrix_S_mo_sym)
7149 :
7150 : CALL dbcsr_create(matrix_F_mo_sym, &
7151 : template=matrix_F_mo, &
7152 0 : matrix_type=dbcsr_type_no_symmetry)
7153 0 : CALL dbcsr_desymmetrize(matrix_F_mo, matrix_F_mo_sym)
7154 :
7155 0 : IF (penalty_occ_vol) THEN
7156 0 : penalty_prefactor_local = penalty_occ_vol_prefactor/(2.0_dp*spin_factor)
7157 : ELSE
7158 0 : penalty_prefactor_local = 0.0_dp
7159 : END IF
7160 :
7161 0 : WRITE (unit_nr, *) "penalty_prefactor_local: ", penalty_prefactor_local
7162 0 : WRITE (unit_nr, *) "penalty_prefactor_2: ", penalty_occ_vol_pf2
7163 :
7164 : ! loop over domains to find the size of the Hessian
7165 0 : H_size = 0
7166 0 : DO col = 1, nblkcols_tot
7167 :
7168 : ! find sizes of AO submatrices
7169 0 : DO row = 1, nblkrows_tot
7170 :
7171 : CALL dbcsr_get_block_p(quench_t, &
7172 0 : row, col, block_p, found)
7173 0 : IF (found) THEN
7174 0 : ao_domain_sizes(col) = ao_domain_sizes(col) + ao_blk_sizes(row)
7175 : END IF
7176 :
7177 : END DO
7178 :
7179 0 : H_size = H_size + ao_domain_sizes(col)*mo_block_sizes(col)
7180 :
7181 : END DO
7182 :
7183 0 : ALLOCATE (H(H_size, H_size))
7184 0 : H(:, :) = 0.0_dp
7185 :
7186 : ! fill the Hessian matrix
7187 0 : lev1_vert_offset = 0
7188 : ! loop over all pairs of fragments
7189 0 : DO row = 1, nblkcols_tot
7190 :
7191 0 : lev1_hori_offset = 0
7192 0 : DO col = 1, nblkcols_tot
7193 :
7194 : ! prepare blocks for the current row-column fragment pair
7195 0 : ALLOCATE (F_ao_block(ao_domain_sizes(row), ao_domain_sizes(col)))
7196 0 : ALLOCATE (S_ao_block(ao_domain_sizes(row), ao_domain_sizes(col)))
7197 0 : ALLOCATE (F_mo_block(mo_block_sizes(row), mo_block_sizes(col)))
7198 0 : ALLOCATE (S_mo_block(mo_block_sizes(row), mo_block_sizes(col)))
7199 :
7200 0 : F_ao_block(:, :) = 0.0_dp
7201 0 : S_ao_block(:, :) = 0.0_dp
7202 : F_mo_block(:, :) = 0.0_dp
7203 : S_mo_block(:, :) = 0.0_dp
7204 :
7205 : ! fill AO submatrices
7206 : ! loop over all blocks of the AO dbcsr matrix
7207 0 : ao_vert_offset = 0
7208 0 : DO block_row = 1, nblkcols_tot
7209 :
7210 : CALL dbcsr_get_block_p(quench_t, &
7211 0 : block_row, row, block_p, found_row)
7212 0 : IF (found_row) THEN
7213 :
7214 0 : ao_hori_offset = 0
7215 0 : DO block_col = 1, nblkcols_tot
7216 :
7217 : CALL dbcsr_get_block_p(quench_t, &
7218 0 : block_col, col, block_p, found_col)
7219 0 : IF (found_col) THEN
7220 :
7221 : CALL dbcsr_get_block_p(matrix_F_ao_sym, &
7222 0 : block_row, block_col, block_p, found)
7223 0 : IF (found) THEN
7224 : ! copy the block into the submatrix
7225 : F_ao_block(ao_vert_offset + 1:ao_vert_offset + ao_block_sizes(block_row), &
7226 : ao_hori_offset + 1:ao_hori_offset + ao_block_sizes(block_col)) &
7227 0 : = block_p(:, :)
7228 : END IF
7229 :
7230 : CALL dbcsr_get_block_p(matrix_S_ao_sym, &
7231 0 : block_row, block_col, block_p, found)
7232 0 : IF (found) THEN
7233 : ! copy the block into the submatrix
7234 : S_ao_block(ao_vert_offset + 1:ao_vert_offset + ao_block_sizes(block_row), &
7235 : ao_hori_offset + 1:ao_hori_offset + ao_block_sizes(block_col)) &
7236 0 : = block_p(:, :)
7237 : END IF
7238 :
7239 0 : ao_hori_offset = ao_hori_offset + ao_block_sizes(block_col)
7240 :
7241 : END IF
7242 :
7243 : END DO
7244 :
7245 0 : ao_vert_offset = ao_vert_offset + ao_block_sizes(block_row)
7246 :
7247 : END IF
7248 :
7249 : END DO
7250 :
7251 : ! fill MO submatrices
7252 0 : CALL dbcsr_get_block_p(matrix_F_mo_sym, row, col, block_p, found)
7253 0 : IF (found) THEN
7254 : ! copy the block into the submatrix
7255 0 : F_mo_block(1:mo_block_sizes(row), 1:mo_block_sizes(col)) = block_p(:, :)
7256 : END IF
7257 0 : CALL dbcsr_get_block_p(matrix_S_mo_sym, row, col, block_p, found)
7258 0 : IF (found) THEN
7259 : ! copy the block into the submatrix
7260 0 : S_mo_block(1:mo_block_sizes(row), 1:mo_block_sizes(col)) = block_p(:, :)
7261 : END IF
7262 :
7263 : ! construct tensor products for the current row-column fragment pair
7264 : lev2_vert_offset = 0
7265 0 : DO orb_j = 1, mo_block_sizes(row)
7266 :
7267 : lev2_hori_offset = 0
7268 0 : DO orb_i = 1, mo_block_sizes(col)
7269 0 : IF (orb_i == orb_j .AND. row == col) THEN
7270 : H(lev1_vert_offset + lev2_vert_offset + 1:lev1_vert_offset + lev2_vert_offset + ao_domain_sizes(row), &
7271 : lev1_hori_offset + lev2_hori_offset + 1:lev1_hori_offset + lev2_hori_offset + ao_domain_sizes(col)) &
7272 0 : = F_ao_block(:, :) + S_ao_block(:, :)
7273 : END IF
7274 :
7275 0 : lev2_hori_offset = lev2_hori_offset + ao_domain_sizes(col)
7276 :
7277 : END DO
7278 :
7279 0 : lev2_vert_offset = lev2_vert_offset + ao_domain_sizes(row)
7280 :
7281 : END DO
7282 :
7283 0 : lev1_hori_offset = lev1_hori_offset + ao_domain_sizes(col)*mo_block_sizes(col)
7284 :
7285 0 : DEALLOCATE (F_ao_block)
7286 0 : DEALLOCATE (S_ao_block)
7287 0 : DEALLOCATE (F_mo_block)
7288 0 : DEALLOCATE (S_mo_block)
7289 :
7290 : END DO ! col fragment
7291 :
7292 0 : lev1_vert_offset = lev1_vert_offset + ao_domain_sizes(row)*mo_block_sizes(row)
7293 :
7294 : END DO ! row fragment
7295 :
7296 0 : CALL dbcsr_release(matrix_S_ao_sym)
7297 0 : CALL dbcsr_release(matrix_F_ao_sym)
7298 0 : CALL dbcsr_release(matrix_S_mo_sym)
7299 0 : CALL dbcsr_release(matrix_F_mo_sym)
7300 :
7301 : ! convert gradient from the dbcsr matrix to the vector form
7302 0 : ALLOCATE (Grad_vec(H_size))
7303 0 : Grad_vec(:) = 0.0_dp
7304 0 : lev1_vert_offset = 0
7305 : ! loop over all electron blocks
7306 0 : DO col = 1, nblkcols_tot
7307 :
7308 : ! loop over AO-rows of the dbcsr matrix
7309 0 : lev2_vert_offset = 0
7310 0 : DO row = 1, nblkrows_tot
7311 :
7312 : CALL dbcsr_get_block_p(quench_t, &
7313 0 : row, col, block_p, found_row)
7314 0 : IF (found_row) THEN
7315 :
7316 : CALL dbcsr_get_block_p(matrix_grad, &
7317 0 : row, col, block_p, found)
7318 0 : IF (found) THEN
7319 : ! copy the data into the vector, column by column
7320 0 : DO orb_i = 1, mo_block_sizes(col)
7321 : Grad_vec(lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + 1: &
7322 : lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + ao_block_sizes(row)) &
7323 0 : = block_p(:, orb_i)
7324 : END DO
7325 :
7326 : END IF
7327 :
7328 0 : lev2_vert_offset = lev2_vert_offset + ao_block_sizes(row)
7329 :
7330 : END IF
7331 :
7332 : END DO
7333 :
7334 0 : lev1_vert_offset = lev1_vert_offset + ao_domain_sizes(col)*mo_block_sizes(col)
7335 :
7336 : END DO ! loop over electron blocks
7337 :
7338 : ! invert the Hessian
7339 0 : INFO = 0
7340 0 : ALLOCATE (Hinv(H_size, H_size))
7341 0 : Hinv(:, :) = H(:, :)
7342 :
7343 : ! before inverting diagonalize
7344 0 : ALLOCATE (eigenvalues(H_size))
7345 : ! Query the optimal workspace for dsyev
7346 0 : LWORK = -1
7347 0 : ALLOCATE (WORK(MAX(1, LWORK)))
7348 0 : CALL dsyev('V', 'L', H_size, Hinv, H_size, eigenvalues, WORK, LWORK, INFO)
7349 0 : LWORK = INT(WORK(1))
7350 0 : DEALLOCATE (WORK)
7351 : ! Allocate the workspace and solve the eigenproblem
7352 0 : ALLOCATE (WORK(MAX(1, LWORK)))
7353 0 : CALL dsyev('V', 'L', H_size, Hinv, H_size, eigenvalues, WORK, LWORK, INFO)
7354 0 : IF (INFO /= 0) THEN
7355 0 : WRITE (unit_nr, *) 'DSYEV ERROR MESSAGE: ', INFO
7356 0 : CPABORT("DSYEV failed")
7357 : END IF
7358 0 : DEALLOCATE (WORK)
7359 :
7360 : ! compute grad vector in the basis of Hessian eigenvectors
7361 0 : ALLOCATE (Step_vec(H_size))
7362 : ! Step_vec contains Grad_vec here
7363 0 : Step_vec(:) = MATMUL(TRANSPOSE(Hinv), Grad_vec)
7364 :
7365 : ! invert eigenvalues and use eigenvectors to compute the Hessian inverse
7366 : ! project out zero-eigenvalue directions
7367 0 : ALLOCATE (test(H_size, H_size))
7368 0 : zero_neg_eiv = 0
7369 0 : DO jj = 1, H_size
7370 0 : WRITE (unit_nr, "(I10,F20.10,F20.10)") jj, eigenvalues(jj), Step_vec(jj)
7371 0 : IF (eigenvalues(jj) > eps_zero) THEN
7372 0 : test(jj, :) = Hinv(:, jj)/eigenvalues(jj)
7373 : ELSE
7374 0 : test(jj, :) = Hinv(:, jj)*0.0_dp
7375 0 : zero_neg_eiv = zero_neg_eiv + 1
7376 : END IF
7377 : END DO
7378 0 : WRITE (unit_nr, *) 'ZERO OR NEGATIVE EIGENVALUES: ', zero_neg_eiv
7379 0 : DEALLOCATE (Step_vec)
7380 :
7381 0 : ALLOCATE (test2(H_size, H_size))
7382 0 : test2(:, :) = MATMUL(Hinv, test)
7383 0 : Hinv(:, :) = test2(:, :)
7384 0 : DEALLOCATE (test, test2)
7385 :
7386 0 : DEALLOCATE (eigenvalues)
7387 :
7388 : ! compute the inversion error
7389 0 : ALLOCATE (test(H_size, H_size))
7390 0 : test(:, :) = MATMUL(Hinv, H)
7391 0 : DO ii = 1, H_size
7392 0 : test(ii, ii) = test(ii, ii) - 1.0_dp
7393 : END DO
7394 0 : test_error = 0.0_dp
7395 0 : DO ii = 1, H_size
7396 0 : DO jj = 1, H_size
7397 0 : test_error = test_error + test(jj, ii)*test(jj, ii)
7398 : END DO
7399 : END DO
7400 0 : WRITE (unit_nr, *) "Hessian inversion error: ", SQRT(test_error)
7401 0 : DEALLOCATE (test)
7402 :
7403 : ! prepare the output vector
7404 0 : ALLOCATE (Step_vec(H_size))
7405 0 : ALLOCATE (tmp(H_size))
7406 0 : tmp(:) = MATMUL(Hinv, Grad_vec)
7407 0 : Step_vec(:) = -1.0_dp*tmp(:)
7408 :
7409 0 : ALLOCATE (tmpr(H_size))
7410 0 : tmpr(:) = MATMUL(H, Step_vec)
7411 0 : tmp(:) = tmpr(:) + Grad_vec(:)
7412 0 : DEALLOCATE (tmpr)
7413 0 : WRITE (unit_nr, *) "NEWTOV step error: ", MAXVAL(ABS(tmp))
7414 :
7415 0 : DEALLOCATE (tmp)
7416 :
7417 0 : DEALLOCATE (H)
7418 0 : DEALLOCATE (Hinv)
7419 0 : DEALLOCATE (Grad_vec)
7420 :
7421 : !S-1.G DEALLOCATE(test3)
7422 :
7423 : ! copy the step from the vector into the dbcsr matrix
7424 :
7425 : ! re-create the step matrix to remove all blocks
7426 : CALL dbcsr_create(matrix_step, &
7427 : template=matrix_grad, &
7428 0 : matrix_type=dbcsr_type_no_symmetry)
7429 0 : CALL dbcsr_work_create(matrix_step, work_mutable=.TRUE.)
7430 :
7431 0 : lev1_vert_offset = 0
7432 : ! loop over all electron blocks
7433 0 : DO col = 1, nblkcols_tot
7434 :
7435 : ! loop over AO-rows of the dbcsr matrix
7436 0 : lev2_vert_offset = 0
7437 0 : DO row = 1, nblkrows_tot
7438 :
7439 : CALL dbcsr_get_block_p(quench_t, &
7440 0 : row, col, block_p, found_row)
7441 0 : IF (found_row) THEN
7442 : ! copy the data column by column
7443 0 : ALLOCATE (new_block(ao_block_sizes(row), mo_block_sizes(col)))
7444 0 : DO orb_i = 1, mo_block_sizes(col)
7445 : new_block(:, orb_i) = &
7446 : Step_vec(lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + 1: &
7447 0 : lev1_vert_offset + ao_domain_sizes(col)*(orb_i - 1) + lev2_vert_offset + ao_block_sizes(row))
7448 : END DO
7449 0 : CALL dbcsr_put_block(matrix_step, row, col, new_block)
7450 0 : DEALLOCATE (new_block)
7451 0 : lev2_vert_offset = lev2_vert_offset + ao_block_sizes(row)
7452 : END IF
7453 :
7454 : END DO
7455 :
7456 0 : lev1_vert_offset = lev1_vert_offset + ao_domain_sizes(col)*mo_block_sizes(col)
7457 :
7458 : END DO ! loop over electron blocks
7459 :
7460 0 : DEALLOCATE (Step_vec)
7461 :
7462 0 : CALL dbcsr_finalize(matrix_step)
7463 :
7464 0 : DEALLOCATE (mo_block_sizes, ao_block_sizes)
7465 0 : DEALLOCATE (ao_domain_sizes)
7466 :
7467 : CALL dbcsr_create(matrix_S_ao_sym, &
7468 : template=quench_t, &
7469 0 : matrix_type=dbcsr_type_no_symmetry)
7470 0 : CALL dbcsr_copy(matrix_S_ao_sym, quench_t)
7471 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
7472 : matrix_F_ao, &
7473 : matrix_step, &
7474 : 0.0_dp, matrix_S_ao_sym, &
7475 0 : retain_sparsity=.TRUE.)
7476 : CALL dbcsr_create(matrix_F_ao_sym, &
7477 : template=quench_t, &
7478 0 : matrix_type=dbcsr_type_no_symmetry)
7479 0 : CALL dbcsr_copy(matrix_F_ao_sym, quench_t)
7480 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
7481 : matrix_S_ao, &
7482 : matrix_step, &
7483 : 0.0_dp, matrix_F_ao_sym, &
7484 0 : retain_sparsity=.TRUE.)
7485 : CALL dbcsr_add(matrix_S_ao_sym, matrix_F_ao_sym, &
7486 0 : 1.0_dp, 1.0_dp)
7487 0 : CALL dbcsr_scale(matrix_S_ao_sym, 2.0_dp*spin_factor)
7488 : CALL dbcsr_add(matrix_S_ao_sym, matrix_grad, &
7489 0 : 1.0_dp, 1.0_dp)
7490 0 : test_error = dbcsr_maxabs(matrix_S_ao_sym)
7491 0 : WRITE (unit_nr, *) "NEWTOL step error: ", test_error
7492 0 : CALL dbcsr_release(matrix_S_ao_sym)
7493 0 : CALL dbcsr_release(matrix_F_ao_sym)
7494 :
7495 0 : CALL timestop(handle)
7496 :
7497 0 : END SUBROUTINE hessian_diag_apply
7498 :
7499 : ! **************************************************************************************************
7500 : !> \brief Optimization of ALMOs using trust region minimizers
7501 : !> \param qs_env ...
7502 : !> \param almo_scf_env ...
7503 : !> \param optimizer controls the optimization algorithm
7504 : !> \param quench_t ...
7505 : !> \param matrix_t_in ...
7506 : !> \param matrix_t_out ...
7507 : !> \param perturbation_only - perturbative (do not update Hamiltonian)
7508 : !> \param special_case to reduce the overhead special cases are implemented:
7509 : !> xalmo_case_normal - no special case (i.e. xALMOs)
7510 : !> xalmo_case_block_diag
7511 : !> xalmo_case_fully_deloc
7512 : !> \par History
7513 : !> 2020.01 created [Rustam Z Khaliullin]
7514 : !> \author Rustam Z Khaliullin
7515 : ! **************************************************************************************************
7516 18 : SUBROUTINE almo_scf_xalmo_trustr(qs_env, almo_scf_env, optimizer, quench_t, &
7517 : matrix_t_in, matrix_t_out, perturbation_only, &
7518 : special_case)
7519 :
7520 : TYPE(qs_environment_type), POINTER :: qs_env
7521 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
7522 : TYPE(optimizer_options_type), INTENT(IN) :: optimizer
7523 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: quench_t, matrix_t_in, matrix_t_out
7524 : LOGICAL, INTENT(IN) :: perturbation_only
7525 : INTEGER, INTENT(IN), OPTIONAL :: special_case
7526 :
7527 : CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_xalmo_trustr'
7528 :
7529 : INTEGER :: handle, ispin, iteration, iteration_type_to_report, my_special_case, ndomains, &
7530 : nspins, outer_iteration, prec_type, unit_nr
7531 18 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nocc
7532 : LOGICAL :: assume_t0_q0x, border_reached, inner_loop_success, normalize_orbitals, &
7533 : optimize_theta, penalty_occ_vol, reset_conjugator, same_position, scf_converged
7534 : REAL(kind=dp) :: beta, energy_start, energy_trial, eta, expected_reduction, &
7535 : fake_step_size_to_report, grad_norm_ratio, grad_norm_ref, loss_change_to_report, &
7536 : loss_start, loss_trial, model_grad_norm, penalty_amplitude, penalty_start, penalty_trial, &
7537 : radius_current, radius_max, real_temp, rho, spin_factor, step_norm, step_size, t1, &
7538 : t1outer, t2, t2outer, y_scalar
7539 18 : REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: grad_norm_spin, &
7540 18 : penalty_occ_vol_g_prefactor, &
7541 18 : penalty_occ_vol_h_prefactor
7542 : TYPE(cp_logger_type), POINTER :: logger
7543 : TYPE(dbcsr_type) :: m_s_inv
7544 18 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: FTsiginv, grad, m_model_Bd, m_model_d, &
7545 18 : m_model_hessian, m_model_hessian_inv, m_model_r, m_model_r_prev, m_model_rt, &
7546 18 : m_model_rt_prev, m_sig_sqrti_ii, m_theta, m_theta_trial, prev_step, siginvTFTsiginv, ST, &
7547 18 : step, STsiginv_0
7548 : TYPE(domain_submatrix_type), ALLOCATABLE, &
7549 18 : DIMENSION(:, :) :: domain_model_hessian_inv, domain_r_down
7550 :
7551 : ! RZK-warning: number of temporary storage matrices can be reduced
7552 18 : CALL timeset(routineN, handle)
7553 :
7554 18 : t1outer = m_walltime()
7555 :
7556 18 : my_special_case = xalmo_case_normal
7557 18 : IF (PRESENT(special_case)) my_special_case = special_case
7558 :
7559 : ! get a useful output_unit
7560 18 : logger => cp_get_default_logger()
7561 18 : IF (logger%para_env%is_source()) THEN
7562 9 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
7563 : ELSE
7564 9 : unit_nr = -1
7565 : END IF
7566 :
7567 : ! Trust radius code is written to obviate the need in projected orbitals
7568 18 : assume_t0_q0x = .FALSE.
7569 : ! Smoothing of the orbitals have not been implemented
7570 18 : optimize_theta = .FALSE.
7571 :
7572 18 : nspins = almo_scf_env%nspins
7573 18 : IF (nspins == 1) THEN
7574 18 : spin_factor = 2.0_dp
7575 : ELSE
7576 0 : spin_factor = 1.0_dp
7577 : END IF
7578 :
7579 18 : IF (unit_nr > 0) THEN
7580 9 : WRITE (unit_nr, *)
7581 1 : SELECT CASE (my_special_case)
7582 : CASE (xalmo_case_block_diag)
7583 1 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 20), &
7584 2 : " Optimization of block-diagonal ALMOs ", REPEAT("-", 21)
7585 : CASE (xalmo_case_fully_deloc)
7586 0 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 20), &
7587 0 : " Optimization of fully delocalized MOs ", REPEAT("-", 20)
7588 : CASE (xalmo_case_normal)
7589 8 : WRITE (unit_nr, '(T2,A,A,A)') REPEAT("-", 27), &
7590 17 : " Optimization of XALMOs ", REPEAT("-", 28)
7591 : END SELECT
7592 9 : WRITE (unit_nr, *)
7593 : CALL trust_r_report(unit_nr, &
7594 : iter_type=0, & ! print header, all values are ignored
7595 : iteration=0, &
7596 : radius=0.0_dp, &
7597 : loss=0.0_dp, &
7598 : delta_loss=0.0_dp, &
7599 : grad_norm=0.0_dp, &
7600 : predicted_reduction=0.0_dp, &
7601 : rho=0.0_dp, &
7602 : new=.TRUE., &
7603 9 : time=0.0_dp)
7604 9 : WRITE (unit_nr, '(T2,A)') REPEAT("-", 79)
7605 : END IF
7606 :
7607 : ! penalty amplitude adjusts the strength of volume conservation
7608 18 : penalty_occ_vol = .FALSE.
7609 18 : normalize_orbitals = penalty_occ_vol
7610 18 : penalty_amplitude = 0.0_dp !almo_scf_env%penalty%occ_vol_coeff
7611 54 : ALLOCATE (penalty_occ_vol_g_prefactor(nspins))
7612 36 : ALLOCATE (penalty_occ_vol_h_prefactor(nspins))
7613 18 : penalty_occ_vol_g_prefactor(:) = 0.0_dp
7614 18 : penalty_occ_vol_h_prefactor(:) = 0.0_dp
7615 :
7616 : ! here preconditioner is the Hessian of model function
7617 18 : prec_type = optimizer%preconditioner
7618 :
7619 36 : ALLOCATE (grad_norm_spin(nspins))
7620 54 : ALLOCATE (nocc(nspins))
7621 :
7622 : ! m_theta contains a set of variational parameters
7623 : ! that define one-electron orbitals (simple, projected, etc.)
7624 72 : ALLOCATE (m_theta(nspins))
7625 36 : DO ispin = 1, nspins
7626 : CALL dbcsr_create(m_theta(ispin), &
7627 : template=matrix_t_out(ispin), &
7628 36 : matrix_type=dbcsr_type_no_symmetry)
7629 : END DO
7630 :
7631 : ! create initial guess from the initial orbitals
7632 : CALL xalmo_initial_guess(m_guess=m_theta, &
7633 : m_t_in=matrix_t_in, &
7634 : m_t0=almo_scf_env%matrix_t_blk, &
7635 : m_quench_t=quench_t, &
7636 : m_overlap=almo_scf_env%matrix_s(1), &
7637 : m_sigma_tmpl=almo_scf_env%matrix_sigma_inv, &
7638 : nspins=nspins, &
7639 : xalmo_history=almo_scf_env%xalmo_history, &
7640 : assume_t0_q0x=assume_t0_q0x, &
7641 : optimize_theta=optimize_theta, &
7642 : envelope_amplitude=almo_scf_env%envelope_amplitude, &
7643 : eps_filter=almo_scf_env%eps_filter, &
7644 : order_lanczos=almo_scf_env%order_lanczos, &
7645 : eps_lanczos=almo_scf_env%eps_lanczos, &
7646 : max_iter_lanczos=almo_scf_env%max_iter_lanczos, &
7647 18 : nocc_of_domain=almo_scf_env%nocc_of_domain)
7648 :
7649 18 : ndomains = almo_scf_env%ndomains
7650 218 : ALLOCATE (domain_r_down(ndomains, nspins))
7651 18 : CALL init_submatrices(domain_r_down)
7652 200 : ALLOCATE (domain_model_hessian_inv(ndomains, nspins))
7653 18 : CALL init_submatrices(domain_model_hessian_inv)
7654 :
7655 54 : ALLOCATE (m_model_hessian(nspins))
7656 54 : ALLOCATE (m_model_hessian_inv(nspins))
7657 54 : ALLOCATE (siginvTFTsiginv(nspins))
7658 54 : ALLOCATE (STsiginv_0(nspins))
7659 54 : ALLOCATE (FTsiginv(nspins))
7660 54 : ALLOCATE (ST(nspins))
7661 54 : ALLOCATE (grad(nspins))
7662 72 : ALLOCATE (prev_step(nspins))
7663 54 : ALLOCATE (step(nspins))
7664 54 : ALLOCATE (m_sig_sqrti_ii(nspins))
7665 54 : ALLOCATE (m_model_r(nspins))
7666 54 : ALLOCATE (m_model_rt(nspins))
7667 54 : ALLOCATE (m_model_d(nspins))
7668 54 : ALLOCATE (m_model_Bd(nspins))
7669 54 : ALLOCATE (m_model_r_prev(nspins))
7670 54 : ALLOCATE (m_model_rt_prev(nspins))
7671 54 : ALLOCATE (m_theta_trial(nspins))
7672 :
7673 36 : DO ispin = 1, nspins
7674 :
7675 : ! init temporary storage
7676 : CALL dbcsr_create(m_model_hessian_inv(ispin), &
7677 : template=almo_scf_env%matrix_ks(ispin), &
7678 18 : matrix_type=dbcsr_type_no_symmetry)
7679 : CALL dbcsr_create(m_model_hessian(ispin), &
7680 : template=almo_scf_env%matrix_ks(ispin), &
7681 18 : matrix_type=dbcsr_type_no_symmetry)
7682 : CALL dbcsr_create(siginvTFTsiginv(ispin), &
7683 : template=almo_scf_env%matrix_sigma(ispin), &
7684 18 : matrix_type=dbcsr_type_no_symmetry)
7685 : CALL dbcsr_create(STsiginv_0(ispin), &
7686 : template=matrix_t_out(ispin), &
7687 18 : matrix_type=dbcsr_type_no_symmetry)
7688 : CALL dbcsr_create(FTsiginv(ispin), &
7689 : template=matrix_t_out(ispin), &
7690 18 : matrix_type=dbcsr_type_no_symmetry)
7691 : CALL dbcsr_create(ST(ispin), &
7692 : template=matrix_t_out(ispin), &
7693 18 : matrix_type=dbcsr_type_no_symmetry)
7694 : CALL dbcsr_create(grad(ispin), &
7695 : template=matrix_t_out(ispin), &
7696 18 : matrix_type=dbcsr_type_no_symmetry)
7697 : CALL dbcsr_create(prev_step(ispin), &
7698 : template=matrix_t_out(ispin), &
7699 18 : matrix_type=dbcsr_type_no_symmetry)
7700 : CALL dbcsr_create(step(ispin), &
7701 : template=matrix_t_out(ispin), &
7702 18 : matrix_type=dbcsr_type_no_symmetry)
7703 : CALL dbcsr_create(m_sig_sqrti_ii(ispin), &
7704 : template=almo_scf_env%matrix_sigma_inv(ispin), &
7705 18 : matrix_type=dbcsr_type_no_symmetry)
7706 : CALL dbcsr_create(m_model_r(ispin), &
7707 : template=matrix_t_out(ispin), &
7708 18 : matrix_type=dbcsr_type_no_symmetry)
7709 : CALL dbcsr_create(m_model_rt(ispin), &
7710 : template=matrix_t_out(ispin), &
7711 18 : matrix_type=dbcsr_type_no_symmetry)
7712 : CALL dbcsr_create(m_model_d(ispin), &
7713 : template=matrix_t_out(ispin), &
7714 18 : matrix_type=dbcsr_type_no_symmetry)
7715 : CALL dbcsr_create(m_model_Bd(ispin), &
7716 : template=matrix_t_out(ispin), &
7717 18 : matrix_type=dbcsr_type_no_symmetry)
7718 : CALL dbcsr_create(m_model_r_prev(ispin), &
7719 : template=matrix_t_out(ispin), &
7720 18 : matrix_type=dbcsr_type_no_symmetry)
7721 : CALL dbcsr_create(m_model_rt_prev(ispin), &
7722 : template=matrix_t_out(ispin), &
7723 18 : matrix_type=dbcsr_type_no_symmetry)
7724 : CALL dbcsr_create(m_theta_trial(ispin), &
7725 : template=matrix_t_out(ispin), &
7726 18 : matrix_type=dbcsr_type_no_symmetry)
7727 :
7728 18 : CALL dbcsr_set(step(ispin), 0.0_dp)
7729 18 : CALL dbcsr_set(prev_step(ispin), 0.0_dp)
7730 :
7731 : CALL dbcsr_get_info(almo_scf_env%matrix_sigma_inv(ispin), &
7732 18 : nfullrows_total=nocc(ispin))
7733 :
7734 : ! invert S domains if necessary
7735 : ! Note: domains for alpha and beta electrons might be different
7736 : ! that is why the inversion of the AO overlap is inside the spin loop
7737 36 : IF (my_special_case == xalmo_case_normal) THEN
7738 :
7739 : CALL construct_domain_s_inv( &
7740 : matrix_s=almo_scf_env%matrix_s(1), &
7741 : subm_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
7742 : dpattern=quench_t(ispin), &
7743 : map=almo_scf_env%domain_map(ispin), &
7744 16 : node_of_domain=almo_scf_env%cpu_of_domain)
7745 :
7746 : END IF
7747 :
7748 : END DO ! ispin
7749 :
7750 : ! invert metric for special case where metric is spin independent
7751 18 : IF (my_special_case == xalmo_case_block_diag) THEN
7752 :
7753 : CALL dbcsr_create(m_s_inv, &
7754 : template=almo_scf_env%matrix_s(1), &
7755 2 : matrix_type=dbcsr_type_no_symmetry)
7756 : CALL invert_Hotelling(m_s_inv, &
7757 : almo_scf_env%matrix_s_blk(1), &
7758 : threshold=almo_scf_env%eps_filter, &
7759 2 : filter_eps=almo_scf_env%eps_filter)
7760 :
7761 16 : ELSE IF (my_special_case == xalmo_case_fully_deloc) THEN
7762 :
7763 : ! invert S using cholesky
7764 : CALL dbcsr_create(m_s_inv, &
7765 : template=almo_scf_env%matrix_s(1), &
7766 0 : matrix_type=dbcsr_type_no_symmetry)
7767 0 : CALL dbcsr_desymmetrize(almo_scf_env%matrix_s(1), m_s_inv)
7768 : CALL cp_dbcsr_cholesky_decompose(m_s_inv, &
7769 : para_env=almo_scf_env%para_env, &
7770 0 : blacs_env=almo_scf_env%blacs_env)
7771 : CALL cp_dbcsr_cholesky_invert(m_s_inv, &
7772 : para_env=almo_scf_env%para_env, &
7773 : blacs_env=almo_scf_env%blacs_env, &
7774 0 : uplo_to_full=.TRUE.)
7775 0 : CALL dbcsr_filter(m_s_inv, almo_scf_env%eps_filter)
7776 :
7777 : END IF ! s_inv
7778 :
7779 18 : radius_max = optimizer%max_trust_radius
7780 18 : radius_current = MIN(optimizer%initial_trust_radius, radius_max)
7781 : ! eta must be between 0 and 0.25
7782 18 : eta = MIN(MAX(optimizer%rho_do_not_update, 0.0_dp), 0.25_dp)
7783 : energy_start = 0.0_dp
7784 18 : energy_trial = 0.0_dp
7785 : penalty_start = 0.0_dp
7786 18 : penalty_trial = 0.0_dp
7787 : loss_start = 0.0_dp ! sum of the energy and penalty
7788 18 : loss_trial = 0.0_dp
7789 :
7790 18 : same_position = .FALSE.
7791 :
7792 : ! compute the energy
7793 : CALL main_var_to_xalmos_and_loss_func( &
7794 : almo_scf_env=almo_scf_env, &
7795 : qs_env=qs_env, &
7796 : m_main_var_in=m_theta, &
7797 : m_t_out=matrix_t_out, &
7798 : m_sig_sqrti_ii_out=m_sig_sqrti_ii, &
7799 : energy_out=energy_start, &
7800 : penalty_out=penalty_start, &
7801 : m_FTsiginv_out=FTsiginv, &
7802 : m_siginvTFTsiginv_out=siginvTFTsiginv, &
7803 : m_ST_out=ST, &
7804 : m_STsiginv0_in=STsiginv_0, &
7805 : m_quench_t_in=quench_t, &
7806 : domain_r_down_in=domain_r_down, &
7807 : assume_t0_q0x=assume_t0_q0x, &
7808 : just_started=.TRUE., &
7809 : optimize_theta=optimize_theta, &
7810 : normalize_orbitals=normalize_orbitals, &
7811 : perturbation_only=perturbation_only, &
7812 : do_penalty=penalty_occ_vol, &
7813 18 : special_case=my_special_case)
7814 18 : loss_start = energy_start + penalty_start
7815 18 : IF (my_special_case == xalmo_case_block_diag) THEN
7816 2 : almo_scf_env%almo_scf_energy = energy_start
7817 : END IF
7818 36 : DO ispin = 1, nspins
7819 36 : IF (penalty_occ_vol) THEN
7820 : penalty_occ_vol_g_prefactor(ispin) = &
7821 0 : -2.0_dp*penalty_amplitude*spin_factor*nocc(ispin)
7822 0 : penalty_occ_vol_h_prefactor(ispin) = 0.0_dp
7823 : END IF
7824 : END DO ! ispin
7825 :
7826 : ! start the outer step-size-adjustment loop
7827 18 : scf_converged = .FALSE.
7828 426 : adjust_r_loop: DO outer_iteration = 1, optimizer%max_iter_outer_loop
7829 :
7830 : ! start the inner fixed-radius loop
7831 426 : border_reached = .FALSE.
7832 :
7833 852 : DO ispin = 1, nspins
7834 426 : CALL dbcsr_set(step(ispin), 0.0_dp)
7835 852 : CALL dbcsr_filter(step(ispin), almo_scf_env%eps_filter)
7836 : END DO
7837 :
7838 426 : IF (.NOT. same_position) THEN
7839 :
7840 852 : DO ispin = 1, nspins
7841 :
7842 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Compute model gradient"
7843 : CALL compute_gradient( &
7844 : m_grad_out=grad(ispin), &
7845 : m_ks=almo_scf_env%matrix_ks(ispin), &
7846 : m_s=almo_scf_env%matrix_s(1), &
7847 : m_t=matrix_t_out(ispin), &
7848 : m_t0=almo_scf_env%matrix_t_blk(ispin), &
7849 : m_siginv=almo_scf_env%matrix_sigma_inv(ispin), &
7850 : m_quench_t=quench_t(ispin), &
7851 : m_FTsiginv=FTsiginv(ispin), &
7852 : m_siginvTFTsiginv=siginvTFTsiginv(ispin), &
7853 : m_ST=ST(ispin), &
7854 : m_STsiginv0=STsiginv_0(ispin), &
7855 : m_theta=m_theta(ispin), &
7856 : m_sig_sqrti_ii=m_sig_sqrti_ii(ispin), &
7857 : domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
7858 : domain_r_down=domain_r_down(:, ispin), &
7859 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
7860 : domain_map=almo_scf_env%domain_map(ispin), &
7861 : assume_t0_q0x=assume_t0_q0x, &
7862 : optimize_theta=optimize_theta, &
7863 : normalize_orbitals=normalize_orbitals, &
7864 : penalty_occ_vol=penalty_occ_vol, &
7865 : penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), &
7866 : envelope_amplitude=almo_scf_env%envelope_amplitude, &
7867 : eps_filter=almo_scf_env%eps_filter, &
7868 : spin_factor=spin_factor, &
7869 852 : special_case=my_special_case)
7870 :
7871 : END DO ! ispin
7872 :
7873 : END IF ! skip_grad
7874 :
7875 : ! check convergence and other exit criteria
7876 852 : DO ispin = 1, nspins
7877 852 : grad_norm_spin(ispin) = dbcsr_maxabs(grad(ispin))
7878 : END DO ! ispin
7879 852 : grad_norm_ref = MAXVAL(grad_norm_spin)
7880 :
7881 426 : t2outer = m_walltime()
7882 : CALL trust_r_report(unit_nr, &
7883 : iter_type=1, & ! only some data is important
7884 : iteration=outer_iteration, &
7885 : loss=loss_start, &
7886 : delta_loss=0.0_dp, &
7887 : grad_norm=grad_norm_ref, &
7888 : predicted_reduction=0.0_dp, &
7889 : rho=0.0_dp, &
7890 : radius=radius_current, &
7891 : new=.NOT. same_position, &
7892 426 : time=t2outer - t1outer)
7893 426 : t1outer = m_walltime()
7894 :
7895 426 : IF (grad_norm_ref <= optimizer%eps_error) THEN
7896 18 : scf_converged = .TRUE.
7897 18 : border_reached = .FALSE.
7898 18 : expected_reduction = 0.0_dp
7899 18 : IF (.NOT. (optimizer%early_stopping_on .AND. outer_iteration == 1)) THEN
7900 : EXIT adjust_r_loop
7901 : END IF
7902 : ELSE
7903 : scf_converged = .FALSE.
7904 : END IF
7905 :
7906 816 : DO ispin = 1, nspins
7907 :
7908 408 : CALL dbcsr_copy(m_model_r(ispin), grad(ispin))
7909 408 : CALL dbcsr_scale(m_model_r(ispin), -1.0_dp)
7910 :
7911 408 : IF (my_special_case == xalmo_case_block_diag .OR. &
7912 : my_special_case == xalmo_case_fully_deloc) THEN
7913 :
7914 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Multiply Sinv.r"
7915 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
7916 : m_s_inv, &
7917 : m_model_r(ispin), &
7918 : 0.0_dp, m_model_rt(ispin), &
7919 92 : filter_eps=almo_scf_env%eps_filter)
7920 :
7921 316 : ELSE IF (my_special_case == xalmo_case_normal) THEN
7922 :
7923 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Multiply Sinv_xx.r"
7924 : CALL apply_domain_operators( &
7925 : matrix_in=m_model_r(ispin), &
7926 : matrix_out=m_model_rt(ispin), &
7927 : operator1=almo_scf_env%domain_s_inv(:, ispin), &
7928 : dpattern=quench_t(ispin), &
7929 : map=almo_scf_env%domain_map(ispin), &
7930 : node_of_domain=almo_scf_env%cpu_of_domain, &
7931 : my_action=0, &
7932 316 : filter_eps=almo_scf_env%eps_filter)
7933 :
7934 : ELSE
7935 0 : CPABORT("Unknown XALMO special case")
7936 : END IF
7937 :
7938 816 : CALL dbcsr_copy(m_model_d(ispin), m_model_rt(ispin))
7939 :
7940 : END DO ! ispin
7941 :
7942 : ! compute model Hessian
7943 408 : IF (.NOT. same_position) THEN
7944 :
7945 : SELECT CASE (prec_type)
7946 : CASE (xalmo_prec_domain)
7947 :
7948 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Compute model Hessian"
7949 816 : DO ispin = 1, nspins
7950 : CALL compute_preconditioner( &
7951 : domain_prec_out=almo_scf_env%domain_preconditioner(:, ispin), &
7952 : m_prec_out=m_model_hessian(ispin), &
7953 : m_ks=almo_scf_env%matrix_ks(ispin), &
7954 : m_s=almo_scf_env%matrix_s(1), &
7955 : m_siginv=almo_scf_env%matrix_sigma_inv(ispin), &
7956 : m_quench_t=quench_t(ispin), &
7957 : m_FTsiginv=FTsiginv(ispin), &
7958 : m_siginvTFTsiginv=siginvTFTsiginv(ispin), &
7959 : m_ST=ST(ispin), &
7960 : para_env=almo_scf_env%para_env, &
7961 : blacs_env=almo_scf_env%blacs_env, &
7962 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
7963 : domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
7964 : domain_r_down=domain_r_down(:, ispin), &
7965 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
7966 : domain_map=almo_scf_env%domain_map(ispin), &
7967 : assume_t0_q0x=.FALSE., &
7968 : penalty_occ_vol=penalty_occ_vol, &
7969 : penalty_occ_vol_prefactor=penalty_occ_vol_g_prefactor(ispin), &
7970 : eps_filter=almo_scf_env%eps_filter, &
7971 : neg_thr=0.5_dp, &
7972 : spin_factor=spin_factor, &
7973 : skip_inversion=.TRUE., &
7974 816 : special_case=my_special_case)
7975 : END DO ! ispin
7976 :
7977 : CASE DEFAULT
7978 :
7979 408 : CPABORT("Unknown preconditioner")
7980 :
7981 : END SELECT ! preconditioner type fork
7982 :
7983 : END IF ! not same position
7984 :
7985 : ! print the header (argument values are ignored)
7986 : CALL fixed_r_report(unit_nr, &
7987 : iter_type=0, &
7988 : iteration=0, &
7989 : step_size=0.0_dp, &
7990 : border_reached=.FALSE., &
7991 : curvature=0.0_dp, &
7992 : grad_norm_ratio=0.0_dp, &
7993 408 : time=0.0_dp)
7994 :
7995 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Start inner loop"
7996 :
7997 408 : t1 = m_walltime()
7998 408 : inner_loop_success = .FALSE.
7999 : ! trustr_steihaug, trustr_cauchy, trustr_dogleg
8000 490 : fixed_r_loop: DO iteration = 1, optimizer%max_iter
8001 :
8002 : ! Step 2. Get curvature. If negative, step to the border
8003 490 : y_scalar = 0.0_dp
8004 980 : DO ispin = 1, nspins
8005 :
8006 : ! Get B.d
8007 490 : IF (my_special_case == xalmo_case_block_diag .OR. &
8008 : my_special_case == xalmo_case_fully_deloc) THEN
8009 :
8010 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
8011 : m_model_hessian(ispin), &
8012 : m_model_d(ispin), &
8013 : 0.0_dp, m_model_Bd(ispin), &
8014 92 : filter_eps=almo_scf_env%eps_filter)
8015 :
8016 : ELSE
8017 :
8018 : CALL apply_domain_operators( &
8019 : matrix_in=m_model_d(ispin), &
8020 : matrix_out=m_model_Bd(ispin), &
8021 : operator1=almo_scf_env%domain_preconditioner(:, ispin), &
8022 : dpattern=quench_t(ispin), &
8023 : map=almo_scf_env%domain_map(ispin), &
8024 : node_of_domain=almo_scf_env%cpu_of_domain, &
8025 : my_action=0, &
8026 398 : filter_eps=almo_scf_env%eps_filter)
8027 :
8028 : END IF ! special case
8029 :
8030 : ! Get y=d^T.B.d
8031 490 : CALL dbcsr_dot(m_model_d(ispin), m_model_Bd(ispin), real_temp)
8032 980 : y_scalar = y_scalar + real_temp
8033 :
8034 : END DO ! ispin
8035 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Curvature: ", y_scalar
8036 :
8037 : ! step to the border
8038 490 : IF (y_scalar < 0.0_dp) THEN
8039 :
8040 : CALL step_size_to_border( &
8041 : step_size_out=step_size, &
8042 : metric_in=almo_scf_env%matrix_s, &
8043 : position_in=step, &
8044 : direction_in=m_model_d, &
8045 : trust_radius_in=radius_current, &
8046 : quench_t_in=quench_t, &
8047 : eps_filter_in=almo_scf_env%eps_filter &
8048 0 : )
8049 :
8050 0 : DO ispin = 1, nspins
8051 0 : CALL dbcsr_add(step(ispin), m_model_d(ispin), 1.0_dp, step_size)
8052 : END DO
8053 :
8054 0 : border_reached = .TRUE.
8055 0 : inner_loop_success = .TRUE.
8056 :
8057 : CALL predicted_reduction( &
8058 : reduction_out=expected_reduction, &
8059 : grad_in=grad, &
8060 : step_in=step, &
8061 : hess_in=m_model_hessian, &
8062 : hess_submatrix_in=almo_scf_env%domain_preconditioner, &
8063 : quench_t_in=quench_t, &
8064 : special_case=my_special_case, &
8065 : eps_filter=almo_scf_env%eps_filter, &
8066 : domain_map=almo_scf_env%domain_map, &
8067 : cpu_of_domain=almo_scf_env%cpu_of_domain &
8068 0 : )
8069 :
8070 0 : t2 = m_walltime()
8071 : CALL fixed_r_report(unit_nr, &
8072 : iter_type=2, &
8073 : iteration=iteration, &
8074 : step_size=step_size, &
8075 : border_reached=border_reached, &
8076 : curvature=y_scalar, &
8077 : grad_norm_ratio=expected_reduction, &
8078 0 : time=t2 - t1)
8079 :
8080 : EXIT fixed_r_loop ! the inner loop
8081 :
8082 : END IF ! y is negative
8083 :
8084 : ! Step 3. Compute the step size along the direction
8085 490 : step_size = 0.0_dp
8086 980 : DO ispin = 1, nspins
8087 490 : CALL dbcsr_dot(m_model_r(ispin), m_model_rt(ispin), real_temp)
8088 980 : step_size = step_size + real_temp
8089 : END DO ! ispin
8090 490 : step_size = step_size/y_scalar
8091 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Proposed step size: ", step_size
8092 :
8093 : ! Update the step matrix
8094 980 : DO ispin = 1, nspins
8095 490 : CALL dbcsr_copy(prev_step(ispin), step(ispin))
8096 980 : CALL dbcsr_add(step(ispin), m_model_d(ispin), 1.0_dp, step_size)
8097 : END DO
8098 :
8099 : ! Compute step norm
8100 : CALL contravariant_matrix_norm( &
8101 : norm_out=step_norm, &
8102 : matrix_in=step, &
8103 : metric_in=almo_scf_env%matrix_s, &
8104 : quench_t_in=quench_t, &
8105 : eps_filter_in=almo_scf_env%eps_filter &
8106 490 : )
8107 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step norm: ", step_norm
8108 :
8109 : ! Do not step beyond the trust radius
8110 490 : IF (step_norm > radius_current) THEN
8111 :
8112 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Norm is too large"
8113 : CALL step_size_to_border( &
8114 : step_size_out=step_size, &
8115 : metric_in=almo_scf_env%matrix_s, &
8116 : position_in=prev_step, &
8117 : direction_in=m_model_d, &
8118 : trust_radius_in=radius_current, &
8119 : quench_t_in=quench_t, &
8120 : eps_filter_in=almo_scf_env%eps_filter &
8121 34 : )
8122 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size
8123 :
8124 68 : DO ispin = 1, nspins
8125 34 : CALL dbcsr_copy(step(ispin), prev_step(ispin))
8126 68 : CALL dbcsr_add(step(ispin), m_model_d(ispin), 1.0_dp, step_size)
8127 : END DO
8128 :
8129 : IF (debug_mode) THEN
8130 : ! Compute step norm
8131 : IF (unit_nr > 0) WRITE (unit_nr, *) "...Extra norm evaluation"
8132 : CALL contravariant_matrix_norm( &
8133 : norm_out=step_norm, &
8134 : matrix_in=step, &
8135 : metric_in=almo_scf_env%matrix_s, &
8136 : quench_t_in=quench_t, &
8137 : eps_filter_in=almo_scf_env%eps_filter &
8138 : )
8139 : IF (unit_nr > 0) WRITE (unit_nr, *) "...Step norm: ", step_norm
8140 : IF (unit_nr > 0) WRITE (unit_nr, *) "...Current radius: ", radius_current
8141 : END IF
8142 :
8143 34 : border_reached = .TRUE.
8144 34 : inner_loop_success = .TRUE.
8145 :
8146 : CALL predicted_reduction( &
8147 : reduction_out=expected_reduction, &
8148 : grad_in=grad, &
8149 : step_in=step, &
8150 : hess_in=m_model_hessian, &
8151 : hess_submatrix_in=almo_scf_env%domain_preconditioner, &
8152 : quench_t_in=quench_t, &
8153 : special_case=my_special_case, &
8154 : eps_filter=almo_scf_env%eps_filter, &
8155 : domain_map=almo_scf_env%domain_map, &
8156 : cpu_of_domain=almo_scf_env%cpu_of_domain &
8157 34 : )
8158 :
8159 34 : t2 = m_walltime()
8160 : CALL fixed_r_report(unit_nr, &
8161 : iter_type=3, &
8162 : iteration=iteration, &
8163 : step_size=step_size, &
8164 : border_reached=border_reached, &
8165 : curvature=y_scalar, &
8166 : grad_norm_ratio=expected_reduction, &
8167 34 : time=t2 - t1)
8168 :
8169 : EXIT fixed_r_loop ! the inner loop
8170 :
8171 : END IF
8172 :
8173 456 : IF (optimizer%trustr_algorithm == trustr_cauchy) THEN
8174 : ! trustr_steihaug, trustr_cauchy, trustr_dogleg
8175 :
8176 80 : border_reached = .FALSE.
8177 80 : inner_loop_success = .TRUE.
8178 :
8179 : CALL predicted_reduction( &
8180 : reduction_out=expected_reduction, &
8181 : grad_in=grad, &
8182 : step_in=step, &
8183 : hess_in=m_model_hessian, &
8184 : hess_submatrix_in=almo_scf_env%domain_preconditioner, &
8185 : quench_t_in=quench_t, &
8186 : special_case=my_special_case, &
8187 : eps_filter=almo_scf_env%eps_filter, &
8188 : domain_map=almo_scf_env%domain_map, &
8189 : cpu_of_domain=almo_scf_env%cpu_of_domain &
8190 80 : )
8191 :
8192 80 : t2 = m_walltime()
8193 : CALL fixed_r_report(unit_nr, &
8194 : iter_type=5, & ! Cauchy point
8195 : iteration=iteration, &
8196 : step_size=step_size, &
8197 : border_reached=border_reached, &
8198 : curvature=y_scalar, &
8199 : grad_norm_ratio=expected_reduction, &
8200 80 : time=t2 - t1)
8201 :
8202 : EXIT fixed_r_loop ! the inner loop
8203 :
8204 376 : ELSE IF (optimizer%trustr_algorithm == trustr_dogleg) THEN
8205 :
8206 : ! invert or pseudo-invert B
8207 268 : SELECT CASE (prec_type)
8208 : CASE (xalmo_prec_domain)
8209 :
8210 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Pseudo-invert model Hessian"
8211 268 : IF (special_case == xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks
8212 :
8213 156 : DO ispin = 1, nspins
8214 : CALL pseudo_invert_diagonal_blk( &
8215 : matrix_in=m_model_hessian(ispin), &
8216 : matrix_out=m_model_hessian_inv(ispin), &
8217 : nocc=almo_scf_env%nocc_of_domain(:, ispin) &
8218 156 : )
8219 : END DO
8220 :
8221 190 : ELSE IF (special_case == xalmo_case_fully_deloc) THEN ! the entire system is a block
8222 :
8223 : ! invert using cholesky decomposition
8224 0 : DO ispin = 1, nspins
8225 : CALL dbcsr_copy(m_model_hessian_inv(ispin), &
8226 0 : m_model_hessian(ispin))
8227 : CALL cp_dbcsr_cholesky_decompose(m_model_hessian_inv(ispin), &
8228 : para_env=almo_scf_env%para_env, &
8229 0 : blacs_env=almo_scf_env%blacs_env)
8230 : CALL cp_dbcsr_cholesky_invert(m_model_hessian_inv(ispin), &
8231 : para_env=almo_scf_env%para_env, &
8232 : blacs_env=almo_scf_env%blacs_env, &
8233 0 : uplo_to_full=.TRUE.)
8234 : CALL dbcsr_filter(m_model_hessian_inv(ispin), &
8235 0 : almo_scf_env%eps_filter)
8236 : END DO
8237 :
8238 : ELSE
8239 :
8240 380 : DO ispin = 1, nspins
8241 : CALL construct_domain_preconditioner( &
8242 : matrix_main=m_model_hessian(ispin), &
8243 : subm_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
8244 : subm_r_down=domain_r_down(:, ispin), &
8245 : matrix_trimmer=quench_t(ispin), &
8246 : dpattern=quench_t(ispin), &
8247 : map=almo_scf_env%domain_map(ispin), &
8248 : node_of_domain=almo_scf_env%cpu_of_domain, &
8249 : preconditioner=domain_model_hessian_inv(:, ispin), &
8250 : use_trimmer=.FALSE., &
8251 : my_action=0, & ! do not do domain (1-r0) projection
8252 : skip_inversion=.FALSE. &
8253 380 : )
8254 : END DO
8255 :
8256 : END IF ! special_case
8257 :
8258 : CASE DEFAULT
8259 :
8260 268 : CPABORT("Unknown preconditioner")
8261 :
8262 : END SELECT ! preconditioner type fork
8263 :
8264 : ! get pB = Binv.m_model_r = -Binv.grad
8265 536 : DO ispin = 1, nspins
8266 :
8267 : ! Get B.d
8268 268 : IF (my_special_case == xalmo_case_block_diag .OR. &
8269 268 : my_special_case == xalmo_case_fully_deloc) THEN
8270 :
8271 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
8272 : m_model_hessian_inv(ispin), &
8273 : m_model_r(ispin), &
8274 : 0.0_dp, m_model_Bd(ispin), &
8275 78 : filter_eps=almo_scf_env%eps_filter)
8276 :
8277 : ELSE
8278 :
8279 : CALL apply_domain_operators( &
8280 : matrix_in=m_model_r(ispin), &
8281 : matrix_out=m_model_Bd(ispin), &
8282 : operator1=domain_model_hessian_inv(:, ispin), &
8283 : dpattern=quench_t(ispin), &
8284 : map=almo_scf_env%domain_map(ispin), &
8285 : node_of_domain=almo_scf_env%cpu_of_domain, &
8286 : my_action=0, &
8287 190 : filter_eps=almo_scf_env%eps_filter)
8288 :
8289 : END IF ! special case
8290 :
8291 : END DO ! ispin
8292 :
8293 : ! Compute norm of pB
8294 : CALL contravariant_matrix_norm( &
8295 : norm_out=step_norm, &
8296 : matrix_in=m_model_Bd, &
8297 : metric_in=almo_scf_env%matrix_s, &
8298 : quench_t_in=quench_t, &
8299 : eps_filter_in=almo_scf_env%eps_filter &
8300 268 : )
8301 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...pB norm: ", step_norm
8302 :
8303 : ! Do not step beyond the trust radius
8304 268 : IF (step_norm <= radius_current) THEN
8305 :
8306 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Full dogleg"
8307 :
8308 266 : border_reached = .FALSE.
8309 :
8310 532 : DO ispin = 1, nspins
8311 532 : CALL dbcsr_copy(step(ispin), m_model_Bd(ispin))
8312 : END DO
8313 :
8314 266 : fake_step_size_to_report = 2.0_dp
8315 266 : iteration_type_to_report = 6
8316 :
8317 : ELSE ! take a shorter dogleg step
8318 :
8319 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...pB norm is too large"
8320 :
8321 2 : border_reached = .TRUE.
8322 :
8323 : ! compute the dogleg vector = pB - pU
8324 : ! this destroys -Binv.grad content
8325 4 : DO ispin = 1, nspins
8326 4 : CALL dbcsr_add(m_model_Bd(ispin), step(ispin), 1.0_dp, -1.0_dp)
8327 : END DO
8328 :
8329 : CALL step_size_to_border( &
8330 : step_size_out=step_size, &
8331 : metric_in=almo_scf_env%matrix_s, &
8332 : position_in=step, &
8333 : direction_in=m_model_Bd, &
8334 : trust_radius_in=radius_current, &
8335 : quench_t_in=quench_t, &
8336 : eps_filter_in=almo_scf_env%eps_filter &
8337 2 : )
8338 : IF (unit_nr > 0 .AND. debug_mode) WRITE (unit_nr, *) "...Step size to border: ", step_size
8339 2 : IF (step_size > 1.0_dp .OR. step_size < 0.0_dp) THEN
8340 0 : IF (unit_nr > 0) THEN
8341 0 : WRITE (unit_nr, *) "Step size (", step_size, ") must lie inside (0,1)"
8342 : END IF
8343 0 : CPABORT("Wrong dog leg step. We should never end up here.")
8344 : END IF
8345 :
8346 4 : DO ispin = 1, nspins
8347 4 : CALL dbcsr_add(step(ispin), m_model_Bd(ispin), 1.0_dp, step_size)
8348 : END DO
8349 :
8350 2 : fake_step_size_to_report = 1.0_dp + step_size
8351 2 : iteration_type_to_report = 7
8352 :
8353 : END IF ! full or partial dogleg?
8354 :
8355 : IF (debug_mode) THEN
8356 : ! Compute step norm
8357 : IF (unit_nr > 0) WRITE (unit_nr, *) "...Extra norm evaluation"
8358 : CALL contravariant_matrix_norm( &
8359 : norm_out=step_norm, &
8360 : matrix_in=step, &
8361 : metric_in=almo_scf_env%matrix_s, &
8362 : quench_t_in=quench_t, &
8363 : eps_filter_in=almo_scf_env%eps_filter &
8364 : )
8365 : IF (unit_nr > 0) WRITE (unit_nr, *) "...Step norm: ", step_norm
8366 : IF (unit_nr > 0) WRITE (unit_nr, *) "...Current radius: ", radius_current
8367 : END IF
8368 :
8369 : CALL predicted_reduction( &
8370 : reduction_out=expected_reduction, &
8371 : grad_in=grad, &
8372 : step_in=step, &
8373 : hess_in=m_model_hessian, &
8374 : hess_submatrix_in=almo_scf_env%domain_preconditioner, &
8375 : quench_t_in=quench_t, &
8376 : special_case=my_special_case, &
8377 : eps_filter=almo_scf_env%eps_filter, &
8378 : domain_map=almo_scf_env%domain_map, &
8379 : cpu_of_domain=almo_scf_env%cpu_of_domain &
8380 268 : )
8381 :
8382 268 : inner_loop_success = .TRUE.
8383 :
8384 268 : t2 = m_walltime()
8385 : CALL fixed_r_report(unit_nr, &
8386 : iter_type=iteration_type_to_report, &
8387 : iteration=iteration, &
8388 : step_size=fake_step_size_to_report, &
8389 : border_reached=border_reached, &
8390 : curvature=y_scalar, &
8391 : grad_norm_ratio=expected_reduction, &
8392 268 : time=t2 - t1)
8393 :
8394 : EXIT fixed_r_loop ! the inner loop
8395 :
8396 : END IF ! Non-iterative subproblem methods exit here
8397 :
8398 : ! Step 4: update model gradient
8399 216 : DO ispin = 1, nspins
8400 : ! save previous data
8401 108 : CALL dbcsr_copy(m_model_r_prev(ispin), m_model_r(ispin))
8402 : CALL dbcsr_add(m_model_r(ispin), m_model_Bd(ispin), &
8403 216 : 1.0_dp, -step_size)
8404 : END DO ! ispin
8405 :
8406 : ! Model grad norm
8407 216 : DO ispin = 1, nspins
8408 216 : grad_norm_spin(ispin) = dbcsr_maxabs(m_model_r(ispin))
8409 : END DO ! ispin
8410 216 : model_grad_norm = MAXVAL(grad_norm_spin)
8411 :
8412 : ! Check norm reduction
8413 108 : grad_norm_ratio = model_grad_norm/grad_norm_ref
8414 108 : IF (grad_norm_ratio < optimizer%model_grad_norm_ratio) THEN
8415 :
8416 26 : border_reached = .FALSE.
8417 26 : inner_loop_success = .TRUE.
8418 :
8419 : CALL predicted_reduction( &
8420 : reduction_out=expected_reduction, &
8421 : grad_in=grad, &
8422 : step_in=step, &
8423 : hess_in=m_model_hessian, &
8424 : hess_submatrix_in=almo_scf_env%domain_preconditioner, &
8425 : quench_t_in=quench_t, &
8426 : special_case=my_special_case, &
8427 : eps_filter=almo_scf_env%eps_filter, &
8428 : domain_map=almo_scf_env%domain_map, &
8429 : cpu_of_domain=almo_scf_env%cpu_of_domain &
8430 26 : )
8431 :
8432 26 : t2 = m_walltime()
8433 : CALL fixed_r_report(unit_nr, &
8434 : iter_type=4, &
8435 : iteration=iteration, &
8436 : step_size=step_size, &
8437 : border_reached=border_reached, &
8438 : curvature=y_scalar, &
8439 : grad_norm_ratio=expected_reduction, &
8440 26 : time=t2 - t1)
8441 :
8442 : EXIT fixed_r_loop ! the inner loop
8443 :
8444 : END IF
8445 :
8446 : ! Step 5: update model direction
8447 164 : DO ispin = 1, nspins
8448 : ! save previous data
8449 164 : CALL dbcsr_copy(m_model_rt_prev(ispin), m_model_rt(ispin))
8450 : END DO ! ispin
8451 :
8452 164 : DO ispin = 1, nspins
8453 :
8454 82 : IF (my_special_case == xalmo_case_block_diag .OR. &
8455 82 : my_special_case == xalmo_case_fully_deloc) THEN
8456 :
8457 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
8458 : m_s_inv, &
8459 : m_model_r(ispin), &
8460 : 0.0_dp, m_model_rt(ispin), &
8461 0 : filter_eps=almo_scf_env%eps_filter)
8462 :
8463 82 : ELSE IF (my_special_case == xalmo_case_normal) THEN
8464 :
8465 : CALL apply_domain_operators( &
8466 : matrix_in=m_model_r(ispin), &
8467 : matrix_out=m_model_rt(ispin), &
8468 : operator1=almo_scf_env%domain_s_inv(:, ispin), &
8469 : dpattern=quench_t(ispin), &
8470 : map=almo_scf_env%domain_map(ispin), &
8471 : node_of_domain=almo_scf_env%cpu_of_domain, &
8472 : my_action=0, &
8473 82 : filter_eps=almo_scf_env%eps_filter)
8474 :
8475 : END IF
8476 :
8477 : END DO ! ispin
8478 :
8479 : CALL compute_cg_beta( &
8480 : beta=beta, &
8481 : reset_conjugator=reset_conjugator, &
8482 : conjugator=optimizer%conjugator, &
8483 : grad=m_model_r(:), &
8484 : prev_grad=m_model_r_prev(:), &
8485 : step=m_model_rt(:), &
8486 : prev_step=m_model_rt_prev(:) &
8487 82 : )
8488 :
8489 164 : DO ispin = 1, nspins
8490 : ! update direction
8491 164 : CALL dbcsr_add(m_model_d(ispin), m_model_rt(ispin), beta, 1.0_dp)
8492 : END DO ! ispin
8493 :
8494 82 : t2 = m_walltime()
8495 : CALL fixed_r_report(unit_nr, &
8496 : iter_type=1, &
8497 : iteration=iteration, &
8498 : step_size=step_size, &
8499 : border_reached=border_reached, &
8500 : curvature=y_scalar, &
8501 : grad_norm_ratio=grad_norm_ratio, &
8502 82 : time=t2 - t1)
8503 82 : t1 = m_walltime()
8504 :
8505 : END DO fixed_r_loop
8506 : !!!! done with the inner loop
8507 : ! the inner loop must return: step, predicted reduction,
8508 : ! whether it reached the border and completed successfully
8509 :
8510 : IF (.NOT. inner_loop_success) THEN
8511 0 : CPABORT("Inner loop did not produce solution")
8512 : END IF
8513 :
8514 816 : DO ispin = 1, nspins
8515 :
8516 408 : CALL dbcsr_copy(m_theta_trial(ispin), m_theta(ispin))
8517 816 : CALL dbcsr_add(m_theta_trial(ispin), step(ispin), 1.0_dp, 1.0_dp)
8518 :
8519 : END DO ! ispin
8520 :
8521 : ! compute the energy
8522 : CALL main_var_to_xalmos_and_loss_func( &
8523 : almo_scf_env=almo_scf_env, &
8524 : qs_env=qs_env, &
8525 : m_main_var_in=m_theta_trial, &
8526 : m_t_out=matrix_t_out, &
8527 : m_sig_sqrti_ii_out=m_sig_sqrti_ii, &
8528 : energy_out=energy_trial, &
8529 : penalty_out=penalty_trial, &
8530 : m_FTsiginv_out=FTsiginv, &
8531 : m_siginvTFTsiginv_out=siginvTFTsiginv, &
8532 : m_ST_out=ST, &
8533 : m_STsiginv0_in=STsiginv_0, &
8534 : m_quench_t_in=quench_t, &
8535 : domain_r_down_in=domain_r_down, &
8536 : assume_t0_q0x=assume_t0_q0x, &
8537 : just_started=.FALSE., &
8538 : optimize_theta=optimize_theta, &
8539 : normalize_orbitals=normalize_orbitals, &
8540 : perturbation_only=perturbation_only, &
8541 : do_penalty=penalty_occ_vol, &
8542 408 : special_case=my_special_case)
8543 408 : loss_trial = energy_trial + penalty_trial
8544 :
8545 408 : rho = (loss_trial - loss_start)/expected_reduction
8546 408 : loss_change_to_report = loss_trial - loss_start
8547 :
8548 408 : IF (rho < 0.25_dp) THEN
8549 0 : radius_current = 0.25_dp*radius_current
8550 : ELSE
8551 408 : IF (rho > 0.75_dp .AND. border_reached) THEN
8552 2 : radius_current = MIN(2.0_dp*radius_current, radius_max)
8553 : END IF
8554 : END IF ! radius adjustment
8555 :
8556 408 : IF (rho > eta) THEN
8557 816 : DO ispin = 1, nspins
8558 816 : CALL dbcsr_copy(m_theta(ispin), m_theta_trial(ispin))
8559 : END DO ! ispin
8560 408 : loss_start = loss_trial
8561 408 : energy_start = energy_trial
8562 408 : penalty_start = penalty_trial
8563 408 : same_position = .FALSE.
8564 408 : IF (my_special_case == xalmo_case_block_diag) THEN
8565 92 : almo_scf_env%almo_scf_energy = energy_trial
8566 : END IF
8567 : ELSE
8568 0 : same_position = .TRUE.
8569 0 : IF (my_special_case == xalmo_case_block_diag) THEN
8570 0 : almo_scf_env%almo_scf_energy = energy_start
8571 : END IF
8572 : END IF ! finalize step
8573 :
8574 408 : t2outer = m_walltime()
8575 : CALL trust_r_report(unit_nr, &
8576 : iter_type=2, &
8577 : iteration=outer_iteration, &
8578 : loss=loss_trial, &
8579 : delta_loss=loss_change_to_report, &
8580 : grad_norm=0.0_dp, &
8581 : predicted_reduction=expected_reduction, &
8582 : rho=rho, &
8583 : radius=radius_current, &
8584 : new=.NOT. same_position, &
8585 408 : time=t2outer - t1outer)
8586 426 : t1outer = m_walltime()
8587 :
8588 : END DO adjust_r_loop
8589 :
8590 : ! post SCF-loop calculations
8591 18 : IF (scf_converged) THEN
8592 :
8593 : CALL wrap_up_xalmo_scf( &
8594 : qs_env=qs_env, &
8595 : almo_scf_env=almo_scf_env, &
8596 : perturbation_in=perturbation_only, &
8597 : m_xalmo_in=matrix_t_out, &
8598 : m_quench_in=quench_t, &
8599 18 : energy_inout=energy_start)
8600 :
8601 : END IF ! if converged
8602 :
8603 36 : DO ispin = 1, nspins
8604 18 : CALL dbcsr_release(m_model_hessian_inv(ispin))
8605 18 : CALL dbcsr_release(m_model_hessian(ispin))
8606 18 : CALL dbcsr_release(STsiginv_0(ispin))
8607 18 : CALL dbcsr_release(ST(ispin))
8608 18 : CALL dbcsr_release(FTsiginv(ispin))
8609 18 : CALL dbcsr_release(siginvTFTsiginv(ispin))
8610 18 : CALL dbcsr_release(prev_step(ispin))
8611 18 : CALL dbcsr_release(grad(ispin))
8612 18 : CALL dbcsr_release(step(ispin))
8613 18 : CALL dbcsr_release(m_theta(ispin))
8614 18 : CALL dbcsr_release(m_sig_sqrti_ii(ispin))
8615 18 : CALL dbcsr_release(m_model_r(ispin))
8616 18 : CALL dbcsr_release(m_model_rt(ispin))
8617 18 : CALL dbcsr_release(m_model_d(ispin))
8618 18 : CALL dbcsr_release(m_model_Bd(ispin))
8619 18 : CALL dbcsr_release(m_model_r_prev(ispin))
8620 18 : CALL dbcsr_release(m_model_rt_prev(ispin))
8621 18 : CALL dbcsr_release(m_theta_trial(ispin))
8622 18 : CALL release_submatrices(domain_r_down(:, ispin))
8623 36 : CALL release_submatrices(domain_model_hessian_inv(:, ispin))
8624 : END DO ! ispin
8625 :
8626 18 : IF (my_special_case == xalmo_case_block_diag .OR. &
8627 : my_special_case == xalmo_case_fully_deloc) THEN
8628 2 : CALL dbcsr_release(m_s_inv)
8629 : END IF
8630 :
8631 18 : DEALLOCATE (m_model_hessian)
8632 18 : DEALLOCATE (m_model_hessian_inv)
8633 18 : DEALLOCATE (siginvTFTsiginv)
8634 18 : DEALLOCATE (STsiginv_0)
8635 18 : DEALLOCATE (FTsiginv)
8636 18 : DEALLOCATE (ST)
8637 18 : DEALLOCATE (grad)
8638 18 : DEALLOCATE (prev_step)
8639 18 : DEALLOCATE (step)
8640 18 : DEALLOCATE (m_sig_sqrti_ii)
8641 18 : DEALLOCATE (m_model_r)
8642 18 : DEALLOCATE (m_model_rt)
8643 18 : DEALLOCATE (m_model_d)
8644 18 : DEALLOCATE (m_model_Bd)
8645 18 : DEALLOCATE (m_model_r_prev)
8646 18 : DEALLOCATE (m_model_rt_prev)
8647 18 : DEALLOCATE (m_theta_trial)
8648 :
8649 146 : DEALLOCATE (domain_r_down)
8650 146 : DEALLOCATE (domain_model_hessian_inv)
8651 :
8652 18 : DEALLOCATE (penalty_occ_vol_g_prefactor)
8653 18 : DEALLOCATE (penalty_occ_vol_h_prefactor)
8654 18 : DEALLOCATE (grad_norm_spin)
8655 18 : DEALLOCATE (nocc)
8656 :
8657 18 : DEALLOCATE (m_theta)
8658 :
8659 18 : IF (.NOT. scf_converged .AND. .NOT. optimizer%early_stopping_on) THEN
8660 0 : CPABORT("Optimization not converged! ")
8661 : END IF
8662 :
8663 18 : CALL timestop(handle)
8664 :
8665 36 : END SUBROUTINE almo_scf_xalmo_trustr
8666 :
8667 : ! **************************************************************************************************
8668 : !> \brief Computes molecular orbitals and the objective (loss) function from the main variables
8669 : !> Most important input and output variables are given as arguments explicitly.
8670 : !> Some variables inside almo_scf_env (KS, DM) and qs_env are also updated but are not
8671 : !> listed as arguments for brevity
8672 : !> \param almo_scf_env ...
8673 : !> \param qs_env ...
8674 : !> \param m_main_var_in ...
8675 : !> \param m_t_out ...
8676 : !> \param energy_out ...
8677 : !> \param penalty_out ...
8678 : !> \param m_sig_sqrti_ii_out ...
8679 : !> \param m_FTsiginv_out ...
8680 : !> \param m_siginvTFTsiginv_out ...
8681 : !> \param m_ST_out ...
8682 : !> \param m_STsiginv0_in ...
8683 : !> \param m_quench_t_in ...
8684 : !> \param domain_r_down_in ...
8685 : !> \param assume_t0_q0x ...
8686 : !> \param just_started ...
8687 : !> \param optimize_theta ...
8688 : !> \param normalize_orbitals ...
8689 : !> \param perturbation_only ...
8690 : !> \param do_penalty ...
8691 : !> \param special_case ...
8692 : !> \par History
8693 : !> 2019.12 created [Rustam Z Khaliullin]
8694 : !> \author Rustam Z Khaliullin
8695 : ! **************************************************************************************************
8696 1486 : SUBROUTINE main_var_to_xalmos_and_loss_func(almo_scf_env, qs_env, m_main_var_in, &
8697 1486 : m_t_out, energy_out, penalty_out, m_sig_sqrti_ii_out, m_FTsiginv_out, &
8698 1486 : m_siginvTFTsiginv_out, m_ST_out, m_STsiginv0_in, m_quench_t_in, domain_r_down_in, &
8699 : assume_t0_q0x, just_started, optimize_theta, normalize_orbitals, perturbation_only, &
8700 : do_penalty, special_case)
8701 :
8702 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
8703 : TYPE(qs_environment_type), POINTER :: qs_env
8704 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_main_var_in
8705 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: m_t_out
8706 : REAL(KIND=dp), INTENT(OUT) :: energy_out, penalty_out
8707 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: m_sig_sqrti_ii_out, m_FTsiginv_out, &
8708 : m_siginvTFTsiginv_out, m_ST_out, &
8709 : m_STsiginv0_in, m_quench_t_in
8710 : TYPE(domain_submatrix_type), DIMENSION(:, :), &
8711 : INTENT(IN) :: domain_r_down_in
8712 : LOGICAL, INTENT(IN) :: assume_t0_q0x, just_started, &
8713 : optimize_theta, normalize_orbitals, &
8714 : perturbation_only, do_penalty
8715 : INTEGER, INTENT(IN) :: special_case
8716 :
8717 : CHARACTER(len=*), PARAMETER :: routineN = 'main_var_to_xalmos_and_loss_func'
8718 :
8719 : INTEGER :: handle, ispin, nspins
8720 1486 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nocc
8721 : REAL(KIND=dp) :: det1, energy_ispin, penalty_amplitude, &
8722 : spin_factor
8723 :
8724 1486 : CALL timeset(routineN, handle)
8725 :
8726 1486 : energy_out = 0.0_dp
8727 1486 : penalty_out = 0.0_dp
8728 :
8729 1486 : nspins = SIZE(m_main_var_in)
8730 1486 : IF (nspins == 1) THEN
8731 1474 : spin_factor = 2.0_dp
8732 : ELSE
8733 12 : spin_factor = 1.0_dp
8734 : END IF
8735 :
8736 1486 : penalty_amplitude = 0.0_dp !almo_scf_env%penalty%occ_vol_coeff
8737 :
8738 4458 : ALLOCATE (nocc(nspins))
8739 2984 : DO ispin = 1, nspins
8740 : CALL dbcsr_get_info(almo_scf_env%matrix_sigma_inv(ispin), &
8741 2984 : nfullrows_total=nocc(ispin))
8742 : END DO
8743 :
8744 2984 : DO ispin = 1, nspins
8745 :
8746 : ! compute MO coefficients from the main variable
8747 : CALL compute_xalmos_from_main_var( &
8748 : m_var_in=m_main_var_in(ispin), &
8749 : m_t_out=m_t_out(ispin), &
8750 : m_quench_t=m_quench_t_in(ispin), &
8751 : m_t0=almo_scf_env%matrix_t_blk(ispin), &
8752 : m_oo_template=almo_scf_env%matrix_sigma_inv(ispin), &
8753 : m_STsiginv0=m_STsiginv0_in(ispin), &
8754 : m_s=almo_scf_env%matrix_s(1), &
8755 : m_sig_sqrti_ii_out=m_sig_sqrti_ii_out(ispin), &
8756 : domain_r_down=domain_r_down_in(:, ispin), &
8757 : domain_s_inv=almo_scf_env%domain_s_inv(:, ispin), &
8758 : domain_map=almo_scf_env%domain_map(ispin), &
8759 : cpu_of_domain=almo_scf_env%cpu_of_domain, &
8760 : assume_t0_q0x=assume_t0_q0x, &
8761 : just_started=just_started, &
8762 : optimize_theta=optimize_theta, &
8763 : normalize_orbitals=normalize_orbitals, &
8764 : envelope_amplitude=almo_scf_env%envelope_amplitude, &
8765 : eps_filter=almo_scf_env%eps_filter, &
8766 : special_case=special_case, &
8767 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
8768 : order_lanczos=almo_scf_env%order_lanczos, &
8769 : eps_lanczos=almo_scf_env%eps_lanczos, &
8770 1498 : max_iter_lanczos=almo_scf_env%max_iter_lanczos)
8771 :
8772 : ! compute the global projectors (for the density matrix)
8773 : CALL almo_scf_t_to_proj( &
8774 : t=m_t_out(ispin), &
8775 : p=almo_scf_env%matrix_p(ispin), &
8776 : eps_filter=almo_scf_env%eps_filter, &
8777 : orthog_orbs=.FALSE., &
8778 : nocc_of_domain=almo_scf_env%nocc_of_domain(:, ispin), &
8779 : s=almo_scf_env%matrix_s(1), &
8780 : sigma=almo_scf_env%matrix_sigma(ispin), &
8781 : sigma_inv=almo_scf_env%matrix_sigma_inv(ispin), &
8782 : use_guess=.FALSE., &
8783 : algorithm=almo_scf_env%sigma_inv_algorithm, &
8784 : inv_eps_factor=almo_scf_env%matrix_iter_eps_error_factor, &
8785 : inverse_accelerator=almo_scf_env%order_lanczos, &
8786 : eps_lanczos=almo_scf_env%eps_lanczos, &
8787 : max_iter_lanczos=almo_scf_env%max_iter_lanczos, &
8788 : para_env=almo_scf_env%para_env, &
8789 1498 : blacs_env=almo_scf_env%blacs_env)
8790 :
8791 : ! compute dm from the projector(s)
8792 : CALL dbcsr_scale(almo_scf_env%matrix_p(ispin), &
8793 2984 : spin_factor)
8794 :
8795 : END DO ! ispin
8796 :
8797 : ! update the KS matrix and energy if necessary
8798 1486 : IF (perturbation_only) THEN
8799 : ! note: do not combine the two IF statements
8800 212 : IF (just_started) THEN
8801 48 : DO ispin = 1, nspins
8802 : CALL dbcsr_copy(almo_scf_env%matrix_ks(ispin), &
8803 48 : almo_scf_env%matrix_ks_0deloc(ispin))
8804 : END DO
8805 : END IF
8806 : ELSE
8807 : ! the KS matrix is updated outside the spin loop
8808 : CALL almo_dm_to_almo_ks(qs_env, &
8809 : almo_scf_env%matrix_p, &
8810 : almo_scf_env%matrix_ks, &
8811 : energy_out, &
8812 : almo_scf_env%eps_filter, &
8813 1274 : almo_scf_env%mat_distr_aos)
8814 : END IF
8815 :
8816 1486 : penalty_out = 0.0_dp
8817 2984 : DO ispin = 1, nspins
8818 :
8819 : CALL compute_frequently_used_matrices( &
8820 : filter_eps=almo_scf_env%eps_filter, &
8821 : m_T_in=m_t_out(ispin), &
8822 : m_siginv_in=almo_scf_env%matrix_sigma_inv(ispin), &
8823 : m_S_in=almo_scf_env%matrix_s(1), &
8824 : m_F_in=almo_scf_env%matrix_ks(ispin), &
8825 : m_FTsiginv_out=m_FTsiginv_out(ispin), &
8826 : m_siginvTFTsiginv_out=m_siginvTFTsiginv_out(ispin), &
8827 1498 : m_ST_out=m_ST_out(ispin))
8828 :
8829 1498 : IF (perturbation_only) THEN
8830 : ! calculate objective function Tr(F_0 R)
8831 212 : IF (ispin == 1) energy_out = 0.0_dp
8832 212 : CALL dbcsr_dot(m_t_out(ispin), m_FTsiginv_out(ispin), energy_ispin)
8833 212 : energy_out = energy_out + energy_ispin*spin_factor
8834 : END IF
8835 :
8836 2984 : IF (do_penalty) THEN
8837 :
8838 : CALL determinant(almo_scf_env%matrix_sigma(ispin), det1, &
8839 0 : almo_scf_env%eps_filter)
8840 : penalty_out = penalty_out - &
8841 0 : penalty_amplitude*spin_factor*nocc(ispin)*LOG(det1)
8842 :
8843 : END IF
8844 :
8845 : END DO ! ispin
8846 :
8847 1486 : DEALLOCATE (nocc)
8848 :
8849 1486 : CALL timestop(handle)
8850 :
8851 1486 : END SUBROUTINE main_var_to_xalmos_and_loss_func
8852 :
8853 : ! **************************************************************************************************
8854 : !> \brief Computes the step size required to reach the trust-radius border,
8855 : !> measured from the origin,
8856 : !> given the current position (position) in the direction (direction)
8857 : !> \param step_size_out ...
8858 : !> \param metric_in ...
8859 : !> \param position_in ...
8860 : !> \param direction_in ...
8861 : !> \param trust_radius_in ...
8862 : !> \param quench_t_in ...
8863 : !> \param eps_filter_in ...
8864 : !> \par History
8865 : !> 2019.12 created [Rustam Z Khaliullin]
8866 : !> \author Rustam Z Khaliullin
8867 : ! **************************************************************************************************
8868 36 : SUBROUTINE step_size_to_border(step_size_out, metric_in, position_in, &
8869 36 : direction_in, trust_radius_in, quench_t_in, eps_filter_in)
8870 :
8871 : REAL(KIND=dp), INTENT(INOUT) :: step_size_out
8872 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: metric_in, position_in, direction_in
8873 : REAL(KIND=dp), INTENT(IN) :: trust_radius_in
8874 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: quench_t_in
8875 : REAL(KIND=dp), INTENT(IN) :: eps_filter_in
8876 :
8877 : INTEGER :: isol, ispin, nsolutions, &
8878 : nsolutions_found, nspins
8879 36 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nocc
8880 : REAL(KIND=dp) :: discrim_sign, discriminant, solution, &
8881 : spin_factor, temp_real
8882 : REAL(KIND=dp), DIMENSION(3) :: coef
8883 36 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: m_temp_no
8884 :
8885 36 : step_size_out = 0.0_dp
8886 :
8887 36 : nspins = SIZE(position_in)
8888 36 : IF (nspins == 1) THEN
8889 : spin_factor = 2.0_dp
8890 : ELSE
8891 0 : spin_factor = 1.0_dp
8892 : END IF
8893 :
8894 108 : ALLOCATE (nocc(nspins))
8895 144 : ALLOCATE (m_temp_no(nspins))
8896 :
8897 36 : coef(:) = 0.0_dp
8898 72 : DO ispin = 1, nspins
8899 :
8900 : CALL dbcsr_create(m_temp_no(ispin), &
8901 36 : template=direction_in(ispin))
8902 :
8903 : CALL dbcsr_get_info(direction_in(ispin), &
8904 36 : nfullcols_total=nocc(ispin))
8905 :
8906 36 : CALL dbcsr_copy(m_temp_no(ispin), quench_t_in(ispin))
8907 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
8908 : metric_in(1), &
8909 : position_in(ispin), &
8910 : 0.0_dp, m_temp_no(ispin), &
8911 36 : retain_sparsity=.TRUE.)
8912 36 : CALL dbcsr_filter(m_temp_no(ispin), eps_filter_in)
8913 36 : CALL dbcsr_dot(position_in(ispin), m_temp_no(ispin), temp_real)
8914 36 : coef(3) = coef(3) + temp_real/nocc(ispin)
8915 36 : CALL dbcsr_dot(direction_in(ispin), m_temp_no(ispin), temp_real)
8916 36 : coef(2) = coef(2) + 2.0_dp*temp_real/nocc(ispin)
8917 36 : CALL dbcsr_copy(m_temp_no(ispin), quench_t_in(ispin))
8918 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
8919 : metric_in(1), &
8920 : direction_in(ispin), &
8921 : 0.0_dp, m_temp_no(ispin), &
8922 36 : retain_sparsity=.TRUE.)
8923 36 : CALL dbcsr_filter(m_temp_no(ispin), eps_filter_in)
8924 36 : CALL dbcsr_dot(direction_in(ispin), m_temp_no(ispin), temp_real)
8925 36 : coef(1) = coef(1) + temp_real/nocc(ispin)
8926 :
8927 108 : CALL dbcsr_release(m_temp_no(ispin))
8928 :
8929 : END DO !ispin
8930 :
8931 36 : DEALLOCATE (nocc)
8932 36 : DEALLOCATE (m_temp_no)
8933 :
8934 144 : coef(:) = coef(:)*spin_factor
8935 36 : coef(3) = coef(3) - trust_radius_in*trust_radius_in
8936 :
8937 : ! solve the quadratic equation
8938 36 : discriminant = coef(2)*coef(2) - 4.0_dp*coef(1)*coef(3)
8939 36 : IF (discriminant > TINY(discriminant)) THEN
8940 : nsolutions = 2
8941 0 : ELSE IF (discriminant < 0.0_dp) THEN
8942 0 : nsolutions = 0
8943 0 : CPABORT("Step to border: no solutions")
8944 : ELSE
8945 : nsolutions = 1
8946 : END IF
8947 :
8948 36 : discrim_sign = 1.0_dp
8949 36 : nsolutions_found = 0
8950 108 : DO isol = 1, nsolutions
8951 72 : solution = (-coef(2) + discrim_sign*SQRT(discriminant))/(2.0_dp*coef(1))
8952 72 : IF (solution > 0.0_dp) THEN
8953 36 : nsolutions_found = nsolutions_found + 1
8954 36 : step_size_out = solution
8955 : END IF
8956 108 : discrim_sign = -discrim_sign
8957 : END DO
8958 :
8959 36 : IF (nsolutions_found == 0) THEN
8960 0 : CPABORT("Step to border: no positive solutions")
8961 36 : ELSE IF (nsolutions_found == 2) THEN
8962 0 : CPABORT("Two positive border steps possible!")
8963 : END IF
8964 :
8965 36 : END SUBROUTINE step_size_to_border
8966 :
8967 : ! **************************************************************************************************
8968 : !> \brief Computes a norm of a contravariant NBasis x Occ matrix using proper metric
8969 : !> \param norm_out ...
8970 : !> \param matrix_in ...
8971 : !> \param metric_in ...
8972 : !> \param quench_t_in ...
8973 : !> \param eps_filter_in ...
8974 : !> \par History
8975 : !> 2019.12 created [Rustam Z Khaliullin]
8976 : !> \author Rustam Z Khaliullin
8977 : ! **************************************************************************************************
8978 758 : SUBROUTINE contravariant_matrix_norm(norm_out, matrix_in, metric_in, &
8979 758 : quench_t_in, eps_filter_in)
8980 :
8981 : REAL(KIND=dp), INTENT(OUT) :: norm_out
8982 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: matrix_in, metric_in, quench_t_in
8983 : REAL(KIND=dp), INTENT(IN) :: eps_filter_in
8984 :
8985 : INTEGER :: ispin, nspins
8986 758 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nocc
8987 : REAL(KIND=dp) :: my_norm, spin_factor, temp_real
8988 758 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: m_temp_no
8989 :
8990 : ! Frist thing: assign the output value to avoid norms being undefined
8991 758 : norm_out = 0.0_dp
8992 :
8993 758 : nspins = SIZE(matrix_in)
8994 758 : IF (nspins == 1) THEN
8995 : spin_factor = 2.0_dp
8996 : ELSE
8997 0 : spin_factor = 1.0_dp
8998 : END IF
8999 :
9000 2274 : ALLOCATE (nocc(nspins))
9001 3032 : ALLOCATE (m_temp_no(nspins))
9002 :
9003 758 : my_norm = 0.0_dp
9004 1516 : DO ispin = 1, nspins
9005 :
9006 758 : CALL dbcsr_create(m_temp_no(ispin), template=matrix_in(ispin))
9007 :
9008 : CALL dbcsr_get_info(matrix_in(ispin), &
9009 758 : nfullcols_total=nocc(ispin))
9010 :
9011 758 : CALL dbcsr_copy(m_temp_no(ispin), quench_t_in(ispin))
9012 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
9013 : metric_in(1), &
9014 : matrix_in(ispin), &
9015 : 0.0_dp, m_temp_no(ispin), &
9016 758 : retain_sparsity=.TRUE.)
9017 758 : CALL dbcsr_filter(m_temp_no(ispin), eps_filter_in)
9018 758 : CALL dbcsr_dot(matrix_in(ispin), m_temp_no(ispin), temp_real)
9019 :
9020 758 : my_norm = my_norm + temp_real/nocc(ispin)
9021 :
9022 1516 : CALL dbcsr_release(m_temp_no(ispin))
9023 :
9024 : END DO !ispin
9025 :
9026 758 : DEALLOCATE (nocc)
9027 758 : DEALLOCATE (m_temp_no)
9028 :
9029 758 : my_norm = my_norm*spin_factor
9030 758 : norm_out = SQRT(my_norm)
9031 :
9032 758 : END SUBROUTINE contravariant_matrix_norm
9033 :
9034 : ! **************************************************************************************************
9035 : !> \brief Loss reduction for a given step is estimated using
9036 : !> gradient and hessian
9037 : !> \param reduction_out ...
9038 : !> \param grad_in ...
9039 : !> \param step_in ...
9040 : !> \param hess_in ...
9041 : !> \param hess_submatrix_in ...
9042 : !> \param quench_t_in ...
9043 : !> \param special_case ...
9044 : !> \param eps_filter ...
9045 : !> \param domain_map ...
9046 : !> \param cpu_of_domain ...
9047 : !> \par History
9048 : !> 2019.12 created [Rustam Z Khaliullin]
9049 : !> \author Rustam Z Khaliullin
9050 : ! **************************************************************************************************
9051 408 : SUBROUTINE predicted_reduction(reduction_out, grad_in, step_in, hess_in, &
9052 408 : hess_submatrix_in, quench_t_in, special_case, eps_filter, domain_map, &
9053 408 : cpu_of_domain)
9054 :
9055 : !RZK-noncritical: can be formulated without submatrices
9056 : REAL(KIND=dp), INTENT(INOUT) :: reduction_out
9057 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: grad_in, step_in, hess_in
9058 : TYPE(domain_submatrix_type), DIMENSION(:, :), &
9059 : INTENT(IN) :: hess_submatrix_in
9060 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: quench_t_in
9061 : INTEGER, INTENT(IN) :: special_case
9062 : REAL(KIND=dp), INTENT(IN) :: eps_filter
9063 : TYPE(domain_map_type), DIMENSION(:), INTENT(IN) :: domain_map
9064 : INTEGER, DIMENSION(:), INTENT(IN) :: cpu_of_domain
9065 :
9066 : INTEGER :: ispin, nspins
9067 : REAL(KIND=dp) :: my_reduction, spin_factor, temp_real
9068 408 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: m_temp_no
9069 :
9070 408 : reduction_out = 0.0_dp
9071 :
9072 408 : nspins = SIZE(grad_in)
9073 408 : IF (nspins == 1) THEN
9074 : spin_factor = 2.0_dp
9075 : ELSE
9076 0 : spin_factor = 1.0_dp
9077 : END IF
9078 :
9079 1632 : ALLOCATE (m_temp_no(nspins))
9080 :
9081 408 : my_reduction = 0.0_dp
9082 816 : DO ispin = 1, nspins
9083 :
9084 408 : CALL dbcsr_create(m_temp_no(ispin), template=grad_in(ispin))
9085 :
9086 408 : CALL dbcsr_dot(step_in(ispin), grad_in(ispin), temp_real)
9087 408 : my_reduction = my_reduction + temp_real
9088 :
9089 : ! Get Hess.step
9090 408 : IF (special_case == xalmo_case_block_diag .OR. &
9091 : special_case == xalmo_case_fully_deloc) THEN
9092 :
9093 : CALL dbcsr_multiply("N", "N", 1.0_dp, &
9094 : hess_in(ispin), &
9095 : step_in(ispin), &
9096 : 0.0_dp, m_temp_no(ispin), &
9097 92 : filter_eps=eps_filter)
9098 :
9099 : ELSE
9100 :
9101 : CALL apply_domain_operators( &
9102 : matrix_in=step_in(ispin), &
9103 : matrix_out=m_temp_no(ispin), &
9104 : operator1=hess_submatrix_in(:, ispin), &
9105 : dpattern=quench_t_in(ispin), &
9106 : map=domain_map(ispin), &
9107 : node_of_domain=cpu_of_domain, &
9108 : my_action=0, &
9109 316 : filter_eps=eps_filter)
9110 :
9111 : END IF ! special case
9112 :
9113 : ! Get y=step^T.Hess.step
9114 408 : CALL dbcsr_dot(step_in(ispin), m_temp_no(ispin), temp_real)
9115 408 : my_reduction = my_reduction + 0.5_dp*temp_real
9116 :
9117 1224 : CALL dbcsr_release(m_temp_no(ispin))
9118 :
9119 : END DO ! ispin
9120 :
9121 : !RZK-critical: do we need to multiply by the spin factor?
9122 408 : my_reduction = spin_factor*my_reduction
9123 :
9124 408 : reduction_out = my_reduction
9125 :
9126 408 : DEALLOCATE (m_temp_no)
9127 :
9128 408 : END SUBROUTINE predicted_reduction
9129 :
9130 : ! **************************************************************************************************
9131 : !> \brief Prints key quantities from the fixed-radius minimizer
9132 : !> \param unit_nr ...
9133 : !> \param iter_type ...
9134 : !> \param iteration ...
9135 : !> \param step_size ...
9136 : !> \param border_reached ...
9137 : !> \param curvature ...
9138 : !> \param grad_norm_ratio ...
9139 : !> \param predicted_reduction ...
9140 : !> \param time ...
9141 : !> \par History
9142 : !> 2019.12 created [Rustam Z Khaliullin]
9143 : !> \author Rustam Z Khaliullin
9144 : ! **************************************************************************************************
9145 898 : SUBROUTINE fixed_r_report(unit_nr, iter_type, iteration, step_size, &
9146 : border_reached, curvature, grad_norm_ratio, predicted_reduction, time)
9147 :
9148 : INTEGER, INTENT(IN) :: unit_nr, iter_type, iteration
9149 : REAL(KIND=dp), INTENT(IN) :: step_size
9150 : LOGICAL, INTENT(IN) :: border_reached
9151 : REAL(KIND=dp), INTENT(IN) :: curvature
9152 : REAL(KIND=dp), INTENT(IN), OPTIONAL :: grad_norm_ratio, predicted_reduction
9153 : REAL(KIND=dp), INTENT(IN) :: time
9154 :
9155 : CHARACTER(LEN=20) :: iter_type_str
9156 : REAL(KIND=dp) :: loss_or_grad_change
9157 :
9158 898 : loss_or_grad_change = 0.0_dp
9159 898 : IF (PRESENT(grad_norm_ratio)) THEN
9160 898 : loss_or_grad_change = grad_norm_ratio
9161 0 : ELSE IF (PRESENT(predicted_reduction)) THEN
9162 0 : loss_or_grad_change = predicted_reduction
9163 : ELSE
9164 0 : CPABORT("one argument is missing")
9165 : END IF
9166 :
9167 1306 : SELECT CASE (iter_type)
9168 : CASE (0)
9169 408 : iter_type_str = TRIM("Ignored")
9170 : CASE (1)
9171 82 : iter_type_str = TRIM("PCG")
9172 : CASE (2)
9173 0 : iter_type_str = TRIM("Neg. curvatr.")
9174 : CASE (3)
9175 34 : iter_type_str = TRIM("Step too long")
9176 : CASE (4)
9177 26 : iter_type_str = TRIM("Grad. reduced")
9178 : CASE (5)
9179 80 : iter_type_str = TRIM("Cauchy point")
9180 : CASE (6)
9181 266 : iter_type_str = TRIM("Full dogleg")
9182 : CASE (7)
9183 2 : iter_type_str = TRIM("Part. dogleg")
9184 : CASE DEFAULT
9185 898 : CPABORT("unknown report type")
9186 : END SELECT
9187 :
9188 898 : IF (unit_nr > 0) THEN
9189 :
9190 204 : SELECT CASE (iter_type)
9191 : CASE (0)
9192 :
9193 204 : WRITE (unit_nr, *)
9194 : WRITE (unit_nr, '(T4,A15,A6,A10,A10,A7,A20,A8)') &
9195 204 : "Action", &
9196 204 : "Iter", &
9197 204 : "Curv", &
9198 204 : "Step", &
9199 204 : "Edge?", &
9200 204 : "Grad/o.f. reduc", &
9201 408 : "Time"
9202 :
9203 : CASE DEFAULT
9204 :
9205 : WRITE (unit_nr, '(T4,A15,I6,F10.5,F10.5,L7,F20.10,F8.2)') &
9206 245 : iter_type_str, &
9207 245 : iteration, &
9208 245 : curvature, step_size, border_reached, &
9209 245 : loss_or_grad_change, &
9210 694 : time
9211 :
9212 : END SELECT
9213 :
9214 : ! epilogue
9215 204 : SELECT CASE (iter_type)
9216 : CASE (2, 3, 4, 5, 6, 7)
9217 :
9218 449 : WRITE (unit_nr, *)
9219 :
9220 : END SELECT
9221 :
9222 : END IF
9223 :
9224 898 : END SUBROUTINE fixed_r_report
9225 :
9226 : ! **************************************************************************************************
9227 : !> \brief Prints key quantities from the loop that tunes trust radius
9228 : !> \param unit_nr ...
9229 : !> \param iter_type ...
9230 : !> \param iteration ...
9231 : !> \param radius ...
9232 : !> \param loss ...
9233 : !> \param delta_loss ...
9234 : !> \param grad_norm ...
9235 : !> \param predicted_reduction ...
9236 : !> \param rho ...
9237 : !> \param new ...
9238 : !> \param time ...
9239 : !> \par History
9240 : !> 2019.12 created [Rustam Z Khaliullin]
9241 : !> \author Rustam Z Khaliullin
9242 : ! **************************************************************************************************
9243 843 : SUBROUTINE trust_r_report(unit_nr, iter_type, iteration, radius, &
9244 : loss, delta_loss, grad_norm, predicted_reduction, rho, new, time)
9245 :
9246 : INTEGER, INTENT(IN) :: unit_nr, iter_type, iteration
9247 : REAL(KIND=dp), INTENT(IN) :: radius, loss, delta_loss, grad_norm, &
9248 : predicted_reduction, rho
9249 : LOGICAL, INTENT(IN) :: new
9250 : REAL(KIND=dp), INTENT(IN) :: time
9251 :
9252 : CHARACTER(LEN=20) :: iter_status, iter_type_str
9253 :
9254 852 : SELECT CASE (iter_type)
9255 : CASE (0) ! header
9256 9 : iter_type_str = TRIM("Iter")
9257 9 : iter_status = TRIM("Stat")
9258 : CASE (1) ! first iteration, not all data is available yet
9259 426 : iter_type_str = TRIM("TR INI")
9260 426 : IF (new) THEN
9261 426 : iter_status = " New" ! new point
9262 : ELSE
9263 0 : iter_status = " Redo" ! restarted
9264 : END IF
9265 : CASE (2) ! typical
9266 408 : iter_type_str = TRIM("TR FIN")
9267 408 : IF (new) THEN
9268 408 : iter_status = " Acc" ! accepted
9269 : ELSE
9270 0 : iter_status = " Rej" ! rejected
9271 : END IF
9272 : CASE DEFAULT
9273 843 : CPABORT("unknown report type")
9274 : END SELECT
9275 :
9276 843 : IF (unit_nr > 0) THEN
9277 :
9278 9 : SELECT CASE (iter_type)
9279 : CASE (0)
9280 :
9281 : WRITE (unit_nr, '(T2,A6,A5,A6,A22,A10,T67,A7,A6)') &
9282 9 : "Method", &
9283 9 : "Stat", &
9284 9 : "Iter", &
9285 9 : "Objective Function", &
9286 9 : "Conver", &!"Model Change", "Rho", &
9287 9 : "Radius", &
9288 18 : "Time"
9289 : WRITE (unit_nr, '(T41,A10,A10,A6)') &
9290 : !"Method", &
9291 : !"Iter", &
9292 : !"Objective Function", &
9293 9 : "Change", "Expct.", "Rho"
9294 : !"Radius", &
9295 : !"Time"
9296 :
9297 : CASE (1)
9298 :
9299 : WRITE (unit_nr, '(T2,A6,A5,I6,F22.10,ES10.2,T67,ES7.0,F6.1)') &
9300 213 : iter_type_str, &
9301 213 : iter_status, &
9302 213 : iteration, &
9303 213 : loss, &
9304 213 : grad_norm, & ! distinct
9305 213 : radius, &
9306 426 : time
9307 :
9308 : CASE (2)
9309 :
9310 : WRITE (unit_nr, '(T2,A6,A5,I6,F22.10,ES10.2,ES10.2,F6.1,ES7.0,F6.1)') &
9311 204 : iter_type_str, &
9312 204 : iter_status, &
9313 204 : iteration, &
9314 204 : loss, &
9315 204 : delta_loss, predicted_reduction, rho, & ! distinct
9316 204 : radius, &
9317 630 : time
9318 :
9319 : END SELECT
9320 : END IF
9321 :
9322 843 : END SUBROUTINE trust_r_report
9323 :
9324 : ! **************************************************************************************************
9325 : !> \brief ...
9326 : !> \param unit_nr ...
9327 : !> \param ref_energy ...
9328 : !> \param energy_lowering ...
9329 : ! **************************************************************************************************
9330 26 : SUBROUTINE energy_lowering_report(unit_nr, ref_energy, energy_lowering)
9331 :
9332 : INTEGER, INTENT(IN) :: unit_nr
9333 : REAL(KIND=dp), INTENT(IN) :: ref_energy, energy_lowering
9334 :
9335 : ! print out the energy lowering
9336 26 : IF (unit_nr > 0) THEN
9337 13 : WRITE (unit_nr, *)
9338 13 : WRITE (unit_nr, '(T2,A35,F25.10)') "ENERGY OF BLOCK-DIAGONAL ALMOs:", &
9339 26 : ref_energy
9340 13 : WRITE (unit_nr, '(T2,A35,F25.10)') "ENERGY LOWERING:", &
9341 26 : energy_lowering
9342 13 : WRITE (unit_nr, '(T2,A35,F25.10)') "CORRECTED ENERGY:", &
9343 26 : ref_energy + energy_lowering
9344 13 : WRITE (unit_nr, *)
9345 : END IF
9346 :
9347 26 : END SUBROUTINE energy_lowering_report
9348 :
9349 : ! post SCF-loop calculations
9350 : ! **************************************************************************************************
9351 : !> \brief ...
9352 : !> \param qs_env ...
9353 : !> \param almo_scf_env ...
9354 : !> \param perturbation_in ...
9355 : !> \param m_xalmo_in ...
9356 : !> \param m_quench_in ...
9357 : !> \param energy_inout ...
9358 : ! **************************************************************************************************
9359 110 : SUBROUTINE wrap_up_xalmo_scf(qs_env, almo_scf_env, perturbation_in, &
9360 110 : m_xalmo_in, m_quench_in, energy_inout)
9361 :
9362 : TYPE(qs_environment_type), POINTER :: qs_env
9363 : TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env
9364 : LOGICAL, INTENT(IN) :: perturbation_in
9365 : TYPE(dbcsr_type), DIMENSION(:), INTENT(IN) :: m_xalmo_in, m_quench_in
9366 : REAL(KIND=dp), INTENT(INOUT) :: energy_inout
9367 :
9368 : CHARACTER(len=*), PARAMETER :: routineN = 'wrap_up_xalmo_scf'
9369 :
9370 : INTEGER :: eda_unit, handle, ispin, nspins, unit_nr
9371 : TYPE(cp_logger_type), POINTER :: logger
9372 110 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: m_temp_no1, m_temp_no2
9373 : TYPE(section_vals_type), POINTER :: almo_print_section, input
9374 :
9375 110 : CALL timeset(routineN, handle)
9376 :
9377 : ! get a useful output_unit
9378 110 : logger => cp_get_default_logger()
9379 110 : IF (logger%para_env%is_source()) THEN
9380 55 : unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
9381 : ELSE
9382 55 : unit_nr = -1
9383 : END IF
9384 :
9385 110 : nspins = almo_scf_env%nspins
9386 :
9387 : ! RZK-warning: must obtain MO coefficients from final theta
9388 :
9389 110 : IF (perturbation_in) THEN
9390 :
9391 96 : ALLOCATE (m_temp_no1(nspins))
9392 72 : ALLOCATE (m_temp_no2(nspins))
9393 :
9394 48 : DO ispin = 1, nspins
9395 24 : CALL dbcsr_create(m_temp_no1(ispin), template=m_xalmo_in(ispin))
9396 48 : CALL dbcsr_create(m_temp_no2(ispin), template=m_xalmo_in(ispin))
9397 : END DO
9398 :
9399 : ! return perturbed density to qs_env
9400 : CALL almo_dm_to_qs_env(qs_env, almo_scf_env%matrix_p, &
9401 24 : almo_scf_env%mat_distr_aos)
9402 :
9403 : ! compute energy correction and perform
9404 : ! detailed decomposition analysis (if requested)
9405 : ! reuse step and grad matrices to store decomposition results
9406 : CALL xalmo_analysis( &
9407 : detailed_analysis=almo_scf_env%almo_analysis%do_analysis, &
9408 : eps_filter=almo_scf_env%eps_filter, &
9409 : m_T_in=m_xalmo_in, &
9410 : m_T0_in=almo_scf_env%matrix_t_blk, &
9411 : m_siginv_in=almo_scf_env%matrix_sigma_inv, &
9412 : m_siginv0_in=almo_scf_env%matrix_sigma_inv_0deloc, &
9413 : m_S_in=almo_scf_env%matrix_s, &
9414 : m_KS0_in=almo_scf_env%matrix_ks_0deloc, &
9415 : m_quench_t_in=m_quench_in, &
9416 : energy_out=energy_inout, & ! get energy loewring
9417 : m_eda_out=m_temp_no1, &
9418 : m_cta_out=m_temp_no2 &
9419 24 : )
9420 :
9421 24 : IF (almo_scf_env%almo_analysis%do_analysis) THEN
9422 :
9423 4 : DO ispin = 1, nspins
9424 :
9425 : ! energy decomposition analysis (EDA)
9426 2 : IF (unit_nr > 0) THEN
9427 1 : WRITE (unit_nr, '(T2,A)') "DECOMPOSITION OF THE DELOCALIZATION ENERGY"
9428 : END IF
9429 :
9430 : ! open the output file, print and close
9431 2 : CALL get_qs_env(qs_env, input=input)
9432 2 : almo_print_section => section_vals_get_subs_vals(input, "DFT%ALMO_SCF%ANALYSIS%PRINT")
9433 : eda_unit = cp_print_key_unit_nr(logger, almo_print_section, &
9434 2 : "ALMO_EDA_CT", extension=".dat", local=.TRUE.)
9435 2 : CALL print_block_sum(m_temp_no1(ispin), eda_unit)
9436 : CALL cp_print_key_finished_output(eda_unit, logger, almo_print_section, &
9437 2 : "ALMO_EDA_CT", local=.TRUE.)
9438 :
9439 : ! charge transfer analysis (CTA)
9440 2 : IF (unit_nr > 0) THEN
9441 1 : WRITE (unit_nr, '(T2,A)') "DECOMPOSITION OF CHARGE TRANSFER TERMS"
9442 : END IF
9443 :
9444 : eda_unit = cp_print_key_unit_nr(logger, almo_print_section, &
9445 2 : "ALMO_CTA", extension=".dat", local=.TRUE.)
9446 2 : CALL print_block_sum(m_temp_no2(ispin), eda_unit)
9447 : CALL cp_print_key_finished_output(eda_unit, logger, almo_print_section, &
9448 4 : "ALMO_CTA", local=.TRUE.)
9449 :
9450 : END DO ! ispin
9451 :
9452 : END IF ! do ALMO EDA/CTA
9453 :
9454 : CALL energy_lowering_report( &
9455 : unit_nr=unit_nr, &
9456 : ref_energy=almo_scf_env%almo_scf_energy, &
9457 24 : energy_lowering=energy_inout)
9458 : CALL almo_scf_update_ks_energy(qs_env, &
9459 : energy=almo_scf_env%almo_scf_energy, &
9460 24 : energy_singles_corr=energy_inout)
9461 :
9462 48 : DO ispin = 1, nspins
9463 24 : CALL dbcsr_release(m_temp_no1(ispin))
9464 48 : CALL dbcsr_release(m_temp_no2(ispin))
9465 : END DO
9466 :
9467 24 : DEALLOCATE (m_temp_no1)
9468 24 : DEALLOCATE (m_temp_no2)
9469 :
9470 : ELSE ! non-perturbative
9471 :
9472 : CALL almo_scf_update_ks_energy(qs_env, &
9473 86 : energy=energy_inout)
9474 :
9475 : END IF ! if perturbation only
9476 :
9477 110 : CALL timestop(handle)
9478 :
9479 110 : END SUBROUTINE wrap_up_xalmo_scf
9480 :
9481 : ! **************************************************************************************************
9482 : !> \brief Computes tanh(alpha*x) of the matrix elements. Fails if |alpha*x| >= 1.
9483 : !> \param matrix ...
9484 : !> \param alpha ...
9485 : !> \author Ole Schuett
9486 : ! **************************************************************************************************
9487 0 : SUBROUTINE tanh_of_elements(matrix, alpha)
9488 : TYPE(dbcsr_type), INTENT(INOUT) :: matrix
9489 : REAL(kind=dp), INTENT(IN) :: alpha
9490 :
9491 : CHARACTER(len=*), PARAMETER :: routineN = 'tanh_of_elements'
9492 :
9493 : INTEGER :: handle
9494 0 : REAL(kind=dp), DIMENSION(:, :), POINTER :: block
9495 : TYPE(dbcsr_iterator_type) :: iter
9496 :
9497 0 : CALL timeset(routineN, handle)
9498 0 : CALL dbcsr_iterator_start(iter, matrix)
9499 0 : DO WHILE (dbcsr_iterator_blocks_left(iter))
9500 0 : CALL dbcsr_iterator_next_block(iter, block=block)
9501 0 : block = TANH(alpha*block)
9502 : END DO
9503 0 : CALL dbcsr_iterator_stop(iter)
9504 0 : CALL timestop(handle)
9505 :
9506 0 : END SUBROUTINE tanh_of_elements
9507 :
9508 : ! **************************************************************************************************
9509 : !> \brief Computes d(tanh(alpha*x)) / dx of the matrix elements. Fails if |alpha*x| >= 1.
9510 : !> \param matrix ...
9511 : !> \param alpha ...
9512 : !> \author Ole Schuett
9513 : ! **************************************************************************************************
9514 0 : SUBROUTINE dtanh_of_elements(matrix, alpha)
9515 : TYPE(dbcsr_type), INTENT(INOUT) :: matrix
9516 : REAL(kind=dp), INTENT(IN) :: alpha
9517 :
9518 : CHARACTER(len=*), PARAMETER :: routineN = 'dtanh_of_elements'
9519 :
9520 : INTEGER :: handle
9521 0 : REAL(kind=dp), DIMENSION(:, :), POINTER :: block
9522 : TYPE(dbcsr_iterator_type) :: iter
9523 :
9524 0 : CALL timeset(routineN, handle)
9525 0 : CALL dbcsr_iterator_start(iter, matrix)
9526 0 : DO WHILE (dbcsr_iterator_blocks_left(iter))
9527 0 : CALL dbcsr_iterator_next_block(iter, block=block)
9528 0 : block = alpha*(1.0_dp - TANH(block)**2)
9529 : END DO
9530 0 : CALL dbcsr_iterator_stop(iter)
9531 0 : CALL timestop(handle)
9532 :
9533 0 : END SUBROUTINE dtanh_of_elements
9534 :
9535 : ! **************************************************************************************************
9536 : !> \brief Computes 1/x of the matrix elements.
9537 : !> \param matrix ...
9538 : !> \author Ole Schuett
9539 : ! **************************************************************************************************
9540 0 : SUBROUTINE inverse_of_elements(matrix)
9541 : TYPE(dbcsr_type), INTENT(INOUT) :: matrix
9542 :
9543 : CHARACTER(len=*), PARAMETER :: routineN = 'inverse_of_elements'
9544 :
9545 : INTEGER :: handle
9546 0 : REAL(kind=dp), DIMENSION(:, :), POINTER :: block
9547 : TYPE(dbcsr_iterator_type) :: iter
9548 :
9549 0 : CALL timeset(routineN, handle)
9550 0 : CALL dbcsr_iterator_start(iter, matrix)
9551 0 : DO WHILE (dbcsr_iterator_blocks_left(iter))
9552 0 : CALL dbcsr_iterator_next_block(iter, block=block)
9553 0 : block = 1.0_dp/block
9554 : END DO
9555 0 : CALL dbcsr_iterator_stop(iter)
9556 0 : CALL timestop(handle)
9557 :
9558 0 : END SUBROUTINE inverse_of_elements
9559 :
9560 : ! **************************************************************************************************
9561 : !> \brief Prints the sum of the elements for each block.
9562 : !> \param matrix ...
9563 : !> \param unit_nr ...
9564 : ! **************************************************************************************************
9565 4 : SUBROUTINE print_block_sum(matrix, unit_nr)
9566 : TYPE(dbcsr_type), INTENT(IN) :: matrix
9567 : INTEGER, INTENT(IN) :: unit_nr
9568 :
9569 : CHARACTER(len=*), PARAMETER :: routineN = 'print_block_sum'
9570 :
9571 : INTEGER :: col, handle, row
9572 4 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: block
9573 : TYPE(dbcsr_iterator_type) :: iter
9574 :
9575 4 : CALL timeset(routineN, handle)
9576 :
9577 4 : IF (unit_nr > 0) THEN
9578 4 : CALL dbcsr_iterator_readonly_start(iter, matrix)
9579 34 : DO WHILE (dbcsr_iterator_blocks_left(iter))
9580 30 : CALL dbcsr_iterator_next_block(iter, row, col, block)
9581 2914 : WRITE (unit_nr, '(I6,I6,ES18.9)') row, col, SUM(block)
9582 : END DO
9583 4 : CALL dbcsr_iterator_stop(iter)
9584 : END IF
9585 :
9586 4 : CALL timestop(handle)
9587 4 : END SUBROUTINE print_block_sum
9588 :
9589 : END MODULE almo_scf_optimizer
9590 :
|
