(git:b279b6b)
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 ! **************************************************************************************************
15 MODULE almo_scf_optimizer
16  USE almo_scf_diis_types, ONLY: almo_scf_diis_extrapolate,&
17  almo_scf_diis_init,&
18  almo_scf_diis_push,&
19  almo_scf_diis_release,&
20  almo_scf_diis_type
21  USE almo_scf_lbfgs_types, ONLY: lbfgs_create,&
22  lbfgs_get_direction,&
23  lbfgs_history_type,&
24  lbfgs_release,&
25  lbfgs_seed
26  USE almo_scf_methods, ONLY: &
27  almo_scf_ks_blk_to_tv_blk, almo_scf_ks_to_ks_blk, almo_scf_ks_to_ks_xx, &
28  almo_scf_ks_xx_to_tv_xx, almo_scf_p_blk_to_t_blk, almo_scf_t_rescaling, &
29  almo_scf_t_to_proj, apply_domain_operators, apply_projector, &
30  construct_domain_preconditioner, construct_domain_r_down, construct_domain_s_inv, &
31  construct_domain_s_sqrt, fill_matrix_with_ones, get_overlap, orthogonalize_mos, &
32  pseudo_invert_diagonal_blk, xalmo_initial_guess
33  USE almo_scf_qs, ONLY: almo_dm_to_almo_ks,&
34  almo_dm_to_qs_env,&
35  almo_scf_update_ks_energy,&
36  matrix_qs_to_almo
37  USE almo_scf_types, ONLY: almo_scf_env_type,&
38  optimizer_options_type
39  USE cell_types, ONLY: cell_type
40  USE cp_blacs_env, ONLY: cp_blacs_env_type
41  USE cp_dbcsr_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 
125 CONTAINS
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 
11073 END MODULE almo_scf_optimizer
11074 
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::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_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_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_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_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_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 w...
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