Line data Source code
1 : !!****m* ABINIT/m_slc_primitive_potential
2 : !! NAME
3 : !! m_slc_primitive_potential
4 : !!
5 : !! FUNCTION
6 : !! This module contains the atomic structures and the spin-lattice coupling terms inside the primitive cell
7 : !! which can be directly mapped to the netcdf file. It is not for the calculation, but for constructing
8 : !! the hamiltonian in supercell.
9 : !!
10 : !! Datatypes:
11 : !! slc_primitive_potential_t
12 : !!
13 : !! Subroutines:
14 : !!
15 : !! COPYRIGHT
16 : !! Copyright (C) 2001-2026 ABINIT group (hexu,nehelbig)
17 : !! This file is distributed under the terms of the
18 : !! GNU General Public License, see ~abinit/COPYING
19 : !! or http://www.gnu.org/copyleft/gpl.txt .
20 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
21 : !!
22 : !! SOURCE
23 :
24 : #if defined HAVE_CONFIG_H
25 : #include "config.h"
26 : #endif
27 : #include "abi_common.h"
28 :
29 : module m_slc_primitive_potential
30 :
31 : use m_nctk
32 : #if defined HAVE_NETCDF
33 : use netcdf
34 : #endif
35 : use m_abicore
36 : use defs_basis
37 : use m_errors
38 :
39 : use m_slc_potential
40 : use m_spmat_ndcoo
41 :
42 : use m_abstract_potential, only: abstract_potential_t
43 : use m_dynamic_array, only: int2d_array_type
44 : use m_mpi_scheduler, only: init_mpi_info
45 : use m_multibinit_cell, only: mbcell_t, mbsupercell_t
46 : use m_multibinit_dataset, only: multibinit_dtset_type
47 : use m_primitive_potential, only: primitive_potential_t
48 :
49 : use m_supercell_maker, only: supercell_maker_t
50 : use m_xmpi
51 :
52 : implicit none
53 :
54 : type, public, extends(primitive_potential_t) :: slc_primitive_potential_t
55 : integer :: natom, nspin ! on every mpi node
56 : logical :: has_bilin=.False. ! bilinear coupling term, i.e. liu
57 : logical :: has_linquad=.False. ! spin first then lattice, i.e. niuv
58 : logical :: has_quadlin=.False. ! spin first then lattice, i.e. oiju
59 : logical :: has_biquad=.False. ! biquadratic coupling term, i.e. tijuv
60 :
61 : !four possible coupling terms, bilinear, quadratic-linear, linear-quadratic, and biquadratic
62 : !all the following are only on master node
63 : type(ndcoo_mat_t) :: liu ! parameter values
64 : type(ndcoo_mat_t) :: niuv ! parameter values
65 : type(ndcoo_mat_t) :: oiju ! parameter values
66 : type(ndcoo_mat_t) :: tijuv ! parameter values
67 : !R vector of i index is always zero
68 : type(int2d_array_type) :: lRulist ! R vector for u index of liu
69 : type(int2d_array_type) :: nRulist ! R vector for u index of niuv
70 : type(int2d_array_type) :: nRvlist ! R vector for v index of niuv
71 : type(int2d_array_type) :: oRjlist ! R vector for j index of oiju
72 : type(int2d_array_type) :: oRulist ! R vector for u index of oiju
73 : type(int2d_array_type) :: tRjlist ! R vector for j index of tijuv
74 : type(int2d_array_type) :: tRulist ! R vector for u index of tijuv
75 : type(int2d_array_type) :: tRvlist ! R vector for v index of tijuv
76 :
77 : contains
78 : procedure:: initialize
79 : procedure:: finalize
80 : procedure :: set_liu
81 : procedure :: set_liu_1term
82 : procedure :: set_niuv
83 : procedure :: set_niuv_1term
84 : procedure :: set_oiju
85 : procedure :: set_oiju_1term
86 : procedure :: set_tijuv
87 : procedure :: set_tijuv_1term
88 : procedure :: load_from_files
89 : procedure :: read_netcdf
90 : procedure :: read_liu
91 : procedure :: read_niuv
92 : procedure :: read_oiju
93 : procedure :: read_tijuv
94 : procedure :: fill_supercell
95 : procedure :: fill_liu
96 : procedure :: fill_niuv
97 : procedure :: fill_oiju
98 : procedure :: fill_tijuv
99 : procedure :: set_liu_sc
100 : procedure :: set_niuv_sc
101 : procedure :: set_oiju_sc
102 : procedure :: set_tijuv_sc
103 : end type slc_primitive_potential_t
104 :
105 : contains
106 :
107 2 : subroutine initialize(self, primcell)
108 : class(slc_primitive_potential_t), intent(inout) :: self
109 : type(mbcell_t), target, intent(inout) :: primcell
110 : !integer, intent(in) :: nspin
111 2 : self%primcell=>primcell
112 2 : self%label="SLC_primitive_potential"
113 2 : self%has_spin=.True.
114 2 : self%has_displacement=.True.
115 2 : self%has_strain=.False.
116 2 : self%has_lwf=.False.
117 2 : end subroutine initialize
118 :
119 :
120 2 : subroutine finalize(self)
121 : class(slc_primitive_potential_t), intent(inout) :: self
122 2 : call self%oiju%finalize()
123 2 : call self%oRjlist%finalize()
124 2 : call self%oRulist%finalize()
125 2 : call self%tijuv%finalize()
126 2 : call self%tRjlist%finalize()
127 2 : call self%tRulist%finalize()
128 2 : call self%tRvlist%finalize()
129 2 : nullify(self%primcell)
130 2 : self%nspin=0
131 2 : self%natom=0
132 2 : self%label="Destroyed SLC_primitive_potential"
133 2 : call self%primitive_potential_t%finalize()
134 2 : end subroutine finalize
135 :
136 2 : subroutine load_from_files(self, params, fnames)
137 : class(slc_primitive_potential_t), intent(inout) :: self
138 : type(multibinit_dtset_type), intent(in) :: params
139 : character(len=fnlen), intent(in) :: fnames(:)
140 : character(len=fnlen) :: ncdf_fname
141 : character(len=500) :: message
142 : integer :: ii
143 : ABI_UNUSED(fnames)
144 2 : if (xmpi_comm_rank(xmpi_world)==0) then
145 2 : ncdf_fname=params%slc_pot_fname
146 164 : write(message,'(a,(81a, 80a),3a)') ch10,('=',ii=1,80),ch10,ch10,&
147 166 : & '- Reading spin-lattice coupling terms from ', trim(ncdf_fname)
148 2 : call wrtout(ab_out,message,'COLL')
149 2 : call wrtout(std_out,message,'COLL')
150 : endif
151 2 : call self%read_netcdf(trim(ncdf_fname)//char(0))
152 :
153 2 : ABI_UNUSED_A(params)
154 2 : end subroutine load_from_files
155 :
156 : !-----------------------------------
157 : ! reading parameters from ncdf file
158 : !-----------------------------------
159 2 : subroutine read_netcdf(self, ncdf_fname)
160 : class(slc_primitive_potential_t), intent(inout) :: self
161 : character (len = *), intent(in) :: ncdf_fname
162 :
163 : integer:: ncid, ncerr, comm
164 :
165 : #if defined HAVE_NETCDF
166 :
167 2 : comm = xmpi_world
168 :
169 2 : ncerr = nctk_open_read(ncid, ncdf_fname, comm)
170 :
171 : ! read primcell info
172 2 : ncerr=nctk_get_dim(ncid, "natom", self%natom)
173 2 : ncerr=nctk_get_dim(ncid, "nspin", self%nspin)
174 :
175 : ! read different coupling terms if they are present in the file
176 2 : call self%read_liu(ncid)
177 2 : call self%read_niuv(ncid)
178 2 : call self%read_oiju(ncid)
179 2 : call self%read_tijuv(ncid)
180 :
181 2 : ncerr = nf90_close(ncid)
182 2 : if(ncerr /= NF90_NOERR) then
183 0 : write(std_out,'(A25)') 'Could not close netcdf file'
184 : endif
185 : #else
186 : ABI_ERROR("Multibint should be installed with netcdf enabled to run this.")
187 :
188 : #endif
189 :
190 2 : end subroutine read_netcdf
191 :
192 : !---------------------------------------
193 : ! reading liu parameters from ncdf file
194 : ! TODO: test
195 : !---------------------------------------
196 2 : subroutine read_liu(self, ncid)
197 : class(slc_primitive_potential_t), intent(inout) :: self
198 : integer, intent(in) :: ncid
199 :
200 : integer :: ncerr, dimid, ndata, varid
201 2 : integer, allocatable :: ilist(:), ulist(:,:)
202 2 : real(dp), allocatable :: vallist(:)
203 : #if defined HAVE_NETCDF
204 :
205 2 : ncerr = nf90_inq_dimid(ncid, "spin_lattice_Liu_number_of_entries", dimid)
206 2 : if(ncerr /= NF90_NOERR) then
207 2 : ndata = 0
208 : else
209 0 : self%has_bilin=.True.
210 0 : ncerr = nctk_get_dim(ncid, "spin_lattice_Liu_number_of_entries", ndata)
211 0 : ABI_MALLOC(ilist, (ndata))
212 0 : ABI_MALLOC(ulist, (4,ndata))
213 0 : ABI_MALLOC(vallist, (ndata))
214 :
215 0 : varid = nctk_idname(ncid, "spin_lattice_Liu_ilist")
216 0 : ncerr = nf90_get_var(ncid, varid, ilist)
217 0 : call netcdf_check(ncerr, "when reading Liu_ilist")
218 :
219 0 : varid = nctk_idname(ncid, "spin_lattice_Liu_ulist")
220 0 : ncerr = nf90_get_var(ncid, varid, ulist)
221 0 : call netcdf_check(ncerr, "when reading Liu_ulist")
222 :
223 0 : varid = nctk_idname(ncid, "spin_lattice_Liu_valuelist")
224 0 : ncerr = nf90_get_var(ncid, varid, vallist)
225 0 : call netcdf_check(ncerr, "when reading Liu_valuelist")
226 :
227 : !change units from eV to Ha and Ang to Bohr
228 0 : vallist(:) = vallist(:)*eV_Ha*Bohr_Ang
229 :
230 : !fill the sparse matrix for liu parameters
231 0 : call self%set_liu(ndata, ilist, ulist, vallist)
232 :
233 0 : ABI_SFREE(ilist)
234 0 : ABI_SFREE(ulist)
235 0 : ABI_SFREE(vallist)
236 : endif
237 :
238 2 : write(std_out,'(A8,I10,A11)') 'L_iu: ', ndata, 'terms read'
239 : #else
240 : ABI_ERROR("Multibinit should be installed with netcdf.")
241 : #endif
242 :
243 2 : end subroutine read_liu
244 :
245 : !----------------------------------------
246 : ! reading niuv parameters from ncdf file
247 : ! TODO: test
248 : !----------------------------------------
249 2 : subroutine read_niuv(self, ncid)
250 : class(slc_primitive_potential_t), intent(inout) :: self
251 : integer, intent(in) :: ncid
252 :
253 : integer :: ncerr, dimid, ndata, varid
254 2 : integer, allocatable :: ilist(:), ulist(:,:), vlist(:,:)
255 2 : real(dp), allocatable :: vallist(:)
256 : #if defined HAVE_NETCDF
257 2 : ncerr = nf90_inq_dimid(ncid, "spin_lattice_Niuv_number_of_entries", dimid)
258 2 : if(ncerr /= NF90_NOERR) then
259 2 : ndata = 0
260 : else
261 0 : self%has_linquad=.True.
262 0 : ncerr = nctk_get_dim(ncid, "spin_lattice_Niuv_number_of_entries", ndata)
263 0 : ABI_MALLOC(ilist, (ndata))
264 0 : ABI_MALLOC(ulist, (4,ndata))
265 0 : ABI_MALLOC(vlist, (4,ndata))
266 0 : ABI_MALLOC(vallist, (ndata))
267 :
268 0 : varid = nctk_idname(ncid, "spin_lattice_Niuv_ilist")
269 0 : ncerr = nf90_get_var(ncid, varid, ilist)
270 0 : call netcdf_check(ncerr, "when reading Niuv_ilist")
271 :
272 0 : varid = nctk_idname(ncid, "spin_lattice_Niuv_ulist")
273 0 : ncerr = nf90_get_var(ncid, varid, ulist)
274 0 : call netcdf_check(ncerr, "when reading Niuv_ulist")
275 :
276 0 : varid = nctk_idname(ncid, "spin_lattice_Niuv_vlist")
277 0 : ncerr = nf90_get_var(ncid, varid, ulist)
278 0 : call netcdf_check(ncerr, "when reading Niuv_vlist")
279 :
280 0 : varid = nctk_idname(ncid, "spin_lattice_Niuv_valuelist")
281 0 : ncerr = nf90_get_var(ncid, varid, vallist)
282 0 : call netcdf_check(ncerr, "when reading Niuv_valuelist")
283 :
284 : !change units from eV to Ha and Ang to Bohr
285 0 : vallist(:) = vallist(:)*eV_Ha*(Bohr_Ang*Bohr_Ang)
286 :
287 : !fill the sparse matrix for liu parameters
288 0 : call self%set_niuv(ndata, ilist, ulist, vlist, vallist)
289 :
290 0 : ABI_SFREE(ilist)
291 0 : ABI_SFREE(ulist)
292 0 : ABI_SFREE(vlist)
293 0 : ABI_SFREE(vallist)
294 : endif
295 :
296 2 : write(std_out,'(A8,I10,A11)') 'N_iuv: ', ndata, 'terms read'
297 : #else
298 : ABI_ERROR("Multibinit should be installed with netcdf")
299 : #endif
300 :
301 2 : end subroutine read_niuv
302 :
303 : !---------------------------------------
304 : ! reading oiju parameters from ncdf file
305 : !---------------------------------------
306 2 : subroutine read_oiju(self, ncid)
307 : class(slc_primitive_potential_t), intent(inout) :: self
308 : integer, intent(in) :: ncid
309 :
310 : integer :: ncerr, dimid, ndata, varid
311 2 : integer, allocatable :: ilist(:), jlist(:,:), ulist(:,:)
312 2 : real(dp), allocatable :: vallist(:)
313 :
314 : #if defined HAVE_NETCDF
315 2 : ncerr = nf90_inq_dimid(ncid, "spin_lattice_Oiju_number_of_entries", dimid)
316 2 : if(ncerr /= NF90_NOERR) then
317 0 : write(std_out,'(A20)') 'No O_iju term found'
318 : else
319 2 : self%has_quadlin=.True.
320 2 : ncerr = nctk_get_dim(ncid, "spin_lattice_Oiju_number_of_entries", ndata)
321 6 : ABI_MALLOC(ilist, (ndata))
322 6 : ABI_MALLOC(jlist, (4,ndata))
323 4 : ABI_MALLOC(ulist, (4,ndata))
324 6 : ABI_MALLOC(vallist, (ndata))
325 :
326 2 : varid = nctk_idname(ncid, "spin_lattice_Oiju_ilist")
327 2 : ncerr = nf90_get_var(ncid, varid, ilist)
328 2 : call netcdf_check(ncerr, "when reading Oiju_ilist")
329 :
330 2 : varid = nctk_idname(ncid, "spin_lattice_Oiju_jlist")
331 2 : ncerr = nf90_get_var(ncid, varid, jlist)
332 2 : call netcdf_check(ncerr, "when reading Oiju_jlist")
333 :
334 2 : varid = nctk_idname(ncid, "spin_lattice_Oiju_ulist")
335 2 : ncerr = nf90_get_var(ncid, varid, ulist)
336 2 : call netcdf_check(ncerr, "when reading Oiju_ulist")
337 :
338 2 : varid = nctk_idname(ncid, "spin_lattice_Oiju_valuelist")
339 2 : ncerr = nf90_get_var(ncid, varid, vallist)
340 2 : call netcdf_check(ncerr, "when reading spin_lattice_Oiju_valuelist")
341 :
342 2 : write(std_out,'(A8,I10,A11)') 'O_iju: ', ndata, 'terms read'
343 :
344 : !change units from eV to Ha and Ang to Bohr
345 4826 : vallist(:) = vallist(:)*eV_Ha*Bohr_Ang
346 :
347 : !fill the sparse matrix for oiju parameters
348 2 : call self%set_oiju(ndata, ilist, jlist, ulist, vallist)
349 :
350 2 : ABI_SFREE(ilist)
351 2 : ABI_SFREE(jlist)
352 2 : ABI_SFREE(ulist)
353 2 : ABI_SFREE(vallist)
354 : endif
355 : #else
356 : ABI_ERROR('Multibinit should be install with netcdf to run this.')
357 : #endif
358 :
359 2 : end subroutine read_oiju
360 :
361 : !-----------------------------------------
362 : ! reading tijuv parameters from ncdf file
363 : !-----------------------------------------
364 2 : subroutine read_tijuv(self, ncid)
365 : class(slc_primitive_potential_t), intent(inout) :: self
366 : integer, intent(in) :: ncid
367 :
368 : integer :: ncerr, dimid, ndata, varid
369 2 : integer, allocatable :: ilist(:), jlist(:,:), ulist(:,:), vlist(:,:)
370 2 : real(dp), allocatable :: vallist(:)
371 :
372 : #if defined HAVE_NETCDF
373 2 : ncerr = nf90_inq_dimid(ncid, "spin_lattice_Tijuv_number_of_entries", dimid)
374 2 : if(ncerr /= NF90_NOERR) then
375 : ndata = 0
376 : else
377 2 : self%has_biquad=.True.
378 2 : ncerr = nctk_get_dim(ncid, "spin_lattice_Tijuv_number_of_entries", ndata)
379 6 : ABI_MALLOC(ilist, (ndata))
380 6 : ABI_MALLOC(jlist, (4, ndata))
381 4 : ABI_MALLOC(ulist, (4, ndata))
382 4 : ABI_MALLOC(vlist, (4, ndata))
383 6 : ABI_MALLOC(vallist, (ndata))
384 :
385 2 : varid = nctk_idname(ncid, "spin_lattice_Tijuv_ilist")
386 2 : ncerr = nf90_get_var(ncid, varid, ilist)
387 2 : call netcdf_check(ncerr, "when reading Tijuv_ilist")
388 :
389 2 : varid = nctk_idname(ncid, "spin_lattice_Tijuv_jlist")
390 2 : ncerr = nf90_get_var(ncid, varid, jlist)
391 2 : call netcdf_check(ncerr, "when reading Tijuv_jlist")
392 :
393 2 : varid = nctk_idname(ncid, "spin_lattice_Tijuv_ulist")
394 2 : ncerr = nf90_get_var(ncid, varid, ulist)
395 2 : call netcdf_check(ncerr, "when reading Tijuv_ulist")
396 :
397 2 : varid = nctk_idname(ncid, "spin_lattice_Tijuv_vlist")
398 2 : ncerr = nf90_get_var(ncid, varid, vlist)
399 2 : call netcdf_check(ncerr, "when reading Tijuv_vlist")
400 :
401 2 : varid = nctk_idname(ncid, "spin_lattice_Tijuv_valuelist")
402 2 : ncerr = nf90_get_var(ncid, varid, vallist)
403 2 : call netcdf_check(ncerr, "when reading Tijuv_valuelist")
404 :
405 2 : write(std_out,'(A8,I10,A11)') 'T_ijuv:', ndata, 'terms read'
406 :
407 : !change units from eV to Ha and Ang to Bohr
408 650 : vallist(:) = vallist(:)*eV_Ha*(Bohr_Ang*Bohr_Ang)
409 :
410 : !fill the sparse matrix for tijuv parameters
411 2 : call self%set_tijuv(ndata, ilist, jlist, ulist, vlist, vallist)
412 :
413 2 : ABI_SFREE(ilist)
414 2 : ABI_SFREE(jlist)
415 2 : ABI_SFREE(ulist)
416 2 : ABI_SFREE(vlist)
417 2 : ABI_SFREE(vallist)
418 : endif
419 :
420 : #else
421 : ABI_ERROR('Multibinit should be install with netcdf to run this.')
422 : #endif
423 :
424 :
425 2 : end subroutine read_tijuv
426 :
427 : !---------------------------------------
428 : ! store liu parameters in sparse matrix
429 : ! TODO: test
430 : !---------------------------------------
431 0 : subroutine set_liu(self, nn, ilist, ulist, vallist)
432 :
433 : class(slc_primitive_potential_t), intent(inout) :: self
434 : integer, intent(inout) :: nn
435 : integer, intent(in) :: ilist(nn)
436 : integer, intent(in) :: ulist(4,nn)
437 : real(dp), intent(in) :: vallist(nn)
438 :
439 : integer :: idx
440 :
441 0 : call self%liu%initialize(mshape=[-1, self%nspin*3, self%natom*3])
442 :
443 0 : if (xmpi_comm_rank(xmpi_world)==0) then
444 0 : do idx=1, nn
445 0 : call self%set_liu_1term(ilist(idx), ulist(1,idx), ulist(2:4,idx), vallist(idx))
446 : end do
447 : endif
448 0 : end subroutine set_liu
449 :
450 : !------------------------------------
451 : ! add one entry to sparse liu matrix
452 : ! TODO: test
453 : !------------------------------------
454 0 : subroutine set_liu_1term(self, ii, uu, Ru, val)
455 : class(slc_primitive_potential_t), intent(inout) :: self
456 : integer, intent(in) :: ii
457 : integer, intent(in) :: uu
458 : integer, intent(in) :: Ru(3)
459 : real(dp), intent(in) :: val
460 :
461 : integer :: indRu
462 :
463 0 : call self%lRulist%push_unique(Ru, position=indRu)
464 :
465 0 : call self%liu%add_entry(ind=[indRu, ii, uu], val=val)
466 :
467 0 : end subroutine set_liu_1term
468 :
469 : !----------------------------------------
470 : ! store niuv parameters in sparse matrix
471 : ! TODO: test
472 : !----------------------------------------
473 0 : subroutine set_niuv(self, nn, ilist, ulist, vlist, vallist)
474 :
475 : class(slc_primitive_potential_t), intent(inout) :: self
476 : integer, intent(inout) :: nn
477 : integer, intent(in) :: ilist(nn)
478 : integer, intent(in) :: ulist(4,nn)
479 : integer, intent(in) :: vlist(4,nn)
480 : real(dp), intent(in) :: vallist(nn)
481 :
482 : integer :: idx
483 :
484 0 : call self%niuv%initialize(mshape=[-1, -1, self%nspin*3, self%natom*3, self%natom*3])
485 :
486 0 : if (xmpi_comm_rank(xmpi_world)==0) then
487 0 : do idx=1, nn
488 0 : call self%set_niuv_1term(ilist(idx), ulist(1,idx), vlist(1,idx), ulist(2:4,idx), vlist(2:4,idx), vallist(idx))
489 : end do
490 : endif
491 :
492 0 : end subroutine set_niuv
493 :
494 : !-------------------------------------
495 : ! add one entry to sparse niuv matrix
496 : !-------------------------------------
497 0 : subroutine set_niuv_1term(self, ii, uu, vv, Ru, Rv, val)
498 : class(slc_primitive_potential_t), intent(inout) :: self
499 : integer, intent(in) :: ii
500 : integer, intent(in) :: uu
501 : integer, intent(in) :: vv
502 : integer, intent(in) :: Ru(3)
503 : integer, intent(in) :: Rv(3)
504 : real(dp), intent(in) :: val
505 :
506 : integer :: indRu, indRv
507 :
508 0 : call self%nRulist%push_unique(Ru, position=indRu)
509 0 : call self%nRvlist%push_unique(Rv, position=indRv)
510 :
511 0 : call self%niuv%add_entry(ind=[indRu, indRv, ii, uu, vv], val=val)
512 :
513 0 : end subroutine set_niuv_1term
514 :
515 :
516 : !----------------------------------------
517 : ! store oiju parameters in sparse matrix
518 : ! TODO: test
519 : !----------------------------------------
520 2 : subroutine set_oiju(self, nn, ilist, jlist, ulist, vallist)
521 :
522 : class(slc_primitive_potential_t), intent(inout) :: self
523 : integer, intent(inout) :: nn
524 : integer, intent(in) :: ilist(nn)
525 : integer, intent(in) :: jlist(4,nn)
526 : integer, intent(in) :: ulist(4,nn)
527 : real(dp), intent(in) :: vallist(nn)
528 :
529 : integer :: idx
530 :
531 12 : call self%oiju%initialize(mshape=[-1, -1, self%nspin*3, self%nspin*3, self%natom*3])
532 :
533 2 : if (xmpi_comm_rank(xmpi_world)==0) then
534 4826 : do idx=1, nn
535 4826 : call self%set_oiju_1term(ilist(idx), jlist(1,idx), ulist(1,idx), jlist(2:4,idx), ulist(2:4,idx), vallist(idx))
536 : end do
537 : endif
538 :
539 2 : call self%oiju%sum_duplicates()
540 2 : end subroutine set_oiju
541 :
542 : !-------------------------------------
543 : ! add one entry to sparse oiju matrix
544 : ! TODO: test
545 : !-------------------------------------
546 4824 : subroutine set_oiju_1term(self, ii, jj, uu, Rj, Ru, val)
547 : class(slc_primitive_potential_t), intent(inout) :: self
548 : integer, intent(in) :: ii
549 : integer, intent(in) :: jj
550 : integer, intent(in) :: uu
551 : integer, intent(in) :: Rj(3)
552 : integer, intent(in) :: Ru(3)
553 : real(dp), intent(in) :: val
554 :
555 : integer :: indRj, indRu
556 :
557 4824 : call self%oRjlist%push_unique(Rj, position=indRj)
558 4824 : call self%oRulist%push_unique(Ru, position=indRu)
559 :
560 28944 : call self%oiju%add_entry(ind=[indRj, indRu, ii, jj, uu], val=val)
561 :
562 4824 : end subroutine set_oiju_1term
563 :
564 : !----------------------------------------
565 : ! store tijuv parameters in sparse matrix
566 : !----------------------------------------
567 2 : subroutine set_tijuv(self, nn, ilist, jlist, ulist, vlist, vallist)
568 :
569 : class(slc_primitive_potential_t), intent(inout) :: self
570 : integer, intent(inout) :: nn
571 : integer, intent(in) :: ilist(nn)
572 : integer, intent(in) :: jlist(4, nn)
573 : integer, intent(in) :: ulist(4, nn)
574 : integer, intent(in) :: vlist(4, nn)
575 : real(dp), intent(in) :: vallist(nn)
576 :
577 : integer :: idx
578 :
579 16 : call self%tijuv%initialize(mshape=[-1, -1, -1, self%nspin*3, self%nspin*3, self%natom*3, self%natom*3])
580 :
581 2 : if (xmpi_comm_rank(xmpi_world)==0) then
582 650 : do idx=1, nn
583 : call self%set_tijuv_1term(ilist(idx), jlist(1, idx), ulist(1, idx), vlist(1, idx), &
584 650 : & jlist(2:4,idx), ulist(2:4,idx), vlist(2:4,idx), vallist(idx))
585 : end do
586 : endif
587 :
588 2 : call self%tijuv%sum_duplicates()
589 :
590 2 : end subroutine set_tijuv
591 :
592 : !-------------------------------------
593 : ! add one entry to sparse tijuv matrix
594 : !-------------------------------------
595 648 : subroutine set_tijuv_1term(self, ii, jj, uu, vv, Rj, Ru, Rv, val)
596 : class(slc_primitive_potential_t), intent(inout) :: self
597 : integer, intent(in) :: ii
598 : integer, intent(in) :: jj
599 : integer, intent(in) :: uu
600 : integer, intent(in) :: vv
601 : integer, intent(in) :: Rj(3)
602 : integer, intent(in) :: Ru(3)
603 : integer, intent(in) :: Rv(3)
604 : real(dp), intent(in) :: val
605 :
606 : integer :: indRj, indRu, indRv
607 :
608 648 : call self%tRjlist%push_unique(Rj, position=indRj)
609 648 : call self%tRulist%push_unique(Ru, position=indRu)
610 648 : call self%tRvlist%push_unique(Rv, position=indRv)
611 :
612 5184 : call self%tijuv%add_entry(ind=[indRj, indRu, indRv, ii, jj, uu, vv], val=val)
613 :
614 648 : end subroutine set_tijuv_1term
615 :
616 :
617 : !-----------------------------------------------------------------
618 : ! transfer parameter information from primitive cell to supercell
619 : ! TODO: test
620 : !-----------------------------------------------------------------
621 2 : subroutine fill_supercell(self, scmaker, params, scpot, supercell)
622 : class(slc_primitive_potential_t) , intent(inout) :: self
623 : type(supercell_maker_t), intent(inout) :: scmaker
624 : type(multibinit_dtset_type), intent(inout) :: params
625 : class(abstract_potential_t), pointer, intent(inout) :: scpot
626 : type(mbsupercell_t), target :: supercell
627 :
628 : integer :: nspin, sc_nspin, natom, sc_natom
629 : integer :: master, my_rank, comm, nproc, ierr
630 : logical :: iam_master
631 :
632 2 : call init_mpi_info(master, iam_master, my_rank, comm, nproc)
633 :
634 2 : nspin=self%nspin
635 2 : natom=self%natom
636 2 : sc_nspin=nspin * scmaker%ncells
637 2 : sc_natom=natom * scmaker%ncells
638 :
639 2 : call xmpi_bcast(sc_nspin, master, comm, ierr)
640 2 : call xmpi_bcast(sc_natom, master, comm, ierr)
641 2 : ABI_MALLOC_TYPE_SCALAR(slc_potential_t, scpot)
642 :
643 : select type(scpot) ! use select type because properties only defined for slc_potential are used
644 : type is (slc_potential_t)
645 2 : call scpot%initialize(sc_nspin, sc_natom)
646 2 : call scpot%set_supercell(supercell)
647 2 : call scpot%set_params(params)
648 : ! fill different coupling terms
649 4 : if (iam_master) then
650 2 : call self%fill_liu(scpot, scmaker)
651 2 : call self%fill_oiju(scpot, scmaker)
652 2 : call self%fill_niuv(scpot, scmaker)
653 2 : call self%fill_tijuv(scpot, scmaker)
654 :
655 : !Write information which terms are used
656 2 : write(std_out,'(A55)') 'Using the following terms for the spin-lattice coupling'
657 2 : if(scpot%has_bilin) write(std_out,'(A19)') 'Bilinear term: Liu'
658 2 : if(scpot%has_quadlin) write(std_out,'(A28)') 'Quadratic-linear term: Oiju'
659 2 : if(scpot%has_linquad) write(std_out,'(A28)') 'Linear-quadratic term: Niuv'
660 2 : if(scpot%has_biquad) write(std_out,'(A24)') 'Biquadratic term: Tijuv'
661 : endif
662 : end select
663 2 : end subroutine fill_supercell
664 :
665 : !--------------------------------------------------------
666 : ! Check for each term if it is needed in the calculation
667 : ! and present in the ncdf input then put into supercell
668 : !--------------------------------------------------------
669 2 : subroutine fill_liu(self, scpot, scmaker)
670 : class(slc_primitive_potential_t) , intent(inout) :: self
671 : type(supercell_maker_t), intent(inout) :: scmaker
672 : class(slc_potential_t), intent(inout) :: scpot
673 :
674 2 : if(scpot%has_bilin) then
675 0 : if(self%has_bilin) then !did we actually find this in the netcdf file
676 0 : call self%liu%sum_duplicates()
677 0 : call self%set_liu_sc(scpot, scmaker)
678 : else
679 0 : ABI_ERROR("No parameters for bilinear coupling available. Check your input and parameter files.")
680 0 : scpot%has_bilin = .False.
681 : endif
682 : endif
683 2 : end subroutine fill_liu
684 :
685 2 : subroutine fill_niuv(self, scpot, scmaker)
686 : class(slc_primitive_potential_t) , intent(inout) :: self
687 : type(supercell_maker_t), intent(inout) :: scmaker
688 : class(slc_potential_t), intent(inout) :: scpot
689 :
690 2 : if(scpot%has_linquad) then
691 0 : if(self%has_linquad) then
692 0 : call self%niuv%sum_duplicates()
693 0 : call self%set_niuv_sc(scpot, scmaker)
694 : else
695 0 : ABI_ERROR("No parameters for linear-quadratic coupling available. Check your input and parameter files.")
696 0 : scpot%has_linquad = .False.
697 : endif
698 : endif
699 2 : end subroutine fill_niuv
700 :
701 2 : subroutine fill_oiju(self, scpot, scmaker)
702 : class(slc_primitive_potential_t) , intent(inout) :: self
703 : type(supercell_maker_t), intent(inout) :: scmaker
704 : class(slc_potential_t), intent(inout) :: scpot
705 :
706 2 : if(scpot%has_quadlin) then
707 2 : if(self%has_quadlin) then
708 2 : call self%oiju%sum_duplicates()
709 2 : call self%set_oiju_sc(scpot, scmaker)
710 : else
711 0 : ABI_ERROR("No parameters for quadratic-linear coupling available. Check your input and parameter files.")
712 0 : scpot%has_quadlin = .False.
713 : endif
714 : endif
715 2 : end subroutine fill_oiju
716 :
717 2 : subroutine fill_tijuv(self, scpot, scmaker)
718 : class(slc_primitive_potential_t) , intent(inout) :: self
719 : type(supercell_maker_t), intent(inout) :: scmaker
720 : class(slc_potential_t), intent(inout) :: scpot
721 :
722 2 : if(scpot%has_biquad) then
723 1 : if(self%has_biquad) then
724 1 : call self%tijuv%sum_duplicates()
725 1 : call self%set_tijuv_sc(scpot, scmaker)
726 : else
727 0 : ABI_ERROR("No parameters for biquadratic coupling available. Check your input and parameter files.")
728 0 : scpot%has_biquad = .False.
729 : endif
730 : endif
731 2 : end subroutine fill_tijuv
732 :
733 : !------------------------------
734 : ! fill liu terms in supercell
735 : ! TODO: test
736 : !------------------------------
737 0 : subroutine set_liu_sc(self, scpot, scmaker)
738 : class(slc_primitive_potential_t), intent(inout) :: self
739 : type(slc_potential_t), intent(inout) :: scpot
740 : type(supercell_maker_t), intent(inout) :: scmaker
741 :
742 : integer :: icell, Ru_prim(3), liu_ind(3), iRu, i_prim, u_prim, inz
743 : integer :: ngroup
744 0 : integer, allocatable :: i_sc(:), u_sc(:), Ru_sc(:,:)
745 0 : integer, allocatable :: i1list(:), ise(:)
746 0 : real(dp) :: val_sc(scmaker%ncells)
747 :
748 : integer :: master, my_rank, comm, nproc
749 : logical :: iam_master
750 :
751 0 : call init_mpi_info(master, iam_master, my_rank, comm, nproc)
752 :
753 0 : if(iam_master) then
754 0 : call scpot%liu_sc%initialize(mshape=[self%nspin*3, self%natom*3])
755 : endif
756 :
757 0 : do inz=1, self%liu%nnz
758 0 : liu_ind=self%liu%get_ind_inz(inz)
759 0 : iRu=liu_ind(1)
760 0 : i_prim=liu_ind(2)
761 0 : u_prim=liu_ind(3)
762 0 : Ru_prim=self%lRulist%data(:,iRu)
763 0 : call scmaker%trans_i(nbasis=self%nspin*3, i=i_prim, i_sc=i_sc)
764 0 : call scmaker%trans_j_and_Rj(nbasis=self%natom*3, j=u_prim, Rj=Ru_prim, j_sc=u_sc, Rj_sc=Ru_sc)
765 0 : val_sc(:)= self%liu%val%data(inz)
766 0 : do icell=1, scmaker%ncells
767 0 : call scpot%add_liu_term(i_sc(icell), u_sc(icell), val_sc(icell))
768 : end do
769 0 : ABI_SFREE(i_sc)
770 0 : ABI_SFREE(u_sc)
771 0 : ABI_SFREE(Ru_sc)
772 : end do
773 :
774 0 : call scpot%liu_sc%group_by_1dim(ngroup, i1list, ise)
775 0 : ABI_SFREE(i1list)
776 0 : ABI_SFREE(ise)
777 :
778 0 : end subroutine set_liu_sc
779 :
780 : !------------------------------
781 : ! fill niuv terms in supercell
782 : ! TODO: test
783 : !------------------------------
784 0 : subroutine set_niuv_sc(self, scpot, scmaker)
785 : class(slc_primitive_potential_t), intent(inout) :: self
786 : type(slc_potential_t), intent(inout) :: scpot
787 : type(supercell_maker_t), intent(inout) :: scmaker
788 :
789 : integer :: icell, Ru_prim(3), Rv_prim(3), niuv_ind(5), iRu, iRv, i_prim, u_prim, v_prim, inz
790 : integer :: ngroup
791 0 : integer, allocatable :: i_sc(:), u_sc(:), v_sc(:), Ru_sc(:,:), Rv_sc(:,:)
792 0 : integer, allocatable :: i1list(:), ise(:)
793 0 : real(dp) :: val_sc(scmaker%ncells)
794 :
795 : integer :: master, my_rank, comm, nproc
796 : logical :: iam_master
797 :
798 0 : call init_mpi_info(master, iam_master, my_rank, comm, nproc)
799 :
800 0 : if(iam_master) then
801 0 : call scpot%niuv_sc%initialize(mshape=[self%nspin*3, self%natom*3, self%natom*3])
802 : endif
803 :
804 0 : do inz=1, self%niuv%nnz
805 0 : niuv_ind=self%niuv%get_ind_inz(inz)
806 0 : iRu=niuv_ind(1)
807 0 : iRv=niuv_ind(2)
808 0 : i_prim=niuv_ind(3)
809 0 : u_prim=niuv_ind(4)
810 0 : v_prim=niuv_ind(5)
811 0 : Ru_prim=self%nRulist%data(:,iRu)
812 0 : Rv_prim=self%nRvlist%data(:,iRv)
813 0 : call scmaker%trans_i(nbasis=self%nspin*3, i=i_prim, i_sc=i_sc)
814 0 : call scmaker%trans_j_and_Rj(nbasis=self%natom*3, j=u_prim, Rj=Ru_prim, j_sc=u_sc, Rj_sc=Ru_sc)
815 0 : call scmaker%trans_j_and_Rj(nbasis=self%natom*3, j=v_prim, Rj=Rv_prim, j_sc=v_sc, Rj_sc=Rv_sc)
816 0 : val_sc(:)= self%niuv%val%data(inz)
817 0 : do icell=1, scmaker%ncells
818 : !call scpot%add_niuv_term(i_sc(icell), u_sc(icell), v_sc(icell), val_sc(icell))
819 : end do
820 0 : ABI_SFREE(i_sc)
821 0 : ABI_SFREE(u_sc)
822 0 : ABI_SFREE(v_sc)
823 0 : ABI_SFREE(Ru_sc)
824 0 : ABI_SFREE(Rv_sc)
825 : end do
826 :
827 0 : call scpot%niuv_sc%group_by_1dim(ngroup, i1list, ise)
828 0 : ABI_SFREE(i1list)
829 0 : ABI_SFREE(ise)
830 :
831 0 : end subroutine set_niuv_sc
832 :
833 :
834 : !------------------------------
835 : ! fill oiju terms in supercell
836 : ! TODO: test
837 : !------------------------------
838 2 : subroutine set_oiju_sc(self, scpot, scmaker)
839 : class(slc_primitive_potential_t), intent(inout) :: self
840 : class(slc_potential_t), intent(inout) :: scpot
841 : type(supercell_maker_t), intent(inout) :: scmaker
842 :
843 : integer :: icell, Rj_prim(3), Ru_prim(3), oiju_ind(5), iRj, iRu, i_prim, j_prim, u_prim, inz
844 : integer :: ngroup
845 2 : integer, allocatable :: i_sc(:), j_sc(:), u_sc(:), Rj_sc(:, :), Ru_sc(:,:)
846 2 : integer, allocatable :: i1list(:), ise(:)
847 4 : real(dp) :: val_sc(scmaker%ncells)
848 :
849 : integer :: master, my_rank, comm, nproc
850 : logical :: iam_master
851 :
852 2 : call init_mpi_info(master, iam_master, my_rank, comm, nproc)
853 :
854 2 : if(iam_master) then
855 8 : call scpot%oiju_sc%initialize(mshape=[self%nspin*3, self%nspin*3, self%natom*3])
856 : endif
857 :
858 4826 : do inz=1, self%oiju%nnz
859 4824 : oiju_ind=self%oiju%get_ind_inz(inz)
860 4824 : iRj=oiju_ind(1)
861 4824 : iRu=oiju_ind(2)
862 4824 : i_prim=oiju_ind(3)
863 4824 : j_prim=oiju_ind(4)
864 4824 : u_prim=oiju_ind(5)
865 19296 : Rj_prim=self%oRjlist%data(:,iRj)
866 19296 : Ru_prim=self%oRulist%data(:,iRu)
867 4824 : call scmaker%trans_i(nbasis=self%nspin*3, i=i_prim, i_sc=i_sc)
868 4824 : call scmaker%trans_j_and_Rj(nbasis=self%nspin*3, j=j_prim, Rj=Rj_prim, j_sc=j_sc, Rj_sc=Rj_sc)
869 4824 : call scmaker%trans_j_and_Rj(nbasis=self%natom*3, j=u_prim, Rj=Ru_prim, j_sc=u_sc, Rj_sc=Ru_sc)
870 1046808 : val_sc(:)= self%oiju%val%data(inz)
871 1046808 : do icell=1, scmaker%ncells
872 1046808 : call scpot%add_oiju_term(i_sc(icell), j_sc(icell), u_sc(icell), val_sc(icell))
873 : end do
874 4824 : ABI_SFREE(i_sc)
875 4824 : ABI_SFREE(j_sc)
876 4824 : ABI_SFREE(u_sc)
877 4824 : ABI_SFREE(Rj_sc)
878 4826 : ABI_SFREE(Ru_sc)
879 : end do
880 :
881 2 : call scpot%oiju_sc%group_by_1dim(ngroup, i1list, ise)
882 2 : ABI_SFREE(i1list)
883 2 : ABI_SFREE(ise)
884 :
885 2 : end subroutine set_oiju_sc
886 :
887 1 : subroutine set_tijuv_sc(self, scpot, scmaker)
888 : class(slc_primitive_potential_t), intent(inout) :: self
889 : type(slc_potential_t), intent(inout) :: scpot
890 : type(supercell_maker_t), intent(inout) :: scmaker
891 :
892 : integer :: icell, Rj(3), Ru(3), Rv(3), tijuv_ind(7), iRj, iRu, iRv, ii, ij, iu, iv, inz
893 1 : integer, allocatable :: i_sc(:), j_sc(:), u_sc(:), v_sc(:), Rj_sc(:, :), Ru_sc(:,:), Rv_sc(:,:)
894 2 : real(dp) :: val_sc(scmaker%ncells)
895 :
896 : integer :: master, my_rank, comm, nproc
897 : logical :: iam_master
898 :
899 1 : call init_mpi_info(master, iam_master, my_rank, comm, nproc)
900 :
901 1 : if(iam_master) then
902 5 : call scpot%tijuv_sc%initialize(mshape=[self%nspin*3, self%nspin*3, self%natom*3, self%natom*3])
903 5 : call scpot%tuvij_sc%initialize(mshape=[self%natom*3, self%natom*3, self%nspin*3, self%nspin*3])
904 : endif
905 :
906 325 : do inz=1, self%tijuv%nnz
907 324 : tijuv_ind=self%tijuv%get_ind_inz(inz)
908 324 : iRj=tijuv_ind(1)
909 324 : iRu=tijuv_ind(2)
910 324 : iRv=tijuv_ind(3)
911 324 : ii=tijuv_ind(4)
912 324 : ij=tijuv_ind(5)
913 324 : iu=tijuv_ind(6)
914 324 : iv=tijuv_ind(7)
915 1296 : Rj=self%tRjlist%data(:,iRj)
916 1296 : Ru=self%tRulist%data(:,iRu)
917 1296 : Rv=self%tRvlist%data(:,iRv)
918 324 : call scmaker%trans_i(nbasis=self%nspin*3, i=ii, i_sc=i_sc)
919 324 : call scmaker%trans_j_and_Rj(nbasis=self%nspin*3, j=ij, Rj=Rj, j_sc=j_sc, Rj_sc=Rj_sc)
920 324 : call scmaker%trans_j_and_Rj(nbasis=self%natom*3, j=iu, Rj=Ru, j_sc=u_sc, Rj_sc=Ru_sc)
921 324 : call scmaker%trans_j_and_Rj(nbasis=self%natom*3, j=iv, Rj=Rv, j_sc=v_sc, Rj_sc=Rv_sc)
922 70308 : val_sc(:)= self%tijuv%val%data(inz)
923 70308 : do icell=1, scmaker%ncells
924 70308 : call scpot%add_tijuv_term(i_sc(icell), j_sc(icell), u_sc(icell), v_sc(icell), val_sc(icell))
925 : end do
926 324 : ABI_SFREE(i_sc)
927 324 : ABI_SFREE(j_sc)
928 324 : ABI_SFREE(u_sc)
929 324 : ABI_SFREE(v_sc)
930 324 : ABI_SFREE(Rj_sc)
931 324 : ABI_SFREE(Ru_sc)
932 325 : ABI_SFREE(Rv_sc)
933 : end do
934 :
935 1 : call scpot%tijuv_sc%group_by_pair()
936 1 : call scpot%tuvij_sc%group_by_pair()
937 :
938 1 : end subroutine set_tijuv_sc
939 :
940 : !!***
941 8 : end module m_slc_primitive_potential
|
