Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Type definitiona for linear response calculations
10 : !> \author MI
11 : ! **************************************************************************************************
12 : MODULE qs_linres_types
13 : USE atomic_kind_types, ONLY: atomic_kind_type,&
14 : get_atomic_kind,&
15 : get_atomic_kind_set
16 : USE basis_set_types, ONLY: get_gto_basis_set,&
17 : gto_basis_set_type
18 : USE cp_array_utils, ONLY: cp_2d_i_p_type,&
19 : cp_2d_r_p_type
20 : USE cp_dbcsr_api, ONLY: dbcsr_p_type
21 : USE cp_fm_struct, ONLY: cp_fm_struct_p_type,&
22 : cp_fm_struct_type
23 : USE cp_fm_types, ONLY: cp_fm_release,&
24 : cp_fm_type
25 : USE kinds, ONLY: dp
26 : USE qs_grid_atom, ONLY: grid_atom_type
27 : USE qs_harmonics_atom, ONLY: harmonics_atom_type
28 : USE qs_kind_types, ONLY: get_qs_kind,&
29 : qs_kind_type
30 : USE qs_loc_types, ONLY: qs_loc_env_release,&
31 : qs_loc_env_type
32 : USE qs_rho_atom_types, ONLY: rho_atom_coeff,&
33 : rho_atom_type
34 : USE qs_rho_types, ONLY: qs_rho_p_type,&
35 : qs_rho_release
36 : USE realspace_grid_types, ONLY: realspace_grid_type
37 : #include "./base/base_uses.f90"
38 :
39 : IMPLICIT NONE
40 :
41 : PRIVATE
42 :
43 : ! **************************************************************************************************
44 : !> \brief General settings for linear response calculations
45 : !> \param property which quantity is to be calculated by LR
46 : !> \param opt_method method to optimize the psi1 by minimization of the second order term of the energy
47 : !> \param preconditioner which kind of preconditioner should be used, if any
48 : !> \param localized_psi 0 : don't use the canonical psi0, but the maximally localized wavefunctions
49 : !> \param do_kernel the kernel is zero if the rho1 is zero as for the magnetic field perturbation
50 : !> \param tolerance convergence criterion for the optimization of the psi1
51 : !> \author MI
52 : ! **************************************************************************************************
53 : TYPE linres_control_type
54 : INTEGER :: property = HUGE(0)
55 : INTEGER :: preconditioner_type = HUGE(0)
56 : INTEGER :: restart_every = HUGE(0)
57 : REAL(KIND=dp) :: energy_gap = HUGE(0.0_dp)
58 : INTEGER :: max_iter = HUGE(0)
59 : LOGICAL :: localized_psi0 = .FALSE.
60 : LOGICAL :: do_kernel = .FALSE.
61 : LOGICAL :: converged = .FALSE.
62 : LOGICAL :: linres_restart = .FALSE.
63 : LOGICAL :: lr_triplet = .FALSE.
64 : REAL(KIND=dp) :: eps = HUGE(0.0_dp)
65 : REAL(KIND=dp) :: eps_filter = TINY(0.0_dp)
66 : TYPE(qs_loc_env_type), POINTER :: qs_loc_env => NULL()
67 : CHARACTER(LEN=8) :: flag = ""
68 : END TYPE linres_control_type
69 :
70 : ! **************************************************************************************************
71 : !> \param ref_coun t
72 : !> \param full_nmr true if the full correction is calculated
73 : !> \param simplenmr_done , fullnmr_done : flags that indicate what has been
74 : !> already calculated: used for restart
75 : !> \param centers_set centers of the maximally localized psi0
76 : !> \param spreads_set spreads of the maximally localized psi0
77 : !> \param p_psi 0 : full matrixes, operator p applied to psi0
78 : !> \param rxp_psi 0 : full matrixes, operator (r-d)xp applied to psi0
79 : !> \param psi 1_p : response wavefunctions to the perturbation given by
80 : !> H1=p (xyz) applied to psi0
81 : !> \param psi 1_rxp : response wavefunctions to the perturbation given by
82 : !> H1=(r-d_i)xp applied to psi0_i where d_i is the center
83 : !> \param psi 1_D : response wavefunctions to the perturbation given by
84 : !> H1=(d_j-d_i)xp applied to psi0_i where d_i is the center
85 : !> and d_j is the center of psi0_j and psi1_D_j is the result
86 : !> This operator has to be used in nstate scf calculations,
87 : !> one for each psi1_D_j vector
88 : !> \param chemical_shift the tensor for each atom
89 : !> \param chi_tensor the susceptibility tensor
90 : !> \param jrho 1_set : current density on the global grid, if gapw this is only the soft part
91 : !> \param jrho 1_atom_set : current density on the local atomic grids (only if gapw)
92 : !> \author MI
93 : ! **************************************************************************************************
94 : TYPE current_env_type
95 : LOGICAL :: full = .FALSE.
96 : LOGICAL :: simple_done(6) = .FALSE.
97 : LOGICAL :: simple_converged(6) = .FALSE.
98 : LOGICAL :: do_qmmm = .FALSE.
99 : LOGICAL :: use_old_gauge_atom = .TRUE.
100 : LOGICAL :: chi_pbc = .FALSE.
101 : LOGICAL :: do_selected_states = .FALSE.
102 : LOGICAL :: gauge_init = .FALSE.
103 : LOGICAL :: all_pert_op_done = .FALSE.
104 : LOGICAL, DIMENSION(:, :), POINTER :: full_done => NULL()
105 : INTEGER :: nao = HUGE(1)
106 : INTEGER, DIMENSION(2) :: nstates = HUGE(1)
107 : INTEGER :: gauge = HUGE(1)
108 : INTEGER :: orb_center = HUGE(1)
109 : INTEGER, DIMENSION(2) :: nbr_center = HUGE(1)
110 : INTEGER, DIMENSION(:), POINTER :: list_cubes => NULL()
111 : INTEGER, DIMENSION(:), POINTER :: selected_states_on_atom_list => NULL()
112 : INTEGER, DIMENSION(:, :, :), POINTER :: statetrueindex => NULL()
113 : CHARACTER(LEN=30) :: gauge_name = ""
114 : CHARACTER(LEN=30) :: orb_center_name = ""
115 : REAL(dp) :: chi_tensor(3, 3, 2) = 0.0_dp
116 : REAL(dp) :: chi_tensor_loc(3, 3, 2) = 0.0_dp
117 : REAL(dp) :: gauge_atom_radius = 0.0_dp
118 : REAL(dp) :: selected_states_atom_radius = 0.0_dp
119 : REAL(dp), DIMENSION(:, :), POINTER :: basisfun_center => NULL()
120 : TYPE(cp_2d_i_p_type), DIMENSION(:), POINTER :: center_list => NULL()
121 : TYPE(cp_2d_r_p_type), DIMENSION(:), POINTER :: centers_set => NULL()
122 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_p => NULL()
123 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_rxp => NULL()
124 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_D => NULL()
125 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: p_psi0 => NULL()
126 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: rxp_psi0 => NULL()
127 : TYPE(jrho_atom_type), DIMENSION(:), POINTER :: jrho1_atom_set => NULL()
128 : TYPE(qs_rho_p_type), DIMENSION(:), POINTER :: jrho1_set => NULL()
129 : TYPE(realspace_grid_type), DIMENSION(:), POINTER :: rs_buf => NULL()
130 : TYPE(realspace_grid_type), DIMENSION(:, :), POINTER :: rs_gauge => NULL()
131 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: psi0_order => NULL()
132 : END TYPE current_env_type
133 :
134 : ! **************************************************************************************************
135 : ! \param type for polarisability calculation using Berry operator
136 : TYPE polar_env_type
137 : LOGICAL :: do_raman = .FALSE.
138 : LOGICAL :: run_stopped = .FALSE.
139 : LOGICAL :: do_periodic = .TRUE.
140 : REAL(dp), DIMENSION(:, :), POINTER :: polar => NULL()
141 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_dBerry => NULL()
142 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: dBerry_psi0 => NULL()
143 : END TYPE polar_env_type
144 : ! **************************************************************************************************
145 :
146 : TYPE issc_env_type
147 : INTEGER :: issc_natms = 0
148 : INTEGER, DIMENSION(:), POINTER :: issc_on_atom_list => NULL()
149 : LOGICAL :: interpolate_issc = .FALSE.
150 : LOGICAL :: do_fc = .FALSE.
151 : LOGICAL :: do_sd = .FALSE.
152 : LOGICAL :: do_pso = .FALSE.
153 : LOGICAL :: do_dso = .FALSE.
154 : REAL(dp) :: issc_gapw_radius = 0.0_dp
155 : REAL(dp) :: issc_factor = 0.0_dp
156 : REAL(dp) :: issc_factor_gapw = 0.0_dp
157 : REAL(dp), DIMENSION(:, :, :, :, :), POINTER :: issc => NULL()
158 : REAL(dp), DIMENSION(:, :, :, :, :), POINTER :: issc_loc => NULL()
159 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_efg => NULL()
160 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_pso => NULL()
161 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: psi1_dso => NULL()
162 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: efg_psi0 => NULL()
163 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: pso_psi0 => NULL()
164 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: dso_psi0 => NULL()
165 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: psi1_fc => NULL()
166 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: fc_psi0 => NULL()
167 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_efg => NULL()
168 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_pso => NULL()
169 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_dso => NULL()
170 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_fc => NULL()
171 : END TYPE issc_env_type
172 :
173 : ! **************************************************************************************************
174 : TYPE nmr_env_type
175 : INTEGER :: n_nics = -1
176 : INTEGER, DIMENSION(:), POINTER :: cs_atom_list => NULL()
177 : INTEGER, DIMENSION(:), POINTER :: do_calc_cs_atom => NULL()
178 : LOGICAL :: do_nics = .FALSE.
179 : LOGICAL :: interpolate_shift = .FALSE.
180 : REAL(dp) :: shift_gapw_radius = 0.0_dp
181 : REAL(dp) :: shift_factor = 0.0_dp
182 : REAL(dp) :: shift_factor_gapw = 0.0_dp
183 : REAL(dp) :: chi_factor = 0.0_dp
184 : REAL(dp) :: chi_SI2shiftppm = 0.0_dp
185 : REAL(dp) :: chi_SI2ppmcgs = 0.0_dp
186 : REAL(dp), DIMENSION(:, :), POINTER :: r_nics => NULL()
187 : REAL(dp), DIMENSION(:, :, :), POINTER :: chemical_shift => NULL()
188 : REAL(dp), DIMENSION(:, :, :), POINTER :: chemical_shift_loc => NULL()
189 : REAL(dp), DIMENSION(:, :, :), POINTER :: chemical_shift_nics_loc => NULL()
190 : REAL(dp), DIMENSION(:, :, :), POINTER :: chemical_shift_nics => NULL()
191 : END TYPE nmr_env_type
192 :
193 : ! **************************************************************************************************
194 : TYPE epr_env_type
195 : REAL(dp) :: g_free_factor = 0.0_dp
196 : REAL(dp) :: g_soo_chicorr_factor = 0.0_dp
197 : REAL(dp) :: g_soo_factor = 0.0_dp
198 : REAL(dp) :: g_so_factor = 0.0_dp
199 : REAL(dp) :: g_so_factor_gapw = 0.0_dp
200 : REAL(dp) :: g_zke_factor = 0.0_dp
201 : REAL(dp) :: g_zke = 0.0_dp
202 : REAL(dp), DIMENSION(:, :), POINTER :: g_total => NULL()
203 : REAL(dp), DIMENSION(:, :), POINTER :: g_so => NULL()
204 : REAL(dp), DIMENSION(:, :), POINTER :: g_soo => NULL()
205 : TYPE(qs_rho_p_type), DIMENSION(:, :), POINTER :: nablavks_set => NULL()
206 : TYPE(nablavks_atom_type), DIMENSION(:), POINTER :: nablavks_atom_set => NULL()
207 : TYPE(qs_rho_p_type), DIMENSION(:, :), POINTER :: bind_set => NULL()
208 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: bind_atom_set => NULL()
209 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: vks_atom_set => NULL()
210 : END TYPE epr_env_type
211 :
212 : ! **************************************************************************************************
213 : TYPE nablavks_atom_type
214 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: nablavks_vec_rad_h => NULL()
215 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: nablavks_vec_rad_s => NULL()
216 : END TYPE nablavks_atom_type
217 :
218 : ! **************************************************************************************************
219 : TYPE jrho_atom_type
220 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc_h => NULL()
221 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc_s => NULL()
222 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc0_h => NULL()
223 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc0_s => NULL()
224 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc_ii_h => NULL()
225 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc_ii_s => NULL()
226 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc_iii_h => NULL()
227 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cjc_iii_s => NULL()
228 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: jrho_vec_rad_h => NULL()
229 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: jrho_vec_rad_s => NULL()
230 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_h => NULL()
231 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_s => NULL()
232 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_a_h => NULL()
233 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_a_s => NULL()
234 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_b_h => NULL()
235 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_b_s => NULL()
236 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_a_h_ii => NULL()
237 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_a_s_ii => NULL()
238 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_b_h_ii => NULL()
239 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_b_s_ii => NULL()
240 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_a_h_iii => NULL()
241 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_a_s_iii => NULL()
242 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_b_h_iii => NULL()
243 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: jrho_b_s_iii => NULL()
244 : END TYPE jrho_atom_type
245 :
246 : ! \param type for dC/dR calculation
247 : TYPE dcdr_env_type
248 : INTEGER :: nao = -1
249 : INTEGER :: orb_center = -1
250 : INTEGER :: beta = -1
251 : INTEGER :: lambda = -1
252 : INTEGER :: output_unit = -1
253 : INTEGER :: nspins = -1
254 : INTEGER, DIMENSION(:), ALLOCATABLE :: nmo
255 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_hc => NULL()
256 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s1 => NULL()
257 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_t1 => NULL()
258 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s => NULL()
259 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_t => NULL()
260 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_ppnl_1 => NULL()
261 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_core_charge_1 => NULL()
262 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_nosym_temp => NULL()
263 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_nosym_temp2 => NULL()
264 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: moments => NULL()
265 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_apply_op_constant => NULL()
266 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: hamiltonian1 => NULL()
267 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: perturbed_dm_correction => NULL()
268 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_vhxc_perturbed_basis => NULL()
269 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_difdip => NULL()
270 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_d_vhxc_dR => NULL()
271 : REAL(dp), DIMENSION(:, :), POINTER :: deltaR => NULL()
272 : REAL(dp), DIMENSION(:, :), POINTER :: delta_basis_function => NULL()
273 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: apt_subset => NULL()
274 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: apt_at_dcdr_per_center => NULL()
275 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: mo_coeff => NULL()
276 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: dCR => NULL()
277 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: dCR_prime => NULL()
278 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: op_dR => NULL()
279 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: chc => NULL()
280 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: ch1c => NULL()
281 : TYPE(cp_fm_type), DIMENSION(:, :), POINTER :: matrix_m_alpha => NULL()
282 : CHARACTER(LEN=30) :: orb_center_name = ""
283 : TYPE(cp_2d_i_p_type), DIMENSION(:), POINTER :: center_list => NULL()
284 : TYPE(cp_2d_r_p_type), DIMENSION(:), POINTER :: centers_set => NULL()
285 : INTEGER, DIMENSION(2) :: nbr_center = -1
286 : INTEGER, DIMENSION(2) :: nstates = -1
287 : REAL(dp), DIMENSION(3) :: ref_point = 0.0_dp
288 : REAL(dp), DIMENSION(3) :: dipole_pos = 0.0_dp
289 : LOGICAL :: localized_psi0 = .FALSE.
290 : INTEGER, POINTER :: list_of_atoms(:) => NULL()
291 : LOGICAL :: distributed_origin = .FALSE.
292 : LOGICAL :: z_matrix_method = .FALSE.
293 : TYPE(cp_fm_struct_type), POINTER :: aoao_fm_struct => NULL()
294 : TYPE(cp_fm_struct_type), POINTER :: homohomo_fm_struct => NULL()
295 : TYPE(cp_fm_struct_p_type), DIMENSION(:), POINTER :: momo_fm_struct => NULL()
296 : TYPE(cp_fm_struct_p_type), DIMENSION(:), POINTER :: likemos_fm_struct => NULL()
297 : REAL(dp), DIMENSION(:, :, :), POINTER :: apt_el_dcdr => NULL()
298 : REAL(dp), DIMENSION(:, :, :), POINTER :: apt_nuc_dcdr => NULL()
299 : REAL(dp), DIMENSION(:, :, :), POINTER :: apt_total_dcdr => NULL()
300 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: apt_el_dcdr_per_center => NULL()
301 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: apt_el_dcdr_per_subset => NULL()
302 : END TYPE dcdr_env_type
303 :
304 : ! \param type for VCD calculation
305 : TYPE vcd_env_type
306 : TYPE(dcdr_env_type) :: dcdr_env = dcdr_env_type()
307 :
308 : INTEGER :: output_unit = -1
309 : REAL(dp), DIMENSION(3) :: spatial_origin = 0.0_dp
310 : REAL(dp), DIMENSION(3) :: spatial_origin_atom = 0.0_dp
311 : REAL(dp), DIMENSION(3) :: magnetic_origin = 0.0_dp
312 : REAL(dp), DIMENSION(3) :: magnetic_origin_atom = 0.0_dp
313 : LOGICAL :: distributed_origin = .FALSE.
314 : LOGICAL :: origin_dependent_op_mfp = .FALSE.
315 : LOGICAL :: do_mfp = .FALSE.
316 :
317 : ! APTs and AATs in velocity form
318 : REAL(dp), DIMENSION(:, :, :), POINTER :: apt_el_nvpt => NULL()
319 : REAL(dp), DIMENSION(:, :, :), POINTER :: apt_nuc_nvpt => NULL()
320 : REAL(dp), DIMENSION(:, :, :), POINTER :: apt_total_nvpt => NULL()
321 : REAL(dp), DIMENSION(:, :, :), POINTER :: aat_atom_nvpt => NULL()
322 : REAL(dp), DIMENSION(:, :, :), POINTER :: aat_atom_mfp => NULL()
323 :
324 : ! Matrices
325 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_dSdV => NULL(), &
326 : matrix_drpnl => NULL(), &
327 : matrix_hxc_dsdv => NULL(), &
328 : hcom => NULL(), &
329 : dipvel_ao => NULL(), &
330 : dipvel_ao_delta => NULL(), &
331 : matrix_rxrv => NULL(), &
332 : matrix_dSdB => NULL()
333 :
334 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_hr => NULL(), &
335 : matrix_rh => NULL(), &
336 : matrix_difdip2 => NULL(), &
337 : moments_der => NULL(), &
338 : moments_der_right => NULL(), &
339 : moments_der_left => NULL(), &
340 : matrix_r_doublecom => NULL(), &
341 : matrix_rcomr => NULL(), &
342 : matrix_rrcom => NULL(), &
343 : matrix_dcom => NULL(), &
344 : matrix_r_rxvr => NULL(), &
345 : matrix_rxvr_r => NULL(), &
346 : matrix_nosym_temp_33 => NULL(), &
347 : matrix_nosym_temp2_33 => NULL()
348 :
349 : TYPE(cp_fm_type), DIMENSION(:), POINTER :: dCV => NULL(), &
350 : dCV_prime => NULL(), &
351 : op_dV => NULL(), &
352 : dCB => NULL(), &
353 : dCB_prime => NULL(), &
354 : op_dB => NULL()
355 : END TYPE vcd_env_type
356 :
357 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_linres_types'
358 :
359 : ! *** Public data types ***
360 :
361 : PUBLIC :: linres_control_type, &
362 : nmr_env_type, issc_env_type, jrho_atom_type, &
363 : epr_env_type, dcdr_env_type, vcd_env_type, &
364 : nablavks_atom_type, current_env_type, &
365 : polar_env_type
366 :
367 : ! *** Public subroutines ***
368 :
369 : PUBLIC :: allocate_jrho_atom_rad, deallocate_jrho_atom_set, get_nmr_env, &
370 : get_current_env, allocate_jrho_coeff, init_jrho_atom_set, init_nablavks_atom_set, &
371 : linres_control_release, set_epr_env, deallocate_nablavks_atom_set, &
372 : set2zero_jrho_atom_rad, get_epr_env, get_issc_env, set_current_env, &
373 : get_polar_env, polar_env_release, set_polar_env
374 :
375 : CONTAINS
376 :
377 : ! **************************************************************************************************
378 : !> \brief ...
379 : !> \param linres_control ...
380 : ! **************************************************************************************************
381 1644 : SUBROUTINE linres_control_release(linres_control)
382 :
383 : TYPE(linres_control_type), INTENT(INOUT) :: linres_control
384 :
385 1644 : IF (ASSOCIATED(linres_control%qs_loc_env)) THEN
386 190 : CALL qs_loc_env_release(linres_control%qs_loc_env)
387 190 : DEALLOCATE (linres_control%qs_loc_env)
388 : END IF
389 :
390 1644 : END SUBROUTINE linres_control_release
391 :
392 : ! **************************************************************************************************
393 : !> \brief ...
394 : !> \param current_env ...
395 : !> \param simple_done ...
396 : !> \param simple_converged ...
397 : !> \param full_done ...
398 : !> \param nao ...
399 : !> \param nstates ...
400 : !> \param gauge ...
401 : !> \param list_cubes ...
402 : !> \param statetrueindex ...
403 : !> \param gauge_name ...
404 : !> \param basisfun_center ...
405 : !> \param nbr_center ...
406 : !> \param center_list ...
407 : !> \param centers_set ...
408 : !> \param psi1_p ...
409 : !> \param psi1_rxp ...
410 : !> \param psi1_D ...
411 : !> \param p_psi0 ...
412 : !> \param rxp_psi0 ...
413 : !> \param jrho1_atom_set ...
414 : !> \param jrho1_set ...
415 : !> \param chi_tensor ...
416 : !> \param chi_tensor_loc ...
417 : !> \param gauge_atom_radius ...
418 : !> \param rs_gauge ...
419 : !> \param use_old_gauge_atom ...
420 : !> \param chi_pbc ...
421 : !> \param psi0_order ...
422 : ! **************************************************************************************************
423 5546 : SUBROUTINE get_current_env(current_env, simple_done, simple_converged, full_done, nao, &
424 : nstates, gauge, list_cubes, statetrueindex, gauge_name, basisfun_center, &
425 : nbr_center, center_list, centers_set, psi1_p, psi1_rxp, psi1_D, p_psi0, &
426 : rxp_psi0, jrho1_atom_set, jrho1_set, chi_tensor, &
427 : chi_tensor_loc, gauge_atom_radius, rs_gauge, use_old_gauge_atom, &
428 : chi_pbc, psi0_order)
429 :
430 : TYPE(current_env_type), OPTIONAL :: current_env
431 : LOGICAL, OPTIONAL :: simple_done(6), simple_converged(6)
432 : LOGICAL, DIMENSION(:, :), OPTIONAL, POINTER :: full_done
433 : INTEGER, OPTIONAL :: nao, nstates(2), gauge
434 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: list_cubes
435 : INTEGER, DIMENSION(:, :, :), OPTIONAL, POINTER :: statetrueindex
436 : CHARACTER(LEN=30), OPTIONAL :: gauge_name
437 : REAL(dp), DIMENSION(:, :), OPTIONAL, POINTER :: basisfun_center
438 : INTEGER, OPTIONAL :: nbr_center(2)
439 : TYPE(cp_2d_i_p_type), DIMENSION(:), OPTIONAL, &
440 : POINTER :: center_list
441 : TYPE(cp_2d_r_p_type), DIMENSION(:), OPTIONAL, &
442 : POINTER :: centers_set
443 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
444 : POINTER :: psi1_p, psi1_rxp, psi1_D, p_psi0, &
445 : rxp_psi0
446 : TYPE(jrho_atom_type), DIMENSION(:), OPTIONAL, &
447 : POINTER :: jrho1_atom_set
448 : TYPE(qs_rho_p_type), DIMENSION(:), OPTIONAL, &
449 : POINTER :: jrho1_set
450 : REAL(dp), INTENT(OUT), OPTIONAL :: chi_tensor(3, 3, 2), &
451 : chi_tensor_loc(3, 3, 2), &
452 : gauge_atom_radius
453 : TYPE(realspace_grid_type), DIMENSION(:, :), &
454 : OPTIONAL, POINTER :: rs_gauge
455 : LOGICAL, OPTIONAL :: use_old_gauge_atom, chi_pbc
456 : TYPE(cp_fm_type), DIMENSION(:), OPTIONAL, POINTER :: psi0_order
457 :
458 5546 : IF (PRESENT(simple_done)) simple_done(1:6) = current_env%simple_done(1:6)
459 5546 : IF (PRESENT(simple_converged)) simple_converged(1:6) = current_env%simple_converged(1:6)
460 5546 : IF (PRESENT(full_done)) full_done => current_env%full_done
461 5546 : IF (PRESENT(nao)) nao = current_env%nao
462 9722 : IF (PRESENT(nstates)) nstates(1:2) = current_env%nstates(1:2)
463 5546 : IF (PRESENT(gauge)) gauge = current_env%gauge
464 5546 : IF (PRESENT(list_cubes)) list_cubes => current_env%list_cubes
465 5546 : IF (PRESENT(statetrueindex)) statetrueindex => current_env%statetrueindex
466 5546 : IF (PRESENT(gauge_name)) gauge_name = current_env%gauge_name
467 5546 : IF (PRESENT(basisfun_center)) basisfun_center => current_env%basisfun_center
468 8156 : IF (PRESENT(nbr_center)) nbr_center(1:2) = current_env%nbr_center(1:2)
469 5546 : IF (PRESENT(center_list)) center_list => current_env%center_list
470 5546 : IF (PRESENT(centers_set)) centers_set => current_env%centers_set
471 11000 : IF (PRESENT(chi_tensor)) chi_tensor(:, :, :) = current_env%chi_tensor(:, :, :)
472 9866 : IF (PRESENT(chi_tensor_loc)) chi_tensor_loc(:, :, :) = current_env%chi_tensor_loc(:, :, :)
473 5546 : IF (PRESENT(psi1_p)) psi1_p => current_env%psi1_p
474 5546 : IF (PRESENT(psi1_rxp)) psi1_rxp => current_env%psi1_rxp
475 5546 : IF (PRESENT(psi1_D)) psi1_D => current_env%psi1_D
476 5546 : IF (PRESENT(p_psi0)) p_psi0 => current_env%p_psi0
477 5546 : IF (PRESENT(rxp_psi0)) rxp_psi0 => current_env%rxp_psi0
478 5546 : IF (PRESENT(jrho1_atom_set)) jrho1_atom_set => current_env%jrho1_atom_set
479 5546 : IF (PRESENT(jrho1_set)) jrho1_set => current_env%jrho1_set
480 5546 : IF (PRESENT(rs_gauge)) rs_gauge => current_env%rs_gauge
481 5546 : IF (PRESENT(psi0_order)) psi0_order => current_env%psi0_order
482 5546 : IF (PRESENT(chi_pbc)) chi_pbc = current_env%chi_pbc
483 5546 : IF (PRESENT(gauge_atom_radius)) gauge_atom_radius = current_env%gauge_atom_radius
484 5546 : IF (PRESENT(use_old_gauge_atom)) use_old_gauge_atom = current_env%use_old_gauge_atom
485 :
486 5546 : END SUBROUTINE get_current_env
487 :
488 : ! **************************************************************************************************
489 : !> \brief ...
490 : !> \param nmr_env ...
491 : !> \param n_nics ...
492 : !> \param cs_atom_list ...
493 : !> \param do_calc_cs_atom ...
494 : !> \param r_nics ...
495 : !> \param chemical_shift ...
496 : !> \param chemical_shift_loc ...
497 : !> \param chemical_shift_nics_loc ...
498 : !> \param chemical_shift_nics ...
499 : !> \param shift_gapw_radius ...
500 : !> \param do_nics ...
501 : !> \param interpolate_shift ...
502 : ! **************************************************************************************************
503 3412 : SUBROUTINE get_nmr_env(nmr_env, n_nics, cs_atom_list, do_calc_cs_atom, &
504 : r_nics, chemical_shift, chemical_shift_loc, &
505 : chemical_shift_nics_loc, chemical_shift_nics, &
506 : shift_gapw_radius, do_nics, interpolate_shift)
507 :
508 : TYPE(nmr_env_type) :: nmr_env
509 : INTEGER, INTENT(OUT), OPTIONAL :: n_nics
510 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: cs_atom_list, do_calc_cs_atom
511 : REAL(dp), DIMENSION(:, :), OPTIONAL, POINTER :: r_nics
512 : REAL(dp), DIMENSION(:, :, :), OPTIONAL, POINTER :: chemical_shift, chemical_shift_loc, &
513 : chemical_shift_nics_loc, &
514 : chemical_shift_nics
515 : REAL(dp), INTENT(OUT), OPTIONAL :: shift_gapw_radius
516 : LOGICAL, INTENT(OUT), OPTIONAL :: do_nics, interpolate_shift
517 :
518 3412 : IF (PRESENT(n_nics)) n_nics = nmr_env%n_nics
519 3412 : IF (PRESENT(cs_atom_list)) cs_atom_list => nmr_env%cs_atom_list
520 3412 : IF (PRESENT(do_calc_cs_atom)) do_calc_cs_atom => nmr_env%do_calc_cs_atom
521 3412 : IF (PRESENT(chemical_shift)) chemical_shift => nmr_env%chemical_shift
522 3412 : IF (PRESENT(chemical_shift_loc)) chemical_shift_loc => nmr_env%chemical_shift_loc
523 3412 : IF (PRESENT(chemical_shift_nics)) chemical_shift_nics => nmr_env%chemical_shift_nics
524 3412 : IF (PRESENT(r_nics)) r_nics => nmr_env%r_nics
525 3412 : IF (PRESENT(chemical_shift_nics_loc)) chemical_shift_nics_loc => nmr_env%chemical_shift_nics_loc
526 3412 : IF (PRESENT(shift_gapw_radius)) shift_gapw_radius = nmr_env%shift_gapw_radius
527 3412 : IF (PRESENT(do_nics)) do_nics = nmr_env%do_nics
528 3412 : IF (PRESENT(interpolate_shift)) interpolate_shift = nmr_env%interpolate_shift
529 :
530 3412 : END SUBROUTINE get_nmr_env
531 :
532 : ! **************************************************************************************************
533 : !> \brief ...
534 : !> \param issc_env ...
535 : !> \param issc_on_atom_list ...
536 : !> \param issc_gapw_radius ...
537 : !> \param issc_loc ...
538 : !> \param do_fc ...
539 : !> \param do_sd ...
540 : !> \param do_pso ...
541 : !> \param do_dso ...
542 : !> \param issc ...
543 : !> \param interpolate_issc ...
544 : !> \param psi1_efg ...
545 : !> \param psi1_pso ...
546 : !> \param psi1_dso ...
547 : !> \param psi1_fc ...
548 : !> \param efg_psi0 ...
549 : !> \param pso_psi0 ...
550 : !> \param dso_psi0 ...
551 : !> \param fc_psi0 ...
552 : !> \param matrix_efg ...
553 : !> \param matrix_pso ...
554 : !> \param matrix_dso ...
555 : !> \param matrix_fc ...
556 : ! **************************************************************************************************
557 144 : SUBROUTINE get_issc_env(issc_env, issc_on_atom_list, issc_gapw_radius, issc_loc, &
558 : do_fc, do_sd, do_pso, do_dso, &
559 : issc, interpolate_issc, psi1_efg, psi1_pso, psi1_dso, psi1_fc, efg_psi0, pso_psi0, dso_psi0, fc_psi0, &
560 : matrix_efg, matrix_pso, matrix_dso, matrix_fc)
561 :
562 : TYPE(issc_env_type) :: issc_env
563 : INTEGER, DIMENSION(:), OPTIONAL, POINTER :: issc_on_atom_list
564 : REAL(dp), OPTIONAL :: issc_gapw_radius
565 : REAL(dp), DIMENSION(:, :, :, :, :), OPTIONAL, &
566 : POINTER :: issc_loc
567 : LOGICAL, OPTIONAL :: do_fc, do_sd, do_pso, do_dso
568 : REAL(dp), DIMENSION(:, :, :, :, :), OPTIONAL, &
569 : POINTER :: issc
570 : LOGICAL, OPTIONAL :: interpolate_issc
571 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
572 : POINTER :: psi1_efg, psi1_pso, psi1_dso
573 : TYPE(cp_fm_type), DIMENSION(:), OPTIONAL, POINTER :: psi1_fc
574 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
575 : POINTER :: efg_psi0, pso_psi0, dso_psi0
576 : TYPE(cp_fm_type), DIMENSION(:), OPTIONAL, POINTER :: fc_psi0
577 : TYPE(dbcsr_p_type), DIMENSION(:), OPTIONAL, &
578 : POINTER :: matrix_efg, matrix_pso, matrix_dso, &
579 : matrix_fc
580 :
581 144 : IF (PRESENT(issc_on_atom_list)) issc_on_atom_list => issc_env%issc_on_atom_list
582 144 : IF (PRESENT(issc_gapw_radius)) issc_gapw_radius = issc_env%issc_gapw_radius
583 144 : IF (PRESENT(issc_loc)) issc_loc => issc_env%issc_loc
584 144 : IF (PRESENT(issc)) issc => issc_env%issc
585 144 : IF (PRESENT(interpolate_issc)) interpolate_issc = issc_env%interpolate_issc
586 144 : IF (PRESENT(psi1_efg)) psi1_efg => issc_env%psi1_efg
587 144 : IF (PRESENT(psi1_pso)) psi1_pso => issc_env%psi1_pso
588 144 : IF (PRESENT(psi1_dso)) psi1_dso => issc_env%psi1_dso
589 144 : IF (PRESENT(psi1_fc)) psi1_fc => issc_env%psi1_fc
590 144 : IF (PRESENT(efg_psi0)) efg_psi0 => issc_env%efg_psi0
591 144 : IF (PRESENT(pso_psi0)) pso_psi0 => issc_env%pso_psi0
592 144 : IF (PRESENT(dso_psi0)) dso_psi0 => issc_env%dso_psi0
593 144 : IF (PRESENT(fc_psi0)) fc_psi0 => issc_env%fc_psi0
594 144 : IF (PRESENT(matrix_efg)) matrix_efg => issc_env%matrix_efg
595 144 : IF (PRESENT(matrix_pso)) matrix_pso => issc_env%matrix_pso
596 144 : IF (PRESENT(matrix_fc)) matrix_fc => issc_env%matrix_fc
597 144 : IF (PRESENT(matrix_dso)) matrix_dso => issc_env%matrix_dso
598 144 : IF (PRESENT(do_fc)) do_fc = issc_env%do_fc
599 144 : IF (PRESENT(do_sd)) do_sd = issc_env%do_sd
600 144 : IF (PRESENT(do_pso)) do_pso = issc_env%do_pso
601 144 : IF (PRESENT(do_dso)) do_dso = issc_env%do_dso
602 :
603 144 : END SUBROUTINE get_issc_env
604 :
605 : ! **************************************************************************************************
606 : !> \brief ...
607 : !> \param current_env ...
608 : !> \param jrho1_atom_set ...
609 : !> \param jrho1_set ...
610 : ! **************************************************************************************************
611 96 : SUBROUTINE set_current_env(current_env, jrho1_atom_set, jrho1_set)
612 :
613 : TYPE(current_env_type) :: current_env
614 : TYPE(jrho_atom_type), DIMENSION(:), OPTIONAL, &
615 : POINTER :: jrho1_atom_set
616 : TYPE(qs_rho_p_type), DIMENSION(:), OPTIONAL, &
617 : POINTER :: jrho1_set
618 :
619 : INTEGER :: idir
620 :
621 96 : IF (PRESENT(jrho1_atom_set)) THEN
622 96 : IF (ASSOCIATED(current_env%jrho1_atom_set)) THEN
623 0 : CALL deallocate_jrho_atom_set(current_env%jrho1_atom_set)
624 : END IF
625 96 : current_env%jrho1_atom_set => jrho1_atom_set
626 : END IF
627 :
628 96 : IF (PRESENT(jrho1_set)) THEN
629 0 : IF (ASSOCIATED(current_env%jrho1_set)) THEN
630 0 : DO idir = 1, 3
631 0 : CALL qs_rho_release(current_env%jrho1_set(idir)%rho)
632 0 : DEALLOCATE (current_env%jrho1_set(idir)%rho)
633 : END DO
634 : END IF
635 0 : current_env%jrho1_set => jrho1_set
636 : END IF
637 :
638 96 : END SUBROUTINE set_current_env
639 :
640 : ! **************************************************************************************************
641 : !> \brief ...
642 : !> \param epr_env ...
643 : !> \param g_total ...
644 : !> \param g_so ...
645 : !> \param g_soo ...
646 : !> \param nablavks_set ...
647 : !> \param nablavks_atom_set ...
648 : !> \param bind_set ...
649 : !> \param bind_atom_set ...
650 : ! **************************************************************************************************
651 140 : SUBROUTINE get_epr_env(epr_env, g_total, g_so, g_soo, nablavks_set, nablavks_atom_set, &
652 : bind_set, bind_atom_set)
653 :
654 : TYPE(epr_env_type) :: epr_env
655 : REAL(dp), DIMENSION(:, :), OPTIONAL, POINTER :: g_total, g_so, g_soo
656 : TYPE(qs_rho_p_type), DIMENSION(:, :), OPTIONAL, &
657 : POINTER :: nablavks_set
658 : TYPE(nablavks_atom_type), DIMENSION(:), OPTIONAL, &
659 : POINTER :: nablavks_atom_set
660 : TYPE(qs_rho_p_type), DIMENSION(:, :), OPTIONAL, &
661 : POINTER :: bind_set
662 : TYPE(rho_atom_coeff), DIMENSION(:, :), OPTIONAL, &
663 : POINTER :: bind_atom_set
664 :
665 140 : IF (PRESENT(g_total)) g_total => epr_env%g_total
666 140 : IF (PRESENT(g_so)) g_so => epr_env%g_so
667 140 : IF (PRESENT(g_soo)) g_soo => epr_env%g_soo
668 140 : IF (PRESENT(nablavks_set)) nablavks_set => epr_env%nablavks_set
669 140 : IF (PRESENT(nablavks_atom_set)) nablavks_atom_set => epr_env%nablavks_atom_set
670 140 : IF (PRESENT(bind_set)) bind_set => epr_env%bind_set
671 140 : IF (PRESENT(bind_atom_set)) bind_atom_set => epr_env%bind_atom_set
672 :
673 140 : END SUBROUTINE get_epr_env
674 :
675 : ! **************************************************************************************************
676 : !> \brief ...
677 : !> \param epr_env ...
678 : !> \param g_free_factor ...
679 : !> \param g_soo_chicorr_factor ...
680 : !> \param g_soo_factor ...
681 : !> \param g_so_factor ...
682 : !> \param g_so_factor_gapw ...
683 : !> \param g_zke_factor ...
684 : !> \param nablavks_set ...
685 : !> \param nablavks_atom_set ...
686 : ! **************************************************************************************************
687 10 : SUBROUTINE set_epr_env(epr_env, g_free_factor, g_soo_chicorr_factor, &
688 : g_soo_factor, g_so_factor, g_so_factor_gapw, &
689 : g_zke_factor, nablavks_set, nablavks_atom_set)
690 :
691 : TYPE(epr_env_type) :: epr_env
692 : REAL(dp), INTENT(IN), OPTIONAL :: g_free_factor, g_soo_chicorr_factor, &
693 : g_soo_factor, g_so_factor, &
694 : g_so_factor_gapw, g_zke_factor
695 : TYPE(qs_rho_p_type), DIMENSION(:, :), OPTIONAL, &
696 : POINTER :: nablavks_set
697 : TYPE(nablavks_atom_type), DIMENSION(:), OPTIONAL, &
698 : POINTER :: nablavks_atom_set
699 :
700 : INTEGER :: idir, ispin
701 :
702 10 : IF (PRESENT(g_free_factor)) epr_env%g_free_factor = g_free_factor
703 10 : IF (PRESENT(g_zke_factor)) epr_env%g_zke_factor = g_zke_factor
704 10 : IF (PRESENT(g_so_factor)) epr_env%g_so_factor = g_so_factor
705 10 : IF (PRESENT(g_so_factor_gapw)) epr_env%g_so_factor_gapw = g_so_factor_gapw
706 10 : IF (PRESENT(g_soo_factor)) epr_env%g_soo_factor = g_soo_factor
707 10 : IF (PRESENT(g_soo_chicorr_factor)) epr_env%g_soo_chicorr_factor = g_soo_chicorr_factor
708 :
709 10 : IF (PRESENT(nablavks_set)) THEN
710 0 : IF (ASSOCIATED(epr_env%nablavks_set)) THEN
711 0 : DO ispin = 1, 2
712 0 : DO idir = 1, 3
713 0 : CALL qs_rho_release(epr_env%nablavks_set(idir, ispin)%rho)
714 0 : DEALLOCATE (epr_env%nablavks_set(idir, ispin)%rho)
715 : END DO
716 : END DO
717 : END IF
718 0 : epr_env%nablavks_set => nablavks_set
719 : END IF
720 :
721 10 : IF (PRESENT(nablavks_atom_set)) THEN
722 10 : IF (ASSOCIATED(epr_env%nablavks_atom_set)) THEN
723 0 : CALL deallocate_nablavks_atom_set(epr_env%nablavks_atom_set)
724 : END IF
725 10 : epr_env%nablavks_atom_set => nablavks_atom_set
726 : END IF
727 :
728 10 : END SUBROUTINE set_epr_env
729 :
730 : ! **************************************************************************************************
731 : !> \brief ...
732 : !> \param nablavks_atom_set ...
733 : !> \param natom ...
734 : ! **************************************************************************************************
735 10 : SUBROUTINE allocate_nablavks_atom_set(nablavks_atom_set, natom)
736 :
737 : TYPE(nablavks_atom_type), DIMENSION(:), POINTER :: nablavks_atom_set
738 : INTEGER, INTENT(IN) :: natom
739 :
740 : INTEGER :: iat
741 :
742 60 : ALLOCATE (nablavks_atom_set(natom))
743 :
744 40 : DO iat = 1, natom
745 30 : NULLIFY (nablavks_atom_set(iat)%nablavks_vec_rad_h)
746 40 : NULLIFY (nablavks_atom_set(iat)%nablavks_vec_rad_s)
747 : END DO
748 10 : END SUBROUTINE allocate_nablavks_atom_set
749 :
750 : ! **************************************************************************************************
751 : !> \brief ...
752 : !> \param nablavks_atom_set ...
753 : ! **************************************************************************************************
754 10 : SUBROUTINE deallocate_nablavks_atom_set(nablavks_atom_set)
755 :
756 : TYPE(nablavks_atom_type), DIMENSION(:), POINTER :: nablavks_atom_set
757 :
758 : INTEGER :: i, iat, idir, n, natom
759 :
760 10 : CPASSERT(ASSOCIATED(nablavks_atom_set))
761 10 : natom = SIZE(nablavks_atom_set)
762 :
763 40 : DO iat = 1, natom
764 40 : IF (ASSOCIATED(nablavks_atom_set(iat)%nablavks_vec_rad_h)) THEN
765 30 : IF (ASSOCIATED(nablavks_atom_set(iat)%nablavks_vec_rad_h(1, 1)%r_coef)) THEN
766 30 : n = SIZE(nablavks_atom_set(iat)%nablavks_vec_rad_h, 2)
767 90 : DO i = 1, n
768 270 : DO idir = 1, 3
769 180 : DEALLOCATE (nablavks_atom_set(iat)%nablavks_vec_rad_h(idir, i)%r_coef)
770 240 : DEALLOCATE (nablavks_atom_set(iat)%nablavks_vec_rad_s(idir, i)%r_coef)
771 : END DO
772 : END DO
773 : END IF
774 30 : DEALLOCATE (nablavks_atom_set(iat)%nablavks_vec_rad_h)
775 30 : DEALLOCATE (nablavks_atom_set(iat)%nablavks_vec_rad_s)
776 : END IF
777 : END DO
778 10 : DEALLOCATE (nablavks_atom_set)
779 10 : END SUBROUTINE deallocate_nablavks_atom_set
780 :
781 : ! **************************************************************************************************
782 : !> \brief ...
783 : !> \param jrho_atom_set ...
784 : ! **************************************************************************************************
785 96 : SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set)
786 :
787 : TYPE(jrho_atom_type), DIMENSION(:), POINTER :: jrho_atom_set
788 :
789 : INTEGER :: i, iat, idir, n, natom
790 :
791 96 : CPASSERT(ASSOCIATED(jrho_atom_set))
792 96 : natom = SIZE(jrho_atom_set)
793 :
794 412 : DO iat = 1, natom
795 316 : IF (ASSOCIATED(jrho_atom_set(iat)%cjc_h)) THEN
796 316 : IF (ASSOCIATED(jrho_atom_set(iat)%cjc_h(1)%r_coef)) THEN
797 186 : n = SIZE(jrho_atom_set(iat)%cjc_h)
798 478 : DO i = 1, n
799 : !
800 : ! size = (nsotot,nsotot) replicated
801 0 : DEALLOCATE (jrho_atom_set(iat)%cjc0_h(i)%r_coef, &
802 0 : jrho_atom_set(iat)%cjc0_s(i)%r_coef, &
803 0 : jrho_atom_set(iat)%cjc_h(i)%r_coef, &
804 0 : jrho_atom_set(iat)%cjc_s(i)%r_coef, &
805 0 : jrho_atom_set(iat)%cjc_ii_h(i)%r_coef, &
806 0 : jrho_atom_set(iat)%cjc_ii_s(i)%r_coef, &
807 0 : jrho_atom_set(iat)%cjc_iii_h(i)%r_coef, &
808 478 : jrho_atom_set(iat)%cjc_iii_s(i)%r_coef)
809 : END DO
810 : END IF
811 0 : DEALLOCATE (jrho_atom_set(iat)%cjc0_h, &
812 0 : jrho_atom_set(iat)%cjc0_s, &
813 0 : jrho_atom_set(iat)%cjc_h, &
814 0 : jrho_atom_set(iat)%cjc_s, &
815 0 : jrho_atom_set(iat)%cjc_ii_h, &
816 0 : jrho_atom_set(iat)%cjc_ii_s, &
817 0 : jrho_atom_set(iat)%cjc_iii_h, &
818 316 : jrho_atom_set(iat)%cjc_iii_s)
819 : END IF
820 :
821 316 : IF (ASSOCIATED(jrho_atom_set(iat)%jrho_a_h)) THEN
822 316 : IF (ASSOCIATED(jrho_atom_set(iat)%jrho_a_h(1)%r_coef)) THEN
823 94 : n = SIZE(jrho_atom_set(iat)%jrho_a_h)
824 241 : DO i = 1, n
825 : !
826 : ! size = (nr,max_iso_not0) distributed
827 0 : DEALLOCATE (jrho_atom_set(iat)%jrho_h(i)%r_coef, &
828 0 : jrho_atom_set(iat)%jrho_s(i)%r_coef, &
829 0 : jrho_atom_set(iat)%jrho_a_h(i)%r_coef, &
830 0 : jrho_atom_set(iat)%jrho_a_s(i)%r_coef, &
831 0 : jrho_atom_set(iat)%jrho_b_h(i)%r_coef, &
832 0 : jrho_atom_set(iat)%jrho_b_s(i)%r_coef, &
833 0 : jrho_atom_set(iat)%jrho_a_h_ii(i)%r_coef, &
834 0 : jrho_atom_set(iat)%jrho_a_s_ii(i)%r_coef, &
835 0 : jrho_atom_set(iat)%jrho_b_h_ii(i)%r_coef, &
836 0 : jrho_atom_set(iat)%jrho_b_s_ii(i)%r_coef, &
837 0 : jrho_atom_set(iat)%jrho_a_h_iii(i)%r_coef, &
838 0 : jrho_atom_set(iat)%jrho_a_s_iii(i)%r_coef, &
839 0 : jrho_atom_set(iat)%jrho_b_h_iii(i)%r_coef, &
840 241 : jrho_atom_set(iat)%jrho_b_s_iii(i)%r_coef)
841 : END DO
842 : END IF
843 0 : DEALLOCATE (jrho_atom_set(iat)%jrho_h, &
844 0 : jrho_atom_set(iat)%jrho_s, &
845 0 : jrho_atom_set(iat)%jrho_a_h, &
846 0 : jrho_atom_set(iat)%jrho_a_s, &
847 0 : jrho_atom_set(iat)%jrho_b_h, &
848 0 : jrho_atom_set(iat)%jrho_b_s, &
849 0 : jrho_atom_set(iat)%jrho_a_h_ii, &
850 0 : jrho_atom_set(iat)%jrho_a_s_ii, &
851 0 : jrho_atom_set(iat)%jrho_b_h_ii, &
852 0 : jrho_atom_set(iat)%jrho_b_s_ii, &
853 0 : jrho_atom_set(iat)%jrho_a_h_iii, &
854 0 : jrho_atom_set(iat)%jrho_a_s_iii, &
855 0 : jrho_atom_set(iat)%jrho_b_h_iii, &
856 316 : jrho_atom_set(iat)%jrho_b_s_iii)
857 : END IF
858 :
859 412 : IF (ASSOCIATED(jrho_atom_set(iat)%jrho_vec_rad_h)) THEN
860 316 : IF (ASSOCIATED(jrho_atom_set(iat)%jrho_vec_rad_h(1, 1)%r_coef)) THEN
861 94 : n = SIZE(jrho_atom_set(iat)%jrho_vec_rad_h, 2)
862 241 : DO i = 1, n
863 682 : DO idir = 1, 3
864 : !
865 : ! size =(nr,na) distributed
866 0 : DEALLOCATE (jrho_atom_set(iat)%jrho_vec_rad_h(idir, i)%r_coef, &
867 588 : jrho_atom_set(iat)%jrho_vec_rad_s(idir, i)%r_coef)
868 : END DO
869 : END DO
870 : END IF
871 0 : DEALLOCATE (jrho_atom_set(iat)%jrho_vec_rad_h, &
872 316 : jrho_atom_set(iat)%jrho_vec_rad_s)
873 : END IF
874 : END DO
875 96 : DEALLOCATE (jrho_atom_set)
876 :
877 96 : END SUBROUTINE deallocate_jrho_atom_set
878 :
879 : ! **************************************************************************************************
880 : !> \brief ...
881 : !> \param jrho1_atom ...
882 : !> \param ispin ...
883 : !> \param nr ...
884 : !> \param na ...
885 : !> \param max_iso_not0 ...
886 : ! **************************************************************************************************
887 147 : SUBROUTINE allocate_jrho_atom_rad(jrho1_atom, ispin, nr, na, max_iso_not0)
888 :
889 : TYPE(jrho_atom_type), POINTER :: jrho1_atom
890 : INTEGER, INTENT(IN) :: ispin, nr, na, max_iso_not0
891 :
892 : CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_atom_rad'
893 :
894 : INTEGER :: handle, idir
895 :
896 147 : CALL timeset(routineN, handle)
897 :
898 147 : CPASSERT(ASSOCIATED(jrho1_atom))
899 :
900 588 : DO idir = 1, 3
901 : ALLOCATE (jrho1_atom%jrho_vec_rad_h(idir, ispin)%r_coef(nr, na), &
902 3087 : jrho1_atom%jrho_vec_rad_s(idir, ispin)%r_coef(nr, na))
903 1079079 : jrho1_atom%jrho_vec_rad_h(idir, ispin)%r_coef = 0.0_dp
904 1079226 : jrho1_atom%jrho_vec_rad_s(idir, ispin)%r_coef = 0.0_dp
905 : END DO
906 :
907 : ALLOCATE (jrho1_atom%jrho_h(ispin)%r_coef(nr, max_iso_not0), &
908 : jrho1_atom%jrho_s(ispin)%r_coef(nr, max_iso_not0), &
909 : jrho1_atom%jrho_a_h(ispin)%r_coef(nr, max_iso_not0), &
910 : jrho1_atom%jrho_a_s(ispin)%r_coef(nr, max_iso_not0), &
911 : jrho1_atom%jrho_b_h(ispin)%r_coef(nr, max_iso_not0), &
912 : jrho1_atom%jrho_b_s(ispin)%r_coef(nr, max_iso_not0), &
913 : jrho1_atom%jrho_a_h_ii(ispin)%r_coef(nr, max_iso_not0), &
914 : jrho1_atom%jrho_a_s_ii(ispin)%r_coef(nr, max_iso_not0), &
915 : jrho1_atom%jrho_b_h_ii(ispin)%r_coef(nr, max_iso_not0), &
916 : jrho1_atom%jrho_b_s_ii(ispin)%r_coef(nr, max_iso_not0), &
917 : jrho1_atom%jrho_a_h_iii(ispin)%r_coef(nr, max_iso_not0), &
918 : jrho1_atom%jrho_a_s_iii(ispin)%r_coef(nr, max_iso_not0), &
919 : jrho1_atom%jrho_b_h_iii(ispin)%r_coef(nr, max_iso_not0), &
920 6321 : jrho1_atom%jrho_b_s_iii(ispin)%r_coef(nr, max_iso_not0))
921 : !
922 85690 : jrho1_atom%jrho_h(ispin)%r_coef = 0.0_dp
923 85690 : jrho1_atom%jrho_s(ispin)%r_coef = 0.0_dp
924 85690 : jrho1_atom%jrho_a_h(ispin)%r_coef = 0.0_dp
925 85690 : jrho1_atom%jrho_a_s(ispin)%r_coef = 0.0_dp
926 85690 : jrho1_atom%jrho_b_h(ispin)%r_coef = 0.0_dp
927 85690 : jrho1_atom%jrho_b_s(ispin)%r_coef = 0.0_dp
928 85690 : jrho1_atom%jrho_a_h_ii(ispin)%r_coef = 0.0_dp
929 85690 : jrho1_atom%jrho_a_s_ii(ispin)%r_coef = 0.0_dp
930 85690 : jrho1_atom%jrho_b_h_ii(ispin)%r_coef = 0.0_dp
931 85690 : jrho1_atom%jrho_b_s_ii(ispin)%r_coef = 0.0_dp
932 85690 : jrho1_atom%jrho_a_h_iii(ispin)%r_coef = 0.0_dp
933 85690 : jrho1_atom%jrho_a_s_iii(ispin)%r_coef = 0.0_dp
934 85690 : jrho1_atom%jrho_b_h_iii(ispin)%r_coef = 0.0_dp
935 85690 : jrho1_atom%jrho_b_s_iii(ispin)%r_coef = 0.0_dp
936 147 : CALL timestop(handle)
937 :
938 147 : END SUBROUTINE allocate_jrho_atom_rad
939 :
940 : ! **************************************************************************************************
941 : !> \brief ...
942 : !> \param jrho1_atom ...
943 : !> \param ispin ...
944 : ! **************************************************************************************************
945 1176 : SUBROUTINE set2zero_jrho_atom_rad(jrho1_atom, ispin)
946 : !
947 : TYPE(jrho_atom_type), POINTER :: jrho1_atom
948 : INTEGER, INTENT(IN) :: ispin
949 :
950 : !
951 :
952 1176 : CPASSERT(ASSOCIATED(jrho1_atom))
953 : !
954 685520 : jrho1_atom%jrho_h(ispin)%r_coef = 0.0_dp
955 685520 : jrho1_atom%jrho_s(ispin)%r_coef = 0.0_dp
956 : !
957 685520 : jrho1_atom%jrho_a_h(ispin)%r_coef = 0.0_dp
958 685520 : jrho1_atom%jrho_a_s(ispin)%r_coef = 0.0_dp
959 685520 : jrho1_atom%jrho_b_h(ispin)%r_coef = 0.0_dp
960 685520 : jrho1_atom%jrho_b_s(ispin)%r_coef = 0.0_dp
961 : !
962 685520 : jrho1_atom%jrho_a_h_ii(ispin)%r_coef = 0.0_dp
963 685520 : jrho1_atom%jrho_a_s_ii(ispin)%r_coef = 0.0_dp
964 685520 : jrho1_atom%jrho_b_h_ii(ispin)%r_coef = 0.0_dp
965 685520 : jrho1_atom%jrho_b_s_ii(ispin)%r_coef = 0.0_dp
966 : !
967 685520 : jrho1_atom%jrho_a_h_iii(ispin)%r_coef = 0.0_dp
968 685520 : jrho1_atom%jrho_a_s_iii(ispin)%r_coef = 0.0_dp
969 685520 : jrho1_atom%jrho_b_h_iii(ispin)%r_coef = 0.0_dp
970 685520 : jrho1_atom%jrho_b_s_iii(ispin)%r_coef = 0.0_dp
971 : !
972 1176 : END SUBROUTINE set2zero_jrho_atom_rad
973 :
974 : ! **************************************************************************************************
975 :
976 : ! **************************************************************************************************
977 : !> \brief ...
978 : !> \param jrho1_atom_set ...
979 : !> \param iatom ...
980 : !> \param nsotot ...
981 : ! **************************************************************************************************
982 186 : SUBROUTINE allocate_jrho_coeff(jrho1_atom_set, iatom, nsotot)
983 :
984 : TYPE(jrho_atom_type), DIMENSION(:), POINTER :: jrho1_atom_set
985 : INTEGER, INTENT(IN) :: iatom, nsotot
986 :
987 : CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_coeff'
988 :
989 : INTEGER :: handle, i
990 :
991 186 : CALL timeset(routineN, handle)
992 186 : CPASSERT(ASSOCIATED(jrho1_atom_set))
993 478 : DO i = 1, SIZE(jrho1_atom_set(iatom)%cjc0_h, 1)
994 : ALLOCATE (jrho1_atom_set(iatom)%cjc0_h(i)%r_coef(nsotot, nsotot), &
995 : jrho1_atom_set(iatom)%cjc0_s(i)%r_coef(nsotot, nsotot), &
996 : jrho1_atom_set(iatom)%cjc_h(i)%r_coef(nsotot, nsotot), &
997 : jrho1_atom_set(iatom)%cjc_s(i)%r_coef(nsotot, nsotot), &
998 : jrho1_atom_set(iatom)%cjc_ii_h(i)%r_coef(nsotot, nsotot), &
999 : jrho1_atom_set(iatom)%cjc_ii_s(i)%r_coef(nsotot, nsotot), &
1000 : jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef(nsotot, nsotot), &
1001 7300 : jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef(nsotot, nsotot))
1002 90836 : jrho1_atom_set(iatom)%cjc0_h(i)%r_coef = 0.0_dp
1003 90836 : jrho1_atom_set(iatom)%cjc0_s(i)%r_coef = 0.0_dp
1004 90836 : jrho1_atom_set(iatom)%cjc_h(i)%r_coef = 0.0_dp
1005 90836 : jrho1_atom_set(iatom)%cjc_s(i)%r_coef = 0.0_dp
1006 90836 : jrho1_atom_set(iatom)%cjc_ii_h(i)%r_coef = 0.0_dp
1007 90836 : jrho1_atom_set(iatom)%cjc_ii_s(i)%r_coef = 0.0_dp
1008 90836 : jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef = 0.0_dp
1009 91022 : jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef = 0.0_dp
1010 : END DO
1011 186 : CALL timestop(handle)
1012 186 : END SUBROUTINE allocate_jrho_coeff
1013 :
1014 : ! **************************************************************************************************
1015 :
1016 : ! **************************************************************************************************
1017 : !> \brief ...
1018 : !> \param jrho1_atom_set ...
1019 : !> \param iatom ...
1020 : ! **************************************************************************************************
1021 0 : SUBROUTINE deallocate_jrho_coeff(jrho1_atom_set, iatom)
1022 :
1023 : TYPE(jrho_atom_type), DIMENSION(:), POINTER :: jrho1_atom_set
1024 : INTEGER, INTENT(IN) :: iatom
1025 :
1026 : CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_jrho_coeff'
1027 :
1028 : INTEGER :: handle, i
1029 :
1030 0 : CALL timeset(routineN, handle)
1031 0 : CPASSERT(ASSOCIATED(jrho1_atom_set))
1032 0 : DO i = 1, SIZE(jrho1_atom_set(iatom)%cjc0_h, 1)
1033 0 : DEALLOCATE (jrho1_atom_set(iatom)%cjc0_h(i)%r_coef, &
1034 0 : jrho1_atom_set(iatom)%cjc0_s(i)%r_coef, &
1035 0 : jrho1_atom_set(iatom)%cjc_h(i)%r_coef, &
1036 0 : jrho1_atom_set(iatom)%cjc_s(i)%r_coef, &
1037 0 : jrho1_atom_set(iatom)%cjc_ii_h(i)%r_coef, &
1038 0 : jrho1_atom_set(iatom)%cjc_ii_s(i)%r_coef, &
1039 0 : jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef, &
1040 0 : jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef)
1041 : END DO
1042 0 : CALL timestop(handle)
1043 0 : END SUBROUTINE deallocate_jrho_coeff
1044 :
1045 : ! **************************************************************************************************
1046 :
1047 : ! **************************************************************************************************
1048 : !> \brief ...
1049 : !> \param jrho1_atom_set ...
1050 : !> \param iatom ...
1051 : !> \param cjc_h ...
1052 : !> \param cjc_s ...
1053 : !> \param cjc_ii_h ...
1054 : !> \param cjc_ii_s ...
1055 : !> \param cjc_iii_h ...
1056 : !> \param cjc_iii_s ...
1057 : !> \param jrho_vec_rad_h ...
1058 : !> \param jrho_vec_rad_s ...
1059 : ! **************************************************************************************************
1060 0 : SUBROUTINE get_jrho_atom(jrho1_atom_set, iatom, cjc_h, cjc_s, cjc_ii_h, cjc_ii_s, &
1061 : cjc_iii_h, cjc_iii_s, jrho_vec_rad_h, jrho_vec_rad_s)
1062 :
1063 : TYPE(jrho_atom_type), DIMENSION(:), POINTER :: jrho1_atom_set
1064 : INTEGER, INTENT(IN) :: iatom
1065 : TYPE(rho_atom_coeff), DIMENSION(:), OPTIONAL, &
1066 : POINTER :: cjc_h, cjc_s, cjc_ii_h, cjc_ii_s, &
1067 : cjc_iii_h, cjc_iii_s
1068 : TYPE(rho_atom_coeff), DIMENSION(:, :), OPTIONAL, &
1069 : POINTER :: jrho_vec_rad_h, jrho_vec_rad_s
1070 :
1071 0 : CPASSERT(ASSOCIATED(jrho1_atom_set))
1072 :
1073 0 : IF (PRESENT(cjc_h)) cjc_h => jrho1_atom_set(iatom)%cjc_h
1074 0 : IF (PRESENT(cjc_s)) cjc_s => jrho1_atom_set(iatom)%cjc_s
1075 0 : IF (PRESENT(cjc_ii_h)) cjc_ii_h => jrho1_atom_set(iatom)%cjc_ii_h
1076 0 : IF (PRESENT(cjc_ii_s)) cjc_ii_s => jrho1_atom_set(iatom)%cjc_ii_s
1077 0 : IF (PRESENT(cjc_iii_h)) cjc_iii_h => jrho1_atom_set(iatom)%cjc_iii_h
1078 0 : IF (PRESENT(cjc_iii_s)) cjc_iii_s => jrho1_atom_set(iatom)%cjc_iii_s
1079 0 : IF (PRESENT(jrho_vec_rad_h)) jrho_vec_rad_h => jrho1_atom_set(iatom)%jrho_vec_rad_h
1080 0 : IF (PRESENT(jrho_vec_rad_s)) jrho_vec_rad_s => jrho1_atom_set(iatom)%jrho_vec_rad_s
1081 :
1082 0 : END SUBROUTINE get_jrho_atom
1083 :
1084 : ! **************************************************************************************************
1085 : !> \brief ...
1086 : !> \param jrho1_atom_set ...
1087 : !> \param atomic_kind_set ...
1088 : !> \param nspins ...
1089 : ! **************************************************************************************************
1090 96 : SUBROUTINE init_jrho_atom_set(jrho1_atom_set, atomic_kind_set, nspins)
1091 : TYPE(jrho_atom_type), DIMENSION(:), POINTER :: jrho1_atom_set
1092 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
1093 : INTEGER, INTENT(IN) :: nspins
1094 :
1095 : CHARACTER(len=*), PARAMETER :: routineN = 'init_jrho_atom_set'
1096 :
1097 : INTEGER :: handle, iat, iatom, ikind, nat, natom, &
1098 : nkind
1099 96 : INTEGER, DIMENSION(:), POINTER :: atom_list
1100 :
1101 96 : CALL timeset(routineN, handle)
1102 :
1103 96 : CPASSERT(ASSOCIATED(atomic_kind_set))
1104 :
1105 96 : IF (ASSOCIATED(jrho1_atom_set)) THEN
1106 0 : CALL deallocate_jrho_atom_set(jrho1_atom_set)
1107 : END IF
1108 :
1109 96 : CALL get_atomic_kind_set(atomic_kind_set, natom=natom)
1110 604 : ALLOCATE (jrho1_atom_set(natom))
1111 :
1112 96 : nkind = SIZE(atomic_kind_set)
1113 :
1114 274 : DO ikind = 1, nkind
1115 :
1116 178 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=nat)
1117 :
1118 590 : DO iat = 1, nat
1119 316 : iatom = atom_list(iat)
1120 :
1121 : ! Allocate the radial density for each LM,for each atom
1122 : ALLOCATE (jrho1_atom_set(iatom)%jrho_vec_rad_h(3, nspins), &
1123 : jrho1_atom_set(iatom)%jrho_vec_rad_s(3, nspins), &
1124 : jrho1_atom_set(iatom)%jrho_h(nspins), &
1125 : jrho1_atom_set(iatom)%jrho_s(nspins), &
1126 : jrho1_atom_set(iatom)%jrho_a_h(nspins), &
1127 : jrho1_atom_set(iatom)%jrho_a_s(nspins), &
1128 : jrho1_atom_set(iatom)%jrho_b_h(nspins), &
1129 : jrho1_atom_set(iatom)%jrho_b_s(nspins), &
1130 : jrho1_atom_set(iatom)%jrho_a_h_ii(nspins), &
1131 : jrho1_atom_set(iatom)%jrho_a_s_ii(nspins), &
1132 : jrho1_atom_set(iatom)%jrho_b_s_ii(nspins), &
1133 : jrho1_atom_set(iatom)%jrho_b_h_ii(nspins), &
1134 : jrho1_atom_set(iatom)%jrho_a_h_iii(nspins), &
1135 : jrho1_atom_set(iatom)%jrho_a_s_iii(nspins), &
1136 : jrho1_atom_set(iatom)%jrho_b_s_iii(nspins), &
1137 : jrho1_atom_set(iatom)%jrho_b_h_iii(nspins), &
1138 : jrho1_atom_set(iatom)%cjc0_h(nspins), &
1139 : jrho1_atom_set(iatom)%cjc0_s(nspins), &
1140 : jrho1_atom_set(iatom)%cjc_h(nspins), &
1141 : jrho1_atom_set(iatom)%cjc_s(nspins), &
1142 : jrho1_atom_set(iatom)%cjc_ii_h(nspins), &
1143 : jrho1_atom_set(iatom)%cjc_ii_s(nspins), &
1144 : jrho1_atom_set(iatom)%cjc_iii_h(nspins), &
1145 21610 : jrho1_atom_set(iatom)%cjc_iii_s(nspins))
1146 :
1147 : END DO ! iat
1148 :
1149 : END DO ! ikind
1150 :
1151 96 : CALL timestop(handle)
1152 :
1153 192 : END SUBROUTINE init_jrho_atom_set
1154 :
1155 : ! **************************************************************************************************
1156 : !> \brief ...
1157 : !> \param nablavks_atom_set ...
1158 : !> \param atomic_kind_set ...
1159 : !> \param qs_kind_set ...
1160 : !> \param nspins ...
1161 : ! **************************************************************************************************
1162 20 : SUBROUTINE init_nablavks_atom_set(nablavks_atom_set, atomic_kind_set, qs_kind_set, nspins)
1163 :
1164 : TYPE(nablavks_atom_type), DIMENSION(:), POINTER :: nablavks_atom_set
1165 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
1166 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1167 : INTEGER, INTENT(IN) :: nspins
1168 :
1169 : CHARACTER(len=*), PARAMETER :: routineN = 'init_nablavks_atom_set'
1170 :
1171 : INTEGER :: handle, iat, iatom, idir, ikind, ispin, &
1172 : max_iso_not0, maxso, na, nat, natom, &
1173 : nkind, nr, nset, nsotot
1174 10 : INTEGER, DIMENSION(:), POINTER :: atom_list
1175 : TYPE(grid_atom_type), POINTER :: grid_atom
1176 : TYPE(gto_basis_set_type), POINTER :: orb_basis_set
1177 : TYPE(harmonics_atom_type), POINTER :: harmonics
1178 :
1179 10 : CALL timeset(routineN, handle)
1180 :
1181 10 : CPASSERT(ASSOCIATED(qs_kind_set))
1182 :
1183 10 : IF (ASSOCIATED(nablavks_atom_set)) THEN
1184 0 : CALL deallocate_nablavks_atom_set(nablavks_atom_set)
1185 : END IF
1186 :
1187 10 : CALL get_atomic_kind_set(atomic_kind_set, natom=natom)
1188 :
1189 10 : CALL allocate_nablavks_atom_set(nablavks_atom_set, natom)
1190 :
1191 10 : nkind = SIZE(atomic_kind_set)
1192 :
1193 30 : DO ikind = 1, nkind
1194 20 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=nat)
1195 : CALL get_qs_kind(qs_kind_set(ikind), &
1196 : basis_set=orb_basis_set, &
1197 : harmonics=harmonics, &
1198 20 : grid_atom=grid_atom)
1199 :
1200 20 : na = grid_atom%ng_sphere
1201 20 : nr = grid_atom%nr
1202 :
1203 : CALL get_gto_basis_set(gto_basis_set=orb_basis_set, &
1204 20 : maxso=maxso, nset=nset)
1205 20 : nsotot = maxso*nset
1206 20 : max_iso_not0 = harmonics%max_iso_not0
1207 80 : DO iat = 1, nat
1208 30 : iatom = atom_list(iat)
1209 : !*** allocate the radial density for each LM,for each atom ***
1210 :
1211 330 : ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_h(3, nspins))
1212 300 : ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_s(3, nspins))
1213 110 : DO ispin = 1, nspins
1214 270 : DO idir = 1, 3
1215 180 : NULLIFY (nablavks_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef)
1216 180 : NULLIFY (nablavks_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef)
1217 720 : ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(nr, na))
1218 600 : ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(nr, na))
1219 : END DO
1220 : END DO ! ispin
1221 : END DO ! iat
1222 :
1223 : END DO ! ikind
1224 :
1225 10 : CALL timestop(handle)
1226 :
1227 10 : END SUBROUTINE init_nablavks_atom_set
1228 :
1229 : ! **************************************************************************************************
1230 : !> \brief ...
1231 : !> \param polar_env ...
1232 : !> \param do_raman ...
1233 : !> \param do_periodic ...
1234 : !> \param dBerry_psi0 ...
1235 : !> \param polar ...
1236 : !> \param psi1_dBerry ...
1237 : !> \param run_stopped ...
1238 : !> \par History
1239 : !> 06.2018 polar_env integrated into qs_env (MK)
1240 : ! **************************************************************************************************
1241 940 : SUBROUTINE get_polar_env(polar_env, do_raman, do_periodic, dBerry_psi0, polar, psi1_dBerry, run_stopped)
1242 :
1243 : TYPE(polar_env_type), INTENT(IN) :: polar_env
1244 : LOGICAL, OPTIONAL :: do_raman, do_periodic
1245 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
1246 : POINTER :: dBerry_psi0
1247 : REAL(dp), DIMENSION(:, :), OPTIONAL, POINTER :: polar
1248 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
1249 : POINTER :: psi1_dBerry
1250 : LOGICAL, OPTIONAL :: run_stopped
1251 :
1252 940 : IF (PRESENT(polar)) polar => polar_env%polar
1253 940 : IF (PRESENT(do_raman)) do_raman = polar_env%do_raman
1254 940 : IF (PRESENT(do_periodic)) do_periodic = polar_env%do_periodic
1255 940 : IF (PRESENT(dBerry_psi0)) dBerry_psi0 => polar_env%dBerry_psi0
1256 940 : IF (PRESENT(psi1_dBerry)) psi1_dBerry => polar_env%psi1_dBerry
1257 940 : IF (PRESENT(run_stopped)) run_stopped = polar_env%run_stopped
1258 :
1259 940 : END SUBROUTINE get_polar_env
1260 :
1261 : ! **************************************************************************************************
1262 : !> \brief ...
1263 : !> \param polar_env ...
1264 : !> \param do_raman ...
1265 : !> \param do_periodic ...
1266 : !> \param dBerry_psi0 ...
1267 : !> \param polar ...
1268 : !> \param psi1_dBerry ...
1269 : !> \param run_stopped ...
1270 : ! **************************************************************************************************
1271 112 : SUBROUTINE set_polar_env(polar_env, do_raman, do_periodic, dBerry_psi0, polar, &
1272 : psi1_dBerry, run_stopped)
1273 :
1274 : TYPE(polar_env_type), INTENT(INOUT) :: polar_env
1275 : LOGICAL, OPTIONAL :: do_raman, do_periodic
1276 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
1277 : POINTER :: dBerry_psi0
1278 : REAL(dp), DIMENSION(:, :), OPTIONAL, POINTER :: polar
1279 : TYPE(cp_fm_type), DIMENSION(:, :), OPTIONAL, &
1280 : POINTER :: psi1_dBerry
1281 : LOGICAL, OPTIONAL :: run_stopped
1282 :
1283 112 : IF (PRESENT(polar)) polar_env%polar => polar
1284 112 : IF (PRESENT(do_raman)) polar_env%do_raman = do_raman
1285 112 : IF (PRESENT(do_periodic)) polar_env%do_periodic = do_periodic
1286 112 : IF (PRESENT(psi1_dBerry)) polar_env%psi1_dBerry => psi1_dBerry
1287 112 : IF (PRESENT(dBerry_psi0)) polar_env%dBerry_psi0 => dBerry_psi0
1288 112 : IF (PRESENT(run_stopped)) polar_env%run_stopped = run_stopped
1289 :
1290 112 : END SUBROUTINE set_polar_env
1291 :
1292 : ! **************************************************************************************************
1293 : !> \brief Deallocate the polar environment
1294 : !> \param polar_env ...
1295 : !> \par History
1296 : !> 06.2018 polar_env integrated into qs_env (MK)
1297 : ! **************************************************************************************************
1298 7413 : SUBROUTINE polar_env_release(polar_env)
1299 :
1300 : TYPE(polar_env_type), POINTER :: polar_env
1301 :
1302 7413 : IF (ASSOCIATED(polar_env)) THEN
1303 84 : IF (ASSOCIATED(polar_env%polar)) THEN
1304 84 : DEALLOCATE (polar_env%polar)
1305 : END IF
1306 84 : CALL cp_fm_release(polar_env%dBerry_psi0)
1307 84 : CALL cp_fm_release(polar_env%psi1_dBerry)
1308 84 : DEALLOCATE (polar_env)
1309 : NULLIFY (polar_env)
1310 : END IF
1311 :
1312 7413 : END SUBROUTINE polar_env_release
1313 :
1314 0 : END MODULE qs_linres_types
|
