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 : 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_operations, ONLY: copy_dbcsr_to_fm
21 : USE cp_fm_struct, ONLY: cp_fm_struct_create,&
22 : cp_fm_struct_release,&
23 : cp_fm_struct_type
24 : USE cp_fm_types, ONLY: cp_fm_create,&
25 : cp_fm_get_info,&
26 : cp_fm_release,&
27 : cp_fm_set_all,&
28 : cp_fm_to_fm_submat,&
29 : cp_fm_type
30 : USE dbcsr_api, ONLY: dbcsr_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, get_cfm_submat, create_cfm_double, &
44 : add_cfm_submat
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 384 : 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 64 : CALL timeset(routineN, handle)
75 :
76 64 : CALL cp_fm_create(fm_mat_work_double_im, cfm_mat_target%matrix_struct)
77 64 : CALL cp_fm_set_all(fm_mat_work_double_im, 0.0_dp)
78 :
79 64 : CALL cp_cfm_create(cfm_mat_work_double, cfm_mat_target%matrix_struct)
80 64 : CALL cp_cfm_create(cfm_mat_work_double_2, cfm_mat_target%matrix_struct)
81 64 : CALL cp_cfm_set_all(cfm_mat_work_double, z_zero)
82 64 : CALL cp_cfm_set_all(cfm_mat_work_double_2, z_zero)
83 :
84 64 : CALL cp_fm_create(fm_mat_work_im, fm_struct_source)
85 :
86 64 : CALL copy_dbcsr_to_fm(mat_source, fm_mat_work_im)
87 :
88 64 : 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 64 : t_firstrow=nstart_row, t_firstcol=nstart_col)
94 :
95 64 : CALL cp_cfm_scale_and_add_fm(z_zero, cfm_mat_work_double, gaussi, fm_mat_work_double_im)
96 :
97 64 : CALL cp_cfm_scale(factor, cfm_mat_work_double)
98 :
99 64 : CALL cp_cfm_scale_and_add(z_one, cfm_mat_target, z_one, cfm_mat_work_double)
100 :
101 64 : IF (add_also_herm_conj) THEN
102 32 : CALL cp_cfm_transpose(cfm_mat_work_double, 'C', cfm_mat_work_double_2)
103 32 : CALL cp_cfm_scale_and_add(z_one, cfm_mat_target, z_one, cfm_mat_work_double_2)
104 : END IF
105 :
106 64 : CALL cp_fm_release(fm_mat_work_double_im)
107 64 : CALL cp_cfm_release(cfm_mat_work_double)
108 64 : CALL cp_cfm_release(cfm_mat_work_double_2)
109 64 : CALL cp_fm_release(fm_mat_work_im)
110 :
111 64 : CALL timestop(handle)
112 :
113 64 : END SUBROUTINE add_dbcsr_submat
114 :
115 : ! **************************************************************************************************
116 : !> \brief ...
117 : !> \param cfm ...
118 : !> \param alpha ...
119 : ! **************************************************************************************************
120 56 : SUBROUTINE cfm_add_on_diag(cfm, alpha)
121 :
122 : TYPE(cp_cfm_type) :: cfm
123 : REAL(KIND=dp), DIMENSION(:) :: alpha
124 :
125 : CHARACTER(LEN=*), PARAMETER :: routineN = 'cfm_add_on_diag'
126 :
127 : INTEGER :: handle, i_global, i_row, j_col, &
128 : j_global, nao, ncol_local, nrow_local
129 56 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
130 :
131 56 : CALL timeset(routineN, handle)
132 :
133 : CALL cp_cfm_get_info(matrix=cfm, &
134 : nrow_local=nrow_local, &
135 : ncol_local=ncol_local, &
136 : row_indices=row_indices, &
137 56 : col_indices=col_indices)
138 :
139 56 : nao = SIZE(alpha)
140 :
141 2360 : DO j_col = 1, ncol_local
142 2304 : j_global = col_indices(j_col)
143 54200 : DO i_row = 1, nrow_local
144 51840 : i_global = row_indices(i_row)
145 54144 : IF (j_global == i_global) THEN
146 1152 : IF (i_global .LE. nao) THEN
147 1152 : cfm%local_data(i_row, j_col) = cfm%local_data(i_row, j_col) + alpha(i_global)*z_one
148 : ELSE
149 0 : cfm%local_data(i_row, j_col) = cfm%local_data(i_row, j_col) + alpha(i_global - nao)*z_one
150 : END IF
151 : END IF
152 : END DO
153 : END DO
154 :
155 56 : CALL timestop(handle)
156 :
157 56 : END SUBROUTINE cfm_add_on_diag
158 :
159 : ! **************************************************************************************************
160 : !> \brief ...
161 : !> \param cfm_mat_target ...
162 : !> \param fm_mat_source ...
163 : !> \param nstart_row ...
164 : !> \param nstart_col ...
165 : ! **************************************************************************************************
166 192 : SUBROUTINE add_fm_submat(cfm_mat_target, fm_mat_source, nstart_row, nstart_col)
167 :
168 : TYPE(cp_cfm_type) :: cfm_mat_target
169 : TYPE(cp_fm_type) :: fm_mat_source
170 : INTEGER :: nstart_row, nstart_col
171 :
172 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_fm_submat'
173 :
174 : INTEGER :: handle, nao
175 : TYPE(cp_fm_type) :: fm_mat_work_double_re
176 :
177 64 : CALL timeset(routineN, handle)
178 :
179 64 : CALL cp_fm_create(fm_mat_work_double_re, cfm_mat_target%matrix_struct)
180 64 : CALL cp_fm_set_all(fm_mat_work_double_re, 0.0_dp)
181 :
182 64 : CALL cp_fm_get_info(fm_mat_source, nrow_global=nao)
183 :
184 : CALL cp_fm_to_fm_submat(msource=fm_mat_source, mtarget=fm_mat_work_double_re, &
185 : nrow=nao, ncol=nao, &
186 : s_firstrow=1, s_firstcol=1, &
187 64 : t_firstrow=nstart_row, t_firstcol=nstart_col)
188 :
189 64 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, z_one, fm_mat_work_double_re)
190 :
191 64 : CALL cp_fm_release(fm_mat_work_double_re)
192 :
193 64 : CALL timestop(handle)
194 :
195 64 : END SUBROUTINE add_fm_submat
196 :
197 : ! **************************************************************************************************
198 : !> \brief ...
199 : !> \param cfm_mat_target ...
200 : !> \param cfm_mat_source ...
201 : !> \param nstart_row ...
202 : !> \param nstart_col ...
203 : !> \param factor ...
204 : ! **************************************************************************************************
205 3360 : SUBROUTINE add_cfm_submat(cfm_mat_target, cfm_mat_source, nstart_row, nstart_col, factor)
206 :
207 : TYPE(cp_cfm_type) :: cfm_mat_target, cfm_mat_source
208 : INTEGER :: nstart_row, nstart_col
209 : COMPLEX(KIND=dp), OPTIONAL :: factor
210 :
211 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_cfm_submat'
212 :
213 : COMPLEX(KIND=dp) :: factor_im, factor_re
214 : INTEGER :: handle, nao
215 : TYPE(cp_fm_type) :: fm_mat_source_im, fm_mat_source_re, &
216 : fm_mat_work_double_im, &
217 : fm_mat_work_double_re
218 :
219 560 : CALL timeset(routineN, handle)
220 :
221 560 : CALL cp_fm_create(fm_mat_work_double_re, cfm_mat_target%matrix_struct)
222 560 : CALL cp_fm_create(fm_mat_work_double_im, cfm_mat_target%matrix_struct)
223 560 : CALL cp_fm_set_all(fm_mat_work_double_re, 0.0_dp)
224 560 : CALL cp_fm_set_all(fm_mat_work_double_im, 0.0_dp)
225 :
226 560 : CALL cp_fm_create(fm_mat_source_re, cfm_mat_source%matrix_struct)
227 560 : CALL cp_fm_create(fm_mat_source_im, cfm_mat_source%matrix_struct)
228 560 : CALL cp_cfm_to_fm(cfm_mat_source, fm_mat_source_re, fm_mat_source_im)
229 :
230 560 : CALL cp_cfm_get_info(cfm_mat_source, nrow_global=nao)
231 :
232 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_re, mtarget=fm_mat_work_double_re, &
233 : nrow=nao, ncol=nao, &
234 : s_firstrow=1, s_firstcol=1, &
235 560 : t_firstrow=nstart_row, t_firstcol=nstart_col)
236 :
237 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_im, mtarget=fm_mat_work_double_im, &
238 : nrow=nao, ncol=nao, &
239 : s_firstrow=1, s_firstcol=1, &
240 560 : t_firstrow=nstart_row, t_firstcol=nstart_col)
241 :
242 560 : IF (PRESENT(factor)) THEN
243 224 : factor_re = factor
244 224 : factor_im = gaussi*factor
245 : ELSE
246 336 : factor_re = z_one
247 336 : factor_im = gaussi
248 : END IF
249 :
250 560 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, factor_re, fm_mat_work_double_re)
251 560 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, factor_im, fm_mat_work_double_im)
252 :
253 560 : CALL cp_fm_release(fm_mat_work_double_re)
254 560 : CALL cp_fm_release(fm_mat_work_double_im)
255 560 : CALL cp_fm_release(fm_mat_source_re)
256 560 : CALL cp_fm_release(fm_mat_source_im)
257 :
258 560 : CALL timestop(handle)
259 :
260 560 : END SUBROUTINE add_cfm_submat
261 :
262 : ! **************************************************************************************************
263 : !> \brief ...
264 : !> \param cfm_mat_target ...
265 : !> \param cfm_mat_source ...
266 : !> \param nstart_row ...
267 : !> \param nstart_col ...
268 : ! **************************************************************************************************
269 1536 : SUBROUTINE get_cfm_submat(cfm_mat_target, cfm_mat_source, nstart_row, nstart_col)
270 :
271 : TYPE(cp_cfm_type) :: cfm_mat_target, cfm_mat_source
272 : INTEGER :: nstart_row, nstart_col
273 :
274 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_cfm_submat'
275 :
276 : INTEGER :: handle, nao
277 : TYPE(cp_fm_type) :: fm_mat_source_double_im, &
278 : fm_mat_source_double_re, &
279 : fm_mat_work_im, fm_mat_work_re
280 :
281 256 : CALL timeset(routineN, handle)
282 :
283 256 : CALL cp_fm_create(fm_mat_source_double_re, cfm_mat_source%matrix_struct)
284 256 : CALL cp_fm_create(fm_mat_source_double_im, cfm_mat_source%matrix_struct)
285 256 : CALL cp_cfm_to_fm(cfm_mat_source, fm_mat_source_double_re, fm_mat_source_double_im)
286 :
287 256 : CALL cp_fm_create(fm_mat_work_re, cfm_mat_target%matrix_struct)
288 256 : CALL cp_fm_create(fm_mat_work_im, cfm_mat_target%matrix_struct)
289 256 : CALL cp_fm_set_all(fm_mat_work_re, 0.0_dp)
290 256 : CALL cp_fm_set_all(fm_mat_work_im, 0.0_dp)
291 :
292 256 : CALL cp_cfm_get_info(cfm_mat_target, nrow_global=nao)
293 :
294 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_double_re, mtarget=fm_mat_work_re, &
295 : nrow=nao, ncol=nao, &
296 : s_firstrow=nstart_row, s_firstcol=nstart_col, &
297 256 : t_firstrow=1, t_firstcol=1)
298 :
299 : CALL cp_fm_to_fm_submat(msource=fm_mat_source_double_im, mtarget=fm_mat_work_im, &
300 : nrow=nao, ncol=nao, &
301 : s_firstrow=nstart_row, s_firstcol=nstart_col, &
302 256 : t_firstrow=1, t_firstcol=1)
303 :
304 256 : CALL cp_fm_to_cfm(fm_mat_work_re, fm_mat_work_im, cfm_mat_target)
305 :
306 256 : CALL cp_fm_release(fm_mat_work_re)
307 256 : CALL cp_fm_release(fm_mat_work_im)
308 256 : CALL cp_fm_release(fm_mat_source_double_re)
309 256 : CALL cp_fm_release(fm_mat_source_double_im)
310 :
311 256 : CALL timestop(handle)
312 :
313 256 : END SUBROUTINE get_cfm_submat
314 :
315 : ! **************************************************************************************************
316 : !> \brief ...
317 : !> \param fm_orig ...
318 : !> \param cfm_double ...
319 : ! **************************************************************************************************
320 96 : SUBROUTINE create_cfm_double(fm_orig, cfm_double)
321 : TYPE(cp_fm_type) :: fm_orig
322 : TYPE(cp_cfm_type) :: cfm_double
323 :
324 : CHARACTER(LEN=*), PARAMETER :: routineN = 'create_cfm_double'
325 :
326 : INTEGER :: handle, ncol_global_orig, &
327 : nrow_global_orig
328 : TYPE(cp_fm_struct_type), POINTER :: fm_struct_double
329 :
330 32 : CALL timeset(routineN, handle)
331 :
332 32 : CALL cp_fm_get_info(matrix=fm_orig, nrow_global=nrow_global_orig, ncol_global=ncol_global_orig)
333 :
334 : CALL cp_fm_struct_create(fm_struct_double, &
335 : nrow_global=2*nrow_global_orig, &
336 : ncol_global=2*ncol_global_orig, &
337 32 : template_fmstruct=fm_orig%matrix_struct)
338 :
339 32 : CALL cp_cfm_create(cfm_double, fm_struct_double)
340 :
341 32 : CALL cp_fm_struct_release(fm_struct_double)
342 :
343 32 : CALL timestop(handle)
344 :
345 32 : END SUBROUTINE create_cfm_double
346 :
347 : END MODULE soc_pseudopotential_utils
|
