Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief localize wavefunctions
10 : !> linear response scf
11 : !> \par History
12 : !> created 07-2005 [MI]
13 : !> \author MI
14 : ! **************************************************************************************************
15 : MODULE qs_linres_methods
16 : USE cp_control_types, ONLY: dft_control_type
17 : USE cp_dbcsr_operations, ONLY: cp_dbcsr_sm_fm_multiply
18 : USE cp_external_control, ONLY: external_control
19 : USE cp_files, ONLY: close_file,&
20 : open_file
21 : USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add,&
22 : cp_fm_trace
23 : USE cp_fm_struct, ONLY: cp_fm_struct_create,&
24 : cp_fm_struct_release,&
25 : cp_fm_struct_type
26 : USE cp_fm_types, ONLY: cp_fm_create,&
27 : cp_fm_get_info,&
28 : cp_fm_get_submatrix,&
29 : cp_fm_release,&
30 : cp_fm_set_submatrix,&
31 : cp_fm_to_fm,&
32 : cp_fm_type
33 : USE cp_log_handling, ONLY: cp_get_default_logger,&
34 : cp_logger_type,&
35 : cp_to_string
36 : USE cp_output_handling, ONLY: cp_p_file,&
37 : cp_print_key_finished_output,&
38 : cp_print_key_generate_filename,&
39 : cp_print_key_should_output,&
40 : cp_print_key_unit_nr
41 : USE dbcsr_api, ONLY: dbcsr_checksum,&
42 : dbcsr_copy,&
43 : dbcsr_p_type,&
44 : dbcsr_set,&
45 : dbcsr_type
46 : USE input_constants, ONLY: do_loc_none,&
47 : op_loc_berry,&
48 : ot_precond_none,&
49 : ot_precond_solver_default,&
50 : state_loc_all
51 : USE input_section_types, ONLY: section_vals_get_subs_vals,&
52 : section_vals_type,&
53 : section_vals_val_get
54 : USE kinds, ONLY: default_path_length,&
55 : default_string_length,&
56 : dp
57 : USE machine, ONLY: m_flush,&
58 : m_walltime
59 : USE message_passing, ONLY: mp_para_env_type
60 : USE parallel_gemm_api, ONLY: parallel_gemm
61 : USE preconditioner, ONLY: apply_preconditioner,&
62 : make_preconditioner
63 : USE qs_2nd_kernel_ao, ONLY: build_dm_response
64 : USE qs_environment_types, ONLY: get_qs_env,&
65 : qs_environment_type
66 : USE qs_gapw_densities, ONLY: prepare_gapw_den
67 : USE qs_linres_kernel, ONLY: apply_op_2
68 : USE qs_linres_types, ONLY: linres_control_type
69 : USE qs_loc_main, ONLY: qs_loc_driver
70 : USE qs_loc_types, ONLY: get_qs_loc_env,&
71 : localized_wfn_control_type,&
72 : qs_loc_env_create,&
73 : qs_loc_env_type
74 : USE qs_loc_utils, ONLY: loc_write_restart,&
75 : qs_loc_control_init,&
76 : qs_loc_init
77 : USE qs_mo_types, ONLY: get_mo_set,&
78 : mo_set_type
79 : USE qs_p_env_methods, ONLY: p_env_check_i_alloc,&
80 : p_env_update_rho
81 : USE qs_p_env_types, ONLY: qs_p_env_type
82 : USE qs_rho_methods, ONLY: qs_rho_update_rho
83 : USE qs_rho_types, ONLY: qs_rho_type
84 : USE string_utilities, ONLY: xstring
85 : #include "./base/base_uses.f90"
86 :
87 : IMPLICIT NONE
88 :
89 : PRIVATE
90 :
91 : ! *** Public subroutines ***
92 : PUBLIC :: linres_localize, linres_solver
93 : PUBLIC :: linres_write_restart, linres_read_restart
94 : PUBLIC :: build_dm_response
95 :
96 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_linres_methods'
97 :
98 : ! **************************************************************************************************
99 :
100 : CONTAINS
101 :
102 : ! **************************************************************************************************
103 : !> \brief Find the centers and spreads of the wfn,
104 : !> if required apply a localization algorithm
105 : !> \param qs_env ...
106 : !> \param linres_control ...
107 : !> \param nspins ...
108 : !> \param centers_only ...
109 : !> \par History
110 : !> 07.2005 created [MI]
111 : !> \author MI
112 : ! **************************************************************************************************
113 190 : SUBROUTINE linres_localize(qs_env, linres_control, nspins, centers_only)
114 :
115 : TYPE(qs_environment_type), POINTER :: qs_env
116 : TYPE(linres_control_type), POINTER :: linres_control
117 : INTEGER, INTENT(IN) :: nspins
118 : LOGICAL, INTENT(IN), OPTIONAL :: centers_only
119 :
120 : INTEGER :: iounit, ispin, istate, nmoloc(2)
121 : LOGICAL :: my_centers_only
122 190 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: mos_localized
123 : TYPE(cp_fm_type), POINTER :: mo_coeff
124 : TYPE(cp_logger_type), POINTER :: logger
125 : TYPE(localized_wfn_control_type), POINTER :: localized_wfn_control
126 190 : TYPE(mo_set_type), DIMENSION(:), POINTER :: mos
127 : TYPE(qs_loc_env_type), POINTER :: qs_loc_env
128 : TYPE(section_vals_type), POINTER :: loc_print_section, loc_section, &
129 : lr_section
130 :
131 190 : NULLIFY (logger, lr_section, loc_section, loc_print_section, localized_wfn_control)
132 380 : logger => cp_get_default_logger()
133 190 : lr_section => section_vals_get_subs_vals(qs_env%input, "PROPERTIES%LINRES")
134 190 : loc_section => section_vals_get_subs_vals(lr_section, "LOCALIZE")
135 190 : loc_print_section => section_vals_get_subs_vals(lr_section, "LOCALIZE%PRINT")
136 : iounit = cp_print_key_unit_nr(logger, lr_section, "PRINT%PROGRAM_RUN_INFO", &
137 190 : extension=".linresLog")
138 190 : my_centers_only = .FALSE.
139 190 : IF (PRESENT(centers_only)) my_centers_only = centers_only
140 :
141 190 : NULLIFY (mos, mo_coeff, qs_loc_env)
142 190 : CALL get_qs_env(qs_env=qs_env, mos=mos)
143 190 : ALLOCATE (qs_loc_env)
144 190 : CALL qs_loc_env_create(qs_loc_env)
145 190 : linres_control%qs_loc_env => qs_loc_env
146 190 : CALL qs_loc_control_init(qs_loc_env, loc_section, do_homo=.TRUE.)
147 190 : CALL get_qs_loc_env(qs_loc_env, localized_wfn_control=localized_wfn_control)
148 :
149 838 : ALLOCATE (mos_localized(nspins))
150 458 : DO ispin = 1, nspins
151 268 : CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff)
152 268 : CALL cp_fm_create(mos_localized(ispin), mo_coeff%matrix_struct)
153 458 : CALL cp_fm_to_fm(mo_coeff, mos_localized(ispin))
154 : END DO
155 :
156 : nmoloc(1:2) = 0
157 190 : IF (my_centers_only) THEN
158 0 : localized_wfn_control%set_of_states = state_loc_all
159 0 : localized_wfn_control%localization_method = do_loc_none
160 0 : localized_wfn_control%operator_type = op_loc_berry
161 : END IF
162 :
163 : CALL qs_loc_init(qs_env, qs_loc_env, loc_section, mos_localized=mos_localized, &
164 190 : do_homo=.TRUE.)
165 :
166 : ! The orbital centers are stored in linres_control%localized_wfn_control
167 458 : DO ispin = 1, nspins
168 : CALL qs_loc_driver(qs_env, qs_loc_env, loc_print_section, myspin=ispin, &
169 268 : ext_mo_coeff=mos_localized(ispin))
170 268 : CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff)
171 458 : CALL cp_fm_to_fm(mos_localized(ispin), mo_coeff)
172 : END DO
173 :
174 : CALL loc_write_restart(qs_loc_env, loc_print_section, mos, &
175 190 : mos_localized, do_homo=.TRUE.)
176 190 : CALL cp_fm_release(mos_localized)
177 :
178 : ! Write Centers and Spreads on std out
179 190 : IF (iounit > 0) THEN
180 229 : DO ispin = 1, nspins
181 : WRITE (iounit, "(/,T2,A,I2)") &
182 134 : "WANNIER CENTERS for spin ", ispin
183 : WRITE (iounit, "(/,T18,A,3X,A)") &
184 134 : "--------------- Centers --------------- ", &
185 268 : "--- Spreads ---"
186 1102 : DO istate = 1, SIZE(localized_wfn_control%centers_set(ispin)%array, 2)
187 : WRITE (iounit, "(T5,A6,I6,2X,3f12.6,5X,f12.6)") &
188 3492 : 'state ', istate, localized_wfn_control%centers_set(ispin)%array(1:3, istate), &
189 1880 : localized_wfn_control%centers_set(ispin)%array(4, istate)
190 : END DO
191 : END DO
192 95 : CALL m_flush(iounit)
193 : END IF
194 :
195 380 : END SUBROUTINE linres_localize
196 :
197 : ! **************************************************************************************************
198 : !> \brief scf loop to optimize the first order wavefunctions (psi1)
199 : !> given a perturbation as an operator applied to the ground
200 : !> state orbitals (h1_psi0)
201 : !> psi1 is defined wrt psi0_order (can be a subset of the occupied space)
202 : !> The reference ground state is defined through qs_env (density and ground state MOs)
203 : !> psi1 is orthogonal to the occupied orbitals in the ground state MO set (qs_env%mos)
204 : !> \param p_env ...
205 : !> \param qs_env ...
206 : !> \param psi1 ...
207 : !> \param h1_psi0 ...
208 : !> \param psi0_order ...
209 : !> \param iounit ...
210 : !> \param should_stop ...
211 : !> \par History
212 : !> 07.2005 created [MI]
213 : !> \author MI
214 : ! **************************************************************************************************
215 4954 : SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, iounit, should_stop)
216 : TYPE(qs_p_env_type) :: p_env
217 : TYPE(qs_environment_type), POINTER :: qs_env
218 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: psi1, h1_psi0, psi0_order
219 : INTEGER, INTENT(IN) :: iounit
220 : LOGICAL, INTENT(OUT) :: should_stop
221 :
222 : CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_solver'
223 :
224 : INTEGER :: handle, ispin, iter, maxnmo, nao, ncol, &
225 : nmo, nocc, nspins
226 : LOGICAL :: restart
227 : REAL(dp) :: alpha, beta, norm_res, t1, t2
228 4954 : REAL(dp), DIMENSION(:), POINTER :: tr_pAp, tr_rz0, tr_rz00, tr_rz1
229 : TYPE(cp_fm_struct_type), POINTER :: tmp_fm_struct
230 : TYPE(cp_fm_type) :: buf
231 4954 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: Ap, chc, mo_coeff_array, p, r, z
232 4954 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: Sc
233 : TYPE(cp_fm_type), POINTER :: mo_coeff
234 4954 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_ks, matrix_s, matrix_t
235 : TYPE(dbcsr_type), POINTER :: matrix_x
236 : TYPE(dft_control_type), POINTER :: dft_control
237 : TYPE(linres_control_type), POINTER :: linres_control
238 4954 : TYPE(mo_set_type), DIMENSION(:), POINTER :: mos
239 : TYPE(mp_para_env_type), POINTER :: para_env
240 :
241 4954 : CALL timeset(routineN, handle)
242 :
243 4954 : NULLIFY (dft_control, linres_control, matrix_s, matrix_t, matrix_ks, para_env)
244 4954 : NULLIFY (mos, tmp_fm_struct, mo_coeff)
245 :
246 4954 : t1 = m_walltime()
247 :
248 : CALL get_qs_env(qs_env=qs_env, &
249 : matrix_ks=matrix_ks, &
250 : matrix_s=matrix_s, &
251 : kinetic=matrix_t, &
252 : dft_control=dft_control, &
253 : linres_control=linres_control, &
254 : para_env=para_env, &
255 4954 : mos=mos)
256 :
257 4954 : nspins = dft_control%nspins
258 4954 : CALL cp_fm_get_info(psi1(1), nrow_global=nao)
259 4954 : maxnmo = 0
260 11954 : DO ispin = 1, nspins
261 7000 : CALL cp_fm_get_info(psi1(ispin), ncol_global=ncol)
262 11954 : maxnmo = MAX(maxnmo, ncol)
263 : END DO
264 : !
265 4954 : CALL check_p_env_init(p_env, linres_control, nspins)
266 : !
267 : ! allocate the vectors
268 : ALLOCATE (tr_pAp(nspins), tr_rz0(nspins), tr_rz00(nspins), tr_rz1(nspins), &
269 112218 : r(nspins), p(nspins), z(nspins), Ap(nspins))
270 : !
271 11954 : DO ispin = 1, nspins
272 7000 : CALL cp_fm_create(r(ispin), psi1(ispin)%matrix_struct)
273 7000 : CALL cp_fm_create(p(ispin), psi1(ispin)%matrix_struct)
274 7000 : CALL cp_fm_create(z(ispin), psi1(ispin)%matrix_struct)
275 11954 : CALL cp_fm_create(Ap(ispin), psi1(ispin)%matrix_struct)
276 : END DO
277 : !
278 : ! build C0 occupied vectors and S*C0 matrix
279 38770 : ALLOCATE (Sc(nspins), mo_coeff_array(nspins))
280 11954 : DO ispin = 1, nspins
281 7000 : CALL get_mo_set(mos(ispin), mo_coeff=mo_coeff, homo=nocc)
282 7000 : NULLIFY (tmp_fm_struct)
283 : CALL cp_fm_struct_create(tmp_fm_struct, nrow_global=nao, &
284 : ncol_global=nocc, para_env=para_env, &
285 7000 : context=mo_coeff%matrix_struct%context)
286 7000 : CALL cp_fm_create(mo_coeff_array(ispin), tmp_fm_struct)
287 7000 : CALL cp_fm_to_fm(mo_coeff, mo_coeff_array(ispin), nocc)
288 7000 : CALL cp_fm_create(Sc(ispin), tmp_fm_struct)
289 18954 : CALL cp_fm_struct_release(tmp_fm_struct)
290 : END DO
291 : !
292 : ! Allocate C0_order'*H*C0_order
293 21862 : ALLOCATE (chc(nspins))
294 11954 : DO ispin = 1, nspins
295 7000 : CALL cp_fm_get_info(psi1(ispin), ncol_global=nmo)
296 7000 : NULLIFY (tmp_fm_struct)
297 : CALL cp_fm_struct_create(tmp_fm_struct, nrow_global=nmo, &
298 : ncol_global=nmo, para_env=para_env, &
299 7000 : context=mo_coeff%matrix_struct%context)
300 7000 : CALL cp_fm_create(chc(ispin), tmp_fm_struct)
301 18954 : CALL cp_fm_struct_release(tmp_fm_struct)
302 : END DO
303 : !
304 11954 : DO ispin = 1, nspins
305 : !
306 : ! C0_order' * H * C0_order
307 : ASSOCIATE (mo_coeff => psi0_order(ispin))
308 7000 : CALL cp_fm_create(buf, mo_coeff%matrix_struct)
309 7000 : CALL cp_fm_get_info(mo_coeff, ncol_global=ncol)
310 7000 : CALL cp_dbcsr_sm_fm_multiply(matrix_ks(ispin)%matrix, mo_coeff, buf, ncol)
311 7000 : CALL parallel_gemm('T', 'N', ncol, ncol, nao, -1.0_dp, mo_coeff, buf, 0.0_dp, chc(ispin))
312 14000 : CALL cp_fm_release(buf)
313 : END ASSOCIATE
314 : !
315 : ! S * C0
316 7000 : CALL cp_fm_get_info(mo_coeff_array(ispin), ncol_global=ncol)
317 18954 : CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, mo_coeff_array(ispin), Sc(ispin), ncol)
318 : END DO
319 : !
320 : ! header
321 4954 : IF (iounit > 0) THEN
322 : WRITE (iounit, "(/,T3,A,T16,A,T25,A,T38,A,T52,A,T72,A,/,T3,A)") &
323 2469 : "Iteration", "Method", "Restart", "Stepsize", "Convergence", "Time", &
324 4938 : REPEAT("-", 78)
325 : END IF
326 : !
327 : ! orthogonalize x with respect to the psi0
328 4954 : CALL preortho(psi1, mo_coeff_array, Sc)
329 : !
330 : ! build the preconditioner
331 4954 : IF (linres_control%preconditioner_type /= ot_precond_none) THEN
332 4954 : IF (p_env%new_preconditioner) THEN
333 2634 : DO ispin = 1, nspins
334 2634 : IF (ASSOCIATED(matrix_t)) THEN
335 : CALL make_preconditioner(p_env%preconditioner(ispin), &
336 : linres_control%preconditioner_type, ot_precond_solver_default, &
337 : matrix_ks(ispin)%matrix, matrix_s(1)%matrix, matrix_t(1)%matrix, &
338 1390 : mos(ispin), linres_control%energy_gap)
339 : ELSE
340 24 : NULLIFY (matrix_x)
341 : CALL make_preconditioner(p_env%preconditioner(ispin), &
342 : linres_control%preconditioner_type, ot_precond_solver_default, &
343 : matrix_ks(ispin)%matrix, matrix_s(1)%matrix, matrix_x, &
344 24 : mos(ispin), linres_control%energy_gap)
345 : END IF
346 : END DO
347 1220 : p_env%new_preconditioner = .FALSE.
348 : END IF
349 : END IF
350 : !
351 : ! initialization of the linear solver
352 : !
353 : ! A * x0
354 4954 : CALL apply_op(qs_env, p_env, psi0_order, psi1, Ap, chc)
355 : !
356 : !
357 : ! r_0 = b - Ax0
358 11954 : DO ispin = 1, nspins
359 7000 : CALL cp_fm_to_fm(h1_psi0(ispin), r(ispin))
360 11954 : CALL cp_fm_scale_and_add(-1.0_dp, r(ispin), -1.0_dp, Ap(ispin))
361 : END DO
362 : !
363 : ! proj r
364 4954 : CALL postortho(r, mo_coeff_array, Sc)
365 : !
366 : ! preconditioner
367 4954 : linres_control%flag = ""
368 4954 : IF (linres_control%preconditioner_type .EQ. ot_precond_none) THEN
369 : !
370 : ! z_0 = r_0
371 0 : DO ispin = 1, nspins
372 0 : CALL cp_fm_to_fm(r(ispin), z(ispin))
373 : END DO
374 0 : linres_control%flag = "CG"
375 : ELSE
376 : !
377 : ! z_0 = M * r_0
378 11954 : DO ispin = 1, nspins
379 : CALL apply_preconditioner(p_env%preconditioner(ispin), r(ispin), &
380 11954 : z(ispin))
381 : END DO
382 4954 : linres_control%flag = "PCG"
383 : END IF
384 : !
385 11954 : DO ispin = 1, nspins
386 : !
387 : ! p_0 = z_0
388 7000 : CALL cp_fm_to_fm(z(ispin), p(ispin))
389 : !
390 : ! trace(r_0 * z_0)
391 11954 : CALL cp_fm_trace(r(ispin), z(ispin), tr_rz0(ispin))
392 : END DO
393 11954 : IF (SUM(tr_rz0) < 0.0_dp) CPABORT("tr(r_j*z_j) < 0")
394 11954 : norm_res = ABS(SUM(tr_rz0))/SQRT(REAL(nspins*nao*maxnmo, dp))
395 : !
396 4954 : alpha = 0.0_dp
397 4954 : restart = .FALSE.
398 4954 : should_stop = .FALSE.
399 32996 : iteration: DO iter = 1, linres_control%max_iter
400 : !
401 : ! check convergence
402 31676 : linres_control%converged = .FALSE.
403 31676 : IF (norm_res .LT. linres_control%eps) THEN
404 3634 : linres_control%converged = .TRUE.
405 : END IF
406 : !
407 31676 : t2 = m_walltime()
408 : IF (iter .EQ. 1 .OR. MOD(iter, 1) .EQ. 0 .OR. linres_control%converged &
409 : .OR. restart .OR. should_stop) THEN
410 31676 : IF (iounit > 0) THEN
411 : WRITE (iounit, "(T5,I5,T18,A3,T28,L1,T38,1E8.2,T48,F16.10,T68,F8.2)") &
412 15772 : iter, linres_control%flag, restart, alpha, norm_res, t2 - t1
413 15772 : CALL m_flush(iounit)
414 : END IF
415 : END IF
416 : !
417 31676 : IF (linres_control%converged) THEN
418 3634 : IF (iounit > 0) THEN
419 1809 : WRITE (iounit, "(T3,A,I4,A)") "The linear solver converged in ", iter, " iterations."
420 1809 : CALL m_flush(iounit)
421 : END IF
422 : EXIT iteration
423 28042 : ELSE IF (should_stop) THEN
424 0 : IF (iounit > 0) THEN
425 0 : WRITE (iounit, "(T3,A,I4,A)") "The linear solver did NOT converge! External stop"
426 0 : CALL m_flush(iounit)
427 : END IF
428 : EXIT iteration
429 : END IF
430 : !
431 : ! Max number of iteration reached
432 28042 : IF (iter == linres_control%max_iter) THEN
433 1320 : IF (iounit > 0) THEN
434 : CALL cp_warn(__LOCATION__, &
435 660 : "The linear solver didn't converge! Maximum number of iterations reached.")
436 660 : CALL m_flush(iounit)
437 : END IF
438 1320 : linres_control%converged = .FALSE.
439 : END IF
440 : !
441 : ! Apply the operators that do not depend on the perturbation
442 28042 : CALL apply_op(qs_env, p_env, psi0_order, p, Ap, chc)
443 : !
444 : ! proj Ap onto the virtual subspace
445 28042 : CALL postortho(Ap, mo_coeff_array, Sc)
446 : !
447 68898 : DO ispin = 1, nspins
448 : !
449 : ! tr(Ap_j*p_j)
450 68898 : CALL cp_fm_trace(Ap(ispin), p(ispin), tr_pAp(ispin))
451 : END DO
452 : !
453 : ! alpha = tr(r_j*z_j) / tr(Ap_j*p_j)
454 68898 : IF (SUM(tr_pAp) < 1.0e-10_dp) THEN
455 170 : alpha = 1.0_dp
456 : ELSE
457 109244 : alpha = SUM(tr_rz0)/SUM(tr_pAp)
458 : END IF
459 68898 : DO ispin = 1, nspins
460 : !
461 : ! x_j+1 = x_j + alpha * p_j
462 68898 : CALL cp_fm_scale_and_add(1.0_dp, psi1(ispin), alpha, p(ispin))
463 : END DO
464 : !
465 : ! need to recompute the residue
466 28042 : restart = .FALSE.
467 28042 : IF (MOD(iter, linres_control%restart_every) .EQ. 0) THEN
468 : !
469 : ! r_j+1 = b - A * x_j+1
470 206 : CALL apply_op(qs_env, p_env, psi0_order, psi1, Ap, chc)
471 : !
472 446 : DO ispin = 1, nspins
473 240 : CALL cp_fm_to_fm(h1_psi0(ispin), r(ispin))
474 446 : CALL cp_fm_scale_and_add(-1.0_dp, r(ispin), -1.0_dp, Ap(ispin))
475 : END DO
476 206 : CALL postortho(r, mo_coeff_array, Sc)
477 : !
478 206 : restart = .TRUE.
479 : ELSE
480 : ! proj Ap onto the virtual subspace
481 27836 : CALL postortho(Ap, mo_coeff_array, Sc)
482 : !
483 : ! r_j+1 = r_j - alpha * Ap_j
484 68452 : DO ispin = 1, nspins
485 68452 : CALL cp_fm_scale_and_add(1.0_dp, r(ispin), -alpha, Ap(ispin))
486 : END DO
487 27836 : restart = .FALSE.
488 : END IF
489 : !
490 : ! preconditioner
491 28042 : linres_control%flag = ""
492 28042 : IF (linres_control%preconditioner_type .EQ. ot_precond_none) THEN
493 : !
494 : ! z_j+1 = r_j+1
495 0 : DO ispin = 1, nspins
496 0 : CALL cp_fm_to_fm(r(ispin), z(ispin))
497 : END DO
498 0 : linres_control%flag = "CG"
499 : ELSE
500 : !
501 : ! z_j+1 = M * r_j+1
502 68898 : DO ispin = 1, nspins
503 : CALL apply_preconditioner(p_env%preconditioner(ispin), r(ispin), &
504 68898 : z(ispin))
505 : END DO
506 28042 : linres_control%flag = "PCG"
507 : END IF
508 : !
509 68898 : DO ispin = 1, nspins
510 : !
511 : ! tr(r_j+1*z_j+1)
512 68898 : CALL cp_fm_trace(r(ispin), z(ispin), tr_rz1(ispin))
513 : END DO
514 68898 : IF (SUM(tr_rz1) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0")
515 68898 : norm_res = SUM(tr_rz1)/SQRT(REAL(nspins*nao*maxnmo, dp))
516 : !
517 : ! beta = tr(r_j+1*z_j+1) / tr(r_j*z_j)
518 68898 : IF (SUM(tr_rz0) < 1.0e-10_dp) THEN
519 208 : beta = 0.0_dp
520 : ELSE
521 109130 : beta = SUM(tr_rz1)/SUM(tr_rz0)
522 : END IF
523 68898 : DO ispin = 1, nspins
524 : !
525 : ! p_j+1 = z_j+1 + beta * p_j
526 40856 : CALL cp_fm_scale_and_add(beta, p(ispin), 1.0_dp, z(ispin))
527 40856 : tr_rz00(ispin) = tr_rz0(ispin)
528 68898 : tr_rz0(ispin) = tr_rz1(ispin)
529 : END DO
530 : !
531 : ! Can we exit the SCF loop?
532 : CALL external_control(should_stop, "LINRES", target_time=qs_env%target_time, &
533 29362 : start_time=qs_env%start_time)
534 :
535 : END DO iteration
536 : !
537 : ! proj psi1
538 4954 : CALL preortho(psi1, mo_coeff_array, Sc)
539 : !
540 : !
541 : ! clean up
542 4954 : CALL cp_fm_release(r)
543 4954 : CALL cp_fm_release(p)
544 4954 : CALL cp_fm_release(z)
545 4954 : CALL cp_fm_release(Ap)
546 : !
547 4954 : CALL cp_fm_release(mo_coeff_array)
548 4954 : CALL cp_fm_release(Sc)
549 4954 : CALL cp_fm_release(chc)
550 : !
551 4954 : DEALLOCATE (tr_pAp, tr_rz0, tr_rz00, tr_rz1)
552 : !
553 4954 : CALL timestop(handle)
554 : !
555 14862 : END SUBROUTINE linres_solver
556 :
557 : ! **************************************************************************************************
558 : !> \brief ...
559 : !> \param qs_env ...
560 : !> \param p_env ...
561 : !> \param c0 ...
562 : !> \param v ...
563 : !> \param Av ...
564 : !> \param chc ...
565 : ! **************************************************************************************************
566 33202 : SUBROUTINE apply_op(qs_env, p_env, c0, v, Av, chc)
567 : !
568 : TYPE(qs_environment_type), INTENT(IN), POINTER :: qs_env
569 : TYPE(qs_p_env_type) :: p_env
570 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: c0, v, Av, chc
571 :
572 : CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_op'
573 :
574 : INTEGER :: handle, ispin, nc1, nc2, nc3, nc4, nr1, &
575 : nr2, nr3, nr4, nspins
576 : REAL(dp) :: chksum
577 33202 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_ks, matrix_s
578 : TYPE(dft_control_type), POINTER :: dft_control
579 : TYPE(linres_control_type), POINTER :: linres_control
580 : TYPE(qs_rho_type), POINTER :: rho
581 :
582 33202 : CALL timeset(routineN, handle)
583 :
584 33202 : NULLIFY (dft_control, matrix_ks, matrix_s, linres_control)
585 : CALL get_qs_env(qs_env=qs_env, &
586 : matrix_ks=matrix_ks, &
587 : matrix_s=matrix_s, &
588 : dft_control=dft_control, &
589 33202 : linres_control=linres_control)
590 :
591 33202 : nspins = dft_control%nspins
592 :
593 81298 : DO ispin = 1, nspins
594 : !c0, v, Av, chc
595 48096 : CALL cp_fm_get_info(c0(ispin), ncol_global=nc1, nrow_global=nr1)
596 48096 : CALL cp_fm_get_info(v(ispin), ncol_global=nc2, nrow_global=nr2)
597 48096 : CALL cp_fm_get_info(Av(ispin), ncol_global=nc3, nrow_global=nr3)
598 48096 : CALL cp_fm_get_info(chc(ispin), ncol_global=nc4, nrow_global=nr4)
599 48096 : IF (.NOT. (nc1 == nc2 .AND. nr1 == nr2 .AND. nc1 == nc3 .AND. nr1 == nr3 &
600 81298 : .AND. nc4 == nr4 .AND. nc1 <= nc4)) THEN
601 : CALL cp_abort(__LOCATION__, &
602 0 : "Number of vectors inconsistent or CHC matrix too small")
603 : END IF
604 : END DO
605 :
606 : ! apply the uncoupled operator
607 81298 : DO ispin = 1, nspins
608 : CALL apply_op_1(v(ispin), Av(ispin), matrix_ks(ispin)%matrix, &
609 81298 : matrix_s(1)%matrix, chc(ispin))
610 : END DO
611 :
612 33202 : IF (linres_control%do_kernel) THEN
613 :
614 : ! build DM, refill p1, build_dm_response keeps sparse structure
615 18698 : DO ispin = 1, nspins
616 18698 : CALL dbcsr_copy(p_env%p1(ispin)%matrix, matrix_s(1)%matrix)
617 : END DO
618 8856 : CALL build_dm_response(c0, v, p_env%p1)
619 :
620 8856 : chksum = 0.0_dp
621 18698 : DO ispin = 1, nspins
622 18698 : chksum = chksum + dbcsr_checksum(p_env%p1(ispin)%matrix)
623 : END DO
624 :
625 : ! skip the kernel if the DM is very small
626 8856 : IF (chksum .GT. 1.0E-14_dp) THEN
627 :
628 7514 : CALL p_env_check_i_alloc(p_env, qs_env)
629 :
630 7514 : CALL p_env_update_rho(p_env, qs_env)
631 :
632 7514 : CALL get_qs_env(qs_env, rho=rho) ! that could be called before
633 7514 : CALL qs_rho_update_rho(rho, qs_env=qs_env) ! that could be called before
634 7514 : IF (dft_control%qs_control%gapw) THEN
635 776 : CALL prepare_gapw_den(qs_env)
636 6738 : ELSEIF (dft_control%qs_control%gapw_xc) THEN
637 352 : CALL prepare_gapw_den(qs_env, do_rho0=.FALSE.)
638 : END IF
639 :
640 15870 : DO ispin = 1, nspins
641 8356 : CALL dbcsr_set(p_env%kpp1(ispin)%matrix, 0.0_dp)
642 15870 : IF (ASSOCIATED(p_env%kpp1_admm)) CALL dbcsr_set(p_env%kpp1_admm(ispin)%matrix, 0.0_dp)
643 : END DO
644 :
645 7514 : CALL apply_op_2(qs_env, p_env, c0, Av)
646 :
647 : END IF
648 :
649 : END IF
650 :
651 33202 : CALL timestop(handle)
652 :
653 33202 : END SUBROUTINE apply_op
654 :
655 : ! **************************************************************************************************
656 : !> \brief ...
657 : !> \param v ...
658 : !> \param Av ...
659 : !> \param matrix_ks ...
660 : !> \param matrix_s ...
661 : !> \param chc ...
662 : ! **************************************************************************************************
663 96192 : SUBROUTINE apply_op_1(v, Av, matrix_ks, matrix_s, chc)
664 : !
665 : TYPE(cp_fm_type), INTENT(IN) :: v, Av
666 : TYPE(dbcsr_type), INTENT(IN) :: matrix_ks, matrix_s
667 : TYPE(cp_fm_type), INTENT(IN) :: chc
668 :
669 : CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_op_1'
670 :
671 : INTEGER :: handle, ncol, nrow
672 : TYPE(cp_fm_type) :: buf
673 :
674 48096 : CALL timeset(routineN, handle)
675 : !
676 48096 : CALL cp_fm_create(buf, v%matrix_struct)
677 : !
678 48096 : CALL cp_fm_get_info(v, ncol_global=ncol, nrow_global=nrow)
679 : ! H * v
680 48096 : CALL cp_dbcsr_sm_fm_multiply(matrix_ks, v, Av, ncol)
681 : ! v * e (chc already multiplied by -1)
682 48096 : CALL parallel_gemm('N', 'N', nrow, ncol, ncol, 1.0_dp, v, chc, 0.0_dp, buf)
683 : ! S * ve
684 48096 : CALL cp_dbcsr_sm_fm_multiply(matrix_s, buf, Av, ncol, alpha=1.0_dp, beta=1.0_dp)
685 : !Results is H*C1 - S*<iHj>*C1
686 : !
687 48096 : CALL cp_fm_release(buf)
688 : !
689 48096 : CALL timestop(handle)
690 : !
691 48096 : END SUBROUTINE apply_op_1
692 :
693 : !MERGE
694 : ! **************************************************************************************************
695 : !> \brief ...
696 : !> \param v ...
697 : !> \param psi0 ...
698 : !> \param S_psi0 ...
699 : ! **************************************************************************************************
700 9908 : SUBROUTINE preortho(v, psi0, S_psi0)
701 : !v = (I-PS)v
702 : !
703 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: v, psi0, S_psi0
704 :
705 : CHARACTER(LEN=*), PARAMETER :: routineN = 'preortho'
706 :
707 : INTEGER :: handle, ispin, mp, mt, mv, np, nspins, &
708 : nt, nv
709 : TYPE(cp_fm_struct_type), POINTER :: tmp_fm_struct
710 : TYPE(cp_fm_type) :: buf
711 :
712 9908 : CALL timeset(routineN, handle)
713 : !
714 9908 : NULLIFY (tmp_fm_struct)
715 : !
716 9908 : nspins = SIZE(v, 1)
717 : !
718 23908 : DO ispin = 1, nspins
719 14000 : CALL cp_fm_get_info(v(ispin), ncol_global=mv, nrow_global=nv)
720 14000 : CALL cp_fm_get_info(psi0(ispin), ncol_global=mp, nrow_global=np)
721 : !
722 : CALL cp_fm_struct_create(tmp_fm_struct, nrow_global=nv, ncol_global=mp, &
723 : para_env=v(ispin)%matrix_struct%para_env, &
724 14000 : context=v(ispin)%matrix_struct%context)
725 14000 : CALL cp_fm_create(buf, tmp_fm_struct)
726 14000 : CALL cp_fm_struct_release(tmp_fm_struct)
727 : !
728 14000 : CALL cp_fm_get_info(buf, ncol_global=mt, nrow_global=nt)
729 14000 : CPASSERT(nv == np)
730 14000 : CPASSERT(mt >= mv)
731 14000 : CPASSERT(mt >= mp)
732 14000 : CPASSERT(nt == nv)
733 : !
734 : ! buf = v' * S_psi0
735 14000 : CALL parallel_gemm('T', 'N', mv, mp, nv, 1.0_dp, v(ispin), S_psi0(ispin), 0.0_dp, buf)
736 : ! v = v - psi0 * buf'
737 14000 : CALL parallel_gemm('N', 'T', nv, mv, mp, -1.0_dp, psi0(ispin), buf, 1.0_dp, v(ispin))
738 : !
739 51908 : CALL cp_fm_release(buf)
740 : END DO
741 : !
742 9908 : CALL timestop(handle)
743 : !
744 9908 : END SUBROUTINE preortho
745 :
746 : ! **************************************************************************************************
747 : !> \brief projects first index of v onto the virtual subspace
748 : !> \param v matrix to be projected
749 : !> \param psi0 matrix with occupied orbitals
750 : !> \param S_psi0 matrix containing product of metric and occupied orbitals
751 : ! **************************************************************************************************
752 61038 : SUBROUTINE postortho(v, psi0, S_psi0)
753 : !v = (I-SP)v
754 : !
755 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: v, psi0, S_psi0
756 :
757 : CHARACTER(LEN=*), PARAMETER :: routineN = 'postortho'
758 :
759 : INTEGER :: handle, ispin, mp, mt, mv, np, nspins, &
760 : nt, nv
761 : TYPE(cp_fm_struct_type), POINTER :: tmp_fm_struct
762 : TYPE(cp_fm_type) :: buf
763 :
764 61038 : CALL timeset(routineN, handle)
765 : !
766 61038 : NULLIFY (tmp_fm_struct)
767 : !
768 61038 : nspins = SIZE(v, 1)
769 : !
770 149750 : DO ispin = 1, nspins
771 88712 : CALL cp_fm_get_info(v(ispin), ncol_global=mv, nrow_global=nv)
772 88712 : CALL cp_fm_get_info(psi0(ispin), ncol_global=mp, nrow_global=np)
773 : !
774 : CALL cp_fm_struct_create(tmp_fm_struct, nrow_global=nv, ncol_global=mp, &
775 : para_env=v(ispin)%matrix_struct%para_env, &
776 88712 : context=v(ispin)%matrix_struct%context)
777 88712 : CALL cp_fm_create(buf, tmp_fm_struct)
778 88712 : CALL cp_fm_struct_release(tmp_fm_struct)
779 : !
780 88712 : CALL cp_fm_get_info(buf, ncol_global=mt, nrow_global=nt)
781 88712 : CPASSERT(nv == np)
782 88712 : CPASSERT(mt >= mv)
783 88712 : CPASSERT(mt >= mp)
784 88712 : CPASSERT(nt == nv)
785 : !
786 : ! buf = v' * psi0
787 88712 : CALL parallel_gemm('T', 'N', mv, mp, nv, 1.0_dp, v(ispin), psi0(ispin), 0.0_dp, buf)
788 : ! v = v - S_psi0 * buf'
789 88712 : CALL parallel_gemm('N', 'T', nv, mv, mp, -1.0_dp, S_psi0(ispin), buf, 1.0_dp, v(ispin))
790 : !
791 327174 : CALL cp_fm_release(buf)
792 : END DO
793 : !
794 61038 : CALL timestop(handle)
795 : !
796 61038 : END SUBROUTINE postortho
797 :
798 : ! **************************************************************************************************
799 : !> \brief ...
800 : !> \param qs_env ...
801 : !> \param linres_section ...
802 : !> \param vec ...
803 : !> \param ivec ...
804 : !> \param tag ...
805 : !> \param ind ...
806 : ! **************************************************************************************************
807 3522 : SUBROUTINE linres_write_restart(qs_env, linres_section, vec, ivec, tag, ind)
808 : TYPE(qs_environment_type), POINTER :: qs_env
809 : TYPE(section_vals_type), POINTER :: linres_section
810 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: vec
811 : INTEGER, INTENT(IN) :: ivec
812 : CHARACTER(LEN=*) :: tag
813 : INTEGER, INTENT(IN), OPTIONAL :: ind
814 :
815 : CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_write_restart'
816 :
817 : CHARACTER(LEN=default_path_length) :: filename
818 : CHARACTER(LEN=default_string_length) :: my_middle, my_pos, my_status
819 : INTEGER :: handle, i, i_block, ia, ie, iounit, &
820 : ispin, j, max_block, nao, nmo, nspins, &
821 : rst_unit
822 3522 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: vecbuffer
823 : TYPE(cp_fm_type), POINTER :: mo_coeff
824 : TYPE(cp_logger_type), POINTER :: logger
825 3522 : TYPE(mo_set_type), DIMENSION(:), POINTER :: mos
826 : TYPE(mp_para_env_type), POINTER :: para_env
827 : TYPE(section_vals_type), POINTER :: print_key
828 :
829 3522 : NULLIFY (logger, mo_coeff, mos, para_env, print_key, vecbuffer)
830 :
831 3522 : CALL timeset(routineN, handle)
832 :
833 3522 : logger => cp_get_default_logger()
834 :
835 3522 : IF (BTEST(cp_print_key_should_output(logger%iter_info, linres_section, "PRINT%RESTART", &
836 : used_print_key=print_key), &
837 : cp_p_file)) THEN
838 :
839 : iounit = cp_print_key_unit_nr(logger, linres_section, &
840 3522 : "PRINT%PROGRAM_RUN_INFO", extension=".Log")
841 :
842 : CALL get_qs_env(qs_env=qs_env, &
843 : mos=mos, &
844 3522 : para_env=para_env)
845 :
846 3522 : nspins = SIZE(mos)
847 :
848 3522 : my_status = "REPLACE"
849 3522 : my_pos = "REWIND"
850 3522 : CALL XSTRING(tag, ia, ie)
851 3522 : IF (PRESENT(ind)) THEN
852 2460 : my_middle = "RESTART-"//tag(ia:ie)//TRIM(ADJUSTL(cp_to_string(ivec)))
853 : ELSE
854 1062 : my_middle = "RESTART-"//tag(ia:ie)
855 1062 : IF (ivec > 1) THEN
856 708 : my_status = "OLD"
857 708 : my_pos = "APPEND"
858 : END IF
859 : END IF
860 : rst_unit = cp_print_key_unit_nr(logger, linres_section, "PRINT%RESTART", &
861 : extension=".lr", middle_name=TRIM(my_middle), file_status=TRIM(my_status), &
862 3522 : file_position=TRIM(my_pos), file_action="WRITE", file_form="UNFORMATTED")
863 :
864 : filename = cp_print_key_generate_filename(logger, print_key, &
865 3522 : extension=".lr", middle_name=TRIM(my_middle), my_local=.FALSE.)
866 :
867 3522 : IF (iounit > 0) THEN
868 : WRITE (UNIT=iounit, FMT="(T2,A)") &
869 1761 : "LINRES| Writing response functions to the restart file <"//TRIM(ADJUSTL(filename))//">"
870 : END IF
871 :
872 : !
873 : ! write data to file
874 : ! use the scalapack block size as a default for buffering columns
875 3522 : CALL get_mo_set(mos(1), mo_coeff=mo_coeff)
876 3522 : CALL cp_fm_get_info(mo_coeff, nrow_global=nao, ncol_block=max_block)
877 14088 : ALLOCATE (vecbuffer(nao, max_block))
878 :
879 3522 : IF (PRESENT(ind)) THEN
880 2460 : IF (rst_unit > 0) WRITE (rst_unit) ind, ivec, nspins, nao
881 : ELSE
882 1062 : IF (rst_unit > 0) WRITE (rst_unit) ivec, nspins, nao
883 : END IF
884 :
885 8934 : DO ispin = 1, nspins
886 5412 : CALL cp_fm_get_info(vec(ispin), ncol_global=nmo)
887 :
888 5412 : IF (rst_unit > 0) WRITE (rst_unit) nmo
889 :
890 19758 : DO i = 1, nmo, MAX(max_block, 1)
891 5412 : i_block = MIN(max_block, nmo - i + 1)
892 5412 : CALL cp_fm_get_submatrix(vec(ispin), vecbuffer, 1, i, nao, i_block)
893 : ! doing this in one write would increase efficiency, but breaks RESTART compatibility.
894 : ! to old ones, and in cases where max_block is different between runs, as might happen during
895 : ! restarts with a different number of CPUs
896 47616 : DO j = 1, i_block
897 42204 : IF (rst_unit > 0) WRITE (rst_unit) vecbuffer(1:nao, j)
898 : END DO
899 : END DO
900 : END DO
901 :
902 3522 : DEALLOCATE (vecbuffer)
903 :
904 : CALL cp_print_key_finished_output(rst_unit, logger, linres_section, &
905 7044 : "PRINT%RESTART")
906 : END IF
907 :
908 3522 : CALL timestop(handle)
909 :
910 3522 : END SUBROUTINE linres_write_restart
911 :
912 : ! **************************************************************************************************
913 : !> \brief ...
914 : !> \param qs_env ...
915 : !> \param linres_section ...
916 : !> \param vec ...
917 : !> \param ivec ...
918 : !> \param tag ...
919 : !> \param ind ...
920 : ! **************************************************************************************************
921 72 : SUBROUTINE linres_read_restart(qs_env, linres_section, vec, ivec, tag, ind)
922 : TYPE(qs_environment_type), POINTER :: qs_env
923 : TYPE(section_vals_type), POINTER :: linres_section
924 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: vec
925 : INTEGER, INTENT(IN) :: ivec
926 : CHARACTER(LEN=*) :: tag
927 : INTEGER, INTENT(INOUT), OPTIONAL :: ind
928 :
929 : CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_read_restart'
930 :
931 : CHARACTER(LEN=default_path_length) :: filename
932 : CHARACTER(LEN=default_string_length) :: my_middle
933 : INTEGER :: handle, i, i_block, ia, ie, iostat, iounit, ispin, iv, iv1, ivec_tmp, j, &
934 : max_block, n_rep_val, nao, nao_tmp, nmo, nmo_tmp, nspins, nspins_tmp, rst_unit
935 : LOGICAL :: file_exists
936 72 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: vecbuffer
937 : TYPE(cp_fm_type), POINTER :: mo_coeff
938 : TYPE(cp_logger_type), POINTER :: logger
939 72 : TYPE(mo_set_type), DIMENSION(:), POINTER :: mos
940 : TYPE(mp_para_env_type), POINTER :: para_env
941 : TYPE(section_vals_type), POINTER :: print_key
942 :
943 72 : file_exists = .FALSE.
944 :
945 72 : CALL timeset(routineN, handle)
946 :
947 72 : NULLIFY (mos, para_env, logger, print_key, vecbuffer)
948 72 : logger => cp_get_default_logger()
949 :
950 : iounit = cp_print_key_unit_nr(logger, linres_section, &
951 72 : "PRINT%PROGRAM_RUN_INFO", extension=".Log")
952 :
953 : CALL get_qs_env(qs_env=qs_env, &
954 : para_env=para_env, &
955 72 : mos=mos)
956 :
957 72 : nspins = SIZE(mos)
958 :
959 72 : rst_unit = -1
960 72 : IF (para_env%is_source()) THEN
961 : CALL section_vals_val_get(linres_section, "WFN_RESTART_FILE_NAME", &
962 36 : n_rep_val=n_rep_val)
963 :
964 36 : CALL XSTRING(tag, ia, ie)
965 36 : IF (PRESENT(ind)) THEN
966 9 : my_middle = "RESTART-"//tag(ia:ie)//TRIM(ADJUSTL(cp_to_string(ivec)))
967 : ELSE
968 27 : my_middle = "RESTART-"//tag(ia:ie)
969 : END IF
970 :
971 36 : IF (n_rep_val > 0) THEN
972 18 : CALL section_vals_val_get(linres_section, "WFN_RESTART_FILE_NAME", c_val=filename)
973 18 : CALL xstring(filename, ia, ie)
974 18 : filename = filename(ia:ie)//TRIM(my_middle)//".lr"
975 : ELSE
976 : ! try to read from the filename that is generated automatically from the printkey
977 18 : print_key => section_vals_get_subs_vals(linres_section, "PRINT%RESTART")
978 : filename = cp_print_key_generate_filename(logger, print_key, &
979 18 : extension=".lr", middle_name=TRIM(my_middle), my_local=.FALSE.)
980 : END IF
981 36 : INQUIRE (FILE=filename, exist=file_exists)
982 : !
983 : ! open file
984 36 : IF (file_exists) THEN
985 : CALL open_file(file_name=TRIM(filename), &
986 : file_action="READ", &
987 : file_form="UNFORMATTED", &
988 : file_position="REWIND", &
989 : file_status="OLD", &
990 15 : unit_number=rst_unit)
991 :
992 15 : IF (iounit > 0) WRITE (iounit, "(T2,A)") &
993 15 : "LINRES| Reading response wavefunctions from the restart file <"//TRIM(ADJUSTL(filename))//">"
994 : ELSE
995 21 : IF (iounit > 0) WRITE (iounit, "(T2,A)") &
996 21 : "LINRES| Restart file <"//TRIM(ADJUSTL(filename))//"> not found"
997 : END IF
998 : END IF
999 :
1000 72 : CALL para_env%bcast(file_exists)
1001 :
1002 72 : IF (file_exists) THEN
1003 :
1004 30 : CALL get_mo_set(mos(1), mo_coeff=mo_coeff)
1005 30 : CALL cp_fm_get_info(mo_coeff, nrow_global=nao, ncol_block=max_block)
1006 :
1007 120 : ALLOCATE (vecbuffer(nao, max_block))
1008 : !
1009 : ! read headers
1010 30 : IF (PRESENT(ind)) THEN
1011 6 : iv1 = ivec
1012 : ELSE
1013 : iv1 = 1
1014 : END IF
1015 54 : DO iv = iv1, ivec
1016 :
1017 54 : IF (PRESENT(ind)) THEN
1018 6 : IF (rst_unit > 0) READ (rst_unit, IOSTAT=iostat) ind, ivec_tmp, nspins_tmp, nao_tmp
1019 6 : CALL para_env%bcast(iostat)
1020 6 : CALL para_env%bcast(ind)
1021 : ELSE
1022 48 : IF (rst_unit > 0) READ (rst_unit, IOSTAT=iostat) ivec_tmp, nspins_tmp, nao_tmp
1023 48 : CALL para_env%bcast(iostat)
1024 : END IF
1025 :
1026 54 : IF (iostat .NE. 0) EXIT
1027 54 : CALL para_env%bcast(ivec_tmp)
1028 54 : CALL para_env%bcast(nspins_tmp)
1029 54 : CALL para_env%bcast(nao_tmp)
1030 :
1031 : ! check that the number nao, nmo and nspins are
1032 : ! the same as in the current mos
1033 54 : IF (nspins_tmp .NE. nspins) CPABORT("nspins not consistent")
1034 54 : IF (nao_tmp .NE. nao) CPABORT("nao not consistent")
1035 : !
1036 108 : DO ispin = 1, nspins
1037 54 : CALL get_mo_set(mos(ispin), mo_coeff=mo_coeff)
1038 54 : CALL cp_fm_get_info(mo_coeff, ncol_global=nmo)
1039 : !
1040 54 : IF (rst_unit > 0) READ (rst_unit) nmo_tmp
1041 54 : CALL para_env%bcast(nmo_tmp)
1042 54 : IF (nmo_tmp .NE. nmo) CPABORT("nmo not consistent")
1043 : !
1044 : ! read the response
1045 216 : DO i = 1, nmo, MAX(max_block, 1)
1046 54 : i_block = MIN(max_block, nmo - i + 1)
1047 270 : DO j = 1, i_block
1048 270 : IF (rst_unit > 0) READ (rst_unit) vecbuffer(1:nao, j)
1049 : END DO
1050 108 : IF (iv .EQ. ivec_tmp) THEN
1051 10422 : CALL para_env%bcast(vecbuffer)
1052 54 : CALL cp_fm_set_submatrix(vec(ispin), vecbuffer, 1, i, nao, i_block)
1053 : END IF
1054 : END DO
1055 : END DO
1056 54 : IF (ivec .EQ. ivec_tmp) EXIT
1057 : END DO
1058 :
1059 30 : IF (iostat /= 0) THEN
1060 0 : IF (iounit > 0) WRITE (iounit, "(T2,A)") &
1061 0 : "LINRES| Restart file <"//TRIM(ADJUSTL(filename))//"> not found"
1062 : END IF
1063 :
1064 60 : DEALLOCATE (vecbuffer)
1065 :
1066 : END IF
1067 :
1068 72 : IF (para_env%is_source()) THEN
1069 36 : IF (file_exists) CALL close_file(unit_number=rst_unit)
1070 : END IF
1071 :
1072 72 : CALL timestop(handle)
1073 :
1074 72 : END SUBROUTINE linres_read_restart
1075 :
1076 : ! **************************************************************************************************
1077 : !> \brief ...
1078 : !> \param p_env ...
1079 : !> \param linres_control ...
1080 : !> \param nspins ...
1081 : ! **************************************************************************************************
1082 4954 : SUBROUTINE check_p_env_init(p_env, linres_control, nspins)
1083 : !
1084 : TYPE(qs_p_env_type) :: p_env
1085 : TYPE(linres_control_type), INTENT(IN) :: linres_control
1086 : INTEGER, INTENT(IN) :: nspins
1087 :
1088 : INTEGER :: ispin, ncol, nrow
1089 :
1090 4954 : IF (linres_control%preconditioner_type /= ot_precond_none) THEN
1091 4954 : CPASSERT(ASSOCIATED(p_env%preconditioner))
1092 11954 : DO ispin = 1, nspins
1093 7000 : CALL cp_fm_get_info(p_env%PS_psi0(ispin), nrow_global=nrow, ncol_global=ncol)
1094 7000 : CPASSERT(nrow == p_env%n_ao(ispin))
1095 18954 : CPASSERT(ncol == p_env%n_mo(ispin))
1096 : END DO
1097 : END IF
1098 :
1099 4954 : END SUBROUTINE check_p_env_init
1100 :
1101 : END MODULE qs_linres_methods
|
