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 : MODULE soc_pseudopotential_utils
9 : USE cp_cfm_basic_linalg, ONLY: cp_cfm_scale,&
10 : cp_cfm_scale_and_add,&
11 : cp_cfm_scale_and_add_fm,&
12 : cp_cfm_transpose
13 : USE cp_cfm_types, ONLY: cp_cfm_create,&
14 : cp_cfm_get_info,&
15 : cp_cfm_release,&
16 : cp_cfm_set_all,&
17 : cp_cfm_to_fm,&
18 : cp_cfm_type,&
19 : cp_fm_to_cfm
20 : USE cp_dbcsr_api, ONLY: dbcsr_type
21 : USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm
22 : USE cp_fm_struct, ONLY: cp_fm_struct_create,&
23 : cp_fm_struct_release,&
24 : cp_fm_struct_type
25 : USE cp_fm_types, ONLY: cp_fm_create,&
26 : cp_fm_get_info,&
27 : cp_fm_release,&
28 : cp_fm_set_all,&
29 : cp_fm_to_fm_submat,&
30 : cp_fm_type
31 : USE kinds, ONLY: dp
32 : USE mathconstants, ONLY: gaussi,&
33 : z_one,&
34 : z_zero
35 : #include "./base/base_uses.f90"
36 :
37 : IMPLICIT NONE
38 :
39 : PRIVATE
40 :
41 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'soc_pseudopotential_utils'
42 :
43 : PUBLIC :: add_dbcsr_submat, cfm_add_on_diag, add_fm_submat, add_cfm_submat, &
44 : get_cfm_submat, create_cfm_double
45 :
46 : CONTAINS
47 :
48 : ! **************************************************************************************************
49 : !> \brief ...
50 : !> \param cfm_mat_target ...
51 : !> \param mat_source ...
52 : !> \param fm_struct_source ...
53 : !> \param nstart_row ...
54 : !> \param nstart_col ...
55 : !> \param factor ...
56 : !> \param add_also_herm_conj ...
57 : ! **************************************************************************************************
58 144 : SUBROUTINE add_dbcsr_submat(cfm_mat_target, mat_source, fm_struct_source, &
59 : nstart_row, nstart_col, factor, add_also_herm_conj)
60 : TYPE(cp_cfm_type) :: cfm_mat_target
61 : TYPE(dbcsr_type) :: mat_source
62 : TYPE(cp_fm_struct_type), POINTER :: fm_struct_source
63 : INTEGER :: nstart_row, nstart_col
64 : COMPLEX(KIND=dp) :: factor
65 : LOGICAL :: add_also_herm_conj
66 :
67 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_dbcsr_submat'
68 :
69 : INTEGER :: handle, nao
70 : TYPE(cp_cfm_type) :: cfm_mat_work_double, &
71 : cfm_mat_work_double_2
72 : TYPE(cp_fm_type) :: fm_mat_work_double_im, fm_mat_work_im
73 :
74 24 : CALL timeset(routineN, handle)
75 :
76 24 : CALL cp_fm_create(fm_mat_work_double_im, cfm_mat_target%matrix_struct)
77 24 : CALL cp_fm_set_all(fm_mat_work_double_im, 0.0_dp)
78 :
79 24 : CALL cp_cfm_create(cfm_mat_work_double, cfm_mat_target%matrix_struct)
80 24 : CALL cp_cfm_create(cfm_mat_work_double_2, cfm_mat_target%matrix_struct)
81 24 : CALL cp_cfm_set_all(cfm_mat_work_double, z_zero)
82 24 : CALL cp_cfm_set_all(cfm_mat_work_double_2, z_zero)
83 :
84 24 : CALL cp_fm_create(fm_mat_work_im, fm_struct_source)
85 :
86 24 : CALL copy_dbcsr_to_fm(mat_source, fm_mat_work_im)
87 :
88 24 : CALL cp_fm_get_info(fm_mat_work_im, nrow_global=nao)
89 :
90 : CALL cp_fm_to_fm_submat(msource=fm_mat_work_im, mtarget=fm_mat_work_double_im, &
91 : nrow=nao, ncol=nao, &
92 : s_firstrow=1, s_firstcol=1, &
93 24 : t_firstrow=nstart_row, t_firstcol=nstart_col)
94 : ! careful: inside add_dbcsr_submat, mat_V_SOC_xyz is multiplied by i because the real matrix
95 : ! mat_V_SOC_xyz is antisymmetric as V_SOC matrix is purely imaginary and Hermitian
96 24 : CALL cp_cfm_scale_and_add_fm(z_zero, cfm_mat_work_double, gaussi, fm_mat_work_double_im)
97 :
98 24 : CALL cp_cfm_scale(factor, cfm_mat_work_double)
99 :
100 24 : CALL cp_cfm_scale_and_add(z_one, cfm_mat_target, z_one, cfm_mat_work_double)
101 :
102 24 : IF (add_also_herm_conj) THEN
103 12 : CALL cp_cfm_transpose(cfm_mat_work_double, 'C', cfm_mat_work_double_2)
104 12 : CALL cp_cfm_scale_and_add(z_one, cfm_mat_target, z_one, cfm_mat_work_double_2)
105 : END IF
106 :
107 24 : CALL cp_fm_release(fm_mat_work_double_im)
108 24 : CALL cp_cfm_release(cfm_mat_work_double)
109 24 : CALL cp_cfm_release(cfm_mat_work_double_2)
110 24 : CALL cp_fm_release(fm_mat_work_im)
111 :
112 24 : CALL timestop(handle)
113 :
114 24 : END SUBROUTINE add_dbcsr_submat
115 :
116 : ! **************************************************************************************************
117 : !> \brief ...
118 : !> \param cfm ...
119 : !> \param alpha ...
120 : ! **************************************************************************************************
121 336 : SUBROUTINE cfm_add_on_diag(cfm, alpha)
122 :
123 : TYPE(cp_cfm_type) :: cfm
124 : REAL(KIND=dp), DIMENSION(:) :: alpha
125 :
126 : CHARACTER(LEN=*), PARAMETER :: routineN = 'cfm_add_on_diag'
127 :
128 : INTEGER :: handle, i_global, i_row, j_col, &
129 : j_global, nao, ncol_local, nrow_local
130 336 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
131 :
132 336 : CALL timeset(routineN, handle)
133 :
134 : CALL cp_cfm_get_info(matrix=cfm, &
135 : nrow_local=nrow_local, &
136 : ncol_local=ncol_local, &
137 : row_indices=row_indices, &
138 336 : col_indices=col_indices)
139 :
140 336 : nao = SIZE(alpha)
141 :
142 7664 : DO j_col = 1, ncol_local
143 7328 : j_global = col_indices(j_col)
144 91536 : DO i_row = 1, nrow_local
145 83872 : i_global = row_indices(i_row)
146 91200 : IF (j_global == i_global) THEN
147 3664 : IF (i_global <= nao) THEN
148 : cfm%local_data(i_row, j_col) = cfm%local_data(i_row, j_col) + &
149 3664 : alpha(i_global)*z_one
150 : ELSE
151 : cfm%local_data(i_row, j_col) = cfm%local_data(i_row, j_col) + &
152 0 : alpha(i_global - nao)*z_one
153 : END IF
154 : END IF
155 : END DO
156 : END DO
157 :
158 336 : CALL timestop(handle)
159 :
160 336 : END SUBROUTINE cfm_add_on_diag
161 :
162 : ! **************************************************************************************************
163 : !> \brief ...
164 : !> \param cfm_mat_target ...
165 : !> \param fm_mat_source ...
166 : !> \param nstart_row ...
167 : !> \param nstart_col ...
168 : ! **************************************************************************************************
169 0 : SUBROUTINE add_fm_submat(cfm_mat_target, fm_mat_source, nstart_row, nstart_col)
170 :
171 : TYPE(cp_cfm_type) :: cfm_mat_target
172 : TYPE(cp_fm_type) :: fm_mat_source
173 : INTEGER :: nstart_row, nstart_col
174 :
175 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_fm_submat'
176 :
177 : INTEGER :: handle, nao
178 : TYPE(cp_fm_type) :: fm_mat_work_double_re
179 :
180 0 : CALL timeset(routineN, handle)
181 :
182 0 : CALL cp_fm_create(fm_mat_work_double_re, cfm_mat_target%matrix_struct)
183 0 : CALL cp_fm_set_all(fm_mat_work_double_re, 0.0_dp)
184 :
185 0 : CALL cp_fm_get_info(fm_mat_source, nrow_global=nao)
186 :
187 : CALL cp_fm_to_fm_submat(msource=fm_mat_source, mtarget=fm_mat_work_double_re, &
188 : nrow=nao, ncol=nao, &
189 : s_firstrow=1, s_firstcol=1, &
190 0 : t_firstrow=nstart_row, t_firstcol=nstart_col)
191 :
192 0 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, z_one, fm_mat_work_double_re)
193 :
194 0 : CALL cp_fm_release(fm_mat_work_double_re)
195 :
196 0 : CALL timestop(handle)
197 :
198 0 : END SUBROUTINE add_fm_submat
199 :
200 : ! **************************************************************************************************
201 : !> \brief ...
202 : !> \param cfm_mat_target ...
203 : !> \param cfm_mat_source ...
204 : !> \param nstart_row ...
205 : !> \param nstart_col ...
206 : !> \param factor ...
207 : ! **************************************************************************************************
208 10680 : SUBROUTINE add_cfm_submat(cfm_mat_target, cfm_mat_source, nstart_row, nstart_col, factor)
209 :
210 : TYPE(cp_cfm_type) :: cfm_mat_target, cfm_mat_source
211 : INTEGER :: nstart_row, nstart_col
212 : COMPLEX(KIND=dp), OPTIONAL :: factor
213 :
214 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_cfm_submat'
215 :
216 : COMPLEX(KIND=dp) :: factor_im, factor_re
217 : INTEGER :: handle, nao
218 : TYPE(cp_fm_type) :: fm_mat_source_im, fm_mat_source_re, &
219 : fm_mat_work_double_im, &
220 : fm_mat_work_double_re
221 :
222 1780 : CALL timeset(routineN, handle)
223 :
224 1780 : CALL cp_fm_create(fm_mat_work_double_re, cfm_mat_target%matrix_struct)
225 1780 : CALL cp_fm_create(fm_mat_work_double_im, cfm_mat_target%matrix_struct)
226 1780 : CALL cp_fm_set_all(fm_mat_work_double_re, 0.0_dp)
227 1780 : CALL cp_fm_set_all(fm_mat_work_double_im, 0.0_dp)
228 :
229 1780 : CALL cp_fm_create(fm_mat_source_re, cfm_mat_source%matrix_struct)
230 1780 : CALL cp_fm_create(fm_mat_source_im, cfm_mat_source%matrix_struct)
231 1780 : CALL cp_cfm_to_fm(cfm_mat_source, fm_mat_source_re, fm_mat_source_im)
232 :
233 1780 : CALL cp_cfm_get_info(cfm_mat_source, nrow_global=nao)
234 :
235 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_re, mtarget=fm_mat_work_double_re, &
236 : nrow=nao, ncol=nao, &
237 : s_firstrow=1, s_firstcol=1, &
238 1780 : t_firstrow=nstart_row, t_firstcol=nstart_col)
239 :
240 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_im, mtarget=fm_mat_work_double_im, &
241 : nrow=nao, ncol=nao, &
242 : s_firstrow=1, s_firstcol=1, &
243 1780 : t_firstrow=nstart_row, t_firstcol=nstart_col)
244 :
245 1780 : IF (PRESENT(factor)) THEN
246 80 : factor_re = factor
247 80 : factor_im = gaussi*factor
248 : ELSE
249 1700 : factor_re = z_one
250 1700 : factor_im = gaussi
251 : END IF
252 :
253 1780 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, factor_re, fm_mat_work_double_re)
254 1780 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, factor_im, fm_mat_work_double_im)
255 :
256 1780 : CALL cp_fm_release(fm_mat_work_double_re)
257 1780 : CALL cp_fm_release(fm_mat_work_double_im)
258 1780 : CALL cp_fm_release(fm_mat_source_re)
259 1780 : CALL cp_fm_release(fm_mat_source_im)
260 :
261 1780 : CALL timestop(handle)
262 :
263 1780 : END SUBROUTINE add_cfm_submat
264 :
265 : ! **************************************************************************************************
266 : !> \brief ...
267 : !> \param cfm_mat_target ...
268 : !> \param cfm_mat_source ...
269 : !> \param nstart_row ...
270 : !> \param nstart_col ...
271 : ! **************************************************************************************************
272 576 : SUBROUTINE get_cfm_submat(cfm_mat_target, cfm_mat_source, nstart_row, nstart_col)
273 :
274 : TYPE(cp_cfm_type) :: cfm_mat_target, cfm_mat_source
275 : INTEGER :: nstart_row, nstart_col
276 :
277 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_cfm_submat'
278 :
279 : INTEGER :: handle, nao
280 : TYPE(cp_fm_type) :: fm_mat_source_double_im, &
281 : fm_mat_source_double_re, &
282 : fm_mat_work_im, fm_mat_work_re
283 :
284 96 : CALL timeset(routineN, handle)
285 :
286 96 : CALL cp_fm_create(fm_mat_source_double_re, cfm_mat_source%matrix_struct)
287 96 : CALL cp_fm_create(fm_mat_source_double_im, cfm_mat_source%matrix_struct)
288 96 : CALL cp_cfm_to_fm(cfm_mat_source, fm_mat_source_double_re, fm_mat_source_double_im)
289 :
290 96 : CALL cp_fm_create(fm_mat_work_re, cfm_mat_target%matrix_struct)
291 96 : CALL cp_fm_create(fm_mat_work_im, cfm_mat_target%matrix_struct)
292 96 : CALL cp_fm_set_all(fm_mat_work_re, 0.0_dp)
293 96 : CALL cp_fm_set_all(fm_mat_work_im, 0.0_dp)
294 :
295 96 : CALL cp_cfm_get_info(cfm_mat_target, nrow_global=nao)
296 :
297 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_double_re, mtarget=fm_mat_work_re, &
298 : nrow=nao, ncol=nao, &
299 : s_firstrow=nstart_row, s_firstcol=nstart_col, &
300 96 : t_firstrow=1, t_firstcol=1)
301 :
302 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_double_im, mtarget=fm_mat_work_im, &
303 : nrow=nao, ncol=nao, &
304 : s_firstrow=nstart_row, s_firstcol=nstart_col, &
305 96 : t_firstrow=1, t_firstcol=1)
306 :
307 96 : CALL cp_fm_to_cfm(fm_mat_work_re, fm_mat_work_im, cfm_mat_target)
308 :
309 96 : CALL cp_fm_release(fm_mat_work_re)
310 96 : CALL cp_fm_release(fm_mat_work_im)
311 96 : CALL cp_fm_release(fm_mat_source_double_re)
312 96 : CALL cp_fm_release(fm_mat_source_double_im)
313 :
314 96 : CALL timestop(handle)
315 :
316 96 : END SUBROUTINE get_cfm_submat
317 :
318 : ! **************************************************************************************************
319 : !> \brief ...
320 : !> \param cfm_double ...
321 : !> \param fm_orig ...
322 : !> \param cfm_orig ...
323 : ! **************************************************************************************************
324 328 : SUBROUTINE create_cfm_double(cfm_double, fm_orig, cfm_orig)
325 : TYPE(cp_cfm_type) :: cfm_double
326 : TYPE(cp_fm_type), OPTIONAL :: fm_orig
327 : TYPE(cp_cfm_type), OPTIONAL :: cfm_orig
328 :
329 : CHARACTER(LEN=*), PARAMETER :: routineN = 'create_cfm_double'
330 :
331 : INTEGER :: handle, ncol_global_orig, &
332 : nrow_global_orig
333 : LOGICAL :: do_cfm_templ, do_fm_templ
334 : TYPE(cp_fm_struct_type), POINTER :: matrix_struct, matrix_struct_double
335 :
336 164 : CALL timeset(routineN, handle)
337 :
338 164 : do_fm_templ = PRESENT(fm_orig)
339 164 : do_cfm_templ = PRESENT(cfm_orig)
340 :
341 : ! either fm template or cfm template
342 164 : CPASSERT(do_fm_templ .NEQV. do_cfm_templ)
343 :
344 164 : IF (do_fm_templ) THEN
345 : CALL cp_fm_get_info(matrix=fm_orig, nrow_global=nrow_global_orig, &
346 6 : ncol_global=ncol_global_orig)
347 6 : matrix_struct => fm_orig%matrix_struct
348 : END IF
349 164 : IF (do_cfm_templ) THEN
350 : CALL cp_cfm_get_info(matrix=cfm_orig, nrow_global=nrow_global_orig, &
351 158 : ncol_global=ncol_global_orig)
352 158 : matrix_struct => cfm_orig%matrix_struct
353 : END IF
354 :
355 : CALL cp_fm_struct_create(matrix_struct_double, &
356 : nrow_global=2*nrow_global_orig, &
357 : ncol_global=2*ncol_global_orig, &
358 164 : template_fmstruct=matrix_struct)
359 :
360 164 : CALL cp_cfm_create(cfm_double, matrix_struct_double)
361 :
362 164 : CALL cp_cfm_set_all(cfm_double, z_zero)
363 :
364 164 : CALL cp_fm_struct_release(matrix_struct_double)
365 :
366 164 : CALL timestop(handle)
367 :
368 164 : END SUBROUTINE create_cfm_double
369 :
370 : END MODULE soc_pseudopotential_utils
|
