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