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