Line data Source code
1 : !!****m* ABINIT/m_ddb
2 : !! NAME
3 : !! m_ddb
4 : !!
5 : !! FUNCTION
6 : !! This module contains the declaration of data types and methods
7 : !! used to handle the blocks of data in DDB files:
8 : !! blkval, nrm, qpt, flg, and associated dimensions
9 : !! Main entry point for client code that needs to read the DDB data.
10 : !!
11 : !! COPYRIGHT
12 : !! Copyright (C) 2011-2026 ABINIT group (MJV, XG, MT, MM, MVeithen, MG, PB, JCC, SP, GA, MMignolet)
13 : !! This file is distributed under the terms of the
14 : !! GNU General Public License, see ~abinit/COPYING
15 : !! or http://www.gnu.org/copyleft/gpl.txt .
16 : !!
17 : !! SOURCE
18 :
19 : #if defined HAVE_CONFIG_H
20 : #include "config.h"
21 : #endif
22 :
23 : #include "abi_common.h"
24 :
25 : module m_ddb
26 :
27 : use defs_basis
28 : use m_abicore
29 : use m_errors
30 : use m_xmpi
31 : use m_ddb_hdr
32 : use m_dtset
33 : use m_nctk
34 : use netcdf
35 :
36 : use m_io_tools, only : iomode_from_fname
37 : use defs_datatypes, only : pseudopotential_type
38 : use m_fstrings, only : sjoin, itoa, ktoa, endswith
39 : use m_numeric_tools, only : mkherm
40 : use m_matrix, only : mati3inv, matr3inv
41 : use m_symtk, only : littlegroup_q, symatm
42 : use m_io_tools, only : get_unit
43 : use m_copy, only : alloc_copy
44 : use m_geometry, only : phdispl_cart2red, mkrdim, xred2xcart, metric, d3lwsym
45 : use m_crystal, only : crystal_t
46 : use m_dynmat, only : cart29, d2sym3, cart39, d3sym, chneu9, asria_calc, asria_corr,&
47 : msria_calc, msria_apply, asrprs, dfpt_phfrq, sytens
48 : use m_pawtab, only : pawtab_type, pawtab_nullify, pawtab_free
49 : use m_psps, only : psps_copy, psps_free
50 :
51 : implicit none
52 :
53 : private
54 :
55 : public :: rdddb9 ! This routine reads the derivative database entirely,
56 : public :: nlopt ! Output of all quantities related to third-order derivatives of the energy.
57 : public :: chkin9
58 : public :: gamma9
59 : public :: carttransf ! Transform a second-derivative matrix (EIG2D) from reduced
60 : ! coordinates to cartesian coordinates.
61 : public :: lwcart ! Transform a 3rd order derivative tensor (long-wave) from reduced (actually
62 : ! mixed since strain derivatives are already in cartesian) to cartesian
63 : ! coordinates
64 : public :: ddb_lw_copy ! Copy the ddb object after reading the long wave 3rd order derivatives
65 : ! into a new ddb_lw and resizes ddb as for 2nd order derivatives
66 :
67 : public :: symdm9
68 :
69 : real(dp),public,parameter :: DDB_QTOL=2.0d-8
70 : ! Tolerance for the identification of two wavevectors
71 : !!***
72 :
73 : !----------------------------------------------------------------------
74 :
75 : !!****t* m_ddb/ddb_type
76 : !! NAME
77 : !! ddb_type
78 : !!
79 : !! FUNCTION
80 : !! Provides methods to extract and post-process the results in the derivative database (DDB)
81 : !!
82 : !! SOURCE
83 :
84 : type,public :: ddb_type
85 :
86 : logical :: has_ncid_open
87 : ! Is currently reading a netcdf file
88 :
89 : integer :: iblock_d2eig_nc
90 : ! Is currently reading a netcdf file
91 :
92 : integer :: msize
93 : ! Maximum size of dynamical matrices and other perturbations (ddk, dde...)
94 :
95 : integer :: mpert
96 : ! Maximum number of perturbations
97 :
98 : integer :: nblok
99 : ! Number of 2dte blocks in present object
100 :
101 : integer :: natom
102 : ! Number of atoms in the unit cell.
103 :
104 : integer :: ntypat
105 : ! Number of type of atoms.
106 :
107 : integer :: occopt
108 : ! Occupation option.
109 :
110 : integer :: prtvol
111 : ! Verbosity level.
112 :
113 : integer :: nband
114 : ! Number of bands for eigenvalues derivatives
115 : ! This corresponds to d2eig arrary shape,
116 : ! but the actual number of band is nband / nsppol
117 :
118 : integer :: nkpt
119 : ! Number of k-points for eigenvalues derivatives
120 :
121 : ! GA: FIXME
122 : integer :: nsppol
123 : ! Number of spin components for eigenvalues derivatives
124 : ! This index is absorbed into nband, to limit array ranks to 7.
125 :
126 : integer :: current_iblok
127 : ! Number of k-points for eigenvalues derivatives
128 :
129 : ! These values are used to call the anaddb routines that don't use rprimd, gprimd.
130 : real(dp) :: rprim(3,3)
131 : real(dp) :: gprim(3,3)
132 : real(dp) :: acell(3)
133 :
134 :
135 : ! Many of these variables should become private so that one can refactor the ddb_t implementation
136 : integer,allocatable :: flg(:,:)
137 : ! flg(msize,nblok)
138 : ! Flag to indicate presence of a given block
139 :
140 : integer,allocatable :: typ(:)
141 : ! typ(nblok)
142 : ! Type of each block - nth-order derivatives of energy or eigenvalues.
143 : ! (0 => total energy)
144 : ! (1=> non-stationary block),
145 : ! (2=> stationary block),
146 : ! (3=> third order derivative).
147 : ! (4 => first-order derivatives of total energy)
148 : ! (5 => 2nd-order derivatives of eigenvalues)
149 : ! (33 => long wave third order derivatives of total energy)
150 : ! (85 => Molecular Berry curvature, 2nd-order derivative)
151 : ! See m_ddb_hdr for the definition of various block types
152 :
153 : real(dp),allocatable :: amu(:)
154 : ! amu(ntypat)
155 : ! Mass of the atoms (atomic mass unit)
156 :
157 : real(dp),allocatable :: omega(:,:)
158 : ! omega(3,nblok)
159 : ! Frequency of the perturbations
160 : ! Three possible frequencies can be specified for 3rd order derivatives.
161 :
162 : real(dp),allocatable :: qpt(:,:)
163 : ! qpt(9,nblok)
164 : ! q-point vector in reciprocal space (reduced lattice coordinates) for each block
165 : ! Three possible phonon wavevectors can be specified for 3rd order derivatives,
166 : ! but only one should be used in case of second derivative of total energy,
167 : ! because we know that the second is the opposite of this value.
168 :
169 : real(dp),allocatable :: nrm(:,:)
170 : ! nrm(3,nblok)
171 : ! Normalization factors of the wavevectors for each block - can be 0 to indicate a direction of approach to gamma
172 :
173 : real(dp),allocatable :: val(:,:,:)
174 : ! val(2,msize,nblok)
175 : ! Values of the second energy derivatives in each block
176 :
177 : real(dp),allocatable :: val_fs(:,:,:)
178 : ! val_fs(2,msize,nblok)
179 : ! Values of the second energy derivatives in each block, at fixed-spin magnetic boundary conditions.
180 :
181 : real(dp),allocatable :: val_rs(:,:,:)
182 : ! val_rs(2,msize,nblok)
183 : ! Values of the second energy derivatives in each block, at relaxed-spin magnetic boundary conditions.
184 :
185 : real(dp),allocatable :: kpt(:,:)
186 : ! kpt(3,nkpt)
187 : ! k-point vector in reciprocal space for eigenvalues derivatives
188 :
189 : real(dp),allocatable :: eig2dval(:,:,:,:)
190 : ! eig2dval(2,msize,nband,nkpt)
191 : ! Values of the second derivatives of eigenvalues
192 : ! Only a single block (a single q-point) is held in memory.
193 : ! Note that isppol index is wrapped into nband index.
194 :
195 : contains
196 :
197 : procedure :: init => ddb_init
198 : ! Construct the object from the dtset.
199 :
200 : procedure :: free => ddb_free
201 : ! Free dynamic memory.
202 :
203 : procedure :: malloc => ddb_malloc
204 : ! Allocate dynamic memory
205 :
206 : procedure :: malloc_d2eig => ddb_malloc_d2eig
207 : ! Allocate dynamic memory
208 :
209 : procedure :: copy => ddb_copy
210 : ! Copy the object.
211 :
212 : procedure :: set_omega => ddb_set_omega
213 : ! Set the frequency
214 :
215 : !procedure :: get_qptopt => ddb_get_qptopt
216 :
217 : procedure :: set_qpt => ddb_set_qpt
218 : ! Set the wavevector
219 :
220 : procedure :: set_d1matr => ddb_set_d1matr
221 : ! Set values for the first-order derivative matrix in tensor shape
222 :
223 : procedure :: get_d1matr => ddb_get_d1matr
224 : ! Transform the first-order derivative matrix in tensor shape
225 :
226 : procedure :: set_d2matr => ddb_set_d2matr
227 : ! Set values for the second-order derivative matrix
228 :
229 : procedure :: get_d2matr => ddb_get_d2matr
230 : ! Transform the second-order derivative matrix in tensor shape
231 :
232 : procedure :: set_d3matr => ddb_set_d3matr
233 : ! Set values for the third-order derivative matrix
234 :
235 : procedure :: get_d3matr => ddb_get_d3matr
236 : ! Transform the third-order derivative matrix in tensor shape
237 :
238 : procedure :: get_d2eig => ddb_get_d2eig
239 : ! Transform the second-order derivative matrix of eigs in tensor shape
240 :
241 : procedure :: set_d2eig => ddb_set_d2eig
242 : ! Set values for the second-order derivative matrix of eigs
243 :
244 : procedure :: set_d2eig_reshape => ddb_set_d2eig_reshape
245 : ! Set values for the second-order derivative matrix of eigs
246 : ! with band index before perturbation indices
247 :
248 : procedure :: set_gred => ddb_set_gred
249 : ! Set the gradient of total energy in reduced coordinates
250 :
251 : procedure :: set_pel => ddb_set_pel
252 : ! Set the electronic polarization
253 :
254 : procedure :: set_strten => ddb_set_strten
255 : ! Set the stress tensor
256 :
257 : procedure :: set_etotal => ddb_set_etotal
258 : ! Set the total energy
259 :
260 : procedure :: set_brav => ddb_set_brav
261 : ! Set the bravais lattice.
262 :
263 : procedure :: to_d2etot => ddb_to_d2etot
264 : ! Converts physical quantities stored in ddb into mathematical
265 : ! second-order derivatives of total energy
266 :
267 : procedure :: set_typ => ddb_set_typ
268 : ! Set the typ of one block
269 :
270 : procedure :: bcast => ddb_bcast
271 : ! Broadcast the object.
272 :
273 : procedure :: get_etotal => ddb_get_etotal
274 : ! Read the GS total energy.
275 :
276 : procedure :: get_gred => ddb_get_gred
277 : ! Get the gradient of total energy in reduced coordinates
278 :
279 : procedure :: get_pel => ddb_get_pel
280 : ! Get the electronic polarization
281 :
282 : procedure :: get_strten => ddb_get_strten
283 : ! Get the stress tensor
284 :
285 : procedure :: get_dielt_zeff => ddb_get_dielt_zeff
286 : ! Reads the Dielectric Tensor and the Effective Charges
287 :
288 : procedure :: get_dielt => ddb_get_dielt
289 : ! Reads the Dielectric Tensor
290 :
291 : procedure :: get_quadrupoles => ddb_get_quadrupoles
292 : ! Reads the Quadrupoles
293 :
294 : procedure :: get_dchidet => ddb_get_dchidet
295 : ! Reads the non-linear optical susceptibility tensor and the
296 : ! first-order change in the linear dielectric susceptibility
297 :
298 : procedure :: diagoq => ddb_diagoq
299 : ! Compute the phonon frequencies at the specified q-point by performing
300 : ! a direct diagonalizatin of the dynamical matrix.
301 :
302 : procedure :: symmetrize_and_transform => ddb_symmetrize_and_transform
303 : ! Symmetrize, transform cartesian coordinates, and add missing components
304 :
305 : procedure :: write_block_txt => ddb_write_block_txt
306 : ! Writes blocks of data in the DDB in text format.
307 :
308 : procedure :: write => ddb_write
309 : ! Write the DDB file in either txt or netcdf format.
310 :
311 : procedure :: write_txt => ddb_write_txt
312 : ! Write the body of the DDB text file.
313 :
314 : procedure :: write_nc => ddb_write_nc
315 : ! Write the netcdf file (DDB.nc).
316 :
317 : procedure :: read_block_txt => ddb_read_block_txt
318 : ! Read blocks of data in the DDB.
319 :
320 : procedure :: get_block => ddb_get_block
321 : ! Finds the block containing the derivatives of the total energy.
322 :
323 : procedure :: read_d2eig => ddb_read_d2eig
324 : ! Read the next DDB block containing 2nd order derivatives of eigenvalues.
325 :
326 : procedure :: read_d2eig_txt => ddb_read_d2eig_txt
327 : ! Read the next DDB block containing 2nd order derivatives of eigenvalues.
328 :
329 : procedure :: read_d2eig_nc => ddb_read_d2eig_nc
330 : ! Read the next DDB block containing 2nd order derivatives of eigenvalues.
331 :
332 : procedure :: write_d2eig => ddb_write_d2eig
333 : ! Read the current DDB block containing 2nd order derivatives of eigenvalues.
334 :
335 : procedure :: write_d2eig_txt => ddb_write_d2eig_txt
336 : ! Read the current DDB block containing 2nd order derivatives of eigenvalues.
337 :
338 : procedure :: write_d2eig_nc => ddb_write_d2eig_nc
339 : ! Write the current DDB block containing 2nd order derivatives of eigenvalues.
340 :
341 : procedure :: read_d0E_nc => ddb_read_d0E_nc
342 : ! Read the next DDB block containing 0th order derivatives of energy.
343 :
344 : procedure :: read_d1E_nc => ddb_read_d1E_nc
345 : ! Read the next DDB block containing 1st order derivatives of energy.
346 :
347 : procedure :: read_d2E_nc => ddb_read_d2E_nc
348 : ! Read the next DDB block containing 2nd order derivatives of energy.
349 :
350 : procedure :: read_d3E_nc => ddb_read_d3E_nc
351 : ! Read the next DDB block containing 3rd order derivatives of energy.
352 :
353 : procedure :: from_file => ddb_from_file
354 : ! Construct the object from the DDB file.
355 :
356 : procedure :: read_txt => ddb_read_txt
357 : ! Construct the object from the DDB file in text format.
358 :
359 : procedure :: read_nc => ddb_read_nc
360 : ! Construct the object from the DDB file in netcdf format.
361 :
362 : procedure :: can_merge_blocks => ddb_can_merge_blocks
363 : ! Tell if two blocks can be merged
364 :
365 : procedure :: merge_blocks => ddb_merge_blocks
366 : ! Merge a block of an other ddb to the current object.
367 :
368 : end type ddb_type
369 :
370 : public :: ddb_to_dtset ! Transfer ddb_hdr to dtset datatype
371 : public :: merge_ddb ! Read a list of ddb files and merge them into a single ddb object
372 :
373 : !!***
374 :
375 : !!****t* m_ddb/asr_t
376 : !! NAME
377 : !! asr_t
378 : !!
379 : !! FUNCTION
380 : !! Object used to enforce the acoustic sum rule from the Dynamical matrix at Gamma.
381 : !! Wraps several approaches that can be activated via the `asr` option.
382 : !!
383 : !! SOURCE
384 :
385 : type,public :: asrq0_t
386 :
387 : integer :: iblok = 0
388 : ! Index of the Gamma block in the DDB.
389 : ! Set to 0 if no block was found. Client code can use this flag to understand
390 : ! if ASR can be enforced.
391 :
392 : integer :: asr
393 : ! Option for the application of the ASR (input variable).
394 :
395 : integer :: natom
396 : ! Number of atoms.
397 :
398 : real(dp),allocatable :: d2asr(:,:,:,:,:)
399 : ! d2asr,(2,3,natom,3,natom))
400 : ! In case the interatomic forces are not calculated, the
401 : ! ASR-correction (d2asr) has to be determined here from the Dynamical matrix at Gamma.
402 :
403 : real(dp),allocatable :: d2dqmsr(:,:,:,:,:)
404 : ! d2dqmsr,(3,natom,3,natom,3))
405 : ! Corrections to the IFCs first derivatives from translational + rotational invariance.
406 :
407 : real(dp),allocatable :: d2dqdqmsr(:,:,:,:,:,:)
408 : ! d2dqmsr,(3,natom,3,natom,3,3))
409 : ! Corrections to the IFCs second derivatives from translational + rotational invariance.
410 :
411 : ! singular, uinvers and vtinvers are allocated and used only if asr in [3,4]
412 : ! i.e. Rotational invariance for 1D and 0D systems. dims=3*natom*(3*natom-1)/2
413 : real(dp),allocatable :: singular(:)
414 : ! singular,(1:dims))
415 :
416 : real(dp),allocatable :: uinvers(:,:)
417 : ! uinvers,(1:dims,1:dims))
418 :
419 : real(dp),allocatable :: vtinvers(:,:)
420 : ! vtinvers,(1:dims,1:dims))
421 :
422 : contains
423 :
424 : procedure :: init => asrq0_init
425 : ! Init the object from a ddb.
426 :
427 : procedure :: apply => asrq0_apply
428 : ! Impose the acoustic sum rule based on the q=0 block found in the DDB file.
429 :
430 : procedure :: free => asrq0_free
431 : ! Free memory
432 :
433 : end type asrq0_t
434 : !!***
435 :
436 : CONTAINS !===========================================================
437 : !!***
438 :
439 : !----------------------------------------------------------------------
440 :
441 : !!****f* m_ddb/ddb_init
442 : !! NAME
443 : !! ddb_init
444 : !!
445 : !! FUNCTION
446 : !! Initialize a new ddb object for the current calculation.
447 : !!
448 : !! INPUTS
449 : !! ddb=the new ddb object
450 : !! dtset=dtset object of the current calculation
451 : !! nblok=number of blocks
452 : !! mpert=maximum number of perturbations (atom displacements + electric field + ...)
453 : !! with_d0E=this ddb contains 0th order derivatives
454 : !! with_d1E=this ddb contains 1st order derivatives
455 : !! with_d2E=this ddb contains 2nd order derivatives
456 : !! with_d3E=this ddb contains 3rd order derivatives
457 : !! with_d2eig=this ddb contains 2nd order derivatives of eigenvalues
458 : !! mband='number of bands' dimension of the d2eig array.
459 : !! Should actually correspond to the maximum number of bands for one kpoint
460 : !! multiplied by the number of spin polarization (mband*nsppol).
461 : !! nkpt=number of kpoints
462 : !! kpt=reduced coordinates of kpoints
463 : !!
464 : !! SOURCE
465 :
466 3399 : subroutine ddb_init(ddb, dtset, nblok, mpert, &
467 3399 : mband, nkpt, kpt,&
468 : with_d0E, with_d1E, with_d2E, with_d3E, with_d2eig)
469 :
470 : !Arguments -------------------------------
471 : class(ddb_type),intent(inout) :: ddb
472 : type(dataset_type),intent(in) :: dtset
473 : integer,intent(in) :: nblok, mpert
474 : integer,intent(in),optional :: mband,nkpt
475 : real(dp),intent(in),optional :: kpt(:,:)
476 : logical,intent(in),optional :: with_d0E, with_d1E, with_d2E, with_d3E, with_d2eig
477 :
478 : !Local variables -------------------------------
479 : integer :: msize_, ii, ikpt
480 : logical :: with_d0E_, with_d1E_, with_d2E_, with_d3E_, with_d2eig_
481 : ! ************************************************************************
482 :
483 3399 : with_d0E_ = .false. ; if (present(with_d0E)) with_d0E_ = with_d0E
484 3399 : with_d1E_ = .false. ; if (present(with_d1E)) with_d1E_ = with_d1E
485 3399 : with_d2E_ = .false. ; if (present(with_d2E)) with_d2E_ = with_d2E
486 3399 : with_d3E_ = .false. ; if (present(with_d3E)) with_d3E_ = with_d3E
487 3399 : with_d2eig_ = .false. ; if (present(with_d2eig)) with_d2eig_ = with_d2eig
488 :
489 3399 : msize_ = 0
490 3399 : if (with_d0E_) msize_ = 1
491 3399 : if (with_d1E_) msize_ = 3 * mpert
492 3399 : if (with_d2E_ .or. with_d2eig_) msize_ = 3 * mpert * 3 * mpert
493 3399 : if (with_d3E_) msize_ = 3 * mpert * 3 * mpert * 3 * mpert
494 :
495 3399 : call ddb%malloc(msize_, nblok, dtset%natom, dtset%ntypat, mpert)
496 :
497 3399 : ddb%occopt = dtset%occopt
498 3399 : ddb%prtvol = dtset%prtvol
499 :
500 44187 : ddb%rprim(:,:) = dtset%rprim_orig(1:3,1:3,1)
501 13596 : ddb%acell(:) = dtset%acell_orig(1:3,1)
502 :
503 3399 : call matr3inv(ddb%rprim, ddb%gprim)
504 :
505 28179 : ddb%omega(:,:) = zero
506 65349 : ddb%qpt(:,:) = zero
507 28179 : ddb%nrm(:,:) = one
508 3399 : if (with_d0E_) then
509 0 : ddb%typ(:) = BLKTYP_d0E_xx
510 3399 : else if (with_d1E_) then
511 8402 : ddb%typ(:) = BLKTYP_d1E_xx
512 596 : else if (with_d2E_) then
513 836 : ddb%typ(:) = BLKTYP_d2E_ns
514 178 : else if (with_d3E_) then
515 82 : ddb%typ(:) = BLKTYP_d3E_xx
516 137 : else if (with_d2eig_) then
517 274 : ddb%typ(:) = BLKTYP_d2eig_re
518 : end if
519 :
520 2755731 : ddb%flg(:,:) = 0
521 7689 : ddb%amu(:) = dtset%amu_orig(:,1)
522 :
523 3399 : ddb%nsppol = dtset%nsppol
524 :
525 3399 : if (present(mband)) then
526 137 : ddb%nband = mband
527 : else
528 3262 : ddb%nband = dtset%mband * ddb%nsppol
529 : end if
530 :
531 3399 : if (present(nkpt)) then
532 137 : ddb%nkpt = nkpt
533 : else
534 3262 : ddb%nkpt = dtset%nkpt
535 : end if
536 :
537 : ! TODO: Allocate d2eig here instead of leaving it to the calling routine.
538 3399 : if (with_d2eig_) call ddb%malloc_d2eig(ddb%nband*ddb%nsppol, ddb%nkpt)
539 :
540 3399 : if (present(kpt)) then
541 2200 : do ikpt=1,ddb%nkpt
542 8389 : do ii = 1,3
543 8252 : ddb%kpt(ii,ikpt) = kpt(ii,ikpt)
544 : end do
545 : end do
546 : end if
547 :
548 3399 : end subroutine ddb_init
549 : !!***
550 :
551 : !----------------------------------------------------------------------
552 :
553 : !!****f* m_ddb/ddb_free
554 : !! NAME
555 : !! ddb_free
556 : !!
557 : !! FUNCTION
558 : !! Clean and deallocate types for the ddb_type structure
559 : !!
560 : !! SOURCE
561 :
562 4100 : subroutine ddb_free(ddb)
563 :
564 : !Arguments -------------------------------
565 : class(ddb_type),intent(inout) :: ddb
566 : ! ************************************************************************
567 :
568 : !integer
569 4100 : ABI_SFREE(ddb%flg)
570 4100 : ABI_SFREE(ddb%typ)
571 :
572 : ! real
573 4100 : ABI_SFREE(ddb%amu)
574 4100 : ABI_SFREE(ddb%qpt)
575 4100 : ABI_SFREE(ddb%omega)
576 4100 : ABI_SFREE(ddb%nrm)
577 4100 : ABI_SFREE(ddb%val_fs)
578 4100 : ABI_SFREE(ddb%val_rs)
579 4100 : ABI_SFREE(ddb%kpt)
580 4100 : ABI_SFREE(ddb%val)
581 4100 : ABI_SFREE(ddb%eig2dval)
582 :
583 4100 : end subroutine ddb_free
584 : !!***
585 :
586 : !----------------------------------------------------------------------
587 :
588 : !!****f* m_ddb/ddb_copy
589 : !! NAME
590 : !! ddb_copy
591 : !!
592 : !! FUNCTION
593 : !! Create object and copy all types for the ddb_type structure
594 : !!
595 : !! SOURCE
596 :
597 9 : subroutine ddb_copy(iddb, oddb)
598 :
599 : !Arguments -------------------------------
600 : class(ddb_type),intent(in) :: iddb
601 : class(ddb_type),intent(out) :: oddb
602 : ! ************************************************************************
603 :
604 : ! Copy dimensions and static variables.
605 9 : oddb%msize = iddb%msize
606 9 : oddb%mpert = iddb%mpert
607 9 : oddb%nblok = iddb%nblok
608 9 : oddb%natom = iddb%natom
609 9 : oddb%ntypat = iddb%ntypat
610 9 : oddb%occopt = iddb%occopt
611 9 : oddb%prtvol = iddb%prtvol
612 :
613 117 : oddb%rprim = iddb%rprim
614 117 : oddb%gprim = iddb%gprim
615 36 : oddb%acell = iddb%acell
616 :
617 : ! Allocate and copy the allocatable arrays.
618 9 : call alloc_copy(iddb%flg, oddb%flg)
619 9 : call alloc_copy(iddb%typ, oddb%typ)
620 9 : call alloc_copy(iddb%amu, oddb%amu)
621 9 : call alloc_copy(iddb%nrm, oddb%nrm)
622 9 : call alloc_copy(iddb%omega, oddb%omega)
623 9 : call alloc_copy(iddb%qpt, oddb%qpt)
624 9 : call alloc_copy(iddb%val, oddb%val)
625 : ! call alloc_copy(iddb%val_fs, oddb%val_fs)
626 : ! call alloc_copy(iddb%val_rs, oddb%val_rs)
627 :
628 9 : end subroutine ddb_copy
629 : !!***
630 :
631 : !----------------------------------------------------------------------
632 :
633 : !!****f* m_ddb/ddb_malloc
634 : !! NAME
635 : !! ddb_malloc
636 : !!
637 : !! FUNCTION
638 : !! Allocate dynamic memory.
639 : !!
640 : !! INPUTS
641 : !! msize=maximum size of one block of the ddb
642 : !! (e.g. 3*mpert * 3*mpert)
643 : !! nblok=number of blocks in the ddb
644 : !! natom=number of atoms
645 : !! ntypat=number of atom types
646 : !! mpert=maximum number of perturbations
647 : !! (atom displacements + electric field + ...)
648 : !! nkpt=number of k-points. Optional, indicates the use of eig2d.
649 : !! nband='number of bands' dimension of the d2eig array.
650 : !! Should actually correspond to the maximum number of bands for one kpoint
651 : !! multiplied by the number of spin polarization (mband*nsppol).
652 : !!
653 : !! SOURCE
654 :
655 3930 : subroutine ddb_malloc(ddb, msize, nblok, natom, ntypat, mpert, nkpt, nband)
656 :
657 : !Arguments -------------------------------
658 : class(ddb_type),intent(inout) :: ddb
659 : integer,intent(in) :: msize,nblok,natom,ntypat,mpert
660 : integer,intent(in),optional :: nkpt,nband
661 : ! ************************************************************************
662 :
663 3930 : ddb%msize = msize
664 3930 : ddb%nblok = nblok
665 3930 : ddb%natom = natom
666 : !ddb%mpert = natom + MPERT_MAX
667 3930 : ddb%mpert = mpert
668 3930 : ddb%ntypat = ntypat
669 :
670 : ! integer
671 53908384 : ABI_CALLOC(ddb%flg, (msize, nblok))
672 20767 : ABI_CALLOC(ddb%typ, (nblok))
673 :
674 : ! real
675 11790 : ABI_MALLOC(ddb%amu, (ntypat))
676 11790 : ABI_MALLOC(ddb%nrm, (3, nblok))
677 7860 : ABI_MALLOC(ddb%omega, (3, nblok))
678 11790 : ABI_MALLOC(ddb%qpt, (9, nblok))
679 15720 : ABI_MALLOC(ddb%val, (2, msize, nblok))
680 161663968 : ddb%val = huge(one)
681 :
682 : ! FIXME: should really add nsppol argument (see thmeig).
683 3930 : if (present(nkpt) .and. present(nband)) then
684 184 : call ddb%malloc_d2eig(nband, nkpt)
685 : end if
686 :
687 3930 : end subroutine ddb_malloc
688 : !!***
689 :
690 : !----------------------------------------------------------------------
691 :
692 : !!****f* m_ddb/ddb_malloc_d2eig
693 : !! NAME
694 : !! ddb_malloc_d2eig
695 : !!
696 : !! FUNCTION
697 : !! Allocate dynamic memory for second derivatives of eigenvalues.
698 : !!
699 : !! INPUTS
700 : !! mband='number of bands' dimension of the d2eig array.
701 : !! Should actually correspond to the maximum number of bands for one kpoint
702 : !! multiplied by the number of spin polarization (mband*nsppol).
703 : !! nkpt=number of kpoints
704 : !!
705 : !! OUTPUT
706 : !!
707 : !! SOURCE
708 :
709 321 : subroutine ddb_malloc_d2eig(ddb, mband, nkpt)
710 :
711 : !Arguments -------------------------------
712 : class(ddb_type),intent(inout) :: ddb
713 : integer,intent(in) :: mband, nkpt
714 : ! ************************************************************************
715 :
716 321 : ddb%nband = mband / ddb%nsppol
717 321 : ddb%nkpt = nkpt
718 963 : ABI_MALLOC(ddb%kpt, (3, nkpt))
719 1605 : ABI_MALLOC(ddb%eig2dval, (2, ddb%msize, mband, nkpt))
720 :
721 321 : end subroutine ddb_malloc_d2eig
722 : !!***
723 :
724 : !----------------------------------------------------------------------
725 :
726 : !!****f* m_ddb/ddb_set_qpt
727 : !! NAME
728 : !! ddb_set_qpt
729 : !!
730 : !! FUNCTION
731 : !! Set the q-point wavevector for a certain block.
732 : !! In case of 3rd order derivatives, three q-points need to be specified
733 : !! with the constraint q1 + q2 + q3 = 0 (not checked).
734 : !! The norm is set to one automatically.
735 : !!
736 : !! INPUTS
737 : !! iblok=index of the block being set.
738 : !! qpt=reduced coordinates of first qpoint
739 : !! qpt2=reduced coordinates of second qpoint
740 : !! qpt3=reduced coordinates of third qpoint
741 : !!
742 : !! OUTPUT
743 : !!
744 : !! SOURCE
745 :
746 572 : subroutine ddb_set_qpt(ddb, iblok, qpt, qpt2, qpt3)
747 :
748 : !Arguments -------------------------------
749 : class(ddb_type),intent(inout) :: ddb
750 : integer,intent(in) :: iblok
751 : !arrays
752 : real(dp), intent(in) :: qpt(3)
753 : real(dp), intent(in),optional :: qpt2(3), qpt3(3)
754 : ! ************************************************************************
755 :
756 5720 : ddb%qpt(:,iblok)=zero
757 2288 : ddb%nrm(:,iblok)=one
758 :
759 2288 : ddb%qpt(1:3,iblok) = qpt(1:3)
760 :
761 572 : if (present(qpt2)) then
762 0 : ddb%qpt(4:6,iblok) = qpt2(1:3)
763 : end if
764 :
765 572 : if (present(qpt3)) then
766 0 : ddb%qpt(7:9,iblok) = qpt3(1:3)
767 : end if
768 :
769 572 : end subroutine ddb_set_qpt
770 : !!***
771 :
772 : !----------------------------------------------------------------------
773 :
774 : !!****f* m_ddb/ddb_set_omega
775 : !! NAME
776 : !! ddb_set_omega
777 : !!
778 : !! FUNCTION
779 : !! Set the frequencies for a certain block.
780 : !! In case of 3rd order derivatives, three frequencies need to be specified
781 : !! with the constraint omegaq1 + omega2 + omega3 = 0 (not checked).
782 : !!
783 : !! INPUTS
784 : !! iblok=index of the block being set.
785 : !!
786 : !! OUTPUT
787 : !!
788 : !! SOURCE
789 :
790 435 : subroutine ddb_set_omega(ddb, iblok, omega, omega2, omega3)
791 :
792 : !Arguments ------------------------------------
793 : !array
794 : class(ddb_type),intent(inout) :: ddb
795 : real(dp), intent(in) :: omega
796 : real(dp), intent(in),optional :: omega2
797 : real(dp), intent(in),optional :: omega3
798 : !scalars
799 : integer,intent(in) :: iblok
800 :
801 : ! ************************************************************************
802 :
803 1740 : ddb%omega(:,iblok)=zero
804 :
805 435 : ddb%omega(1,iblok) = omega
806 435 : if (present(omega2)) ddb%omega(2,iblok) = omega2
807 435 : if (present(omega3)) ddb%omega(3,iblok) = omega3
808 :
809 435 : end subroutine ddb_set_omega
810 : !!***
811 :
812 : !----------------------------------------------------------------------
813 :
814 : !!****f* m_ddb/ddb_set_d2matr
815 : !! NAME
816 : !! ddb_set_d2matr
817 : !!
818 : !! FUNCTION
819 : !! Set values for the second-order derivative matrix.
820 : !!
821 : !! INPUTS
822 : !! iblok=index of the block being set.
823 : !! d2matr=the second-order derivative matrix.
824 : !! flg=flag to indicate presence of a given element.
825 : !!
826 : !! SOURCE
827 :
828 2913 : subroutine ddb_set_d2matr(ddb, iblok, d2matr, flg)
829 :
830 : !Arguments -------------------------------
831 : !scalars
832 : class(ddb_type),intent(inout) :: ddb
833 : integer,intent(in) :: iblok
834 : !arrays
835 : real(dp), intent(in) :: d2matr(2,3,ddb%mpert,3,ddb%mpert)
836 : integer, intent(in) :: flg(3,ddb%mpert,3,ddb%mpert)
837 :
838 : !Local variables -------------------------
839 : integer :: idir1,idir2,ii,ipert1,ipert2
840 : ! ************************************************************************
841 :
842 2913 : ii=0
843 30251 : do ipert2=1,ddb%mpert
844 112265 : do idir2=1,3
845 998852 : do ipert1=1,ddb%mpert
846 3640014 : do idir1=1,3
847 2668500 : ii=ii+1
848 2668500 : ddb%flg(ii,iblok) = flg(idir1,ipert1,idir2,ipert2)
849 2668500 : ddb%val(1,ii,iblok) = d2matr(1,idir1,ipert1,idir2,ipert2)
850 3558000 : ddb%val(2,ii,iblok) = d2matr(2,idir1,ipert1,idir2,ipert2)
851 : end do
852 : end do
853 : end do
854 : end do
855 :
856 2913 : end subroutine ddb_set_d2matr
857 : !!***
858 :
859 : !----------------------------------------------------------------------
860 :
861 : !!****f* m_ddb/ddb_get_d2matr
862 : !! NAME
863 : !! ddb_get_d2matr
864 : !!
865 : !! FUNCTION
866 : !! Transform the second-order derivative matrix
867 : !! from flat indices to real tensor d2matr(cplex,ncart,natom,ncart,natom)
868 : !!
869 : !! INPUTS
870 : !! iblok=index of the block to get.
871 : !!
872 : !! OUTPUT
873 : !! d2matr=the second-order derivative matrix.
874 : !! flg=flag to indicate presence of a given element.
875 : !!
876 : !! SOURCE
877 :
878 670 : subroutine ddb_get_d2matr(ddb, iblok, d2matr, flg)
879 :
880 : !Arguments -------------------------------
881 : !scalars
882 : class(ddb_type),intent(inout) :: ddb
883 : integer,intent(in) :: iblok
884 : !arrays
885 : real(dp), allocatable, intent(out) :: d2matr(:,:,:,:,:)
886 : integer, allocatable, intent(out) :: flg(:,:,:,:)
887 :
888 : !Local variables -------------------------
889 : integer :: ii,idir1,idir2,ipert1,ipert2
890 : ! ************************************************************************
891 :
892 3350 : ABI_MALLOC(d2matr, (2,3,ddb%mpert,3,ddb%mpert))
893 3350 : ABI_MALLOC(flg, (3,ddb%mpert,3,ddb%mpert))
894 :
895 2821800 : d2matr = zero
896 :
897 : ii=0
898 7995 : do ipert2=1,ddb%mpert
899 29970 : do idir2=1,3
900 308483 : do ipert1=1,ddb%mpert
901 1138707 : do idir1=1,3
902 837549 : ii=ii+1
903 837549 : flg(idir1,ipert1,idir2,ipert2) = ddb%flg(ii,iblok)
904 1116732 : if (ddb%flg(ii,iblok) > 0) then
905 44806 : d2matr(1,idir1,ipert1,idir2,ipert2) = ddb%val(1,ii,iblok)
906 44806 : d2matr(2,idir1,ipert1,idir2,ipert2) = ddb%val(2,ii,iblok)
907 : end if
908 : end do
909 : end do
910 : end do
911 : end do
912 :
913 670 : end subroutine ddb_get_d2matr
914 : !!***
915 :
916 : !----------------------------------------------------------------------
917 :
918 : !!****f* m_ddb/ddb_set_gred
919 : !! NAME
920 : !! ddb_set_gred
921 : !!
922 : !! FUNCTION
923 : !! Set the forces in reduced coordinates (Hartree).
924 : !!
925 : !! INPUTS
926 : !! gred=the gradient of the total energy with respect
927 : !! to change of reduced coordinates
928 : !! iblok=index of the block being set.
929 : !!
930 : !! SOURCE
931 :
932 2796 : subroutine ddb_set_gred(ddb, gred, iblok)
933 :
934 : !Arguments -------------------------------
935 : !scalars
936 : class(ddb_type),intent(inout) :: ddb
937 : integer,intent(in) :: iblok
938 : !arrays
939 : real(dp), intent(in) :: gred(3,ddb%natom)
940 :
941 : !Local variables -------------------------
942 : integer :: idir, iatom, indx
943 : ! ************************************************************************
944 :
945 2796 : ddb%typ(iblok) = BLKTYP_d1E_xx
946 2796 : indx = 0
947 9331 : do iatom = 1, ddb%natom
948 28936 : do idir = 1, 3
949 19605 : indx = indx + 1
950 19605 : ddb%flg(indx,iblok) = 1
951 19605 : ddb%val(1,indx,iblok) = gred(idir,iatom)
952 26140 : ddb%val(2,indx,iblok) = zero
953 : end do
954 : end do
955 :
956 2796 : end subroutine ddb_set_gred
957 : !!***
958 :
959 : !----------------------------------------------------------------------
960 :
961 : !!****f* m_ddb/ddb_set_pel
962 : !! NAME
963 : !! ddb_set_gred
964 : !!
965 : !! FUNCTION
966 : !! Set the electronic polarization.
967 : !!
968 : !! INPUTS
969 : !! pel=ucvol times the electronic polarization in reduced coordinates.
970 : !! flg=flag to indicate presence of a given element.
971 : !! iblok=index of the block being set.
972 : !!
973 : !! OUTPUT
974 : !!
975 : !! SOURCE
976 :
977 45 : subroutine ddb_set_pel(ddb, pel, flg, iblok)
978 :
979 : !Arguments -------------------------------
980 : !array
981 : class(ddb_type),intent(inout) :: ddb
982 : real(dp), intent(in) :: pel(3)
983 : integer,intent(in) :: flg(3)
984 : !scalars
985 : integer,intent(in) :: iblok
986 :
987 : !Local variables -------------------------
988 : integer :: idir, indx
989 : ! ************************************************************************
990 :
991 45 : ddb%typ(iblok) = BLKTYP_d1E_xx
992 45 : indx = 3*ddb%natom + 3
993 180 : do idir = 1, 3
994 135 : indx = indx + 1
995 135 : ddb%flg(indx,iblok) = flg(idir)
996 135 : ddb%val(1,indx,iblok) = pel(idir)
997 180 : ddb%val(2,indx,iblok) = zero
998 : end do
999 :
1000 45 : end subroutine ddb_set_pel
1001 : !!***
1002 :
1003 : !----------------------------------------------------------------------
1004 :
1005 : !!****f* m_ddb/ddb_set_strten
1006 : !! NAME
1007 : !! ddb_set_strten
1008 : !!
1009 : !! FUNCTION
1010 : !! Set the stress tensor.
1011 : !!
1012 : !! INPUTS
1013 : !! strten=the stress tensor in cartesian coordinates.
1014 : !! iblok=index of the block we are setting.
1015 : !!
1016 : !! OUTPUT
1017 : !!
1018 : !! SOURCE
1019 :
1020 2796 : subroutine ddb_set_strten(ddb, strten, iblok)
1021 :
1022 : !Arguments -------------------------------
1023 : !array
1024 : class(ddb_type),intent(inout) :: ddb
1025 : real(dp), intent(in) :: strten(6)
1026 : !scalars
1027 : integer,intent(in) :: iblok
1028 :
1029 : !Local variables -------------------------
1030 : integer :: indx
1031 : ! ************************************************************************
1032 :
1033 2796 : ddb%typ(iblok) = BLKTYP_d1E_xx
1034 2796 : indx = 3*ddb%natom + 6
1035 :
1036 19572 : ddb%flg(indx+1:indx+6,1) = 1
1037 19572 : ddb%val(1,indx+1:indx+6,1) = strten(1:6)
1038 19572 : ddb%val(2,indx+1:indx+6,1) = zero
1039 :
1040 2796 : end subroutine ddb_set_strten
1041 : !!***
1042 :
1043 : !----------------------------------------------------------------------
1044 :
1045 : !!****f* m_ddb/ddb_get_d1matr
1046 : !! NAME
1047 : !! ddb_get_d1matr
1048 : !!
1049 : !! FUNCTION
1050 : !! Transform the first-order derivative matrix
1051 : !! from flat indices to real tensor d1matr(cplex,ncart,natom)
1052 : !!
1053 : !! INPUTS
1054 : !! iblok=index of the block to get.
1055 : !!
1056 : !! OUTPUT
1057 : !! d1matr=the first-order derivative matrix.
1058 : !! flg=flag to indicate presence of a given element.
1059 : !!
1060 : !! SOURCE
1061 :
1062 2730 : subroutine ddb_get_d1matr(ddb, iblok, d1matr, flg)
1063 :
1064 : !Arguments -------------------------------
1065 : !array
1066 : class(ddb_type),intent(inout) :: ddb
1067 : integer,intent(in) :: iblok
1068 : real(dp), allocatable, intent(out) :: d1matr(:,:,:)
1069 : integer, allocatable, intent(out) :: flg(:,:)
1070 : !scalars
1071 :
1072 : !Local variables -------------------------
1073 : integer :: ii,idir1,ipert1
1074 : ! ************************************************************************
1075 :
1076 8190 : ABI_MALLOC(d1matr, (2,3,ddb%mpert))
1077 8190 : ABI_MALLOC(flg, (3,ddb%mpert))
1078 :
1079 230960 : d1matr = zero
1080 :
1081 : ii=0
1082 25553 : do ipert1=1,ddb%mpert
1083 94022 : do idir1=1,3
1084 68469 : ii=ii+1
1085 68469 : flg(idir1,ipert1) = ddb%flg(ii,iblok)
1086 91292 : if (ddb%flg(ii,iblok) > 0) then
1087 35613 : d1matr(1,idir1,ipert1) = ddb%val(1,ii,iblok)
1088 35613 : d1matr(2,idir1,ipert1) = ddb%val(2,ii,iblok)
1089 : end if
1090 : end do
1091 : end do
1092 :
1093 2730 : end subroutine ddb_get_d1matr
1094 : !!***
1095 :
1096 : !----------------------------------------------------------------------
1097 :
1098 : !!****f* m_ddb/ddb_set_d1matr
1099 : !! NAME
1100 : !! ddb_set_d1matr
1101 : !!
1102 : !! FUNCTION
1103 : !! Set values for the first-order derivative matrix.
1104 : !!
1105 : !! INPUTS
1106 : !! iblok=index of the block being set.
1107 : !! d1matr=the first-order derivative matrix.
1108 : !! flg=flag to indicate presence of a given element.
1109 : !!
1110 : !! SOURCE
1111 :
1112 10 : subroutine ddb_set_d1matr(ddb, iblok, d1matr, flg)
1113 :
1114 : !Arguments -------------------------------
1115 : !array
1116 : class(ddb_type),intent(inout) :: ddb
1117 : real(dp), intent(in) :: d1matr(2,3,ddb%mpert)
1118 : integer, intent(in) :: flg(3,ddb%mpert)
1119 : !scalars
1120 : integer,intent(in) :: iblok
1121 :
1122 : !Local variables -------------------------
1123 : integer :: ii,ipert1,idir1
1124 : ! ************************************************************************
1125 :
1126 10 : ii=0
1127 105 : do ipert1=1,ddb%mpert
1128 390 : do idir1=1,3
1129 285 : ii=ii+1
1130 285 : ddb%val(1,ii,iblok) = d1matr(1,idir1,ipert1)
1131 285 : ddb%val(2,ii,iblok) = d1matr(2,idir1,ipert1)
1132 380 : ddb%flg(ii,iblok) = flg(idir1,ipert1)
1133 : end do
1134 : end do
1135 :
1136 10 : end subroutine ddb_set_d1matr
1137 : !!***
1138 :
1139 : !----------------------------------------------------------------------
1140 :
1141 : !!****f* m_ddb/ddb_set_etotal
1142 : !! NAME
1143 : !! ddb_set_etotal
1144 : !!
1145 : !! FUNCTION
1146 : !! Set the total energy
1147 : !!
1148 : !! INPUTS
1149 : !! etotal=the total energy.
1150 : !! iblok=index of the block we are setting.
1151 : !!
1152 : !! SOURCE
1153 :
1154 2796 : subroutine ddb_set_etotal(ddb, etotal, iblok)
1155 :
1156 : !Arguments -------------------------------
1157 : !array
1158 : class(ddb_type),intent(inout) :: ddb
1159 : !scalars
1160 : real(dp),intent(in) :: etotal
1161 : integer,intent(in) :: iblok
1162 : ! ************************************************************************
1163 :
1164 2796 : ddb%typ(iblok) = BLKTYP_d0E_xx
1165 2796 : ddb%val(1,1,iblok) = etotal
1166 2796 : ddb%val(2,1,iblok) = zero
1167 2796 : ddb%flg(1,iblok) = 1
1168 :
1169 2796 : end subroutine ddb_set_etotal
1170 : !!***
1171 :
1172 : !----------------------------------------------------------------------
1173 :
1174 : !!****f* m_ddb/ddb_set_brav
1175 : !! NAME
1176 : !! ddb_set_brav
1177 : !!
1178 : !! FUNCTION
1179 : !! Modify the current values of rprim according to bravais lattice.
1180 : !! Perform some checks on the primitive vectors
1181 : !! before rescaling them such that rprim(1,2)=0.5
1182 : !!
1183 : !! INPUTS
1184 : !! brav
1185 : !! 1 -> No rescaling.
1186 : !! other -> Check and rescale.
1187 : !!
1188 : !! The meaning of brav is
1189 : !! 1 or -1 -> simple lattice
1190 : !! 2 -> face-centered cubic
1191 : !! 3 -> body-centered lattice
1192 : !! 4 -> hexagonal lattice (D6h)
1193 : !!
1194 : !! OUTPUT
1195 : !!
1196 : !! NOTE
1197 : !! The use of brav is deprecated, but it is still used for initializing IFC.
1198 : !! We should try to remove its occurence.
1199 : !!
1200 : !! SOURCE
1201 :
1202 234 : subroutine ddb_set_brav(ddb, brav)
1203 :
1204 : !Arguments -------------------------------
1205 : !array
1206 : class(ddb_type),intent(inout) :: ddb
1207 : !scalars
1208 : integer,intent(in) :: brav
1209 :
1210 : !Local variables-------------------------------
1211 : !scalars
1212 : real(dp) :: factor
1213 : character(len=500) :: msg
1214 : ! *************************************************************************
1215 :
1216 : ! Renormalize rprim to possibly satisfy the constraint abs(rprim(1,2))=half when abs(brav)/=1
1217 : ! This section is needed to preserve the behaviour of the old implementation.
1218 234 : if (abs(brav)/=1 .and. abs(abs(ddb%rprim(1,2))-half)>tol10) then
1219 2 : if(abs(ddb%rprim(1,2))<tol6)then
1220 : write(msg, '(a,i0,7a)' )&
1221 0 : 'The input DDB value of brav is ',brav,',',ch10,&
1222 0 : 'and the one of rprim(1,2) is zero.',ch10,&
1223 0 : 'These are incompatible',ch10,&
1224 0 : 'Action: check the value of brav and rprim(1,2) in your DDB.'
1225 0 : ABI_ERROR(msg)
1226 : end if
1227 2 : factor = abs(ddb%rprim(1,2)) * two
1228 8 : ddb%acell(:) = ddb%acell(:) * factor
1229 26 : ddb%rprim(:,:) = ddb%rprim(:,:) / factor
1230 26 : ddb%gprim(:,:) = ddb%gprim(:,:) * factor
1231 : end if
1232 :
1233 234 : end subroutine ddb_set_brav
1234 : !!***
1235 :
1236 : !----------------------------------------------------------------------
1237 :
1238 : !!****f* m_ddb/ddb_to_d2etot
1239 : !!
1240 : !! NAME
1241 : !! ddb_to_d2etot
1242 : !!
1243 : !! FUNCTION
1244 : !! Convert the physical quantities (Born charges, dielectric tensor,
1245 : !! magnetic susceptibility, etc...)
1246 : !! stored in ddb%val to mathematical second-derivatives of the total energy
1247 : !!
1248 : !! INPUTS
1249 : !! ddb<type(ddb_type)>=Derivative Database.
1250 : !! option= 0 transform ddb to d2etot
1251 : !! 1 transform d2etot to ddb
1252 : !! optgb= 0 do the transform even it ddb might be zeros
1253 : !! 1 check whether the corresponding quantity is present in the ddb data
1254 : !! qeq0= called from a Gamma point blok
1255 : !! ucvol= unit cell volume
1256 : !!
1257 : !! OUTPUT
1258 : !! ddb<type(ddb_type)>=Derivative Database.
1259 : !!
1260 : !! SOURCE
1261 :
1262 106 : subroutine ddb_to_d2etot(ddb,blkval,kblok,option,qeq0,qphon,qphnrm,ucvol,optgb,omega)
1263 :
1264 : !Arguments -------------------------------
1265 : !scalars
1266 : class(ddb_type),intent(inout) :: ddb
1267 : integer,intent(in) :: kblok,option,optgb
1268 : real(dp),intent(in) :: ucvol
1269 : logical,intent(in) :: qeq0
1270 : !arrays
1271 : real(dp),intent(inout) :: blkval(2,3,ddb%mpert,3,ddb%mpert,ddb%nblok)
1272 : real(dp),intent(inout) :: qphnrm(3),qphon(3,3)
1273 : real(dp),optional,intent(in) :: omega(3)
1274 :
1275 : !Local variables -------------------------
1276 : !scalars
1277 : integer :: iblok,rftyp
1278 : integer :: idir1,idir2,ipert1,ipert2
1279 : real(dp) :: fac
1280 : !arrays
1281 : integer :: rfelfd(4),rfmagn(4),rfphon(4),rfstrs(4)
1282 : real(dp) :: val(2)
1283 :
1284 : ! *********************************************************************
1285 :
1286 106 : rfelfd(:)=0
1287 106 : rfphon(:)=0
1288 106 : rfstrs(:)=0
1289 : rfmagn(:)=0
1290 106 : rftyp=1
1291 :
1292 : !IFCs are equal to the d2etot
1293 :
1294 106 : if (qeq0) then
1295 :
1296 : !Born charges
1297 72 : if (optgb==1) then
1298 36 : rfphon(1:2)=1
1299 36 : rfelfd(1:2)=2
1300 12 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp, omega=omega)
1301 : end if
1302 72 : if ((iblok/=0.and.iblok==kblok).or.optgb==0) then
1303 72 : ipert1= ddb%natom + 2
1304 504 : do ipert2= 1, ddb%natom
1305 1800 : do idir2= 1, 3
1306 5616 : do idir1= 1, 3
1307 11664 : val(:)=blkval(:,idir1,ipert1,idir2,ipert2,kblok)
1308 11664 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)=-val(:)
1309 11664 : val(:)=blkval(:,idir2,ipert2,idir1,ipert1,kblok)
1310 12960 : blkval(:,idir2,ipert2,idir1,ipert1,kblok)=-val(:)
1311 : end do
1312 : end do
1313 : end do
1314 : end if
1315 :
1316 : !Dielectric tensor
1317 72 : if (optgb==1) then
1318 : iblok=0
1319 12 : rfphon(:)=0
1320 36 : rfelfd(1:2)=2
1321 12 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp, omega=omega)
1322 : end if
1323 72 : if ((iblok/=0.and.iblok==kblok).or.optgb==0) then
1324 72 : ipert1= ddb%natom + 2
1325 72 : ipert2= ddb%natom + 2
1326 288 : do idir2= 1, 3
1327 936 : do idir1= 1, 3
1328 1944 : val(:)=blkval(:,idir1,ipert1,idir2,ipert2,kblok)
1329 864 : if (option==0) then
1330 207 : if (idir1==idir2) then
1331 207 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)= (one - val(:))*ucvol/four_pi
1332 : else
1333 414 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)= -ucvol/four_pi*val(:)
1334 : end if
1335 441 : else if (option==1) then
1336 441 : if (idir1==idir2) then
1337 441 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)= one - four_pi/ucvol*val(:)
1338 : else
1339 882 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)= -four_pi/ucvol*val(:)
1340 : end if
1341 : end if
1342 : end do
1343 : end do
1344 : end if
1345 :
1346 72 : if (option==0) fac=-ucvol
1347 72 : if (option==1) fac=-one/ucvol
1348 : !Magnetoelectric susceptibility
1349 72 : if (optgb==1) then
1350 : iblok=0
1351 12 : rfphon(:)=0
1352 12 : rfelfd(1)=0
1353 12 : rfelfd(2)=2
1354 : rfmagn(1)=1
1355 : rfmagn(2)=0
1356 12 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp, omega=omega)
1357 : end if
1358 72 : if ((iblok/=0.and.iblok==kblok).or.optgb==0) then
1359 72 : ipert1= ddb%natom + 5
1360 72 : ipert2= ddb%natom + 2
1361 288 : do idir2= 1, 3
1362 936 : do idir1= 1, 3
1363 1944 : val(:)=blkval(:,idir1,ipert1,idir2,ipert2,kblok)
1364 1944 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)=val(:)*fac
1365 1944 : val(:)=blkval(:,idir2,ipert2,idir1,ipert1,kblok)
1366 2160 : blkval(:,idir2,ipert2,idir1,ipert1,kblok)=val(:)*fac
1367 : end do
1368 : end do
1369 : end if
1370 :
1371 : end if
1372 :
1373 : !Magnetic susceptibility
1374 106 : if (option==0) fac=-ucvol
1375 106 : if (option==1) fac=-one/ucvol
1376 106 : if (optgb==1) then
1377 : iblok=0
1378 16 : rfphon(:)=0
1379 48 : rfelfd(1:2)=0
1380 : rfmagn(1:2)=1
1381 16 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp, omega=omega)
1382 : end if
1383 106 : if ((iblok/=0.and.iblok==kblok).or.optgb==0) then
1384 106 : ipert2= ddb%natom + 5
1385 106 : ipert1= ddb%natom + 5
1386 424 : do idir2= 1, 3
1387 1378 : do idir1= 1, 3
1388 2862 : val(:)=blkval(:,idir1,ipert1,idir2,ipert2,kblok)
1389 3180 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)=val(:)*fac
1390 : end do
1391 : end do
1392 : end if
1393 :
1394 : !Forces induced by magnetic field
1395 106 : if (optgb==1) then
1396 : iblok=0
1397 16 : rfelfd(:)=0
1398 : rfmagn(:)=0
1399 16 : rfphon(2)=1
1400 : rfmagn(1)=1
1401 16 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp, omega=omega)
1402 : end if
1403 106 : if ((iblok/=0.and.iblok==kblok).or.optgb==0) then
1404 106 : ipert1= ddb%natom + 5
1405 742 : do ipert2= 1, ddb%natom
1406 2650 : do idir2= 1, 3
1407 8268 : do idir1= 1, 3
1408 17172 : val(:)=blkval(:,idir1,ipert1,idir2,ipert2,kblok)
1409 17172 : blkval(:,idir1,ipert1,idir2,ipert2,kblok)=-val(:)
1410 17172 : val(:)=blkval(:,idir2,ipert2,idir1,ipert1,kblok)
1411 19080 : blkval(:,idir2,ipert2,idir1,ipert1,kblok)=-val(:)
1412 : end do
1413 : end do
1414 : end do
1415 : end if
1416 :
1417 106 : end subroutine ddb_to_d2etot
1418 : !!***
1419 :
1420 : !----------------------------------------------------------------------
1421 : !!****f* m_ddb/ddb_set_typ
1422 : !! NAME
1423 : !! ddb_set_typ
1424 : !!
1425 : !! FUNCTION
1426 : !! Set the blok typ for one block
1427 : !!
1428 : !! INPUTS
1429 : !! iblok: block index
1430 : !! typ: type of block
1431 : !!
1432 : !! OUTPUT
1433 : !!
1434 : !! SOURCE
1435 :
1436 0 : subroutine ddb_set_typ(ddb, iblok, typ)
1437 :
1438 : !Arguments -------------------------------
1439 : !array
1440 : class(ddb_type),intent(inout) :: ddb
1441 : !scalars
1442 : integer,intent(in) :: iblok,typ
1443 : ! *************************************************************************
1444 :
1445 0 : ddb%typ(iblok) = typ
1446 :
1447 0 : end subroutine ddb_set_typ
1448 : !!***
1449 :
1450 : !----------------------------------------------------------------------
1451 :
1452 : !!****f* m_ddb/ddb_bcast
1453 : !! NAME
1454 : !! ddb_bcast
1455 : !!
1456 : !! FUNCTION
1457 : !! MPI broadcast all types for the ddb_type structure
1458 : !!
1459 : !! INPUTS
1460 : !! comm=MPI communicator
1461 : !!
1462 : !! SIDE EFFECTS
1463 : !! Ddb<type(ddb_type)>= Input if node is master, other nodes returns with a completely initialized instance.
1464 : !!
1465 : !! SOURCE
1466 :
1467 12 : subroutine ddb_bcast(ddb, comm)
1468 :
1469 : !Arguments -------------------------------
1470 : !array
1471 : class(ddb_type),intent(inout) :: ddb
1472 : integer, intent(in) :: comm
1473 :
1474 : !Local variables-------------------------------
1475 : !scalars
1476 : integer, parameter :: master=0
1477 : integer :: ierr
1478 : ! *************************************************************************
1479 :
1480 12 : if (xmpi_comm_size(comm) == 1) return
1481 :
1482 : DBG_ENTER("COLL")
1483 :
1484 : ! Transmit dimensions and static variables.
1485 12 : call xmpi_bcast(ddb%nblok, master, comm, ierr)
1486 12 : call xmpi_bcast(ddb%natom, master, comm, ierr)
1487 12 : call xmpi_bcast(ddb%ntypat, master, comm, ierr)
1488 12 : call xmpi_bcast(ddb%nsppol, master, comm, ierr)
1489 12 : call xmpi_bcast(ddb%mpert, master, comm, ierr)
1490 12 : call xmpi_bcast(ddb%msize, master, comm, ierr)
1491 :
1492 12 : call xmpi_bcast(ddb%occopt, master, comm, ierr)
1493 12 : call xmpi_bcast(ddb%prtvol, master, comm, ierr)
1494 :
1495 : !real
1496 12 : call xmpi_bcast(ddb%rprim, master, comm, ierr)
1497 12 : call xmpi_bcast(ddb%gprim, master, comm, ierr)
1498 12 : call xmpi_bcast(ddb%acell, master, comm, ierr)
1499 :
1500 : ! Allocate arrays on the other nodes.
1501 12 : if (xmpi_comm_rank(comm) /= master) then
1502 8 : call ddb%malloc(ddb%msize, ddb%nblok, ddb%natom, ddb%ntypat, ddb%mpert)
1503 : end if
1504 :
1505 12 : call xmpi_bcast(ddb%flg, master, comm, ierr)
1506 12 : call xmpi_bcast(ddb%typ, master, comm, ierr)
1507 12 : call xmpi_bcast(ddb%amu, master, comm, ierr)
1508 12 : call xmpi_bcast(ddb%nrm, master, comm, ierr)
1509 12 : call xmpi_bcast(ddb%omega, master, comm, ierr)
1510 12 : call xmpi_bcast(ddb%qpt, master, comm, ierr)
1511 12 : call xmpi_bcast(ddb%val, master, comm, ierr)
1512 : ! call xmpi_bcast(ddb%val_fs, master, comm, ierr)
1513 : ! call xmpi_bcast(ddb%val_rs, master, comm, ierr)
1514 :
1515 : DBG_EXIT("COLL")
1516 :
1517 : end subroutine ddb_bcast
1518 : !!***
1519 :
1520 : !----------------------------------------------------------------------
1521 :
1522 : !!****f* m_ddb/ddb_get_block
1523 : !!
1524 : !! NAME
1525 : !! ddb_get_block
1526 : !!
1527 : !! FUNCTION
1528 : !! This routine finds the block that contains the
1529 : !! information on the derivatives of the total energy specified
1530 : !! by the parameters rfphon,rfelfd,rfstrs,rftyp and
1531 : !! the phonon wavevectors qphon (and their normalisation).
1532 : !! In case the DDB does not contain this information, the subroutine returns iblok=0
1533 : !!
1534 : !! INPUTS
1535 : !! ddb = ddb blok datastructure
1536 : !! flg(msize,nblok)=flag for every matrix element:
1537 : !! 0 => the element is not in the data block.
1538 : !! 1 => the element is in the data blok.
1539 : !! nrm(3,nblok)=normalization factors for the three allowed wavevectors
1540 : !! qpt(3,nblok)=wavevector of the perturbation(s). The elements
1541 : !! typ(nblok)=type of the block.
1542 : !! (1=> non-stationary block),
1543 : !! (2=> stationary block),
1544 : !! (3=> third order derivative).
1545 : !! omega(3)= frequency of the perturbation
1546 : !! qphon(3,3)=wavevectors for the three possible phonons
1547 : !! (note : only one should be used in case of second derivative of total energy,
1548 : !! because we know that the second is the opposite of this value)
1549 : !! qphnrm(3) =normalisation factors for the three possible phonons
1550 : !! rfphon(4) = 1=> response to phonons
1551 : !! 2=> second derivative of total energy
1552 : !! rfelfd(4) = 1=> d/dk, 2=> electric field only, 3=> both (see comment on rfphon)
1553 : !! rfstrs(4) = 1=> uniaxial stresses, 2=> shear stresses, 3=> both (see comment on rfphon)
1554 : !! rftyp =
1555 : !! 0 => total energy
1556 : !! 1 => non-stationary formulation of the 2nd derivative
1557 : !! 2 => stationary formulation of the 2nd derivative
1558 : !! 3 => third derivative of total energy
1559 : !! 4 => first-order derivatives of total energy
1560 : !! 33 => long wave third order derivatives of total energy
1561 : !! [rffreq(4)] = 1=> d/dw (optional)
1562 : !! [rfmagn(4)] = 1=> Uniform Zeeman, 2 => Local Zeeman (optional)
1563 : !! 85 => molecular Berry curvature
1564 : !! [rfqvec(4)] = 1=> d/dq (optional)
1565 : !! [mpatpol(2)] = atoms on which the magnetic penalty was applied (optional)
1566 : !! [mpdir(3)] = directions alongw which the magnetic penalty was applied (optional)
1567 : !!
1568 : !! OUTPUT
1569 : !! iblok= number of the block that corresponds to the specifications. 0 if not found.
1570 : !!
1571 : !! SOURCE
1572 :
1573 887 : subroutine ddb_get_block(ddb, iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp, &
1574 : & mpatpol,mpdir,omega,rffreq,rfmagn,rfqvec)
1575 :
1576 : !Arguments -------------------------------
1577 : !scalars
1578 : class(ddb_type),intent(in) :: ddb
1579 : integer,intent(out) :: iblok
1580 : integer,intent(in) :: rftyp
1581 : !arrays
1582 : integer,intent(in) :: rfelfd(4),rfphon(4),rfstrs(4)
1583 : real(dp),intent(inout) :: qphnrm(3),qphon(3,3)
1584 : integer,optional,intent(in) :: mpatpol(2),mpdir(3)
1585 : integer,optional,intent(in) :: rfmagn(4),rffreq(4),rfqvec(4)
1586 : real(dp),optional,intent(in) :: omega(3)
1587 :
1588 : !Local variables -------------------------
1589 : !scalars
1590 : integer, parameter :: cvrsio9_new=20240201
1591 : integer :: blkgam,ider,idir,idir1,idir2,idir3,ii,index,ipert,ipert1,ipert2
1592 : integer :: ipert3,nder,ok,mpert,natom,ndir3
1593 : character(len=500) :: msg
1594 : !arrays
1595 : integer :: gamma(3)
1596 887 : integer,allocatable :: worki(:,:)
1597 : real(dp) :: omega_(3),qpt(3)
1598 : integer :: mpatpol_(2),mpdir_(3)
1599 : integer :: rfmagn_(4),rffreq_(4),rfqvec_(4)
1600 :
1601 : ! *********************************************************************
1602 :
1603 887 : mpert = ddb%mpert
1604 887 : natom = ddb%natom
1605 :
1606 : ! Get the number of derivative
1607 887 : if (is_type_d2E(rftyp)) then
1608 : nder=2
1609 119 : else if (is_type_d3E(rftyp)) then
1610 : nder=3
1611 80 : else if (is_type_d0E(rftyp)) then
1612 : nder=0
1613 48 : else if (is_type_d1E(rftyp)) then
1614 : nder=1
1615 : else
1616 0 : write(msg, '(a,i0,a)')' rftyp is equal to ',rftyp,'. The only allowed values are 0, 1, 2, 3, 5, 6, 33 or 85.'
1617 0 : ABI_BUG(msg)
1618 : end if
1619 :
1620 : ! Default optionals
1621 887 : rfqvec_(:)=0; if (present(rfqvec)) rfqvec_(:)=rfqvec(:)
1622 887 : rfmagn_(:)=0; if (present(rfmagn)) rfmagn_(:)=rfmagn(:)
1623 887 : rffreq_(:)=0; if (present(rffreq)) rffreq_(:)=rffreq(:)
1624 887 : mpatpol_(:)=0; if (present(mpatpol)) mpatpol_(:)=mpatpol(:)
1625 887 : mpdir_(:)=0; if (present(mpdir)) mpdir_(:)=mpdir(:)
1626 887 : omega_(:)=0; if (present(omega)) omega_(:)=omega(:)
1627 :
1628 : ! In case of a second-derivative, a second phonon wavevector is provided.
1629 887 : if(nder==2)then
1630 3072 : do ii=1,3
1631 3072 : qphon(ii,2)=-qphon(ii,1)
1632 : end do
1633 768 : qphnrm(2)=qphnrm(1)
1634 : end if
1635 :
1636 : ! In case of a third derivative, the sum of wavevectors to gamma is checked
1637 887 : if (nder == 3.and.rffreq_(3)==0) then
1638 96 : qpt(:) = qphon(:,1)/qphnrm(1) + qphon(:,2)/qphnrm(2) + qphon(:,3)/qphnrm(3)
1639 24 : call gamma9(gamma(nder),qpt,qphnrm(1),DDB_QTOL)
1640 24 : if (gamma(nder) == 0) then
1641 : write(msg,'(a,a,a)')&
1642 0 : 'the sum of the wavevectors of the third-order energy is ',ch10,&
1643 0 : 'not equal to zero'
1644 0 : ABI_ERROR(msg)
1645 : end if
1646 : end if
1647 :
1648 : ! Check the validity of the requirement
1649 2588 : do ider=1,nder
1650 : ! Identifies if qphon is at gamma
1651 1701 : call gamma9(gamma(ider),qphon(1:3,ider),qphnrm(ider),DDB_QTOL)
1652 :
1653 2588 : if(gamma(ider)==0)then
1654 131 : if(rfstrs(ider)/=0.or.rfelfd(ider)/=0.or.rfqvec_(ider)/=0)then
1655 : write(msg, '(a,a)' )&
1656 0 : 'Not yet able to handle stresses or electric fields',ch10,&
1657 0 : 'with non-zero wavevector.'
1658 0 : ABI_BUG(msg)
1659 : end if
1660 : end if
1661 : end do
1662 :
1663 : ! Initialise the perturbation table
1664 2661 : ABI_MALLOC(worki,(mpert,4))
1665 32757 : worki(:,1:nder)=0
1666 :
1667 : ! Build the perturbation table
1668 2588 : do ider=1,nder
1669 : ! First the phonons
1670 1701 : if(rfphon(ider)==1)then ! what about the rfphon = 2 case ?
1671 3573 : do ipert=1,natom
1672 3573 : worki(ipert,ider)=1
1673 : end do
1674 : end if
1675 : ! Then the d/dk
1676 1701 : if (rfelfd(ider)==1.or.rfelfd(ider)==3) worki(natom+1,ider)=1
1677 : ! Then the electric field
1678 1701 : if (rfelfd(ider)==2.or.rfelfd(ider)==3) worki(natom+2,ider)=1
1679 : ! Then the ddq
1680 1701 : if (rfqvec_(ider)==1) worki(natom+8,ider)=1
1681 : ! Then the uniaxial stress
1682 1701 : if (rfstrs(ider)==1.or.rfstrs(ider)==3) worki(natom+3,ider)=1
1683 : ! Then the shear stress
1684 1701 : if (rfstrs(ider)==2.or.rfstrs(ider)==3) worki(natom+4,ider)=1
1685 : ! Then the uniform Zeeman field
1686 1701 : if (rfmagn_(ider)==1) worki(natom+5,ider)=1
1687 : ! Then the ddw
1688 1701 : if (rffreq_(ider)==1) worki(natom+9,ider)=1
1689 : ! At last, the local Zeeman fields
1690 2588 : if (rfmagn_(ider)==2) then
1691 81 : do ipert=natom+11+mpatpol_(1),natom+11+mpatpol_(2)
1692 81 : worki(ipert,ider)=1
1693 : end do
1694 : end if
1695 : end do
1696 :
1697 : ! Examine every blok:
1698 3159 : do iblok=1,ddb%nblok
1699 :
1700 : ! If this variable is still 1 at the end of the examination, the blok is the good one...
1701 2937 : ok=1
1702 :
1703 : ! Check the type
1704 2937 : if(rftyp/=ddb%typ(iblok)) ok=0
1705 :
1706 : ! Check the wavevector
1707 : if( ok==1 )then
1708 :
1709 1824 : if (nder == 2) then
1710 1744 : call gamma9(blkgam,ddb%qpt(1:3,iblok),ddb%nrm(1,iblok),DDB_QTOL)
1711 1744 : if(blkgam/=gamma(1))then
1712 : ok=0
1713 927 : else if(blkgam==0)then
1714 796 : do idir=1,3
1715 796 : if( abs( ddb%qpt(idir,iblok)/ddb%nrm(1,iblok) - qphon(idir,1)/qphnrm(1) )>DDB_QTOL ) ok=0
1716 : end do
1717 : end if
1718 :
1719 80 : else if (nder == 3) then
1720 156 : do ider = 1, nder
1721 507 : do idir=1,3
1722 468 : if( abs( ddb%qpt(idir+3*(ider-1),iblok)/ddb%nrm(ider,iblok) - qphon(idir,ider)/qphnrm(ider) )>DDB_QTOL )then
1723 2 : ok=0
1724 : end if ! qphon
1725 : end do ! idir
1726 : end do ! nder
1727 : end if ! nder
1728 :
1729 : end if ! ok
1730 :
1731 : ! ! Check the frequency
1732 : ! if( ok==1 .and. ddb_version>=cvrsio9_new )then
1733 : !TODO: This might fail if previous DDB files are read
1734 1007 : if( ok==1 )then
1735 865 : if (nder == 2) then
1736 786 : if( abs( ddb%omega(1,iblok) - omega_(1) )>DDB_QTOL ) ok=0
1737 79 : else if (nder == 3) then
1738 152 : do ider=1,3
1739 152 : if( abs( ddb%omega(ider,iblok) - omega_(ider) )>DDB_QTOL ) ok=0
1740 : end do
1741 : end if
1742 : end if !ok
1743 :
1744 : ! Check if there is enough information in this blok
1745 835 : if( ok==1 )then
1746 :
1747 835 : if (nder == 0) then
1748 15 : if (ddb%flg(1,iblok) /= 1) then
1749 0 : ok = 0
1750 0 : if (ddb%prtvol > 1) then
1751 : write(msg,'(a,i0,3a)' )&
1752 0 : 'The block ',iblok,' does not match the requirement',ch10,&
1753 0 : 'because it lacks the total energy'
1754 0 : ABI_COMMENT(msg)
1755 : end if
1756 : end if
1757 : end if
1758 :
1759 15706 : do ipert1=1,mpert
1760 :
1761 : if ((nder == 4).and.(worki(ipert1,4) == 1).and.(ok == 1)) then
1762 : do idir1 = 1, 3
1763 : index = 3*(ipert1 - 1) + idir1
1764 : if (ddb%flg(index,iblok) /= 1) ok = 0
1765 : end do
1766 : end if
1767 :
1768 15706 : if (worki(ipert1,1)==1 .and. ok==1 )then
1769 43058 : do ipert2=1,mpert
1770 43058 : if (worki(ipert2,2)==1 .and. ok==1 )then
1771 31172 : do idir1=1,3
1772 23379 : if (ipert1>natom+11.and.ipert1<=2*natom+11.and.mpdir_(idir1)==0) cycle
1773 97073 : do idir2=1,3
1774 66960 : if (ipert2>natom+11.and.ipert2<=2*natom+11.and.mpdir_(idir2)==0) cycle
1775 :
1776 88986 : if (nder == 2) then
1777 57847 : index=idir1+ 3*((ipert1-1)+mpert*((idir2-1)+3*(ipert2-1)))
1778 123425 : if (ddb%flg(index,iblok)/=1) ok=0
1779 :
1780 7760 : else if (nder == 3) then
1781 52392 : do ipert3 = 1, mpert
1782 52392 : if (worki(ipert3,3) == 1 .and. ok == 1) then
1783 2388 : if (ipert3==natom+9) then
1784 : ndir3= 1
1785 : else
1786 955 : ndir3= 3
1787 : end if
1788 6686 : do idir3 = 1, ndir3
1789 : index = idir1 + &
1790 : 3*((ipert1 - 1) + mpert*((idir2 - 1) + &
1791 4298 : 3*((ipert2 -1 ) + mpert*((idir3 - 1) + 3*(ipert3 - 1)))))
1792 6686 : if (ddb%flg(index,iblok) /= 1) ok = 0
1793 : end do ! idir3
1794 : end if ! worki(ipert3,3)
1795 : end do ! i3pert
1796 : end if
1797 :
1798 : end do
1799 : end do
1800 : end if
1801 : end do
1802 : end if
1803 : end do
1804 : end if
1805 :
1806 : ! Now that everything has been checked, eventually end the search
1807 1057 : if(ok==1)exit
1808 : end do
1809 :
1810 887 : if(ok==0)then
1811 222 : iblok=0
1812 :
1813 222 : if (ddb%prtvol > 1) then
1814 : write(msg, '(3a)' )&
1815 49 : ' gtblk9 : ',ch10,&
1816 98 : ' Unable to find block corresponding to the following specifications :'
1817 49 : call wrtout(std_out,msg)
1818 49 : write(msg, '(a,i3)' )' Type (rfmeth) =',rftyp
1819 49 : call wrtout(std_out,msg)
1820 49 : write(msg, '(a)' ) ' ider qphon(3) qphnrm rfphon rfelfd rfstrs rfmagn rfqvec rffreq'
1821 49 : call wrtout(std_out,msg)
1822 98 : do ider=1,nder
1823 : write(msg, '(i4,4f6.2,6i7)' )&
1824 49 : ider,(qphon(ii,ider),ii=1,3),qphnrm(ider),rfphon(ider),rfelfd(ider),rfstrs(ider),&
1825 98 : & rfmagn_(ider),rfqvec_(ider),rffreq_(ider)
1826 98 : call wrtout(std_out,msg)
1827 : end do
1828 : end if
1829 : end if
1830 :
1831 665 : if (ok==1 .and. ddb%prtvol > 1) then
1832 290 : write(msg,'(a,i0,2a)')' gtblk9: found block number ',iblok,' agree with',' specifications '
1833 290 : call wrtout(std_out,msg)
1834 : end if
1835 :
1836 887 : ABI_FREE(worki)
1837 :
1838 887 : end subroutine ddb_get_block
1839 : !!***
1840 :
1841 : !----------------------------------------------------------------------
1842 :
1843 : !!****f* m_ddb/gamma9
1844 : !!
1845 : !! NAME
1846 : !! gamma9
1847 : !!
1848 : !! FUNCTION
1849 : !! This small routine checks if the wavevector qphon and the
1850 : !! corresponding normalisation factor represent a phonon at Gamma.
1851 : !!
1852 : !! INPUTS
1853 : !! qphon(3)=wavevector
1854 : !! qphnrm=normalisation factor
1855 : !! qtol=tolerance
1856 : !!
1857 : !! OUTPUT
1858 : !! gamma= if 1, means that the wavevector is indeed at Gamma otherwise 0.
1859 : !!
1860 : !! SOURCE
1861 :
1862 5816 : subroutine gamma9(gamma,qphon,qphnrm,qtol)
1863 :
1864 : !Arguments -------------------------------
1865 : !scalars
1866 : integer,intent(out) :: gamma
1867 : real(dp),intent(in) :: qphnrm,qtol
1868 : !arrays
1869 : real(dp),intent(in) :: qphon(3)
1870 : ! *********************************************************************
1871 :
1872 5816 : if( (abs(qphon(1))<qtol .and. abs(qphon(2))<qtol .and. abs(qphon(3))<qtol) .or. abs(qphnrm)<qtol ) then
1873 2415 : gamma=1
1874 : else
1875 3401 : gamma=0
1876 : end if
1877 :
1878 5816 : end subroutine gamma9
1879 : !!***
1880 :
1881 : !----------------------------------------------------------------------
1882 :
1883 : !!****f* m_ddb/ddb_read_block_txt
1884 : !!
1885 : !! NAME
1886 : !! ddb_read_block_txt
1887 : !!
1888 : !! FUNCTION
1889 : !! Read the next block of data from a DDB in text format.
1890 : !!
1891 : !! INPUTS
1892 : !! iblok=the blok index to be assigned
1893 : !! mpert=maximum number of ipert
1894 : !! msize=maximum size of the arrays flags and values
1895 : !! nunit=unit number for the data block file
1896 : !!
1897 : !! OUTPUT
1898 : !! (see side effects)
1899 : !!
1900 : !! SIDE EFFECTS
1901 : !! Input/Output
1902 : !! ddb = ddb block datastructure
1903 : !! ddb%typ=type of the block:
1904 : !! 0 => total energy
1905 : !! 1 => second-order energy derivatives, non-stationary block
1906 : !! 2 => second-order energy derivatives, stationary block
1907 : !! 3 => third-order energy derivatives
1908 : !! 4 => first-order energy derivatives: forces, stresses and polarization
1909 : !! 5 => second-order eigenvalue derivatives
1910 : !! ddb%flg(msize)=flag for every matrix element (0=> the element is
1911 : !! not in the data block), (1=> the element is in the data blok)
1912 : !! ddb%qpt(9)=wavevector of the perturbation(s). The elements from
1913 : !! 1 to 3 are used if we are dealing with the 2nd derivative of
1914 : !! total energy (only one wavevector), while all elements are
1915 : !! used in case of a third order derivative of total energy (three wavevector could be present)
1916 : !! ddb%nrm(3)=normalization factors for the three allowed wavevectors.
1917 : !! ddb%val(2,msize)=real(dp), complex, value of the matrix elements that are present in the data block
1918 : !! [blkval2(2,msize,mband,nkpt)]= value of the matrix elements that are present in a block of EIGR2D/EIGI2D
1919 : !!
1920 : !! NOTES
1921 : !! only executed by one processor.
1922 : !!
1923 : !! SOURCE
1924 :
1925 2081 : subroutine ddb_read_block_txt(ddb,iblok,mband,mpert,msize,nkpt,nunit,&
1926 48 : blkval2,kpt,ddb_version) !optional
1927 :
1928 : !Arguments -------------------------------
1929 : !scalars
1930 : integer,intent(in) :: mband,mpert,msize,nkpt,nunit
1931 : integer,intent(in) :: iblok
1932 : integer,intent(in) :: ddb_version
1933 : !logical, intent(in), optional :: eig2d
1934 : class(ddb_type),intent(inout) :: ddb
1935 : !arrays
1936 : real(dp),intent(out),optional :: kpt(3,nkpt)
1937 : real(dp),intent(out),optional :: blkval2(2,msize,mband,nkpt)
1938 :
1939 : !Local variables -------------------------
1940 : !scalars
1941 : integer, parameter :: cvrsio9_new=20240201
1942 : integer :: band,iband,idir1,idir2,idir3,ii,ikpt,index,ipert1,ipert2,ipert3,nelmts
1943 : logical :: eig2d_
1944 : real(dp) :: ai,ar
1945 : character(len=32) :: name
1946 : character(len=500) :: msg
1947 : ! *********************************************************************
1948 :
1949 : ! Zero every flag
1950 44797259 : ddb%flg(1:msize, iblok)=0
1951 :
1952 2081 : eig2d_ = .false.
1953 :
1954 :
1955 2081 : if(present(kpt).and.present(blkval2)) then
1956 : ! GA: Weird that it is not allocated here
1957 126924 : blkval2(:,:,:,:)=zero
1958 1000 : kpt(:,:)=zero
1959 : eig2d_ = .true.
1960 : end if
1961 :
1962 : !if (present(eig2d)) then
1963 : ! eig2d_ = eig2d
1964 : !end if
1965 :
1966 : ! Read the block type and number of elements
1967 2081 : read(nunit,*)
1968 2081 : read(nunit, '(a32,12x,i12)' )name,nelmts
1969 :
1970 : ! TODO: Replace with STRING_d2E, etc.
1971 : ! GA: Note that older versions used the expression '2rd' instead of '2nd'
1972 : ! So this substitution needs to be checked for backward compatibility.
1973 : ! Also, the strings for d2eig and d2eig_brd are undistinguishable
1974 : ! I don't think the d2eig_brd was ever read by abinit or anaddb.
1975 2081 : if(name==' 2nd derivatives (non-stat.) - ' .or. name==' 2rd derivatives (non-stat.) - ')then
1976 1913 : ddb%typ(iblok)=BLKTYP_d2E_ns
1977 168 : else if(name==' 2nd derivatives (stationary) - ' .or. name==' 2rd derivatives (stationary) - ')then
1978 54 : ddb%typ(iblok)=BLKTYP_d2E_st
1979 114 : else if(name==' 3rd derivatives - ')then
1980 4 : ddb%typ(iblok)=BLKTYP_d3E_xx
1981 110 : else if(name==' Total energy - ')then
1982 34 : ddb%typ(iblok)=BLKTYP_d0E_xx
1983 76 : else if(name==' 1st derivatives - ')then
1984 34 : ddb%typ(iblok)=BLKTYP_d1E_xx
1985 42 : else if(name==' 2nd eigenvalue derivatives - ' .or. name==' 2rd eigenvalue derivatives - ')then
1986 24 : ddb%typ(iblok)=BLKTYP_d2eig_re
1987 18 : else if(name==' 3rd derivatives (long wave) - ')then
1988 18 : ddb%typ(iblok)=BLKTYP_d3E_lw
1989 0 : else if(name==' 2nd derivatives (MBC) - ')then
1990 0 : ddb%typ(iblok)=BLKTYP_d2E_mbc
1991 : else
1992 : write(msg,'(6a)')&
1993 0 : 'The following string appears in the DDB in place of',&
1994 0 : ' the block type description :',ch10,trim(name),ch10,&
1995 0 : 'Action: check your DDB.'
1996 0 : ABI_ERROR(msg)
1997 : end if
1998 :
1999 : ! Read the 2nd derivative block
2000 2081 : if (is_type_d2E(ddb%typ(iblok))) then
2001 :
2002 : ! First check if there is enough space to read it
2003 1967 : if(msize<(3*mpert*3*mpert))then
2004 : write(msg,'(3a)')&
2005 0 : 'There is not enough space to read a second-derivative block.',ch10,&
2006 0 : 'Action: increase msize and recompile.'
2007 0 : ABI_ERROR(msg)
2008 : end if
2009 :
2010 : ! Read the phonon wavevector
2011 7868 : read(nunit, '(4x,3es16.8,f6.1)' )(ddb%qpt(ii,iblok),ii=1,3),ddb%nrm(1,iblok)
2012 :
2013 : ! Read the perturbation frequency
2014 1967 : if (ddb_version>=cvrsio9_new) then
2015 565 : read(nunit, '(10x,1es16.8)' ) ddb%omega(1,iblok)
2016 : else
2017 1402 : ddb%omega(1,iblok)=0.d0
2018 : end if
2019 5901 : ddb%omega(2:3,iblok)=0.d0
2020 :
2021 : ! Read every element
2022 324735 : do ii=1,nelmts
2023 322768 : read(nunit,*)idir1,ipert1,idir2,ipert2,ar,ai
2024 322768 : index=idir1+3*((ipert1-1)+mpert*((idir2-1)+3*(ipert2-1)))
2025 322768 : ddb%flg(index,iblok)=1
2026 322768 : ddb%val(1,index,iblok)=ar
2027 324735 : ddb%val(2,index,iblok)=ai
2028 : end do
2029 :
2030 114 : else if (is_type_d3E(ddb%typ(iblok))) then
2031 : ! Read the 3rd derivative block
2032 :
2033 : ! First check if there is enough space to read it
2034 22 : if(msize<(3*mpert*3*mpert*3*mpert))then
2035 : write(msg, '(a,a,a,i10,a,i10,a,a,a)' )&
2036 0 : 'There is not enough space to read a third-derivative block.',ch10,&
2037 0 : 'The size provided is only ',msize,' although ',3*mpert*3*mpert*3*mpert,' is needed.',ch10,&
2038 0 : 'Action: increase msize and recompile.'
2039 0 : ABI_ERROR(msg)
2040 : end if
2041 :
2042 : ! Read the perturbation wavevectors
2043 88 : read(nunit,'(4x,3es16.8,f6.1)')(ddb%qpt(ii,iblok),ii=1,3),ddb%nrm(1,iblok)
2044 88 : read(nunit,'(4x,3es16.8,f6.1)')(ddb%qpt(ii,iblok),ii=4,6),ddb%nrm(2,iblok)
2045 88 : read(nunit,'(4x,3es16.8,f6.1)')(ddb%qpt(ii,iblok),ii=7,9),ddb%nrm(3,iblok)
2046 :
2047 : ! Read the perturbation frequency
2048 22 : if (ddb_version>=cvrsio9_new) then
2049 18 : read(nunit, '(10x,1es16.8)' ) ddb%omega(1,iblok)
2050 18 : read(nunit, '(10x,1es16.8)' ) ddb%omega(2,iblok)
2051 18 : read(nunit, '(10x,1es16.8)' ) ddb%omega(3,iblok)
2052 : else
2053 16 : ddb%omega(:,iblok)=0.d0
2054 : end if
2055 :
2056 : ! Read every element
2057 5703 : do ii=1,nelmts
2058 5681 : read(nunit,*)idir1,ipert1,idir2,ipert2,idir3,ipert3,ar,ai
2059 : index=idir1+ &
2060 : 3*((ipert1-1)+mpert*((idir2-1)+ &
2061 5681 : 3*((ipert2-1)+mpert*((idir3-1)+3*(ipert3-1)))))
2062 5681 : ddb%flg(index,iblok)=1
2063 5681 : ddb%val(1,index,iblok)=ar
2064 5703 : ddb%val(2,index,iblok)=ai
2065 : end do
2066 :
2067 92 : else if (is_type_d0E(ddb%typ(iblok))) then
2068 : ! Read the total energy
2069 : ! First check if there is enough space to read it
2070 34 : if(msize<1)then
2071 : write(msg, '(3a,i0,3a)' )&
2072 0 : 'There is not enough space to read a total energy block.',ch10,&
2073 0 : 'The size provided is only ',msize,' although 1 is needed.',ch10,&
2074 0 : 'Action: increase msize and recompile.'
2075 0 : ABI_ERROR(msg)
2076 : end if
2077 :
2078 : ! Read the total energy
2079 34 : read(nunit,'(2d22.14)')ar,ai
2080 34 : ddb%flg(1,iblok)=1
2081 34 : ddb%val(1,1,iblok)=ar
2082 34 : ddb%val(2,1,iblok)=ai
2083 :
2084 :
2085 58 : else if (is_type_d1E(ddb%typ(iblok))) then
2086 : ! Read the 1st derivative block
2087 : ! First check if there is enough space to read it
2088 34 : if (msize < (3*mpert)) then
2089 : write(msg, '(3a,i0,a,i0,3a)' )&
2090 0 : 'There is not enough space to read a first-derivative block.',ch10,&
2091 0 : 'The size provided is only ',msize,' although ',3*mpert,' is needed.',ch10,&
2092 0 : 'Action: increase msize and recompile.'
2093 0 : ABI_ERROR(msg)
2094 : end if
2095 :
2096 : ! Read every element
2097 658 : do ii=1,nelmts
2098 624 : read(nunit,*)idir1,ipert1,ar,ai
2099 624 : index=idir1 + 3*(ipert1 - 1)
2100 624 : ddb%flg(index,iblok)=1
2101 624 : ddb%val(1,index,iblok)=ar
2102 658 : ddb%val(2,index,iblok)=ai
2103 : end do
2104 :
2105 :
2106 24 : else if (is_type_d2eig(ddb%typ(iblok))) then
2107 :
2108 : ! Read the 2nd eigenvalue derivative block
2109 : ! First check if there is enough space to read it
2110 24 : if(msize<(3*mpert*3*mpert))then
2111 : write(msg, '(3a,i0,a,i0,3a)' )&
2112 0 : 'There is not enough space to read a second-derivative block.',ch10,&
2113 0 : 'The size provided is only ',msize,' although ',3*mpert*3*mpert*mband*nkpt,' is needed.',ch10,&
2114 0 : 'Action: increase msize and recompile.'
2115 0 : ABI_ERROR(msg)
2116 : end if
2117 :
2118 : ! Read the phonon wavevector
2119 96 : read(nunit, '(4x,3es16.8,f6.1)' )(ddb%qpt(ii,iblok),ii=1,3),ddb%nrm(1,iblok)
2120 :
2121 : ! Read the K point and band
2122 24 : if (eig2d_) then
2123 268 : do ikpt=1,nkpt
2124 244 : read(nunit, '(9x,3es16.8)')(kpt(ii,ikpt),ii=1,3)
2125 1644 : do iband=1,mband
2126 1376 : read(nunit, '(6x,i3)') band
2127 : ! Read every element
2128 43380 : do ii=1,nelmts
2129 41760 : read(nunit,*)idir1,ipert1,idir2,ipert2,ar,ai
2130 41760 : index=idir1+3*((ipert1-1)+mpert*((idir2-1)+3*(ipert2-1)))
2131 41760 : ddb%flg(index,iblok)=1
2132 41760 : blkval2(1,index,iband,ikpt)=ar
2133 43136 : blkval2(2,index,iband,ikpt)=ai
2134 : end do !nelmts
2135 : end do !band
2136 : end do !kpt
2137 : end if
2138 : end if
2139 :
2140 2105 : end subroutine ddb_read_block_txt
2141 : !!***
2142 :
2143 : !----------------------------------------------------------------------
2144 :
2145 : !!****f* m_ddb/ddb_read_d2eig
2146 : !!
2147 : !! NAME
2148 : !! ddb_read_d2eig
2149 : !!
2150 : !! FUNCTION
2151 : !! Read the next DDB block containing second-order derivatives of eigenvalues
2152 : !! and store it in block number iblok.
2153 : !! The values of nband and nkpt must be set.
2154 : !!
2155 : !! INPUTS
2156 : !! ddb_hdr=ddb header object with open file.
2157 : !! iblok_store=the block index in the ddb object
2158 : !! iblok_read=the block index in the ddb file
2159 : !!
2160 : !! OUTPUT
2161 : !!
2162 : !! NOTE
2163 : !! The ddb object must be allocated becore calling this routine.
2164 : !!
2165 : !! SOURCE
2166 :
2167 :
2168 48 : subroutine ddb_read_d2eig(ddb, ddb_hdr, iblok_store, iblok_read, comm)
2169 :
2170 : !Arguments -------------------------------
2171 : !scalars
2172 : class(ddb_type),intent(inout) :: ddb
2173 : type(ddb_hdr_type),intent(in) :: ddb_hdr
2174 : integer, intent(in) :: iblok_store
2175 : integer, intent(in),optional :: iblok_read
2176 : integer, intent(in),optional :: comm
2177 :
2178 : !Local variables -------------------------
2179 : !scalars
2180 : integer,parameter :: master=0
2181 : integer :: comm_
2182 : character(len=500) :: msg
2183 : ! *********************************************************************
2184 :
2185 48 : if (present(comm)) then
2186 0 : comm_ = comm
2187 : else
2188 48 : comm_ = xmpi_comm_self
2189 : end if
2190 :
2191 48 : if (xmpi_comm_rank(comm_) == master) then
2192 :
2193 48 : if (ddb_hdr%has_open_file_nc) then
2194 :
2195 : ! Read the specified block and store it
2196 24 : call ddb%read_d2eig_nc(ddb_hdr%ncid, iblok_store, iblok_read)
2197 :
2198 24 : else if (ddb_hdr%has_open_file_txt) then
2199 :
2200 : ! Read the next block and store it
2201 24 : call ddb%read_d2eig_txt(ddb_hdr%unddb, iblok_store,ddb_hdr%ddb_version)
2202 :
2203 : else
2204 : write(msg, '(3a)' )&
2205 : ! File has not beed open by ddb_hdr
2206 0 : 'Attempting to read from unopen file DDB.',ch10,&
2207 0 : 'Action: contact Abinit group.'
2208 0 : ABI_ERROR(msg)
2209 : end if
2210 :
2211 : end if
2212 :
2213 : ! GA: Should in principle broadcast the d2eig array,
2214 : ! but I dont think it is required yet.
2215 :
2216 48 : end subroutine ddb_read_d2eig
2217 : !!***
2218 :
2219 : !----------------------------------------------------------------------
2220 :
2221 : !!****f* m_ddb/ddb_read_d2eig_txt
2222 : !!
2223 : !! NAME
2224 : !! ddb_read_d2eig_txt
2225 : !!
2226 : !! FUNCTION
2227 : !! Read the next DDB block containing second-order derivatives of eigenvalues
2228 : !! and store it in block number iblok.
2229 : !! The ddb object must have been allocated with nband and nkpt.
2230 : !!
2231 : !! INPUTS
2232 : !! unddb=unit for the open file in text format
2233 : !! iblok=the block index in the ddb object
2234 : !!
2235 : !! OUTPUT
2236 : !!
2237 : !! SOURCE
2238 :
2239 :
2240 24 : subroutine ddb_read_d2eig_txt(ddb, unddb, iblok, ddbvsn)
2241 :
2242 : !Arguments -------------------------------
2243 : !scalars
2244 : class(ddb_type),intent(inout) :: ddb
2245 : integer, intent(in) :: unddb, ddbvsn
2246 : integer, intent(in), optional :: iblok
2247 : !Local variables -------------------------
2248 : !scalars
2249 : integer :: iblok_eig2d
2250 : ! *********************************************************************
2251 :
2252 24 : iblok_eig2d = 1
2253 24 : if (present(iblok)) iblok_eig2d = iblok
2254 :
2255 : call ddb%read_block_txt(iblok_eig2d,ddb%nband*ddb%nsppol,ddb%mpert,ddb%msize,ddb%nkpt,unddb,&
2256 24 : ddb%eig2dval(:,:,:,:),ddb%kpt(:,:),ddb_version=ddbvsn)
2257 :
2258 24 : end subroutine ddb_read_d2eig_txt
2259 : !!***
2260 :
2261 : !----------------------------------------------------------------------
2262 :
2263 : !!****f* m_ddb/rdddb9
2264 : !! NAME
2265 : !! rdddb9
2266 : !!
2267 : !! FUNCTION
2268 : !! This routine reads the derivative database entirely,
2269 : !! for use in ppddb9, and performs some checks and symmetrisation
2270 : !! At the end, the whole DDB is in central memory, contained in the array ddb%val(2,msize,ddb%nblok).
2271 : !!
2272 : !! The information on it is contained in the four arrays
2273 : !! ddb%flg(msize,ddb%nblok) : blok flag for each element
2274 : !! ddb%qpt(9,ddb%nblok) : blok wavevector (unnormalized)
2275 : !! ddb%nrm(3,ddb%nblok) : blok wavevector normalization
2276 : !! ddb%typ(ddb%nblok) : blok type
2277 : !!
2278 : !! INPUTS
2279 : !! unddb = unit number for DDB io
2280 : !! dimekb=dimension of ekb (for the time being, only for norm- conserving psps)
2281 : !! iout=unit number for output of formatted data
2282 : !! lmnmax=if useylm=1, max number of (l,m,n) comp. over all type of psps
2283 : !! =if useylm=0, max number of (l,n) comp. over all type of psps
2284 : !! mband=maximum number of bands
2285 : !! mpert =maximum number of ipert
2286 : !! msize=maximum size of data blocks
2287 : !! msym =maximum number of symmetry elements in space group
2288 : !! natom = number of atoms
2289 : !! ntypat=number of atom types
2290 : !! usepaw= 0 for non paw calculation; =1 for paw calculation
2291 : !! [raw] = 1 -> do not perform any symetrization or transformation to cartesian coordinates.
2292 : !! 0 (default) -> do perform these transformations.
2293 : !!
2294 : !! OUTPUT
2295 : !! acell(3)=length scales of cell (bohr)
2296 : !! amu(ntypat)=mass of the atoms (atomic mass unit)
2297 : !! ddb: ddb blok datatype
2298 : !! contents: ddb%flg(msize,nblok)= flag of existence for each element of the DDB
2299 : !! ddb%nrm(3,nblok) : blok wavevector normalization
2300 : !! ddb%qpt(9,nblok) : blok wavevector (unnormalized)
2301 : !! ddb%typ(nblok) : blok type
2302 : !! ddb%val(2,msize,nblok)= value of each complex element of the DDB
2303 : !! ddb%nblok= number of bloks in the DDB
2304 : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2
2305 : !! gprim(3,3)=dimensionless reciprocal space primitive translations
2306 : !! indsym(4,msym,natom)=indirect indexing array for symmetries
2307 : !! natom=number of atoms in cell
2308 : !! nsym=number of space group symmetries
2309 : !! rmet(3,3)=metric tensor in real space (bohr^2)
2310 : !! rprim(3,3)= primitive translation vectors
2311 : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (reciprocal space)
2312 : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
2313 : !! symafm(nsym)=Anti-ferromagnetic symmetries.
2314 : !! tnons(3,nsym)=fractional nonsymmorphic translations
2315 : !! typat(natom)=type integer for each atom in cell
2316 : !! ucvol=unit cell volume in bohr**3
2317 : !! xcart(3,natom)=atomic cartesian coordinates
2318 : !! xred(3,natom)=fractional dimensionless atomic coordinates
2319 : !! zion(ntypat)=charge on each type of atom (real number)
2320 : !! znucl(ntypat)=Nuclear charge for each type of pseudopotential
2321 : !!
2322 : !! SOURCE
2323 :
2324 288 : subroutine rdddb9(ddb,ddb_hdr,unddb,&
2325 288 : acell,amu,gmet,gprim,indsym,&
2326 : mband,mpert,msize,msym,natom,nkpt,nsym,ntypat,&
2327 288 : rmet,rprim,symrec,symrel,symafm,tnons,typat,ucvol,&
2328 288 : xcart,xred,zion,znucl,raw)
2329 :
2330 : !Arguments -------------------------------
2331 : ! NOTE: these are used for dimensioning and then re-assigned in ioddb8.
2332 : ! This is almost definitely bad practice. In particular
2333 : ! it should be indsym(4,msym,natom),
2334 : ! and
2335 : ! the allocation allocate(kpt(3,nkpt)) is strange
2336 : !scalars
2337 : class(ddb_type),intent(inout) :: ddb
2338 : integer,intent(in) :: unddb,mband,mpert,msize,msym
2339 : integer,intent(inout) :: natom,nkpt,nsym,ntypat
2340 : real(dp),intent(out) :: ucvol
2341 : type(ddb_hdr_type),intent(inout) :: ddb_hdr
2342 : integer,optional,intent(in) :: raw
2343 : !arrays
2344 : integer,intent(inout) :: indsym(4,msym,natom)
2345 : integer,intent(out) :: symrec(3,3,msym),symrel(3,3,msym),symafm(msym)
2346 : integer,intent(out) :: typat(natom)
2347 : real(dp),intent(out) :: acell(3),amu(ntypat)
2348 : real(dp),intent(out) :: gmet(3,3),gprim(3,3),rmet(3,3)
2349 : real(dp),intent(out) :: rprim(3,3),tnons(3,msym),xcart(3,natom),xred(3,natom)
2350 : real(dp),intent(out) :: zion(ntypat),znucl(ntypat)
2351 :
2352 : !Local variables -------------------------
2353 : !mtyplo=maximum number of type, locally
2354 : !scalars
2355 : integer,parameter :: msppol=2,mtyplo=6
2356 : integer :: raw_
2357 : integer :: iblok,isym
2358 : integer :: ddb_version
2359 : real(dp),parameter :: tolsym8=tol8
2360 : !arrays
2361 : real(dp) :: gprimd(3,3),rprimd(3,3)
2362 : ! *********************************************************************
2363 :
2364 : DBG_ENTER("COLL")
2365 :
2366 288 : if (present(raw)) then
2367 83 : raw_ = raw
2368 : else
2369 : raw_ = 0
2370 : end if
2371 :
2372 : ! FIXME
2373 : ! GA: Most of this stuff could be moved up to the calling routine
2374 :
2375 288 : nsym = ddb_hdr%nsym
2376 1152 : acell = ddb_hdr%acell
2377 3744 : rprim = ddb_hdr%rprim
2378 288 : ddb_version = ddb_hdr%ddb_version
2379 :
2380 826 : amu(:) = ddb_hdr%amu(1:ntypat)
2381 1110 : typat(:) = ddb_hdr%typat(1:natom)
2382 826 : zion(:) = ddb_hdr%zion(1:ntypat)
2383 826 : znucl(:) = ddb_hdr%znucl(1:ntypat)
2384 :
2385 55584 : symafm(:) = ddb_hdr%symafm(:)
2386 719136 : symrel(:,:,:) = ddb_hdr%symrel(:,:,:)
2387 221472 : tnons(:,:) = ddb_hdr%tnons(:,:)
2388 :
2389 3576 : xred(:,:) = ddb_hdr%xred(:,:)
2390 :
2391 : !call ddb_hdr%free()
2392 :
2393 : ! Compute different matrices in real and reciprocal space, also
2394 : ! checks whether ucvol is positive.
2395 288 : call mkrdim(acell,rprim,rprimd)
2396 :
2397 : ! call metric without printing to output
2398 288 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
2399 :
2400 : ! Obtain reciprocal space primitive transl g from inverse trans of r
2401 : ! (Unlike in abinit, gprim is used throughout ifc; should be changed, later)
2402 288 : call matr3inv(rprim,gprim)
2403 :
2404 : ! Generate atom positions in cartesian coordinates
2405 288 : call xred2xcart(natom,rprimd,xcart,xred)
2406 :
2407 : ! Transposed inversion of the symmetry matrices, for use in the reciprocal space
2408 11061 : do isym=1,nsym
2409 11061 : call mati3inv(symrel(:,:,isym),symrec(:,:,isym))
2410 : end do
2411 :
2412 : ! SYMATM generates for all the atoms and all the symmetries, the atom
2413 : ! on which the referenced one is sent and also the translation bringing
2414 : ! back this atom to the referenced unit cell
2415 : ! GA: symatm was already called in crystal_init, no need to do it again.
2416 288 : call symatm(indsym,natom,nsym,symrec,tnons,tolsym8,typat,xred)
2417 :
2418 : !write(msg, '(3a,i0,a)' )ch10,ch10,' rdddb9: read ',ddb%nblok,' blocks from the input DDB '
2419 : !call wrtout(std_out,msg)
2420 :
2421 : ! Read the blocks from the input database, and close it.
2422 2345 : do iblok=1,ddb%nblok
2423 :
2424 2057 : call ddb%read_block_txt(iblok,mband,mpert,msize,nkpt,unddb, ddb_version=ddb_version)
2425 :
2426 2345 : if (raw_ == 0) then
2427 1949 : call ddb%symmetrize_and_transform(ddb_hdr%crystal,iblok)
2428 : end if
2429 :
2430 : end do ! iblok
2431 :
2432 : DBG_EXIT("COLL")
2433 :
2434 288 : end subroutine rdddb9
2435 : !!***
2436 :
2437 : !----------------------------------------------------------------------
2438 :
2439 : !!****f* m_ddb/chkin9
2440 : !! NAME
2441 : !! chkin9
2442 : !!
2443 : !! FUNCTION
2444 : !! Construct flags for the computation of IFC for each atoms.
2445 : !! Also check that the value of natifc makes sense.
2446 : !!
2447 : !! INPUTS
2448 : !! atifc(natifc)=list of the atom ifc to be analysed
2449 : !! natifc= number of atom ifc to be analysed
2450 : !! natom= number of atoms
2451 : !!
2452 : !! OUTPUT
2453 : !! atifcflg(natom) = atifcflg(ia) equals 1 if the analysis of ifc
2454 : !! has to be done for atom ia; otherwise 0.
2455 : !!
2456 : !! NOTES
2457 : !! Only for one processor (no use of wrtout)
2458 : !!
2459 : !! SOURCE
2460 :
2461 81 : subroutine chkin9(atifcflg,atifc,natifc,natom)
2462 :
2463 : ! GA: FIXME Move this subroutine into m_anaddb_dataset
2464 : !Arguments -------------------------------
2465 : !scalars
2466 : integer,intent(in) :: natifc,natom
2467 : !arrays
2468 : integer,intent(in) :: atifc(natifc)
2469 : integer,intent(out) :: atifcflg(natom)
2470 :
2471 : !Local variables -------------------------
2472 : !scalars
2473 : integer :: iatifc
2474 : character(len=500) :: msg
2475 : !arrays
2476 : !integer,allocatable :: work(:)
2477 : ! *********************************************************************
2478 :
2479 81 : if(natifc>natom)then
2480 : write(msg, '(a,i0,3a,i0,3a)' )&
2481 0 : 'The number of atom ifc in the input files',natifc,',',ch10,&
2482 0 : 'is larger than the number of atoms',natom,'.',ch10,&
2483 0 : 'Action: change natifc in the input file.'
2484 0 : ABI_ERROR(msg)
2485 : end if
2486 :
2487 341 : atifcflg = zero
2488 81 : if(natifc>=1)then
2489 :
2490 42 : do iatifc=1,natifc
2491 26 : if(atifc(iatifc)<=0.or.atifc(iatifc)>natom)then
2492 : write(msg, '(a,i0,5a,i0,3a)' )&
2493 0 : 'For iatifc=',iatifc,', the number of the atom ifc to be ',ch10,&
2494 0 : 'analysed is not valid : either negative, ',ch10,&
2495 0 : 'zero, or larger than natom =',natom,'.',ch10,&
2496 0 : 'Action: change atifc in your input file.'
2497 0 : ABI_ERROR(msg)
2498 : end if
2499 42 : atifcflg(atifc(iatifc))=1
2500 : end do
2501 :
2502 : end if
2503 :
2504 81 : end subroutine chkin9
2505 : !!***
2506 :
2507 : !----------------------------------------------------------------------
2508 :
2509 : !!****f* m_ddb/nlopt
2510 : !! NAME
2511 : !! nlopt
2512 : !!
2513 : !! FUNCTION
2514 : !! Output of all quantities related to third-order derivatives of the energy.
2515 : !! Compute the permutations of the three perturbations, then
2516 : !! write out the whole matrix of third order derivatives
2517 : !! in reduced coordinates. Finally, compute the non-linear optical
2518 : !! susceptibility d and the first-order change in the dielectric
2519 : !! susceptibility tensor induced by an atomic displacement.
2520 : !!
2521 : !! INPUTS
2522 : !! blkflg(3,mpert,3,mpert,3,mpert)= ( 1 if the element of the 3dte
2523 : !! has been calculated ; 0 otherwise )
2524 : !! d3(2,3,mpert,3,mpert,3,mpert)= matrix of the 3DTE
2525 : !! gprimd(3,3)=dimensional primitive translations for reciprocal space(bohr^-1)
2526 : !! mpert =maximum number of ipert
2527 : !! natom= number of atoms
2528 : !! rprimd(3,3)=dimensional primitive translations (bohr)
2529 : !! ucvol=unit cell volume (bohr^3)
2530 : !!
2531 : !! OUTPUT
2532 : !! carflg(3,mpert,3,mpert,3,mpert)=1 if the element of d3cart has been calculated, 0 otherwise
2533 : !! d3cart(2,3,mpert,3,mpert,3,mpert)=matrix of third-order energy derivatives in cartesian coordinates
2534 : !!
2535 : !! SOURCE
2536 :
2537 37 : subroutine nlopt(blkflg,carflg,d3,d3cart,gprimd,mpert,natom,rprimd,ucvol)
2538 :
2539 : !Arguments -------------------------------
2540 : !scalars
2541 : integer,intent(in) :: mpert,natom
2542 : real(dp),intent(in) :: ucvol
2543 : !arrays
2544 : integer,intent(in) :: blkflg(3,mpert,3,mpert,3,mpert)
2545 : integer,intent(out) :: carflg(3,mpert,3,mpert,3,mpert)
2546 : real(dp),intent(in) :: d3(2,3,mpert,3,mpert,3,mpert),gprimd(3,3),rprimd(3,3)
2547 : real(dp),intent(out) :: d3cart(2,3,mpert,3,mpert,3,mpert)
2548 :
2549 : !Local variables -------------------------
2550 : !scalars
2551 : integer :: i1dir,i1pert,i2dir,i2pert,i3dir,i3pert
2552 : !arrays
2553 : integer :: flg1(3),flg2(3)
2554 : real(dp) :: vec1(3),vec2(3)
2555 :
2556 : ! *******************************************************************
2557 :
2558 : !Compute the permutations of the perturbations
2559 :
2560 2773117 : d3cart(:,:,:,:,:,:,:) = 0._dp
2561 :
2562 361 : do i1pert = 1,mpert
2563 3373 : do i2pert = 1,mpert
2564 33732 : do i3pert = 1,mpert
2565 124596 : do i1dir=1,3
2566 395148 : do i2dir=1,3
2567 1185444 : do i3dir=1,3
2568 :
2569 : ! Check if all elements are available
2570 :
2571 : if ((blkflg(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)/=0).and. &
2572 : (blkflg(i1dir,i1pert,i3dir,i3pert,i2dir,i2pert)/=0).and. &
2573 : (blkflg(i2dir,i2pert,i1dir,i1pert,i3dir,i3pert)/=0).and. &
2574 : (blkflg(i2dir,i2pert,i3dir,i3pert,i1dir,i1pert)/=0).and. &
2575 820692 : (blkflg(i3dir,i3pert,i1dir,i1pert,i2dir,i2pert)/=0).and. &
2576 273564 : (blkflg(i3dir,i3pert,i2dir,i2pert,i1dir,i1pert)/=0)) then
2577 :
2578 : d3cart(:,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = &
2579 : ( d3(:,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) + &
2580 : d3(:,i1dir,i1pert,i3dir,i3pert,i2dir,i2pert) + &
2581 : d3(:,i2dir,i2pert,i1dir,i1pert,i3dir,i3pert) + &
2582 : d3(:,i2dir,i2pert,i3dir,i3pert,i1dir,i1pert) + &
2583 : d3(:,i3dir,i3pert,i1dir,i1pert,i2dir,i2pert) + &
2584 16611 : d3(:,i3dir,i3pert,i2dir,i2pert,i1dir,i1pert))*sixth
2585 :
2586 : end if
2587 : end do
2588 : end do
2589 : end do
2590 : end do
2591 : end do
2592 : end do
2593 :
2594 : !Transform to cartesian coordinates
2595 1131733 : carflg(:,:,:,:,:,:) = 0
2596 :
2597 361 : do i1pert = 1, mpert
2598 3373 : do i2pert = 1, mpert
2599 33732 : do i3pert = 1, mpert
2600 :
2601 121584 : do i2dir = 1, 3
2602 395148 : do i3dir = 1, 3
2603 :
2604 1094256 : vec1(:) = d3cart(1,:,i1pert,i2dir,i2pert,i3dir,i3pert)
2605 1094256 : flg1(:) = blkflg(:,i1pert,i2dir,i2pert,i3dir,i3pert)
2606 273564 : call cart39(flg1,flg2,gprimd,i1pert,natom,rprimd,vec1,vec2)
2607 1094256 : d3cart(1,:,i1pert,i2dir,i2pert,i3dir,i3pert) = vec2(:)
2608 1185444 : carflg(:,i1pert,i2dir,i2pert,i3dir,i3pert) = flg2(:)
2609 :
2610 : end do
2611 : end do
2612 :
2613 121584 : do i1dir = 1, 3
2614 395148 : do i3dir = 1, 3
2615 1094256 : vec1(:) = d3cart(1,i1dir,i1pert,:,i2pert,i3dir,i3pert)
2616 1094256 : flg1(:) = blkflg(i1dir,i1pert,:,i2pert,i3dir,i3pert)
2617 273564 : call cart39(flg1,flg2,gprimd,i2pert,natom,rprimd,vec1,vec2)
2618 1094256 : d3cart(1,i1dir,i1pert,:,i2pert,i3dir,i3pert) = vec2(:)
2619 1185444 : carflg(i1dir,i1pert,:,i2pert,i3dir,i3pert) = flg2(:)
2620 : end do
2621 : end do
2622 :
2623 124596 : do i1dir = 1, 3
2624 395148 : do i2dir = 1, 3
2625 1094256 : vec1(:) = d3cart(1,i1dir,i1pert,i2dir,i2pert,:,i3pert)
2626 1094256 : flg1(:) = blkflg(i1dir,i1pert,i2dir,i2pert,:,i3pert)
2627 273564 : call cart39(flg1,flg2,gprimd,i3pert,natom,rprimd,vec1,vec2)
2628 1094256 : d3cart(1,i1dir,i1pert,i2dir,i2pert,:,i3pert) = vec2(:)
2629 1185444 : carflg(i1dir,i1pert,i2dir,i2pert,:,i3pert) = flg2(:)
2630 : end do
2631 : end do
2632 :
2633 : end do
2634 : end do
2635 : end do
2636 :
2637 : ! Compute non linear-optical coefficients d_ijk (atomic units)
2638 37 : i1pert = natom+2
2639 3478 : d3cart(:,:,i1pert,:,i1pert,:,i1pert) = -3._dp*d3cart(:,:,i1pert,:,i1pert,:,i1pert)/(ucvol*2._dp)
2640 :
2641 : ! Compute first-order change in the electronic dielectric
2642 : ! susceptibility (Bohr^-1) induced by an atomic displacement
2643 7141 : d3cart(1:2,1:3,1:natom,1:3,natom + 2,1:3,natom + 2) = -6._dp*d3cart(1:2,1:3,1:natom,1:3,natom + 2,1:3,natom + 2)/ucvol
2644 :
2645 37 : end subroutine nlopt
2646 : !!***
2647 :
2648 : !----------------------------------------------------------------------
2649 :
2650 : !!****f* m_ddb/ddb_from_file
2651 : !! NAME
2652 : !! ddb_from_file
2653 : !!
2654 : !! FUNCTION
2655 : !! This subroutine reads data from the DDB file and constructs an instance of ddb_type
2656 : !! It also returns an instance of crystal_t with the crystalline structure reported in the DDB file
2657 : !! and the DDB header.
2658 : !!
2659 : !! INPUTS
2660 : !! filename=DDB filename.
2661 : !! comm=MPI communicator.
2662 : !! [prtvol] = Verbosity level
2663 : !! raw = 1 -> do not perform any symetrization or transformation to cartesian coordinates.
2664 : !! 0 (default) -> do perform these transformations.
2665 : !!
2666 : !! OUTPUT
2667 : !! ddb<type(ddb_type)>=Object storing the DDB results.
2668 : !! crystal<type(crystal_t)>=Crystal structure parameters
2669 : !! ddb_hdr<type(ddb_hdr_type)>= Header of the DDB file.
2670 : !!
2671 : !! SOURCE
2672 :
2673 52771 : subroutine ddb_from_file(ddb, filename, ddb_hdr, crystal, comm, prtvol, raw)
2674 :
2675 : !Arguments -------------------------------
2676 : !scalars
2677 : class(ddb_type),intent(inout) :: ddb
2678 : integer,intent(in) :: comm
2679 : integer,optional,intent(in) :: prtvol, raw
2680 : character(len=*),intent(in) :: filename
2681 : type(crystal_t),intent(out) :: crystal
2682 : type(ddb_hdr_type),intent(out) :: ddb_hdr
2683 : !array
2684 :
2685 : !Local variables-------------------------------
2686 : integer :: iomode
2687 : character(len=fnlen) :: filename_
2688 : integer :: prtvol_
2689 : character(len=500) :: msg
2690 : ! ************************************************************************
2691 :
2692 : DBG_ENTER("COLL")
2693 :
2694 467 : prtvol_ = 0; if (present(prtvol)) prtvol_ = prtvol
2695 :
2696 467 : call ddb_hdr%get_iomode(filename, 1, iomode, filename_)
2697 :
2698 467 : if (iomode==IO_MODE_ETSF) then
2699 171 : call ddb%read_nc(filename_, ddb_hdr, crystal, comm, prtvol, raw)
2700 296 : else if (iomode==IO_MODE_FORTRAN) then
2701 296 : call ddb%read_txt(filename_, ddb_hdr, crystal, comm, prtvol, raw)
2702 : end if
2703 :
2704 : ! Print out info on the crystal
2705 467 : if (prtvol_ >= -1) then
2706 :
2707 467 : call ddb_hdr%crystal%print(unit=std_out)
2708 467 : if (prtvol_ >= 0) then
2709 224 : call ddb_hdr%crystal%print(unit=ab_out)
2710 : end if
2711 :
2712 467 : write(msg, '(2a,i0,a)' )ch10,' DDB file with ',ddb%nblok,' blocks has been read.'
2713 467 : call wrtout(std_out,msg)
2714 467 : if (prtvol_ >= 0) then
2715 224 : call wrtout(ab_out,msg)
2716 : end if
2717 :
2718 : end if
2719 :
2720 : DBG_EXIT("COLL")
2721 :
2722 467 : end subroutine ddb_from_file
2723 : !!***
2724 :
2725 : !----------------------------------------------------------------------
2726 :
2727 : !!****f* m_ddb/ddb_read_txt
2728 : !! NAME
2729 : !! ddb_read_txt
2730 : !!
2731 : !! FUNCTION
2732 : !! This subroutine reads data from the DDB file and constructs an instance of ddb_type
2733 : !! It also returns an instance of crystal_t with the crystalline structure reported in the DDB file
2734 : !! and the DDB header.
2735 : !!
2736 : !! INPUTS
2737 : !! filename=DDB filename.
2738 : !! comm=MPI communicator.
2739 : !! prtvol=Verbosity level
2740 : !! raw = 1 -> do not perform any symetrization or transformation to cartesian coordinates.
2741 : !! 0 (default) -> do perform these transformations.
2742 : !!
2743 : !! OUTPUT
2744 : !! ddb<type(ddb_type)>=Object storing the DDB results.
2745 : !! crystal<type(crystal_t)>=Crystal structure parameters
2746 : !! ddb_hdr= Header of the DDB file.
2747 : !!
2748 : !! SOURCE
2749 :
2750 33448 : subroutine ddb_read_txt(ddb, filename, ddb_hdr, crystal, comm, prtvol, raw)
2751 :
2752 : !Arguments -------------------------------
2753 : !scalars
2754 : class(ddb_type),intent(inout) :: ddb
2755 : integer,intent(in) :: comm
2756 : integer,optional,intent(in) :: prtvol, raw
2757 : character(len=*),intent(in) :: filename
2758 : type(crystal_t),intent(out) :: Crystal
2759 : type(ddb_hdr_type),intent(out) :: ddb_hdr
2760 :
2761 : !Local variables-------------------------------
2762 : !scalars
2763 : integer,parameter :: master=0
2764 : integer :: msym,dimekb,lmnmax,mband,nkpt,ntypat,nsym,usepaw
2765 : integer :: mpert,msize,natom,nblok,occopt,nsppol
2766 : real(dp) :: ucvol
2767 :
2768 : !arrays
2769 296 : integer,allocatable :: symrec(:,:,:),symrel(:,:,:),symafm(:),indsym(:,:,:),typat(:)
2770 : real(dp) :: acell(3),gmet(3,3),gprim(3,3),rmet(3,3),rprim(3,3)
2771 296 : real(dp),allocatable :: amu(:),xcart(:),xred(:,:),zion(:),znucl(:),tnons(:,:)
2772 : ! ************************************************************************
2773 :
2774 : DBG_ENTER("COLL")
2775 :
2776 : ! Must read natom from the DDB before being able to allocate some arrays needed for invars9
2777 296 : call ddb_hdr%open_read_txt(filename, comm)
2778 :
2779 : ! GA: clean this up. Not all of it is useful
2780 296 : nblok = ddb_hdr%nblok
2781 296 : msym = ddb_hdr%msym
2782 296 : natom = ddb_hdr%natom
2783 296 : ntypat = ddb_hdr%ntypat
2784 296 : mband = ddb_hdr%mband
2785 296 : nkpt = ddb_hdr%nkpt
2786 296 : nsppol = ddb_hdr%nsppol
2787 296 : usepaw = ddb_hdr%usepaw
2788 296 : dimekb = ddb_hdr%psps%dimekb
2789 296 : lmnmax = ddb_hdr%psps%lmnmax
2790 296 : occopt = ddb_hdr%occopt
2791 296 : mpert = ddb_hdr%mpert
2792 296 : msize = ddb_hdr%msize
2793 :
2794 : ! Master reads and then broadcasts data.
2795 296 : if (xmpi_comm_rank(comm) == master) then
2796 :
2797 : ! Allocate arrays depending on msym (which is actually fixed to nsym inside inprep8)
2798 864 : ABI_MALLOC(symrel,(3,3,msym))
2799 864 : ABI_MALLOC(symafm,(msym))
2800 864 : ABI_MALLOC(tnons,(3,msym))
2801 864 : ABI_MALLOC(typat,(natom))
2802 864 : ABI_MALLOC(xred,(3,natom))
2803 864 : ABI_MALLOC(zion,(ntypat))
2804 576 : ABI_MALLOC(znucl,(ntypat))
2805 :
2806 576 : ABI_MALLOC(symrec,(3,3,msym))
2807 1152 : ABI_MALLOC(indsym,(4,msym,natom))
2808 864 : ABI_MALLOC(xcart,(3*natom))
2809 576 : ABI_MALLOC(amu,(ntypat))
2810 :
2811 288 : ddb%nsppol = nsppol
2812 288 : call ddb%malloc(msize, nblok, natom, ntypat, mpert)
2813 :
2814 : ! GA: FIXME
2815 : ! Should clean this up. Lots of the arguments are not needed.
2816 : ! In particular, rprim and acell could be taken from ddb_hdr%crystal
2817 : ! which is already initialized at this point
2818 : call rdddb9(ddb, ddb_hdr, ddb_hdr%unddb,&
2819 : acell,amu,gmet,gprim,indsym,&
2820 : mband,mpert,msize,msym,&
2821 : natom,nkpt,nsym,ntypat,&
2822 : rmet,rprim,symrec,symrel,symafm,&
2823 288 : tnons,typat,ucvol,xcart,xred,zion,znucl,raw)
2824 :
2825 288 : ABI_FREE(symrec)
2826 288 : ABI_FREE(indsym)
2827 288 : ABI_FREE(xcart)
2828 :
2829 : ! Save variables needed to call legacy code.
2830 1152 : ddb%acell = acell
2831 3744 : ddb%rprim = rprim
2832 3744 : ddb%gprim = gprim
2833 :
2834 : !call ddb%set_brav(brav)
2835 :
2836 : ! Other useful quantities.
2837 : ! 2 is to preserve the old behaviour
2838 288 : ddb%prtvol = 2; if (present(prtvol)) ddb%prtvol = prtvol
2839 288 : ddb%occopt = occopt
2840 1114 : ddb%amu = amu
2841 288 : ABI_FREE(amu)
2842 :
2843 : ! These were not needed because crystal is already initialized in the header.
2844 288 : ABI_FREE(symrel)
2845 288 : ABI_FREE(symafm)
2846 288 : ABI_FREE(tnons)
2847 288 : ABI_FREE(typat)
2848 288 : ABI_FREE(xred)
2849 288 : ABI_FREE(zion)
2850 576 : ABI_FREE(znucl)
2851 :
2852 : end if
2853 :
2854 296 : call ddb_hdr%close()
2855 :
2856 296 : if (xmpi_comm_size(comm) > 1) then
2857 12 : call ddb%bcast(comm)
2858 12 : call ddb_hdr%bcast(comm)
2859 :
2860 : !! GA: This seems superfluous now...
2861 : !call xmpi_bcast(nsym, master, comm, ierr)
2862 : !call xmpi_bcast(symrel, master, comm, ierr)
2863 : !call xmpi_bcast(symafm, master, comm, ierr)
2864 : !call xmpi_bcast(typat, master, comm, ierr)
2865 : !call xmpi_bcast(acell, master, comm, ierr)
2866 : !call xmpi_bcast(occopt, master, comm, ierr)
2867 : !call xmpi_bcast(gprim, master, comm, ierr)
2868 : !call xmpi_bcast(rprim, master, comm, ierr)
2869 : !call xmpi_bcast(tnons, master, comm, ierr)
2870 : !call xmpi_bcast(xred, master, comm, ierr)
2871 : !call xmpi_bcast(zion, master, comm, ierr)
2872 : !call xmpi_bcast(znucl, master, comm, ierr)
2873 : end if
2874 :
2875 296 : call ddb_hdr%crystal%copy(Crystal)
2876 :
2877 : !! Initialize crystal_t object.
2878 : !call mkrdim(acell,rprim,rprimd)
2879 :
2880 : !! GA: These variables are hardcoded which means the crystal object
2881 : !! is not reliable for antiferro systems or alchemical potentials
2882 : !! when it is read from a text DDB file.
2883 : !npsp = ntypat; space_group = 0; timrev = 2
2884 : !use_antiferro=.FALSE. !; use_antiferro=(nspden==2.and.nsppol==1)
2885 : !ABI_MALLOC(title, (ntypat))
2886 :
2887 : !do ii=1,ntypat
2888 : ! write(title(ii),'(a,i0)')"No title for typat ",ii
2889 : !end do
2890 :
2891 : !! Warning znucl is dimensioned with ntypat = nspsp hence alchemy is not supported here
2892 : !call crystal%init(ddb%amu,space_group,natom,npsp,ntypat,nsym,rprimd,typat,xred,&
2893 : ! zion,znucl,timrev,use_antiferro,.FALSE.,title,&
2894 : ! symrel=symrel(:,:,1:nsym),tnons=tnons(:,1:nsym),symafm=symafm(1:nsym))
2895 :
2896 : !ABI_FREE(title)
2897 : !ABI_FREE(symrel)
2898 : !ABI_FREE(symafm)
2899 : !ABI_FREE(tnons)
2900 : !ABI_FREE(typat)
2901 : !ABI_FREE(xred)
2902 : !ABI_FREE(zion)
2903 : !ABI_FREE(znucl)
2904 :
2905 : DBG_EXIT("COLL")
2906 :
2907 296 : end subroutine ddb_read_txt
2908 : !!***
2909 :
2910 : !----------------------------------------------------------------------
2911 :
2912 : !!****f* m_ddb/ddb_read_nc
2913 : !! NAME
2914 : !! ddb_read_nc
2915 : !!
2916 : !! FUNCTION
2917 : !! This subroutine reads data from the DDB.nc file and constructs an instance of ddb_type
2918 : !! It also returns an instance of crystal_t with the crystalline structure reported in the DDB file
2919 : !! and the DDB header.
2920 : !!
2921 : !! INPUTS
2922 : !! filename=DDB filename.
2923 : !! comm=MPI communicator.
2924 : !! prtvol=Verbosity level
2925 : !! raw = 1 -> do not perform any symetrization or transformation to cartesian coordinates.
2926 : !! 0 (default) -> do perform these transformations.
2927 : !!
2928 : !! OUTPUT
2929 : !! ddb<type(ddb_type)>=Object storing the DDB results.
2930 : !! crystal<type(crystal_t)>=Crystal structure parameters
2931 : !! ddb_hdr= Header of the DDB file.
2932 : !!
2933 : !! SOURCE
2934 :
2935 17955 : subroutine ddb_read_nc(ddb, filename, ddb_hdr, crystal, comm, prtvol, raw)
2936 :
2937 : !Arguments -------------------------------
2938 : !scalars
2939 : class(ddb_type),intent(inout) :: ddb
2940 : integer,intent(in) :: comm
2941 : integer,optional,intent(in) :: prtvol, raw
2942 : character(len=*),intent(in) :: filename
2943 : type(crystal_t),intent(out) :: crystal
2944 : type(ddb_hdr_type),intent(out) :: ddb_hdr
2945 : !array
2946 :
2947 : !Local variables-------------------------------
2948 : !scalars
2949 : integer,parameter :: master=0
2950 : integer :: prtvol_, raw_
2951 : integer :: ncid, ddb_version
2952 : integer :: iblok,iblok_d0E,iblok_d1E,iblok_d2E,iblok_d3E,iblok_d2eig
2953 :
2954 : !arrays
2955 : !character(len=132),allocatable :: title(:)
2956 : ! ************************************************************************
2957 :
2958 : DBG_ENTER("COLL")
2959 :
2960 171 : if (present(raw)) then
2961 160 : raw_ = raw
2962 : else
2963 : raw_ = 0
2964 : end if
2965 :
2966 : ! GA: Not really used so far
2967 : if (present(prtvol)) then
2968 : prtvol_ = prtvol
2969 : else
2970 : prtvol_ = 0
2971 : end if
2972 :
2973 : ! Read header
2974 171 : call ddb_hdr%open_read_nc(filename, comm)
2975 171 : ncid = ddb_hdr%ncid
2976 :
2977 171 : if (xmpi_comm_rank(comm) == master) then
2978 :
2979 171 : ddb%nsppol = ddb_hdr%nsppol
2980 :
2981 : ! Copy dimensions from header and allocate arrays
2982 : call ddb%malloc(ddb_hdr%msize, ddb_hdr%nblok, ddb_hdr%natom, &
2983 : ddb_hdr%ntypat, ddb_hdr%mpert,&
2984 171 : ddb_hdr%nkpt, ddb_hdr%mband*ddb_hdr%nsppol)
2985 :
2986 : ! Copy arrays from header
2987 358 : ddb%typ(:) = ddb_hdr%typ(:)
2988 408 : ddb%amu(:) = ddb_hdr%crystal%amu(:)
2989 :
2990 : ! GA: Note that these quantities are stored twice in the nc file.
2991 : ! We could also use those quantities in ddb_hdr.
2992 684 : ddb%acell(:) = one
2993 2223 : ddb%rprim(:,:) = ddb_hdr%crystal%rprimd(:,:)
2994 2223 : ddb%gprim(:,:) = ddb_hdr%crystal%gprimd(:,:)
2995 171 : ddb_version = ddb_hdr%ddb_version
2996 : !ddb%acell(:) = ddb_hdr%acell
2997 : !ddb%rprim(:,:) = ddb_hdr%rprim(:,:)
2998 : !ddb%gprim(:,:) = ddb_hdr%gprim(:,:)
2999 :
3000 : ! ---------------
3001 : ! Read all blocks
3002 : ! ---------------
3003 171 : iblok_d0E = 0
3004 171 : iblok_d1E = 0
3005 171 : iblok_d2E = 0
3006 171 : iblok_d3E = 0
3007 171 : iblok_d2eig = 0
3008 :
3009 358 : do iblok=1,ddb%nblok
3010 :
3011 187 : if (is_type_d0E(ddb%typ(iblok))) then
3012 6 : iblok_d0E = iblok_d0E + 1
3013 6 : call ddb%read_d0E_nc(ncid, iblok, iblok_d0E)
3014 :
3015 181 : else if (is_type_d1E(ddb%typ(iblok))) then
3016 10 : iblok_d1E = iblok_d1E + 1
3017 10 : call ddb%read_d1E_nc(ncid, iblok, iblok_d1E)
3018 :
3019 171 : else if (is_type_d2E(ddb%typ(iblok))) then
3020 148 : iblok_d2E = iblok_d2E + 1
3021 148 : call ddb%read_d2E_nc(ncid, iblok, iblok_d2E, ddb_version)
3022 :
3023 23 : else if (is_type_d3E(ddb%typ(iblok))) then
3024 3 : iblok_d3E = iblok_d3E + 1
3025 3 : call ddb%read_d3E_nc(ncid, iblok, iblok_d3E, ddb_version)
3026 :
3027 20 : else if (is_type_d2eig(ddb%typ(iblok))) then
3028 20 : iblok_d2eig = iblok_d2eig + 1
3029 : ! GA: It is kind of weird to call this function inside a loop,
3030 : ! because the ddb can only hold a single block of d2eig data.
3031 20 : call ddb%read_d2eig_nc(ncid, iblok, iblok_d2eig)
3032 :
3033 : end if
3034 :
3035 : ! Symmetrize and transform if raw==0
3036 358 : if (raw_==0) then
3037 11 : call ddb%symmetrize_and_transform(ddb_hdr%crystal,iblok)
3038 : end if
3039 :
3040 : end do
3041 :
3042 : end if
3043 :
3044 : ! Close the file
3045 171 : call ddb_hdr%close()
3046 :
3047 : ! --------------
3048 : ! Broadcast data
3049 : ! --------------
3050 171 : if (xmpi_comm_size(comm) > 1) then
3051 0 : call ddb%bcast(comm)
3052 0 : call ddb_hdr%bcast(comm)
3053 : end if
3054 :
3055 : ! Copy crystal
3056 171 : call ddb_hdr%crystal%copy(crystal)
3057 :
3058 : DBG_EXIT("COLL")
3059 :
3060 171 : end subroutine ddb_read_nc
3061 : !!***
3062 :
3063 : !----------------------------------------------------------------------
3064 :
3065 : !!****f* m_ddb/ddb_can_merge_blocks
3066 : !! NAME
3067 : !! ddb_can_merge_blocks
3068 : !!
3069 : !! FUNCTION
3070 : !! Return true if iblok1 of ddb1 can be merged to iblok2 of ddb2
3071 : !!
3072 : !! INPUTS
3073 : !! ddb1=ddb object 1
3074 : !! ddb2=ddb object 2
3075 : !! iblok1=block index from ddb1
3076 : !! iblok2=block index from ddb2
3077 : !!
3078 : !! OUTPUT
3079 : !! can_merge=.true. if the blocks are compatible for merging.
3080 : !!
3081 : !! SOURCE
3082 :
3083 784 : logical function ddb_can_merge_blocks(ddb1, ddb2, iblok1, iblok2, ddbvsn) result(can_merge)
3084 :
3085 : !Arguments -------------------------------
3086 : !array
3087 : class(ddb_type),intent(inout) :: ddb1
3088 : type(ddb_type),intent(inout) :: ddb2
3089 : integer,intent(in) :: iblok1
3090 : integer,intent(in) :: iblok2
3091 : integer,intent(in) :: ddbvsn
3092 :
3093 : !local variables
3094 : !scalars
3095 : integer :: nq, ii, blktyp
3096 : integer,parameter :: cvrsio9_new=20240201
3097 : real(dp),parameter :: qtol=2.0d-8
3098 : real(dp) :: diff
3099 : ! ************************************************************************
3100 :
3101 784 : can_merge = .false.
3102 784 : if(ddb1%typ(iblok1)/=ddb2%typ(iblok2)) return
3103 :
3104 674 : blktyp = ddb1%typ(iblok1)
3105 :
3106 674 : can_merge = .true.
3107 :
3108 674 : if (is_type_d0E(blktyp) .or. is_type_d1E(blktyp)) return
3109 :
3110 : ! Compare wavevectors
3111 670 : if (is_type_d2E(blktyp).or.is_type_d2eig(blktyp))then
3112 : nq=1
3113 4 : else if (is_type_d3E(blktyp))then
3114 4 : nq=3
3115 : end if
3116 :
3117 1348 : do ii=1,nq
3118 : diff = (ddb1%qpt(1+3*(ii-1),iblok1)/ddb1%nrm(ii,iblok1) &
3119 678 : - ddb2%qpt(1+3*(ii-1),iblok2)/ddb2%nrm(ii,iblok2))
3120 678 : if (abs(diff) > qtol) can_merge = .false.
3121 : diff = (ddb1%qpt(2+3*(ii-1),iblok1)/ddb1%nrm(ii,iblok1) &
3122 678 : - ddb2%qpt(2+3*(ii-1),iblok2)/ddb2%nrm(ii,iblok2))
3123 678 : if (abs(diff) > qtol) can_merge = .false.
3124 : diff = (ddb1%qpt(3+3*(ii-1),iblok1)/ddb1%nrm(ii,iblok1) &
3125 678 : - ddb2%qpt(3+3*(ii-1),iblok2)/ddb2%nrm(ii,iblok2))
3126 1348 : if (abs(diff) > qtol) can_merge = .false.
3127 : end do
3128 670 : if(ddbvsn >= cvrsio9_new)then
3129 680 : do ii=1,nq
3130 344 : diff=ddb1%omega(ii,iblok1)-ddb2%omega(ii,iblok2)
3131 680 : if (abs(diff) > qtol) can_merge = .false.
3132 : end do
3133 : end if
3134 :
3135 : end function ddb_can_merge_blocks
3136 : !!***
3137 :
3138 : !----------------------------------------------------------------------
3139 :
3140 : !!****f* m_ddb/ddb_merge_blocks
3141 : !! NAME
3142 : !! ddb_merge_blocks
3143 : !!
3144 : !! FUNCTION
3145 : !! Merge block number iblok2 from ddb2 into block number iblok1 in ddb1.
3146 : !!
3147 : !! INPUTS
3148 : !! ddb1=ddb object 1
3149 : !! ddb2=ddb object 2
3150 : !! iblok1=block index from ddb1
3151 : !! iblok2=block index from ddb2
3152 : !!
3153 : !! OUTPUT
3154 : !!
3155 : !! SOURCE
3156 :
3157 284 : subroutine ddb_merge_blocks(ddb1, ddb2, iblok1, iblok2, ddbvsn)
3158 :
3159 : !Arguments -------------------------------
3160 : !array
3161 : class(ddb_type),intent(inout) :: ddb1
3162 : class(ddb_type),intent(inout) :: ddb2
3163 : integer,intent(in) :: iblok1
3164 : integer,intent(in) :: iblok2
3165 : integer,intent(in) :: ddbvsn
3166 :
3167 : !local variables
3168 : !scalars
3169 : integer :: ii, blktyp, mpert1, mpert2
3170 : integer :: idir1, idir2, idir3, ipert1, ipert2, ipert3
3171 : real(dp),parameter :: qtol=2.0d-8
3172 : integer,parameter :: cvrsio9_new=20240201
3173 : !arrays
3174 284 : real(dp), allocatable :: d1matr(:,:,:)
3175 284 : real(dp), allocatable :: d2matr(:,:,:,:,:)
3176 284 : real(dp), allocatable :: d3matr(:,:,:,:,:,:,:)
3177 284 : integer, allocatable :: d1flg(:,:)
3178 284 : integer, allocatable :: d2flg(:,:,:,:)
3179 284 : integer, allocatable :: d3flg(:,:,:,:,:,:)
3180 : ! ************************************************************************
3181 :
3182 : ! Note that ddb and ddb2 may have a different values for mpert
3183 : !mpert = min(ddb1%mpert, ddb2%mpert)
3184 284 : mpert1 = ddb1%mpert
3185 284 : mpert2 = ddb2%mpert
3186 :
3187 : ! Add the blok to the output ddb
3188 284 : blktyp = ddb2%typ(iblok2)
3189 284 : ddb1%typ(iblok1) = blktyp
3190 :
3191 : ! Copy q-point
3192 2840 : do ii=1,9
3193 2840 : ddb1%qpt(ii,iblok1) = ddb2%qpt(ii,iblok2)
3194 : end do
3195 284 : if(ddbvsn >= cvrsio9_new)then
3196 740 : do ii=1,3
3197 740 : ddb1%omega(ii,iblok1) = ddb2%omega(ii,iblok2)
3198 : end do
3199 : else
3200 396 : ddb1%omega(:,iblok1) = 0.d0
3201 : endif
3202 1136 : do ii=1,3
3203 1136 : ddb1%nrm(ii,iblok1) = ddb2%nrm(ii,iblok2)
3204 : end do
3205 :
3206 284 : if (is_type_d0E(blktyp)) then
3207 : ! --------------
3208 : ! Copy d0E block
3209 : ! --------------
3210 7 : if (ddb2%flg(1,iblok2) > 0) then
3211 7 : ddb1%val(1,1,iblok1) = ddb2%val(1,1,iblok2)
3212 7 : ddb1%val(2,1,iblok1) = ddb2%val(2,1,iblok2)
3213 7 : ddb1%flg(1,iblok1) = ddb2%flg(1,iblok2)
3214 : end if
3215 :
3216 277 : else if (is_type_d1E(blktyp)) then
3217 : ! --------------
3218 : ! Copy d1E block
3219 : ! --------------
3220 11 : call ddb2%get_d1matr(iblok2, d1matr, d1flg)
3221 : !call ddb%set_d1matr(iblok, d1matr, d1flg)
3222 11 : ii=0
3223 138 : do ipert1=1,mpert1
3224 519 : do idir1=1,3
3225 381 : ii=ii+1
3226 508 : if (ipert1 <= mpert2) then
3227 348 : if (d1flg(idir1,ipert1)>0) then
3228 114 : ddb1%val(1,ii,iblok1) = d1matr(1,idir1,ipert1)
3229 114 : ddb1%val(2,ii,iblok1) = d1matr(2,idir1,ipert1)
3230 114 : ddb1%flg(ii,iblok1) = d1flg(idir1,ipert1)
3231 : end if
3232 : end if
3233 : end do
3234 : end do
3235 11 : ABI_SFREE(d1matr)
3236 11 : ABI_SFREE(d1flg)
3237 :
3238 266 : else if (is_type_d2E(blktyp)) then
3239 : ! --------------
3240 : ! Copy d2E block
3241 : ! --------------
3242 234 : call ddb2%get_d2matr(iblok2, d2matr, d2flg)
3243 : !call ddb%set_d2matr(iblok, d2matr, d2flg)
3244 234 : ii=0
3245 3448 : do ipert2=1,mpert1
3246 13090 : do idir2=1,3
3247 166096 : do ipert1=1,mpert1
3248 622602 : do idir1=1,3
3249 459720 : ii=ii+1
3250 612960 : if ((ipert1 <= mpert2).and.(ipert2<=mpert2)) then
3251 444168 : if (d2flg(idir1,ipert1,idir2,ipert2)>0) then
3252 16470 : ddb1%val(1,ii,iblok1) = d2matr(1,idir1,ipert1,idir2,ipert2)
3253 16470 : ddb1%val(2,ii,iblok1) = d2matr(2,idir1,ipert1,idir2,ipert2)
3254 16470 : ddb1%flg(ii,iblok1) = d2flg(idir1,ipert1,idir2,ipert2)
3255 : end if
3256 : end if
3257 : end do
3258 : end do
3259 : end do
3260 : end do
3261 234 : ABI_SFREE(d2matr)
3262 234 : ABI_SFREE(d2flg)
3263 :
3264 32 : else if (is_type_d3E(blktyp)) then
3265 : ! --------------
3266 : ! Copy d3E block
3267 : ! --------------
3268 12 : call ddb2%get_d3matr(iblok2, d3matr, d3flg)
3269 : !call ddb%set_d3matr(iblok, d3matr, d3flg)
3270 12 : ii=0
3271 222 : do ipert1=1,mpert1
3272 852 : do idir1=1,3
3273 13116 : do ipert2=1,mpert1
3274 49734 : do idir2=1,3
3275 816930 : do ipert3=1,mpert1
3276 3108132 : do idir3=1,3
3277 :
3278 :
3279 : !ii=ii+1 ! GA: This is not equivalent
3280 : ii = idir1 + 3*((ipert1-1)+mpert1*((idir2-1) &
3281 : + 3*((ipert2-1)+mpert1*((idir3-1) &
3282 2303478 : + 3*(ipert3-1)))))
3283 :
3284 : ! Note that the loop order (1,2,3) is not really consistent
3285 : ! with the d2E case (2, 1)
3286 : ! TODO Clean this up
3287 :
3288 3071304 : if ((ipert1 <= mpert2).and.(ipert2<=mpert2).and.(ipert3<=mpert2)) then
3289 2285901 : if (d3flg(idir1,ipert1,idir2,ipert2,idir3,ipert3)>0) then
3290 1353 : ddb1%flg(ii,iblok1) = d3flg(idir1,ipert1,idir2,ipert2,idir3,ipert3)
3291 4059 : ddb1%val(:,ii,iblok1) = d3matr(:,idir1,ipert1,idir2,ipert2,idir3,ipert3)
3292 : end if
3293 : end if
3294 :
3295 : end do
3296 : end do
3297 : end do
3298 : end do
3299 : end do
3300 : end do
3301 12 : ABI_SFREE(d3matr)
3302 12 : ABI_SFREE(d3flg)
3303 :
3304 : else if (is_type_d2eig(blktyp)) then
3305 : ! ----------------
3306 : ! Skip d2eig block
3307 : ! ----------------
3308 :
3309 : ! TODO need a function ddb_merge_d2eig(filename1, filename2, )
3310 :
3311 : end if ! blktyp
3312 :
3313 284 : end subroutine ddb_merge_blocks
3314 : !!***
3315 :
3316 : !----------------------------------------------------------------------
3317 :
3318 : !!****f* m_ddb/carttransf
3319 : !! NAME
3320 : !! carttransf
3321 : !!
3322 : !! FUNCTION
3323 : !! Transform a second-derivative matrix (EIG2D) from reduced
3324 : !! coordinates to cartesian coordinates.
3325 : !!
3326 : !! INPUTS
3327 : !! blkflg(msize,nblok)=
3328 : !! ( 1 if the element of the dynamical matrix has been calculated ;
3329 : !! 0 otherwise )
3330 : !! gprimd(3,3)=basis vector in the reciprocal space
3331 : !! iqpt = number of the Q-point currently used
3332 : !! mband = maximal number of bands
3333 : !! mpert = maximum number of ipert
3334 : !! msize = size of the EIG2D arrays (3*mpert*3*mpert)
3335 : !! natom = number of atom
3336 : !! nblok = number of bloks in blkflg
3337 : !! nkpt = number of K-points
3338 : !! rprimd(3,3) = basis vector in the real space
3339 : !!
3340 : !! OUTPUT
3341 : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
3342 : !! EIG2D matrix has been calculated correctly ; 0 otherwise )
3343 : !!
3344 : !! SIDE EFFECT
3345 : !! blkval2(2,msize,mband,nkpt)=Second order eigenvalues (EIG2D)
3346 : !! is transformed from reduced coordinates to cartesian coordinates
3347 : !!
3348 : !! SOURCE
3349 :
3350 28 : subroutine carttransf(blkflg,blkval2,carflg,gprimd,iqpt,mband, mpert,msize,natom,nblok,nkpt,rprimd)
3351 :
3352 : !Arguments -------------------------------
3353 : !scalars
3354 : integer,intent(in) :: mband,msize
3355 : integer,intent(in) :: iqpt
3356 : integer,intent(in) :: mpert,nblok
3357 : integer,intent(inout) :: natom,nkpt
3358 : !arrays
3359 : integer,intent(in) :: blkflg(msize,nblok)
3360 : integer,intent(out) :: carflg(3,mpert,3,mpert)
3361 : real(dp),intent(in) :: gprimd(3,3),rprimd(3,3)
3362 : real(dp),intent(inout) :: blkval2(2,msize,mband,nkpt)
3363 :
3364 : !Local variables-------------------------------
3365 : !scalars
3366 : integer :: iatom1,iatom2,iband,idir1,idir2,ikpt, index
3367 : !arrays
3368 28 : real(dp),allocatable :: blkflgtmp(:,:,:,:,:), blkval2tmp(:,:,:,:,:,:), d2cart(:,:,:,:,:)
3369 : ! *********************************************************************
3370 :
3371 : ! Start by allocating local arrays
3372 140 : ABI_MALLOC(blkflgtmp,(3,mpert,3,mpert,1))
3373 140 : ABI_MALLOC(blkval2tmp,(2,3,mpert,3,mpert,1))
3374 84 : ABI_MALLOC(d2cart,(2,3,mpert,3,mpert))
3375 :
3376 : ! Begin by formating the arrays to be compatible with cart29
3377 : ! Then call cart29 to transform the arrays in cartesian coordinates
3378 : ! Finally reformat the cartesian arrays in old format
3379 276 : do ikpt=1,nkpt
3380 1720 : do iband=1,mband
3381 :
3382 5776 : do idir1=1,3
3383 14728 : do iatom1=1,mpert
3384 40140 : do idir2=1,3
3385 114576 : do iatom2=1,mpert
3386 78768 : index = idir1 + 3*((iatom1 - 1) + natom * ((idir2-1)+3*(iatom2-1)))
3387 78768 : blkflgtmp(idir1,iatom1,idir2,iatom2,1) = blkflg(index,iqpt)
3388 263160 : blkval2tmp(:,idir1,iatom1,idir2,iatom2,1) = blkval2(:,index,iband,ikpt)
3389 : end do
3390 : end do
3391 : end do
3392 : end do
3393 :
3394 : ! The 1sin the argument of cart29 are respectively iblok and nblok. We are doing only one blok.
3395 1444 : call carteig2d(blkflg(:,iqpt),blkval2tmp,carflg,d2cart,gprimd,1,mpert,natom,1,rprimd)
3396 :
3397 6024 : do idir1=1,3
3398 14728 : do iatom1=1,mpert
3399 40140 : do idir2=1,3
3400 114576 : do iatom2=1,mpert
3401 78768 : index = idir1 + 3*((iatom1 - 1) + natom * ((idir2-1)+3*(iatom2-1)))
3402 263160 : blkval2(:,index,iband,ikpt) = d2cart(:,idir1,iatom1,idir2,iatom2)
3403 : end do
3404 : end do
3405 : end do
3406 : end do
3407 :
3408 : end do
3409 : end do
3410 :
3411 28 : ABI_FREE(blkflgtmp)
3412 28 : ABI_FREE(blkval2tmp)
3413 28 : ABI_FREE(d2cart)
3414 :
3415 28 : end subroutine carttransf
3416 : !!***
3417 :
3418 : !----------------------------------------------------------------------
3419 :
3420 : !!****f* m_ddb/carteig2d
3421 : !! NAME
3422 : !! carteig2d
3423 : !!
3424 : !! FUNCTION
3425 : !! Transform a second-derivative matrix (EIG2D) from reduced
3426 : !! coordinates to cartesian coordinates
3427 : !!
3428 : !! INPUTS
3429 : !! blkflg(3,mpert,3,mpert,nblok)=
3430 : !! ( 1 if the element of the dynamical matrix has been calculated ;
3431 : !! 0 otherwise )
3432 : !! blkval(2,3,mpert,3,mpert,nblok)=DDB values
3433 : !! gprimd(3,3)=basis vector in the reciprocal space
3434 : !! iblok=number of the blok that will be transformed
3435 : !! mpert =maximum number of ipert
3436 : !! natom=number of atom
3437 : !! nblok=number of blocks (dimension of blkflg and blkval)
3438 : !! rprimd(3,3)=basis vector in the real space
3439 : !!
3440 : !! OUTPUT
3441 : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
3442 : !! 2DTE matrix has been calculated correctly ; 0 otherwise )
3443 : !! d2cart(2,3,mpert,3,mpert)=
3444 : !! dynamical matrix, effective charges, dielectric tensor,....
3445 : !! all in cartesian coordinates
3446 : !!
3447 : !! SOURCE
3448 :
3449 1444 : subroutine carteig2d(blkflg,blkval,carflg,d2cart,gprimd,iblok,mpert,natom,nblok,rprimd)
3450 :
3451 : !Arguments -------------------------------
3452 : !scalars
3453 : integer,intent(in) :: iblok,mpert,natom,nblok
3454 : !arrays
3455 : integer,intent(in) :: blkflg(3,mpert,3,mpert,nblok)
3456 : integer,intent(out) :: carflg(3,mpert,3,mpert)
3457 : real(dp),intent(in) :: blkval(2,3,mpert,3,mpert,nblok),gprimd(3,3),rprimd(3,3)
3458 : real(dp),intent(out) :: d2cart(2,3,mpert,3,mpert)
3459 :
3460 : !Local variables -------------------------
3461 : !scalars
3462 : integer :: idir1,idir2,ii,ipert1,ipert2
3463 : !arrays
3464 : integer :: flg1(3),flg2(3)
3465 : real(dp) :: vec1(3),vec2(3)
3466 : ! *********************************************************************
3467 :
3468 : ! First, copy the data blok in place.
3469 275940 : d2cart(:,:,:,:,:)=blkval(:,:,:,:,:,iblok)
3470 :
3471 : ! Cartesian coordinates transformation (in two steps)
3472 : ! First step
3473 4428 : do ipert1=1,mpert
3474 13180 : do ipert2=1,mpert
3475 29240 : do ii=1,2
3476 78768 : do idir1=1,3
3477 210048 : do idir2=1,3
3478 157536 : vec1(idir2)=d2cart(ii,idir1,ipert1,idir2,ipert2)
3479 : ! Note here blkflg
3480 210048 : flg1(idir2)=blkflg(idir1,ipert1,idir2,ipert2,iblok)
3481 : end do
3482 52512 : call cart39(flg1,flg2,gprimd,ipert2,natom,rprimd,vec1,vec2)
3483 227552 : do idir2=1,3
3484 157536 : d2cart(ii,idir1,ipert1,idir2,ipert2)=vec2(idir2)
3485 : ! And here carflg
3486 210048 : carflg(idir1,ipert1,idir2,ipert2)=flg2(idir2)
3487 : end do
3488 : end do
3489 : end do
3490 : end do
3491 : end do
3492 :
3493 : ! Second step
3494 4428 : do ipert1=1,mpert
3495 13180 : do ipert2=1,mpert
3496 29240 : do ii=1,2
3497 78768 : do idir2=1,3
3498 210048 : do idir1=1,3
3499 157536 : vec1(idir1)=d2cart(ii,idir1,ipert1,idir2,ipert2)
3500 : ! Note here carflg
3501 210048 : flg1(idir1)=carflg(idir1,ipert1,idir2,ipert2)
3502 : end do
3503 52512 : call cart39(flg1,flg2,gprimd,ipert1,natom,rprimd,vec1,vec2)
3504 227552 : do idir1=1,3
3505 157536 : d2cart(ii,idir1,ipert1,idir2,ipert2)=vec2(idir1)
3506 : ! And here carflg again
3507 210048 : carflg(idir1,ipert1,idir2,ipert2)=flg2(idir1)
3508 : end do
3509 : end do
3510 : end do
3511 : end do
3512 : end do
3513 :
3514 1444 : end subroutine carteig2d
3515 : !!***
3516 :
3517 : !----------------------------------------------------------------------
3518 :
3519 : !!****f* m_ddb/dtech9
3520 : !!
3521 : !! NAME
3522 : !! dtech9
3523 : !!
3524 : !! FUNCTION
3525 : !! Reads the Dielectric Tensor and the Effective Charges in the
3526 : !! Gamma Block coming from the Derivative Data Base.
3527 : !!
3528 : !! INPUTS
3529 : !! natom= number of atoms in unit cell
3530 : !! iblok= index of the Gamma block
3531 : !! mpert =maximum number of ipert
3532 : !! nblok= number of blocks in the DDB
3533 : !! blkval(2,3*mpert*3*mpert,nblok)= dynamical matrices
3534 : !! In our case, the nblok is restricted to iblok
3535 : !! [unit]=Output unit number
3536 : !!
3537 : !! OUTPUT
3538 : !! zeff(3,3,natom)=effective charge on each atom, versus electric
3539 : !! field and atomic displacement. Note the following convention:
3540 : !! zeff(electric field direction, atomic direction, atom index)
3541 : !! dielt(3,3)=dielectric tensor
3542 : !!
3543 : !! SOURCE
3544 :
3545 256 : subroutine dtech9(blkval,dielt,iblok,mpert,natom,nblok,zeff,unit)
3546 :
3547 : !Arguments -------------------------------
3548 : !scalars
3549 : integer,intent(in) :: iblok,mpert,natom,nblok
3550 : integer,intent(in),optional :: unit
3551 : !arrays
3552 : real(dp),intent(in) :: blkval(2,3,mpert,3,mpert,nblok)
3553 : real(dp),intent(out) :: dielt(3,3),zeff(3,3,natom)
3554 :
3555 : !Local variables -------------------------
3556 : !scalars
3557 : integer :: depl,elec,elec1,elec2,iatom, unt
3558 : character(len=1000) :: msg
3559 : ! *********************************************************************
3560 :
3561 256 : unt = std_out; if (present(unit)) unt = unit
3562 :
3563 : ! Extraction of effectives charges
3564 1090 : do iatom=1,natom
3565 3592 : do elec=1,3
3566 10842 : do depl=1,3
3567 : zeff(elec,depl,iatom)=0.5*&
3568 : (blkval(1,depl,iatom,elec,natom+2,iblok)+&
3569 10008 : blkval(1,elec,natom+2,depl,iatom,iblok))
3570 : end do
3571 : end do
3572 : end do
3573 :
3574 : ! Extraction of dielectric tensor
3575 1024 : do elec1=1,3
3576 3328 : do elec2=1,3
3577 3072 : dielt(elec1,elec2)=blkval(1,elec1,natom+2,elec2,natom+2,iblok)
3578 : end do
3579 : end do
3580 :
3581 256 : write(msg,'(a,3es16.6,3es16.6,3es16.6)' )' Dielectric Tensor ',&
3582 256 : dielt(1,1),dielt(1,2),dielt(1,3),&
3583 256 : dielt(2,1),dielt(2,2),dielt(2,3),&
3584 512 : dielt(3,1),dielt(3,2),dielt(3,3)
3585 256 : call wrtout(unt, msg)
3586 :
3587 256 : call wrtout(unt, ' Effectives Charges ')
3588 1090 : do iatom=1,natom
3589 834 : write(msg,'(a,i4,3es16.6,3es16.6,3es16.6)' )' atom ',iatom,&
3590 834 : zeff(1,1,iatom),zeff(1,2,iatom),zeff(1,3,iatom),&
3591 834 : zeff(2,1,iatom),zeff(2,2,iatom),zeff(2,3,iatom),&
3592 1668 : zeff(3,1,iatom),zeff(3,2,iatom),zeff(3,3,iatom)
3593 1090 : call wrtout(unt, msg)
3594 : end do
3595 :
3596 256 : end subroutine dtech9
3597 : !!***
3598 :
3599 : !----------------------------------------------------------------------
3600 :
3601 : !!****f* m_ddb/dtchi
3602 : !! NAME
3603 : !! dtchi
3604 : !!
3605 : !! FUNCTION
3606 : !! Reads the non-linear optical susceptibility tensor and the
3607 : !! first-order change in the linear dielectric susceptibility
3608 : !! induced by an atomic displacement in the Gamma Block coming from the Derivative Data Base
3609 : !! (third-order derivatives).
3610 : !!
3611 : !! INPUTS
3612 : !! blkval(2,3*mpert*3*mpert*3*mpert)= matrix of third-order energies
3613 : !! natom= number of atoms in unit cell
3614 : !! mpert =maximum number of ipert
3615 : !! ramansr= if /= 0, impose sum rule on first-order derivatives
3616 : !! of the electronic susceptibility with respect
3617 : !! to atomic displacements
3618 : !! nlflag= if =3, only the non-linear optical susceptibilities is computed
3619 : !!
3620 : !! OUTPUT
3621 : !! dchide(3,3,3) = non-linear optical coefficients
3622 : !! dchidt(natom,3,3,3) = first-order change of the electronic dielectric
3623 : !! tensor induced by an individual atomic displacement
3624 : !!
3625 : !! SOURCE
3626 :
3627 4 : subroutine dtchi(blkval,dchide,dchidt,mpert,natom,ramansr,nlflag)
3628 :
3629 : !Arguments -------------------------------
3630 : !scalars
3631 : integer,intent(in) :: mpert,natom,ramansr,nlflag
3632 : !arrays
3633 : real(dp),intent(in) :: blkval(2,3*mpert*3*mpert*3*mpert)
3634 : real(dp),intent(out) :: dchide(3,3,3),dchidt(natom,3,3,3)
3635 :
3636 : !Local variables -------------------------
3637 : !scalars
3638 : integer :: depl,elfd1,elfd2,elfd3,iatom,ivoigt
3639 : logical :: iwrite
3640 : real(dp) :: wttot
3641 : !arrays
3642 : integer :: voigtindex(6,2)
3643 8 : real(dp) :: d3cart(2,3,mpert,3,mpert,3,mpert),dvoigt(3,6),sumrule(3,3,3)
3644 8 : real(dp) :: wghtat(natom)
3645 : ! *********************************************************************
3646 :
3647 497068 : d3cart(1,:,:,:,:,:,:) = reshape(blkval(1,:),shape = (/3,mpert,3,mpert,3,mpert/))
3648 497068 : d3cart(2,:,:,:,:,:,:) = reshape(blkval(2,:),shape = (/3,mpert,3,mpert,3,mpert/))
3649 :
3650 : ! Extraction of non-linear optical coefficients
3651 16 : do elfd1 = 1,3
3652 52 : do elfd2 = 1,3
3653 156 : do elfd3 = 1,3
3654 144 : dchide(elfd1,elfd2,elfd3) = d3cart(1,elfd1,natom+2,elfd2,natom+2,elfd3,natom+2)
3655 : end do
3656 : end do
3657 : end do
3658 :
3659 : ! Transform to Voigt notations
3660 28 : voigtindex(:,1) = (/1,2,3,2,1,1/)
3661 28 : voigtindex(:,2) = (/1,2,3,3,3,2/)
3662 28 : do ivoigt = 1, 6
3663 24 : elfd2 = voigtindex(ivoigt,1)
3664 24 : elfd3 = voigtindex(ivoigt,2)
3665 100 : do elfd1 = 1, 3
3666 96 : dvoigt(elfd1,ivoigt) = 0.5_dp*(dchide(elfd1,elfd2,elfd3) + dchide(elfd1,elfd3,elfd2))
3667 : end do
3668 : end do
3669 :
3670 : ! Transform to pm/V
3671 100 : dvoigt(:,:) = dvoigt(:,:)*16*(pi**2)*(Bohr_Ang**2)*1.0d-8*eps0/e_Cb
3672 :
3673 : ! Extraction of $\frac{d \chi}{d \tau}$
3674 4 : if (nlflag < 3) then
3675 9 : do iatom = 1, natom
3676 27 : do depl = 1,3
3677 78 : do elfd1 = 1,3
3678 234 : do elfd2 = 1,3
3679 216 : dchidt(iatom,depl,elfd1,elfd2) = d3cart(1,depl,iatom,elfd1,natom+2,elfd2,natom+2)
3680 : end do
3681 : end do
3682 : end do
3683 : end do
3684 : end if
3685 :
3686 12 : wghtat(:) = zero
3687 4 : if (ramansr == 1) then
3688 9 : wghtat(:) = one/dble(natom)
3689 :
3690 1 : else if (ramansr == 2) then
3691 :
3692 0 : wttot = zero
3693 0 : do iatom = 1, natom
3694 0 : do depl = 1,3
3695 0 : do elfd1 = 1,3
3696 0 : do elfd2 = 1,3
3697 0 : wghtat(iatom) = wghtat(iatom) + abs(dchidt(iatom,depl,elfd1,elfd2))
3698 : end do
3699 : end do
3700 : end do
3701 0 : wttot = wttot + wghtat(iatom)
3702 : end do
3703 :
3704 0 : wghtat(:) = wghtat(:)/wttot
3705 : end if
3706 :
3707 4 : iwrite = ab_out > 0
3708 :
3709 4 : if (iwrite) then
3710 4 : write(ab_out,*)ch10
3711 4 : write(ab_out,*)'Non-linear optical coefficients d (pm/V)'
3712 4 : write(ab_out,'(6f12.6)')dvoigt(1,:)
3713 4 : write(ab_out,'(6f12.6)')dvoigt(2,:)
3714 4 : write(ab_out,'(6f12.6)')dvoigt(3,:)
3715 : end if
3716 :
3717 4 : if (ramansr /= 0) then
3718 3 : if (iwrite) then
3719 3 : write(ab_out,*)ch10
3720 3 : write(ab_out,*)'The violation of the Raman sum rule'
3721 3 : write(ab_out,*)'by the first-order electronic dielectric tensors ','is as follows'
3722 3 : write(ab_out,*)' atom'
3723 3 : write(ab_out,*)' displacement'
3724 : end if
3725 :
3726 3 : sumrule(:,:,:) = zero
3727 12 : do elfd2 = 1,3
3728 39 : do elfd1 = 1,3
3729 117 : do depl = 1,3
3730 243 : do iatom = 1, natom
3731 243 : sumrule(depl,elfd1,elfd2) = sumrule(depl,elfd1,elfd2) + dchidt(iatom,depl,elfd1,elfd2)
3732 : end do
3733 270 : do iatom = 1, natom
3734 243 : dchidt(iatom,depl,elfd1,elfd2) = dchidt(iatom,depl,elfd1,elfd2) - wghtat(iatom)*sumrule(depl,elfd1,elfd2)
3735 : end do
3736 : end do
3737 : end do
3738 : end do
3739 :
3740 3 : if (iwrite) then
3741 12 : do depl = 1,3
3742 9 : write(ab_out,'(6x,i2,3(3x,f16.9))') depl,sumrule(depl,1,1:3)
3743 9 : write(ab_out,'(8x,3(3x,f16.9))') sumrule(depl,2,1:3)
3744 9 : write(ab_out,'(8x,3(3x,f16.9))') sumrule(depl,3,1:3)
3745 12 : write(ab_out,*)
3746 : end do
3747 : end if
3748 : end if ! ramansr
3749 :
3750 4 : if (nlflag < 3) then
3751 3 : if (iwrite) then
3752 3 : write(ab_out,*)ch10
3753 3 : write(ab_out,*)' First-order change in the electronic dielectric '
3754 3 : write(ab_out,*)' susceptibility tensor (Bohr^-1)'
3755 3 : write(ab_out,*)' induced by an atomic displacement'
3756 3 : if (ramansr /= 0) then
3757 3 : write(ab_out,*)' (after imposing the sum over all atoms to vanish)'
3758 : end if
3759 3 : write(ab_out,*)' atom displacement'
3760 :
3761 9 : do iatom = 1,natom
3762 24 : do depl = 1,3
3763 18 : write(ab_out,'(1x,i4,9x,i2,3(3x,f16.9))')iatom,depl,dchidt(iatom,depl,1,:)
3764 18 : write(ab_out,'(16x,3(3x,f16.9))')dchidt(iatom,depl,2,:)
3765 24 : write(ab_out,'(16x,3(3x,f16.9))')dchidt(iatom,depl,3,:)
3766 : end do
3767 :
3768 9 : write(ab_out,*)
3769 : end do
3770 : end if
3771 : end if
3772 :
3773 4 : end subroutine dtchi
3774 : !!***
3775 :
3776 : !----------------------------------------------------------------------
3777 :
3778 : !!****f* m_ddb/ddb_get_etotal
3779 : !!
3780 : !! NAME
3781 : !! ddb_get_etotal
3782 : !!
3783 : !! FUNCTION
3784 : !! Read the GS total energy from the DDB file.
3785 : !!
3786 : !! INPUTS
3787 : !! ddb<type(ddb_type)>=Derivative database.
3788 : !!
3789 : !! OUTPUT
3790 : !! etotal=GS Total energy in Hartree
3791 : !! iblok=Index of the block in the DDB file. 0 if not found.
3792 : !!
3793 : !! SOURCE
3794 :
3795 32 : integer function ddb_get_etotal(ddb, etotal) result(iblok)
3796 :
3797 : !Arguments -------------------------------
3798 : !scalars
3799 : class(ddb_type),intent(in) :: ddb
3800 : real(dp),intent(out) :: etotal
3801 :
3802 : !Local variables -------------------------
3803 : !scalars
3804 : integer :: rftyp
3805 : !arrays
3806 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
3807 : real(dp) :: qphnrm(3),qphon(3,3)
3808 : ! *********************************************************************
3809 :
3810 : ! Extract the block with the total energy
3811 32 : qphon(:,:) = zero
3812 32 : qphnrm(:) = zero
3813 32 : rfphon(:) = 0
3814 32 : rfelfd(:) = 0
3815 32 : rfstrs(:) = 0
3816 32 : rftyp = BLKTYP_d0E_xx
3817 :
3818 32 : call ddb%get_block(iblok,qphon,qphnrm,rfphon,rfelfd,rfstrs,rftyp)
3819 :
3820 32 : if (iblok /= 0) then
3821 15 : etotal = ddb%val(1,1,iblok)
3822 : else
3823 17 : etotal = huge(one)
3824 : end if
3825 :
3826 32 : end function ddb_get_etotal
3827 : !!***
3828 :
3829 : !----------------------------------------------------------------------
3830 :
3831 : !!****f* m_ddb/ddb_get_dielt_zeff
3832 : !!
3833 : !! NAME
3834 : !! ddb_get_dielt_zeff
3835 : !!
3836 : !! FUNCTION
3837 : !! Reads the Dielectric Tensor and the Effective Charges from the DDB file
3838 : !! Impose the charge neutrality on the effective charges and eventually select some parts of the effective charges
3839 : !!
3840 : !! INPUTS
3841 : !! Crystal<type(crystal_t)>=Crystal structure parameters
3842 : !! rftyp = 1 if non-stationary block
3843 : !! 2 if stationary block
3844 : !! 3 if third order derivatives
3845 : !! chneut=(0 => no ASR, 1 => equal repartition,2 => weighted repartition )
3846 : !! selectz=selection of some parts of the effective charge tensor attached to one atom.
3847 : !! (0=> no selection, 1=> trace only, 2=> symmetric part only)
3848 : !!
3849 : !! SIDE EFFECTS
3850 : !! ddb<type(ddb_type)>=
3851 : !! The block with the effective charges is modified if charge neutrality is imposed.
3852 : !!
3853 : !! OUTPUT
3854 : !! iblok=Index of the block containing the data. 0 if block is not found.
3855 : !! dielt(3,3) = Macroscopic dielectric tensor
3856 : !! zeff(3,3,natom)=effective charge on each atom, versus electric field and atomic displacement
3857 : !! [zeff_raw(3,3,natom)]=effective charge on each atom before enforcing charge-neutrality.
3858 : !!
3859 : !! NOTES
3860 : !! dielt and zeff are initialized to one_3D and zero if the derivatives are not available in the DDB file.
3861 : !!
3862 : !! SOURCE
3863 :
3864 219 : integer function ddb_get_dielt_zeff(ddb, crystal, rftyp, chneut, selectz, dielt, zeff, zeff_raw) result(iblok)
3865 :
3866 : !Arguments -------------------------------
3867 : !scalars
3868 : class(ddb_type),intent(inout) :: ddb
3869 : integer,intent(in) :: rftyp,chneut,selectz
3870 : type(crystal_t),intent(in) :: crystal
3871 : !arrays
3872 : real(dp),intent(out) :: dielt(3,3),zeff(3,3,crystal%natom)
3873 : real(dp),optional,intent(out) :: zeff_raw(3,3,crystal%natom)
3874 :
3875 : !Local variables -------------------------
3876 : !scalars
3877 : integer :: ii, units(2)
3878 : character(len=500) :: msg
3879 : !arrays
3880 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
3881 438 : real(dp) :: qphnrm(3),qphon(3,3), my_zeff_raw(3,3,crystal%natom)
3882 : ! *********************************************************************
3883 :
3884 657 : units = [std_out, ab_out]
3885 :
3886 : ! Look for the Gamma Block in the DDB
3887 876 : qphon(:,1)=zero
3888 219 : qphnrm(1)=zero
3889 : !rfphon(1:2)=1
3890 : !rfelfd(1:2)=2
3891 : ! For effective charges: perturbation 1 = phonons, perturbation 2 = electric field
3892 219 : rfphon(1)=1; rfphon(2)=0
3893 219 : rfelfd(1)=0; rfelfd(2)=2
3894 657 : rfstrs(1:2)=0
3895 :
3896 : !write(std_out,*)"ddb%mpert",ddb%mpert
3897 219 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, rftyp)
3898 :
3899 : ! Compute effective charges and dielectric tensor only if the Gamma-blok was found in the DDB
3900 : ! In case it was not found, iblok = 0
3901 8188 : zeff=zero; dielt=zero; dielt(1,1)=one; dielt(2,2)=one; dielt(3,3)=one
3902 8188 : my_zeff_raw = zero
3903 :
3904 219 : if (iblok /= 0) then
3905 10496 : write(msg, '(2a,(80a),4a)' ) ch10,('=',ii=1,80),ch10,ch10,&
3906 10624 : ' Dielectric Tensor and Effective Charges ',ch10
3907 128 : call wrtout(units, msg)
3908 :
3909 : ! Make the imaginary part of the Gamma block vanish
3910 128 : write(msg, '(5a)' ) ch10,&
3911 128 : ' anaddb : Zero the imaginary part of the Dynamical Matrix at Gamma,',ch10,&
3912 256 : ' and impose the ASR on the effective charges ',ch10
3913 128 : call wrtout(units, msg)
3914 :
3915 : ! Extrac Zeff before enforcing sum rule.
3916 128 : call dtech9(ddb%val, dielt, iblok, ddb%mpert, ddb%natom, ddb%nblok, my_zeff_raw, unit=dev_null)
3917 :
3918 : ! Impose the charge neutrality on the effective charges and eventually select some parts of the effective charges
3919 128 : call chneu9(chneut,ddb%val(:,:,iblok),ddb%mpert,ddb%natom,ddb%ntypat,selectz,Crystal%typat,Crystal%zion)
3920 :
3921 : ! Extraction of the dielectric tensor and the effective charges
3922 128 : call dtech9(ddb%val, dielt, iblok, ddb%mpert, ddb%natom, ddb%nblok, zeff)
3923 : end if ! iblok not found
3924 :
3925 3058 : if (present(zeff_raw)) zeff_raw = my_zeff_raw
3926 :
3927 219 : end function ddb_get_dielt_zeff
3928 : !!***
3929 :
3930 : !----------------------------------------------------------------------
3931 :
3932 : !!****f* m_ddb/ddb_get_dielt
3933 : !!
3934 : !! NAME
3935 : !! ddb_get_dielt
3936 : !!
3937 : !! FUNCTION
3938 : !! Reads the electronic dielectric tensor from the DDB file
3939 : !!
3940 : !! INPUTS
3941 : !! ddb<type(ddb_type)>=Derivative database.
3942 : !! rftyp = 1 if non-stationary block
3943 : !! 2 if stationary block
3944 : !! 3 if third order derivatives
3945 : !!
3946 : !! OUTPUT
3947 : !! dielt(3,3) = Macroscopic dielectric tensor (electronic contribution)
3948 : !! iblok=Index of the block containing the data. 0 if block is not found.
3949 : !!
3950 : !! NOTES
3951 : !! dielt is initialized to one_3D if the derivatives are not available in the DDB file.
3952 : !!
3953 : !! SOURCE
3954 :
3955 141 : integer function ddb_get_dielt(ddb, rftyp, dielt) result(iblok)
3956 :
3957 : !Arguments -------------------------------
3958 : !scalars
3959 : integer,intent(in) :: rftyp
3960 : class(ddb_type),intent(in) :: ddb
3961 : !arrays
3962 : real(dp),intent(out) :: dielt(3,3)
3963 :
3964 : !Local variables -------------------------
3965 : !scalars
3966 : integer :: mpert
3967 : character(len=1000) :: msg
3968 : !arrays
3969 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
3970 : real(dp) :: qphnrm(3),qphon(3,3)
3971 141 : real(dp),allocatable :: tmpval(:,:,:,:)
3972 : ! *********************************************************************
3973 :
3974 : ! Look for the Gamma Block in the DDB
3975 564 : qphon(:,1)=zero
3976 141 : qphnrm(1)=zero
3977 423 : rfphon(1:2)=0
3978 423 : rfelfd(1:2)=2
3979 423 : rfstrs(1:2)=0
3980 :
3981 141 : call ddb%get_block(iblok,qphon,qphnrm,rfphon,rfelfd,rfstrs,rftyp)
3982 :
3983 : ! Read the dielectric tensor only if the Gamma-block was found in the DDB
3984 : ! In case it was not found, iblok = 0
3985 141 : dielt=zero; dielt(1,1)=one; dielt(2,2)=one; dielt(3,3)=one
3986 :
3987 141 : if (iblok/=0) then
3988 : !Extration of dielectric tensor
3989 60 : mpert = ddb%mpert
3990 :
3991 300 : ABI_MALLOC(tmpval,(3,mpert,3,mpert))
3992 300 : tmpval(:,:,:,:) = reshape(ddb%val(1,:,iblok), shape = (/3,mpert,3,mpert/))
3993 780 : dielt=tmpval(1:3,ddb%natom+2,1:3,ddb%natom+2)
3994 :
3995 : write(msg,'(a,3es16.6,3es16.6,3es16.6)' )&
3996 60 : ' Dielectric Tensor ',&
3997 60 : dielt(1,1),dielt(1,2),dielt(1,3),&
3998 60 : dielt(2,1),dielt(2,2),dielt(2,3),&
3999 120 : dielt(3,1),dielt(3,2),dielt(3,3)
4000 :
4001 60 : call wrtout(std_out,msg)
4002 :
4003 60 : ABI_FREE(tmpval)
4004 : end if ! iblok not found
4005 :
4006 141 : end function ddb_get_dielt
4007 : !!***
4008 :
4009 : !----------------------------------------------------------------------
4010 :
4011 : !!****f* m_ddb/ddb_get_quadrupoles
4012 : !!
4013 : !! NAME
4014 : !! ddb_get_quadrupoles
4015 : !!
4016 : !! FUNCTION
4017 : !! Reads the Dynamic Quadrupoles or the P^(1) tensor from the DDB file
4018 : !!
4019 : !! INPUTS
4020 : !! ddb<type(ddb_type)>=Derivative database.
4021 : !! ddb_version = 6 digit integer giving date. To mantain compatibility with old DDB files.
4022 : !! lwsym = 0 do not symmetrize the tensor wrt efield and qvec derivative
4023 : !! |-> 1st gradient of polarization response to atomic displacement
4024 : !! = 1 symmetrize the tensor wrt efield and qvec derivative
4025 : !! |-> dynamic quadrupoles
4026 : !! rftyp = 1 if non-stationary block
4027 : !! 2 if stationary block
4028 : !! 3 if third order derivatives
4029 : !! 33 if long wave third order derivatives
4030 : !!
4031 : !! OUTPUT
4032 : !! quadrupoles(3,3,3,natom) = Dynamic Quadrupole tensor
4033 : !! iblok=Index of the block containing the data. 0 if block is not found.
4034 : !!
4035 : !! NOTES
4036 : !! quadrupoles is initialized to zero if the derivatives are not available in the DDB file.
4037 : !!
4038 : !! SOURCE
4039 :
4040 22 : integer function ddb_get_quadrupoles(ddb, ddb_version, lwsym, rftyp, quadrupoles) result(iblok)
4041 :
4042 : !Arguments -------------------------------
4043 : !scalars
4044 : integer,intent(in) :: ddb_version,lwsym,rftyp
4045 : class(ddb_type),intent(in) :: ddb
4046 : !arrays
4047 : real(dp),intent(out) :: quadrupoles(3,3,3,ddb%natom)
4048 :
4049 : !Local variables -------------------------
4050 : !scalars
4051 : character(len=500) :: msg
4052 : !arrays
4053 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
4054 : integer :: rfqvec(4)
4055 : real(dp) :: qphnrm(3),qphon(3,3)
4056 : ! *********************************************************************
4057 :
4058 : ! Look for the Gamma Block in the DDB
4059 11 : qphon(:,:)=zero
4060 44 : qphnrm(:)=one
4061 11 : rfphon(:)=0
4062 11 : rfelfd(:)=0
4063 11 : rfqvec(:)=0
4064 11 : rfstrs(:)=0
4065 11 : rfelfd(1)=2
4066 11 : rfphon(2)=1
4067 11 : rfqvec(3)=1
4068 :
4069 11 : call ddb%get_block(iblok,qphon,qphnrm,rfphon,rfelfd,rfstrs,rftyp,rfqvec=rfqvec)
4070 :
4071 : ! Compute the quadrupole tensor only if the Gamma-block was found in the DDB
4072 : ! In case it was not found, iblok = 0
4073 1451 : quadrupoles=zero
4074 :
4075 11 : if (iblok /= 0) then
4076 9 : write(msg,'(2a)') ch10, ' Extract quadrupoles or P^(1) coefficients from 3DTE'
4077 9 : call wrtout(std_out, msg)
4078 :
4079 9 : if (lwsym==1) then
4080 7 : write(msg, '(3a)' ) ch10, ' Dynamical Quadrupoles Tensor (units: e Bohr)',ch10
4081 2 : else if (lwsym==0) then
4082 2 : write(msg, '(3a)' ) ch10, &
4083 4 : ' First moment of Polarization induced by atomic displacement (1/ucvol factor not included) (units: e Bohr) ',ch10
4084 : endif
4085 27 : call wrtout([std_out, ab_out], msg)
4086 :
4087 9 : call dtqdrp(ddb%val(:,:,iblok),ddb_version,lwsym,ddb%mpert,ddb%natom,quadrupoles)
4088 : end if
4089 :
4090 11 : end function ddb_get_quadrupoles
4091 : !!***
4092 :
4093 : !----------------------------------------------------------------------
4094 :
4095 : !!****f* m_ddb/ddb_get_dchidet
4096 : !!
4097 : !! NAME
4098 : !! ddb_get_dchidet
4099 : !!
4100 : !! FUNCTION
4101 : !! Reads the non-linear optical susceptibility tensor and the
4102 : !! first-order change in the linear dielectric susceptibility
4103 : !!
4104 : !! INPUTS
4105 : !! ddb<type(ddb_type)>=Derivative Database.
4106 : !! ramansr= if /= 0, impose sum rule on first-order derivatives
4107 : !! of the electronic susceptibility with respect
4108 : !! to atomic displacements
4109 : !! nlflag= if =3, only the non-linear optical susceptibilities is computed
4110 : !!
4111 : !! OUTPUT
4112 : !! dchide(3,3,3) = non-linear optical coefficients
4113 : !! dchidt(natom,3,3,3) = first-order change of the electronic dielectric
4114 : !! tensor induced by an individual atomic displacement
4115 : !! iblok=Index of the block containing the data. 0 if block is not found.
4116 : !! The caller should check the returned value.
4117 : !!
4118 : !! SOURCE
4119 :
4120 8 : integer function ddb_get_dchidet(ddb, ramansr, nlflag, dchide, dchidt) result(iblok)
4121 :
4122 : !Arguments -------------------------------
4123 : !scalars
4124 : integer,intent(in) :: ramansr, nlflag
4125 : class(ddb_type),intent(in) :: ddb
4126 : !arrays
4127 : real(dp),intent(out) :: dchide(3,3,3),dchidt(ddb%natom,3,3,3)
4128 :
4129 : !Local variables -------------------------
4130 : !scalars
4131 : integer :: rftyp
4132 : !arrays
4133 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
4134 : real(dp) :: qphnrm(3),qphon(3,3)
4135 : ! *********************************************************************
4136 :
4137 4 : qphon(:,:) = zero
4138 16 : qphnrm(:) = one
4139 : ! rfphon(1) = 1 ; rfphon(2:3) = 0
4140 20 : rfelfd(:) = 2
4141 4 : rfstrs(:) = 0
4142 4 : rftyp = BLKTYP_d3E_xx
4143 :
4144 4 : if (nlflag < 3) then
4145 9 : rfphon(1) = 1 ; rfphon(2:3) = 0
4146 : else
4147 3 : rfphon(1) = 0 ; rfphon(2:3) = 0
4148 : end if
4149 :
4150 4 : call ddb%get_block(iblok,qphon,qphnrm,rfphon,rfelfd,rfstrs,rftyp)
4151 :
4152 4 : if (iblok /= 0) then
4153 4 : call dtchi(ddb%val(:,:,iblok),dchide,dchidt,ddb%mpert,ddb%natom,ramansr,nlflag)
4154 : else
4155 : ! Let the caller handle the error.
4156 0 : dchide = huge(one); dchidt = huge(one)
4157 : end if
4158 :
4159 4 : end function ddb_get_dchidet
4160 : !!***
4161 :
4162 : !----------------------------------------------------------------------
4163 :
4164 : !!****f* m_ddb/ddb_get_pel
4165 : !!
4166 : !! NAME
4167 : !! ddb_get_pel
4168 : !!
4169 : !! FUNCTION
4170 : !! Get the electronic polarizability vector from the database.
4171 : !!
4172 : !! INPUTS
4173 : !! ddb<type(ddb_type)>=Derivative database.
4174 : !! relaxat
4175 : !! 0 => without relaxation of the atoms
4176 : !! 1 => with relaxation of the atoms
4177 : !! relaxstr
4178 : !! 0 => without relaxed lattice constants
4179 : !! 1 => with relaxed lattice constants at constrained polarization
4180 : !!
4181 : !! OUTPUT
4182 : !! pel(3) = Macroscopic polarizability vector (electronic contribution)
4183 : !! iblok=Index of the block containing the data. 0 if block is not found.
4184 : !!
4185 : !! NOTES
4186 : !!
4187 : !! SOURCE
4188 :
4189 3 : integer function ddb_get_pel(ddb, pel, relaxat, relaxstr) result(iblok)
4190 :
4191 : !Arguments -------------------------------
4192 : !scalars
4193 : class(ddb_type),intent(in) :: ddb
4194 : integer, intent(in) :: relaxat
4195 : integer, intent(in) :: relaxstr
4196 : !arrays
4197 : real(dp),intent(out) :: pel(3)
4198 :
4199 : !Local variables -------------------------
4200 : !scalars
4201 : integer :: natom
4202 : !arrays
4203 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
4204 : real(dp) :: qphnrm(3),qphon(3,3)
4205 : ! *********************************************************************
4206 :
4207 3 : natom = ddb%natom
4208 :
4209 3 : qphon(:,:) = zero; qphnrm(:) = zero
4210 15 : rfphon(:) = 0; rfstrs(:) = 0; rfelfd(:) = 2
4211 13 : if (relaxat == 1) rfphon(:) = 1
4212 13 : if (relaxstr == 1) rfstrs(:) = 3
4213 :
4214 3 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, BLKTYP_d1E_xx)
4215 :
4216 3 : if (iblok/=0) then
4217 12 : pel(1:3) = ddb%val(1, 3*natom+4:3*natom+6, iblok)
4218 : end if
4219 :
4220 3 : end function ddb_get_pel
4221 : !!***
4222 :
4223 : !----------------------------------------------------------------------
4224 :
4225 : !!****f* m_ddb/ddb_get_gred
4226 : !!
4227 : !! NAME
4228 : !! ddb_get_gred
4229 : !!
4230 : !! FUNCTION
4231 : !! Get the forces in reduced coordinates (Hartree).
4232 : !!
4233 : !! INPUTS
4234 : !! ddb<type(ddb_type)>=Derivative database.
4235 : !! relaxat
4236 : !! 0 => without relaxation of the atoms
4237 : !! 1 => with relaxation of the atoms
4238 : !! relaxstr
4239 : !! 0 => without relaxed lattice constants
4240 : !! 1 => with relaxed lattice constants at constrained polarization
4241 : !!
4242 : !! OUTPUT
4243 : !! gred(3,natom)=the gradient of the total energy with respect
4244 : !! to change of reduced coordinates
4245 : !! iblok=Index of the block containing the data. 0 if block is not found.
4246 : !!
4247 : !! NOTES
4248 : !!
4249 : !! SOURCE
4250 :
4251 3 : integer function ddb_get_gred(ddb, gred, relaxat, relaxstr) result(iblok)
4252 :
4253 : !Arguments -------------------------------
4254 : !scalars
4255 : class(ddb_type),intent(in) :: ddb
4256 : integer, intent(in) :: relaxat
4257 : integer, intent(in) :: relaxstr
4258 : !arrays
4259 : real(dp),intent(out),allocatable :: gred(:,:)
4260 :
4261 : !Local variables -------------------------
4262 : !scalars
4263 : integer :: natom
4264 : integer :: idir, iatom, index
4265 : !arrays
4266 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
4267 : real(dp) :: qphnrm(3),qphon(3,3)
4268 : ! *********************************************************************
4269 :
4270 3 : natom = ddb%natom
4271 :
4272 9 : ABI_MALLOC(gred, (3, natom))
4273 :
4274 3 : qphon(:,:) = zero; qphnrm(:) = zero
4275 15 : rfphon(:) = 0; rfstrs(:) = 0; rfelfd(:) = 2
4276 13 : if (relaxat == 1) rfphon(:) = 1
4277 13 : if (relaxstr == 1) rfstrs(:) = 3
4278 :
4279 : ! GA: I dont see why relaxstr is relevant as an input
4280 3 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, BLKTYP_d1E_xx)
4281 :
4282 3 : if (iblok/=0) then
4283 3 : if (relaxat == 1) then
4284 : index = 0
4285 9 : do iatom = 1, natom
4286 30 : do idir = 1, 3
4287 21 : index = index+1
4288 28 : gred(idir, iatom) = ddb%val(1, index, iblok)
4289 : end do
4290 : end do
4291 : end if
4292 : end if
4293 :
4294 3 : end function ddb_get_gred
4295 : !!***
4296 :
4297 : !----------------------------------------------------------------------
4298 :
4299 : !!****f* m_ddb/ddb_get_strten
4300 : !!
4301 : !! NAME
4302 : !! ddb_get_strten
4303 : !!
4304 : !! FUNCTION
4305 : !! Get the stress tensor.
4306 : !!
4307 : !! INPUTS
4308 : !! ddb<type(ddb_type)>=Derivative database.
4309 : !! relaxat
4310 : !! 0 => without relaxation of the atoms
4311 : !! 1 => with relaxation of the atoms
4312 : !! relaxstr
4313 : !! 0 => without relaxed lattice constants
4314 : !! 1 => with relaxed lattice constants at constrained polarization
4315 : !!
4316 : !! OUTPUT
4317 : !! strten(6)=the stress tensor in cartesian coordinates.
4318 : !! iblok=Index of the block containing the data. 0 if block is not found.
4319 : !!
4320 : !! NOTES
4321 : !!
4322 : !! SOURCE
4323 :
4324 3 : integer function ddb_get_strten(ddb, strten, relaxat, relaxstr) result(iblok)
4325 :
4326 : !Arguments -------------------------------
4327 : !scalars
4328 : class(ddb_type),intent(in) :: ddb
4329 : integer, intent(in) :: relaxat
4330 : integer, intent(in) :: relaxstr
4331 : !arrays
4332 : real(dp),intent(out) :: strten(6)
4333 :
4334 : !Local variables -------------------------
4335 : !scalars
4336 : integer :: natom
4337 : integer :: ii, index
4338 : !arrays
4339 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
4340 : real(dp) :: qphnrm(3),qphon(3,3)
4341 : ! *********************************************************************
4342 :
4343 3 : natom = ddb%natom
4344 :
4345 3 : qphon(:,:) = zero; qphnrm(:) = zero
4346 15 : rfphon(:) = 0; rfstrs(:) = 0; rfelfd(:) = 2
4347 13 : if (relaxat == 1) rfphon(:) = 1
4348 13 : if (relaxstr == 1) rfstrs(:) = 3
4349 :
4350 : ! GA: I dont see why relaxstr is relevant as an input
4351 3 : call ddb%get_block(iblok, qphon, qphnrm, rfphon, rfelfd, rfstrs, BLKTYP_d1E_xx)
4352 :
4353 3 : if (iblok/=0) then
4354 3 : if (relaxstr == 1) then
4355 2 : index = 3*natom+6
4356 14 : do ii = 1, 6
4357 12 : index = index+1
4358 14 : strten(ii) = ddb%val(1, index, iblok)
4359 : end do
4360 : end if
4361 : end if
4362 :
4363 3 : end function ddb_get_strten
4364 : !!***
4365 :
4366 : !----------------------------------------------------------------------
4367 :
4368 : !!****f* m_ddb/asrq0_init
4369 : !! NAME
4370 : !! asrq0_init
4371 : !!
4372 : !! FUNCTION
4373 : !! Initialize an asrq0 object for the imposition
4374 : !! of the accoustic sum rule (ASR) at q=0.
4375 : !! In case the interatomic forces are not calculated, the
4376 : !! ASR-correction has to be determined here from the Dynamical matrix at Gamma.
4377 : !! In case the DDB does not contain this information, the subroutine returns iblok=0
4378 : !! %d2asr is initialized and set to zero to preserve the old behaviour.
4379 : !!
4380 : !! INPUTS
4381 : !! asr=Input variable selecting the method for the ASR
4382 : !! rftyp = 1 if non-stationary block
4383 : !! 2 if stationary block
4384 : !! 3 if third order derivatives
4385 : !! Crystal<type(crystal_t)>=Crystal structure parameter
4386 : !! sys_dim=System dimensionality (0D, 1D, ...) used for rotational invariance
4387 : !! dcdq = derivative of interatomic force constants at the zone center
4388 : !! dcdqdq = second derivative of interatomic force constants at the zone center
4389 : !!
4390 : !! SIDE EFFECTS
4391 : !! ddb<type(ddb_type)>= Database with the derivates. The routine does not change it
4392 : !! except when asr is in [3,4]. TODO This should not happen.
4393 : !!
4394 : !! OUTPUT
4395 : !! asrq0<asrq0_t>
4396 : !! iblok= is set to 0 if the Gamma block is not found
4397 : !!
4398 : !! SOURCE
4399 :
4400 110 : subroutine asrq0_init(asrq0, ddb, asr, rftyp, crystal, sys_dim, dcdq, dcdqdq)
4401 :
4402 : !Arguments -------------------------------
4403 : !scalars
4404 : integer,intent(in) :: asr,sys_dim,rftyp
4405 : class(ddb_type),intent(inout) :: ddb
4406 : type(crystal_t),intent(in) :: crystal
4407 : class(asrq0_t), intent(out) :: asrq0
4408 : !arrays
4409 : real(dp), optional, intent(in) :: dcdq(3,crystal%natom,3,crystal%natom,3)
4410 : real(dp), optional, intent(in) :: dcdqdq(3,crystal%natom,3,3,3)
4411 : !Local variables-------------------------------
4412 : !scalars
4413 : integer :: dims,iblok
4414 : !character(len=500) :: msg
4415 : !arrays
4416 : integer :: rfelfd(4),rfphon(4),rfstrs(4)
4417 : real(dp) :: qphnrm(3),qphon(3,3)
4418 110 : real(dp),allocatable :: d2asr_res(:,:,:,:,:),d2cart(:,:)
4419 : ! ************************************************************************
4420 :
4421 110 : asrq0%asr = asr; asrq0%natom = ddb%natom
4422 : ! Find the Gamma block in the DDB (no need for E-field entries)
4423 440 : qphon(:,1)=zero
4424 110 : qphnrm(1)=zero
4425 330 : rfphon(1:2)=1
4426 110 : rfelfd(:)=0
4427 110 : rfstrs(:)=0
4428 :
4429 110 : call ddb%get_block(asrq0%iblok,qphon,qphnrm,rfphon,rfelfd,rfstrs,rftyp)
4430 : ! this is to maintain the old behaviour in which the arrays where allocated and set to zero in anaddb.
4431 550 : ABI_MALLOC(asrq0%d2asr, (2,3,ddb%natom,3,ddb%natom))
4432 660 : ABI_MALLOC(asrq0%d2dqmsr, (3,ddb%natom,3,ddb%natom,3))
4433 770 : ABI_MALLOC(asrq0%d2dqdqmsr, (3,ddb%natom,3,ddb%natom,3,3))
4434 72078 : asrq0%d2asr = zero
4435 89768 : asrq0%d2dqmsr = zero
4436 269414 : asrq0%d2dqdqmsr = zero
4437 :
4438 110 : if (asrq0%iblok == 0) return
4439 108 : iblok = asrq0%iblok
4440 :
4441 108 : select case (asrq0%asr)
4442 : case (0)
4443 100 : continue
4444 :
4445 : case (1,2)
4446 100 : call asria_calc(asr,asrq0%d2asr,ddb%val(:,:,iblok),ddb%mpert,ddb%natom)
4447 :
4448 : case (3,4)
4449 : ! Rotational invariance for 1D and 0D systems
4450 : ! Compute uinvers, vtinvers and singular matrices.
4451 2 : dims = 3*ddb%natom*(3*ddb%natom-1) / 2
4452 488 : ABI_CALLOC(asrq0%uinvers, (dims, dims))
4453 486 : ABI_CALLOC(asrq0%vtinvers,(dims, dims))
4454 36 : ABI_CALLOC(asrq0%singular, (dims))
4455 :
4456 : call asrprs(asr,1,3,asrq0%uinvers,asrq0%vtinvers,asrq0%singular,&
4457 2 : ddb%val(:,:,iblok),ddb%mpert,ddb%natom,crystal%xcart)
4458 :
4459 : case (5)
4460 : ! d2cart is a temp variable here
4461 0 : ABI_MALLOC(d2cart,(2,ddb%msize))
4462 0 : d2cart = ddb%val(:,:,iblok)
4463 : ! calculate diagonal correction
4464 0 : call asria_calc(2,asrq0%d2asr,d2cart,ddb%mpert,ddb%natom)
4465 : ! apply diagonal correction
4466 0 : call asria_corr(2,asrq0%d2asr,d2cart,ddb%mpert,ddb%natom)
4467 : ! hermitianize
4468 0 : call mkherm(d2cart,3*ddb%mpert)
4469 : ! remove remaining ASR rupture due to Hermitianization
4470 0 : ABI_MALLOC(d2asr_res,(2,3,ddb%natom,3,ddb%natom))
4471 0 : call asria_calc(asr,d2asr_res,d2cart,ddb%mpert,ddb%natom)
4472 : ! full correction is sum of both
4473 0 : asrq0%d2asr = asrq0%d2asr + d2asr_res
4474 :
4475 0 : ABI_FREE(d2cart)
4476 0 : ABI_FREE(d2asr_res)
4477 : case (6)
4478 : call msria_calc(asr,crystal,asrq0%d2asr,ddb%val(:,:,iblok),&
4479 2 : dcdq,dcdqdq,asrq0%d2dqmsr,asrq0%d2dqdqmsr,sys_dim,ddb%mpert,ddb%natom)
4480 : case default
4481 108 : ABI_ERROR(sjoin("Wrong value for asr:", itoa(asr)))
4482 : end select
4483 :
4484 : end subroutine asrq0_init
4485 : !!***
4486 :
4487 : !----------------------------------------------------------------------
4488 :
4489 : !!****f* m_ddb/ddb_symmetrize_and_transform
4490 : !! NAME
4491 : !! ddb_symmetrize_and_transform
4492 : !!
4493 : !! FUNCTION
4494 : !! First apply symmetry operations, then
4495 : !! transform the second-derivative matrix from reduced
4496 : !! coordinates to cartesian coordinates, and also
4497 : !! 1) add the ionic part of the effective charges,
4498 : !! 2) normalize the electronic dielectric tensor, and
4499 : !! add the vacuum polarisation
4500 : !!
4501 : !! INPUTS
4502 : !! crystal<type(crystal_t)>
4503 : !! iblock=the block index on which to act
4504 : !!
4505 : !! SIDE EFFECTS
4506 : !! ddb<type(ddb_type)>=
4507 : !!
4508 : !! OUTPUT
4509 : !!
4510 : !! SOURCE
4511 :
4512 1960 : subroutine ddb_symmetrize_and_transform(ddb, crystal, iblok)
4513 :
4514 : !Arguments -------------------------------
4515 : !scalars
4516 : class(ddb_type),intent(inout) :: ddb
4517 : class(crystal_t),intent(in) :: crystal
4518 : integer,intent(in) :: iblok
4519 : !integer,intent(inout) :: indsym(4,msym,natom)
4520 : !integer,intent(out) :: symrec(3,3,msym),symrel(3,3,msym),symafm(msym)
4521 :
4522 : !Local variables-------------------------------
4523 : !scalars
4524 : integer :: mpert,natom,nsym,ntypat
4525 : integer :: nsize,timrev
4526 : integer :: i1dir,i1pert,i2dir,i2pert,i3dir,i3pert
4527 : !arrays
4528 : !integer :: symq(4,2,msym)
4529 1960 : integer,allocatable :: symq(:,:,:)
4530 1960 : integer,allocatable :: car3flg(:,:,:,:,:,:),carflg(:,:,:,:)
4531 1960 : integer,allocatable :: tmpflg(:,:,:,:,:,:),rfpert(:,:,:,:,:,:)
4532 : real(dp) :: gprimd(3,3),qpt(3),rprimd(3,3)
4533 1960 : real(dp),allocatable :: d2cart(:,:,:,:,:),d3cart(:,:,:,:,:,:,:)
4534 1960 : real(dp),allocatable :: tmpval(:,:,:,:,:,:,:)
4535 : ! ************************************************************************
4536 :
4537 1960 : mpert = ddb%mpert
4538 1960 : natom = ddb%natom
4539 1960 : ntypat = crystal%ntypat
4540 :
4541 1960 : nsym = crystal%nsym
4542 25480 : rprimd(:,:) = crystal%rprimd(:,:)
4543 25480 : gprimd(:,:) = crystal%gprimd(:,:)
4544 :
4545 5880 : ABI_MALLOC(symq,(4,2,nsym))
4546 :
4547 : ! Here complete the matrix by symmetrisation of the existing elements
4548 1960 : if (ddb%typ(iblok) == BLKTYP_d2E_ns .or. ddb%typ(iblok) == BLKTYP_d2E_st) then
4549 :
4550 1881 : qpt(1)=ddb%qpt(1,iblok)/ddb%nrm(1,iblok)
4551 1881 : qpt(2)=ddb%qpt(2,iblok)/ddb%nrm(1,iblok)
4552 1881 : qpt(3)=ddb%qpt(3,iblok)/ddb%nrm(1,iblok)
4553 :
4554 : ! Examine the symmetries of the q wavevector
4555 1881 : call littlegroup_q(crystal%nsym,qpt,symq,crystal%symrec,crystal%symafm,timrev,prtvol=0)
4556 :
4557 : ! Deactuvate TRS for finite-omega calculations
4558 7521 : if (any(abs(ddb%omega(:,iblok)) > tol8)) timrev=0
4559 :
4560 : !GA: Note that d2sym3 and cart29 expect different shapes for tmpflg and tmpval
4561 : ! hence the extra dimensions
4562 1881 : nsize=3*mpert*3*mpert
4563 9405 : ABI_MALLOC(tmpflg,(3,mpert,3,mpert,1,1))
4564 9405 : ABI_MALLOC(tmpval,(2,3,mpert,3,mpert,1,1))
4565 :
4566 9405 : tmpflg(:,:,:,:,1,1) = reshape(ddb%flg(1:nsize,iblok), shape = (/3,mpert,3,mpert/))
4567 8191397 : tmpval(1,:,:,:,:,1,1) = reshape(ddb%val(1,1:nsize,iblok), shape = (/3,mpert,3,mpert/))
4568 8191397 : tmpval(2,:,:,:,:,1,1) = reshape(ddb%val(2,1:nsize,iblok), shape = (/3,mpert,3,mpert/))
4569 :
4570 : ! Then apply symmetry operations
4571 1881 : call d2sym3(tmpflg,tmpval,crystal%indsym,mpert,natom,nsym,qpt,symq,crystal%symrec,crystal%symrel,timrev,1)
4572 :
4573 : ! Transform the dynamical matrix in cartesian coordinates
4574 5643 : ABI_MALLOC(carflg,(3,mpert,3,mpert))
4575 5643 : ABI_MALLOC(d2cart,(2,3,mpert,3,mpert))
4576 :
4577 1881 : call cart29(tmpflg,tmpval,carflg,d2cart,gprimd,1,mpert,natom,1,ntypat,rprimd,crystal%typat,crystal%ucvol,crystal%zion)
4578 :
4579 6036606 : ddb%flg(1:nsize,iblok) = reshape(carflg,shape = (/3*mpert*3*mpert/))
4580 6036606 : ddb%val(1,1:nsize,iblok) = reshape(d2cart(1,:,:,:,:), shape = (/3*mpert*3*mpert/))
4581 6036606 : ddb%val(2,1:nsize,iblok) = reshape(d2cart(2,:,:,:,:), shape = (/3*mpert*3*mpert/))
4582 :
4583 1881 : ABI_FREE(carflg)
4584 1881 : ABI_FREE(d2cart)
4585 1881 : ABI_FREE(tmpflg)
4586 1881 : ABI_FREE(tmpval)
4587 :
4588 79 : else if (ddb%typ(iblok) == BLKTYP_d3E_xx) then
4589 :
4590 4 : nsize=3*mpert*3*mpert*3*mpert
4591 28 : ABI_MALLOC(tmpflg,(3,mpert,3,mpert,3,mpert))
4592 28 : ABI_MALLOC(tmpval,(2,3,mpert,3,mpert,3,mpert))
4593 16 : ABI_MALLOC(rfpert,(3,mpert,3,mpert,3,mpert))
4594 :
4595 28 : tmpflg(:,:,:,:,:,:) = reshape(ddb%flg(1:nsize,iblok), shape = (/3,mpert,3,mpert,3,mpert/))
4596 497068 : tmpval(1,:,:,:,:,:,:) = reshape(ddb%val(1,1:nsize,iblok), shape = (/3,mpert,3,mpert,3,mpert/))
4597 497068 : tmpval(2,:,:,:,:,:,:) = reshape(ddb%val(2,1:nsize,iblok), shape = (/3,mpert,3,mpert,3,mpert/))
4598 :
4599 : ! Set the elements that are zero by symmetry for raman and
4600 : ! non-linear optical susceptibility tensors
4601 497044 : rfpert = 0
4602 160 : rfpert(:,natom+2,:,natom+2,:,natom+2) = 1
4603 340 : rfpert(:,1:natom,:,natom+2,:,natom+2) = 1
4604 328 : rfpert(:,natom+2,:,1:natom,:,natom+2) = 1
4605 324 : rfpert(:,natom+2,:,natom+2,:,1:natom) = 1
4606 4 : call sytens(crystal%indsym,mpert,natom,nsym,rfpert,crystal%symrec,crystal%symrel)
4607 64 : do i1pert = 1,mpert
4608 964 : do i2pert = 1,mpert
4609 14460 : do i3pert = 1,mpert
4610 54900 : do i1dir=1,3
4611 175500 : do i2dir=1,3
4612 526500 : do i3dir=1,3
4613 364500 : if ((rfpert(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)==-2) .and. &
4614 121500 : (tmpflg(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)/=1)) then
4615 0 : tmpval(:,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = zero
4616 0 : tmpflg(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)=1
4617 : end if
4618 : end do
4619 : end do
4620 : end do
4621 : end do
4622 : end do
4623 : end do
4624 :
4625 4 : call d3sym(tmpflg,tmpval,crystal%indsym,mpert,natom,nsym,crystal%symrec,crystal%symrel)
4626 :
4627 16 : ABI_MALLOC(d3cart,(2,3,mpert,3,mpert,3,mpert))
4628 16 : ABI_MALLOC(car3flg,(3,mpert,3,mpert,3,mpert))
4629 :
4630 4 : call nlopt(tmpflg,car3flg,tmpval,d3cart,gprimd,mpert,natom,rprimd,crystal%ucvol)
4631 :
4632 364508 : ddb%flg(1:nsize,iblok) = reshape(car3flg, shape = (/3*mpert*3*mpert*3*mpert/))
4633 364508 : ddb%val(1,1:nsize,iblok) = reshape(d3cart(1,:,:,:,:,:,:), shape = (/3*mpert*3*mpert*3*mpert/))
4634 364508 : ddb%val(2,1:nsize,iblok) = reshape(d3cart(2,:,:,:,:,:,:), shape = (/3*mpert*3*mpert*3*mpert/))
4635 :
4636 4 : ABI_FREE(d3cart)
4637 4 : ABI_FREE(car3flg)
4638 4 : ABI_FREE(tmpflg)
4639 4 : ABI_FREE(tmpval)
4640 4 : ABI_FREE(rfpert)
4641 :
4642 75 : else if (ddb%typ(iblok) == BLKTYP_d3E_lw) then
4643 :
4644 9 : nsize=3*mpert*3*mpert*3*mpert
4645 63 : ABI_MALLOC(tmpflg,(3,mpert,3,mpert,3,mpert))
4646 63 : ABI_MALLOC(tmpval,(2,3,mpert,3,mpert,3,mpert))
4647 :
4648 63 : tmpflg(:,:,:,:,:,:) = reshape(ddb%flg(1:nsize,iblok), shape = (/3,mpert,3,mpert,3,mpert/))
4649 2012931 : tmpval(1,:,:,:,:,:,:) = reshape(ddb%val(1,1:nsize,iblok), shape = (/3,mpert,3,mpert,3,mpert/))
4650 2012931 : tmpval(2,:,:,:,:,:,:) = reshape(ddb%val(2,1:nsize,iblok), shape = (/3,mpert,3,mpert,3,mpert/))
4651 :
4652 36 : ABI_MALLOC(d3cart,(2,3,mpert,3,mpert,3,mpert))
4653 36 : ABI_MALLOC(car3flg,(3,mpert,3,mpert,3,mpert))
4654 :
4655 9 : call lwcart(tmpflg,car3flg,tmpval,d3cart,gprimd,mpert,natom,rprimd)
4656 :
4657 1483047 : ddb%flg(1:nsize,iblok) = reshape(car3flg, shape = (/3*mpert*3*mpert*3*mpert/))
4658 1483047 : ddb%val(1,1:nsize,iblok) = reshape(d3cart(1,:,:,:,:,:,:), shape = (/3*mpert*3*mpert*3*mpert/))
4659 1483047 : ddb%val(2,1:nsize,iblok) = reshape(d3cart(2,:,:,:,:,:,:), shape = (/3*mpert*3*mpert*3*mpert/))
4660 :
4661 9 : ABI_FREE(d3cart)
4662 9 : ABI_FREE(car3flg)
4663 9 : ABI_FREE(tmpflg)
4664 9 : ABI_FREE(tmpval)
4665 : end if
4666 :
4667 1960 : ABI_FREE(symq)
4668 :
4669 1960 : end subroutine ddb_symmetrize_and_transform
4670 : !!***
4671 :
4672 : !----------------------------------------------------------------------
4673 :
4674 : !!****f* m_ddb/ddb_diagoq
4675 : !! NAME
4676 : !! ddb_diagoq
4677 : !!
4678 : !! FUNCTION
4679 : !! Compute the phonon frequencies at the specified q-point by performing
4680 : !! a direct diagonalization of the dynamical matrix. The q-point **MUST** be
4681 : !! one the points stored in the DDB file.
4682 : !!
4683 : !! INPUTS
4684 : !! ddb<type(ddb_type)>=Object storing the DDB results.
4685 : !! crystal<type(crystal_t)> = Information on the crystalline structure.
4686 : !! asrq0<asrq0_t>=Object for the treatment of the ASR based on the q=0 block found in the DDB file.
4687 : !! symdynmat=If equal to 1, the dynamical matrix is symmetrized in dfpt_phfrq before the diagonalization.
4688 : !! rftyp = 1 if non-stationary block
4689 : !! 2 if stationary block
4690 : !! 3 if third order derivatives
4691 : !! qpt(3)=q-point in reduced coordinates.
4692 : !!
4693 : !! OUTPUT
4694 : !! phfrq(3*crystal%natom)=Phonon frequencies in Hartree
4695 : !! displ_cart(2,3*%natom,3*%natom)=Phonon displacement in Cartesian coordinates
4696 : !! [out_eigvec(2*3*natom*3*natom) = The igenvectors of the dynamical matrix.
4697 : !! [out_displ_red(2*3*natom*3*natom) = The displacement in reduced coordinates.
4698 : !!
4699 : !! SOURCE
4700 :
4701 0 : subroutine ddb_diagoq(ddb, crystal, qpt, asrq0, symdynmat, rftyp, phfrq, displ_cart, &
4702 0 : out_eigvec,out_displ_red) ! Optional [out]
4703 :
4704 : !Arguments -------------------------------
4705 : !scalars
4706 : integer,intent(in) :: symdynmat
4707 : integer,intent(in) :: rftyp
4708 : class(ddb_type),intent(in) :: ddb
4709 : type(asrq0_t),intent(inout) :: asrq0
4710 : type(crystal_t),intent(in) :: crystal
4711 : !arrays
4712 : real(dp),intent(in) :: qpt(3)
4713 : real(dp),intent(out) :: displ_cart(2,3,crystal%natom,3,crystal%natom)
4714 : real(dp),intent(out) :: phfrq(3*crystal%natom)
4715 : !real(dp),optional,intent(out) :: out_d2cart(2,3*crystal%natom,3*crystal%natom)
4716 : real(dp),optional,intent(out) :: out_eigvec(2,3,crystal%natom,3*crystal%natom)
4717 : real(dp),optional,intent(out) :: out_displ_red(2,3,crystal%natom,3*crystal%natom)
4718 :
4719 : !Local variables-------------------------------
4720 : integer :: iblok,natom
4721 : !arrays
4722 : integer :: rfphon(4),rfelfd(4),rfstrs(4)
4723 0 : real(dp) :: qphnrm(3), qphon_padded(3,3),d2cart(2,ddb%msize),my_qpt(3)
4724 0 : real(dp) :: eigvec(2,3,crystal%natom,3*crystal%natom),eigval(3*crystal%natom)
4725 : ! ************************************************************************
4726 :
4727 : ! Use my_qpt because dfpt_phfrq can change the q-point (very bad design)
4728 0 : qphnrm = one; my_qpt = qpt
4729 :
4730 : ! Look for the information in the DDB (no interpolation here!)
4731 0 : rfphon(1:2)=1; rfelfd(1:2)=0; rfstrs(1:2)=0
4732 0 : qphon_padded = zero; qphon_padded(:,1) = qpt
4733 0 : natom = crystal%natom
4734 :
4735 0 : call ddb%get_block(iblok, qphon_padded, qphnrm, rfphon, rfelfd, rfstrs, rftyp)
4736 0 : ABI_CHECK(iblok /= 0, sjoin("Cannot find q-point ", ktoa(qpt)," in DDB file"))
4737 :
4738 : ! Copy the dynamical matrix in d2cart
4739 0 : d2cart(:,1:ddb%msize) = ddb%val(:,:,iblok)
4740 :
4741 : ! Eventually impose the acoustic sum rule based on previously calculated d2asr
4742 0 : call asrq0%apply(natom, ddb%mpert, ddb%msize, qphon_padded, crystal, d2cart)
4743 :
4744 : ! Calculation of the eigenvectors and eigenvalues of the dynamical matrix
4745 : call dfpt_phfrq(ddb%amu,displ_cart,d2cart,eigval,eigvec,crystal%indsym,&
4746 : ddb%mpert,crystal%nsym,natom,crystal%nsym,crystal%ntypat,phfrq,qphnrm(1),my_qpt,&
4747 0 : crystal%rprimd,symdynmat,crystal%symrel,crystal%symafm,crystal%typat,crystal%ucvol)
4748 :
4749 : ! Return the dynamical matrix and the eigenvector for this q-point
4750 : !if (present(out_d2cart)) out_d2cart = d2cart(:,:3*natom,:3*natom)
4751 0 : if (present(out_eigvec)) out_eigvec = eigvec
4752 :
4753 : ! Return phonon displacement in reduced coordinates.
4754 0 : if (present(out_displ_red)) call phdispl_cart2red(natom, crystal%gprimd, displ_cart, out_displ_red)
4755 :
4756 0 : end subroutine ddb_diagoq
4757 : !!***
4758 :
4759 : !----------------------------------------------------------------------
4760 :
4761 : !!****f* m_ddb/asrq0_apply
4762 : !! NAME
4763 : !! asrq0_apply
4764 : !!
4765 : !! FUNCTION
4766 : !! Impose the acoustic sum rule based on the q=0 block found in the DDB file.
4767 : !!
4768 : !! INPUTS
4769 : !! asrq0<asrq0_t>=Object for the treatment of the ASR based on the q=0 block found in the DDB file.
4770 : !! natom=Number of atoms per unit cell.
4771 : !! mpert=Maximum number of perturbation (reported in ddb%mpert)
4772 : !! msize=Maximum size of array ddb%val
4773 : !! qphon(3,3)=wavevectors for the three possible phonons
4774 : !! crystal<type(crystal_t)> = Information on the crystalline structure.
4775 : !! dcdq=Moment of IFCs from Fourier transform
4776 : !! d2cdq=Second Moment of IFCs from Fourier transform
4777 : !! phi1=First Moment of IFCs from LW driver, if available
4778 : !! phi2=Second Moment of IFCs from LW driver summed of kappa', if available
4779 : !!
4780 : !! SIDE EFFECTS
4781 : !! d2cart=matrix of second derivatives of total energy, in cartesian coordinates
4782 : !! Input: Values stored in ddb%
4783 : !! Output: Changed to enforce ASR.
4784 : !!
4785 : !! SOURCE
4786 :
4787 222 : subroutine asrq0_apply(asrq0, natom, mpert, msize, qphon, crystal, d2cart)
4788 :
4789 : !Arguments -------------------------------
4790 : !scalars
4791 : class(asrq0_t),intent(inout) :: asrq0
4792 : type(crystal_t),intent(in) :: crystal
4793 : integer, intent(in) :: natom, mpert, msize
4794 : !arrays
4795 : real(dp),intent(in) :: qphon(3,3)
4796 : real(dp),intent(inout) :: d2cart(2,msize)
4797 : ! ************************************************************************
4798 :
4799 : ! TODO: Remove msize, since it can be inferred from mpert.
4800 :
4801 222 : if (asrq0%asr /= 0 .and. asrq0%iblok == 0) then
4802 0 : ABI_WARNING("asr != 0 but DDB file does not contain q=Gamma. D(q) cannot be corrected")
4803 0 : return
4804 : end if
4805 :
4806 : select case (asrq0%asr)
4807 : case (0)
4808 34 : return
4809 : case (1,2,5)
4810 34 : call asria_corr(asrq0%asr, asrq0%d2asr, d2cart, mpert, natom)
4811 : case (3,4)
4812 : ! Impose acoustic sum rule plus rotational symmetry for 0D and 1D systems
4813 22 : call asrprs(asrq0%asr,2,3,asrq0%uinvers,asrq0%vtinvers,asrq0%singular,d2cart,mpert,natom,crystal%xcart)
4814 : case (6)
4815 162 : call msria_apply(asrq0%asr,asrq0%d2asr,asrq0%d2dqmsr,d2cart,mpert,natom,qphon,crystal)
4816 : case default
4817 222 : ABI_ERROR(sjoin("Wrong value for asr:", itoa(asrq0%asr)))
4818 : end select
4819 : end subroutine asrq0_apply
4820 : !!***
4821 :
4822 : !----------------------------------------------------------------------
4823 :
4824 : !!****f* m_ddb/asrq0_free
4825 : !! NAME
4826 : !! asrq0_free
4827 : !!
4828 : !! FUNCTION
4829 : !! Free dynamic memory
4830 : !!
4831 : !! SOURCE
4832 :
4833 110 : subroutine asrq0_free(asrq0)
4834 :
4835 : !Arguments -------------------------------
4836 : class(asrq0_t),intent(inout) :: asrq0
4837 : ! ************************************************************************
4838 :
4839 : ! real
4840 110 : ABI_SFREE(asrq0%d2asr)
4841 110 : ABI_SFREE(asrq0%d2dqmsr)
4842 110 : ABI_SFREE(asrq0%d2dqdqmsr)
4843 110 : ABI_SFREE(asrq0%singular)
4844 110 : ABI_SFREE(asrq0%uinvers)
4845 110 : ABI_SFREE(asrq0%vtinvers)
4846 :
4847 110 : end subroutine asrq0_free
4848 : !!***
4849 :
4850 : !----------------------------------------------------------------------
4851 :
4852 : !!****f* m_ddb/ddb_write_block_txt
4853 : !!
4854 : !! NAME
4855 : !! ddb_write_block_txt
4856 : !!
4857 : !! FUNCTION
4858 : !! This routine writes blocks of data in the DDB in text format.
4859 : !!
4860 : !! INPUTS
4861 : !! choice= (2 => write), (3 => write minimal info )
4862 : !! mpert =maximum number of ipert
4863 : !! msize=maximum size of the arrays flags and values
4864 : !! nunit=unit number for the data block file
4865 : !!
4866 : !! OUTPUT
4867 : !! (see side effects)
4868 : !!
4869 : !! SIDE EFFECTS
4870 : !! Input/Output
4871 : !! ddb = ddb block datastructure
4872 : !! ddb%typ=type of the block:
4873 : !! 0 => total energy
4874 : !! 1 => second-order energy derivatives, non-stationary block
4875 : !! 2 => second-order energy derivatives, stationary block
4876 : !! 3 => third-order energy derivatives
4877 : !! 4 => first-order energy derivatives: forces, stresses and polarization
4878 : !! 5 => second-order eigenvalue derivatives
4879 : !! ddb%flg(msize)=flag for every matrix element (0=> the element is
4880 : !! not in the data block), (1=> the element is in the data blok)
4881 : !! ddb%qpt(9)=wavevector of the perturbation(s). The elements from
4882 : !! 1 to 3 are used if we are dealing with the 2nd derivative of
4883 : !! total energy (only one wavevector), while all elements are
4884 : !! used in case of a third order derivative of total energy
4885 : !! (three wavevector could be present)
4886 : !! ddb%nrm(3)=normalization factors for the three allowed wavevectors.
4887 : !! ddb%val(2,msize)=real(dp), complex, value of the
4888 : !! matrix elements that are present in the data block
4889 : !! blkval2(2,msize,mband,nkpt) = value of the matrix elements
4890 : !! that are present in a block of EIGR2D/EIGI2D
4891 : !!
4892 : !! NOTES
4893 : !! only executed by one processor.
4894 : !!
4895 : !! SOURCE
4896 :
4897 2645 : subroutine ddb_write_block_txt(ddb,iblok,choice,mband,mpert,msize,nkpt,nunit, &
4898 20 : blkval2,kpt) !optional
4899 :
4900 : !Arguments -------------------------------
4901 : !scalars
4902 : integer,intent(in) :: choice,mband,mpert,msize,nkpt,nunit
4903 : integer,intent(in) :: iblok
4904 : class(ddb_type),intent(in) :: ddb
4905 : !arrays
4906 : real(dp),intent(in),optional :: kpt(3,nkpt)
4907 : real(dp),intent(in),optional :: blkval2(2,msize,mband,nkpt)
4908 :
4909 : !Local variables -------------------------
4910 : !scalars
4911 : integer,parameter :: cvrsio9_new=20240201
4912 : integer :: iband,idir1,idir2,idir3,ii,ikpt,ipert1,ipert2,ipert3
4913 : integer :: nelmts
4914 : logical :: eig2d_
4915 : ! *********************************************************************
4916 :
4917 : ! GA: Remove choice option.
4918 : ! choice=3 is used to write summary info at the end of the DDB.
4919 : ! With MG and MV, we agreed that it could be removed.
4920 :
4921 : ! GA: Remove arguments: mband, blkval2, kpt
4922 : ! This feature of writing eigenvalues 2nd deriv is no longer used
4923 : ! (see 80_tdep/m_tdep_abitypes.F90)
4924 : ! With FB, we agreed that it could be removed.
4925 :
4926 2645 : eig2d_ = .false.
4927 2645 : if(present(blkval2).and.present(kpt)) eig2d_ = .true.
4928 :
4929 :
4930 : ! Count the number of elements
4931 2645 : nelmts=0
4932 7296329 : do ii=1,msize
4933 7296329 : if(ddb%flg(ii,iblok)==1)nelmts=nelmts+1
4934 : end do
4935 :
4936 : ! Write the block type and number of elements
4937 2645 : write(nunit,*)' '
4938 2645 : if (ddb%typ(iblok) == BLKTYP_d0E_xx) then
4939 48 : write(nunit, '(a,i12)' )' Total energy - # elements :',nelmts
4940 : else if (ddb%typ(iblok)==BLKTYP_d2E_ns) then
4941 2502 : write(nunit, '(a,i12)' )' 2nd derivatives (non-stat.) - # elements :',nelmts
4942 : else if(ddb%typ(iblok)==BLKTYP_d2E_st) then
4943 2 : write(nunit, '(a,i12)' )' 2nd derivatives (stationary) - # elements :',nelmts
4944 : else if(ddb%typ(iblok)==BLKTYP_d2E_mbc) then
4945 0 : write(nunit, '(a,i12)' )' 2nd derivatives (MBC) - # elements :',nelmts
4946 : else if(ddb%typ(iblok)==BLKTYP_d3E_xx) then
4947 3 : write(nunit, '(a,i12)' )' 3rd derivatives - # elements :',nelmts
4948 : else if (ddb%typ(iblok) == BLKTYP_d1E_xx) then
4949 48 : write(nunit, '(a,i12)' )' 1st derivatives - # elements :',nelmts
4950 : else if (ddb%typ(iblok) == BLKTYP_d2eig_re) then
4951 20 : write(nunit, '(a,i12)' )' 2nd eigenvalue derivatives - # elements :',nelmts
4952 : else if(ddb%typ(iblok)==BLKTYP_d3E_lw) then
4953 22 : write(nunit, '(a,i12)' )' 3rd derivatives (long wave) - # elements :',nelmts
4954 : end if
4955 :
4956 : ! Write the 2nd derivative block
4957 2645 : if (is_type_d2E(ddb%typ(iblok))) then
4958 :
4959 : ! Write the phonon wavevector
4960 10016 : write(nunit, '(a,3es16.8,f6.1)' )' qpt',(ddb%qpt(ii,iblok),ii=1,3),ddb%nrm(1,iblok)
4961 :
4962 : ! Write the perturbation frequency
4963 2504 : write(nunit, '(a,1es16.8)' )' frequency',ddb%omega(1,iblok)
4964 :
4965 : ! Write the matrix elements
4966 2504 : if(choice==2)then
4967 2504 : ii=0
4968 26334 : do ipert2=1,mpert
4969 97824 : do idir2=1,3
4970 895474 : do ipert1=1,mpert
4971 3272106 : do idir1=1,3
4972 2400462 : ii=ii+1
4973 3200616 : if(ddb%flg(ii,iblok)==1)then
4974 564810 : write(nunit,'(4i4,2d22.14)') idir1, ipert1, idir2, ipert2, &
4975 1129620 : ddb%val(1,ii,iblok),ddb%val(2,ii,iblok)
4976 : end if
4977 : end do
4978 : end do
4979 : end do
4980 : end do
4981 : end if
4982 :
4983 :
4984 141 : else if (is_type_d3E(ddb%typ(iblok))) then
4985 : ! Write the 3rd derivative block
4986 :
4987 : ! Write the phonon wavevectors
4988 100 : write(nunit, '(a,3es16.8,f6.1)' )' qpt',(ddb%qpt(ii,iblok),ii=1,3),ddb%nrm(1,iblok)
4989 100 : write(nunit, '(a,3es16.8,f6.1)' )' ',(ddb%qpt(ii,iblok),ii=4,6),ddb%nrm(2,iblok)
4990 100 : write(nunit, '(a,3es16.8,f6.1)' )' ',(ddb%qpt(ii,iblok),ii=7,9),ddb%nrm(3,iblok)
4991 :
4992 : ! Write the perturbation frequency
4993 25 : write(nunit, '(a,1es16.8)' )' frequency',ddb%omega(1,iblok)
4994 25 : write(nunit, '(a,1es16.8)' )' ',ddb%omega(2,iblok)
4995 25 : write(nunit, '(a,1es16.8)' )' ',ddb%omega(3,iblok)
4996 :
4997 : ! Write the matrix elements
4998 25 : if(choice==2)then
4999 25 : ii=0
5000 385 : do ipert3=1,mpert
5001 1465 : do idir3=1,3
5002 19140 : do ipert2=1,mpert
5003 71880 : do idir2=1,3
5004 1044366 : do ipert1=1,mpert
5005 3947364 : do idir1=1,3
5006 2920698 : ii=ii+1
5007 3894264 : if(ddb%flg(ii,iblok)==1)then
5008 : write(nunit, '(6i6,2d22.14)' )&
5009 3941 : idir1,ipert1,idir2,ipert2,idir3,ipert3,ddb%val(1,ii,iblok),ddb%val(2,ii,iblok)
5010 : end if
5011 : end do
5012 : end do
5013 : end do
5014 : end do
5015 : end do
5016 : end do
5017 : end if
5018 :
5019 :
5020 116 : else if (is_type_d0E(ddb%typ(iblok))) then
5021 : ! Write total energy
5022 48 : if (choice == 2) write(nunit,'(2d22.14)')ddb%val(1,1,iblok),ddb%val(2,1,iblok)
5023 :
5024 68 : else if (is_type_d1E(ddb%typ(iblok))) then
5025 : ! Write the 1st derivative blok
5026 48 : if (choice == 2) then
5027 48 : ii = 0
5028 459 : do ipert1 = 1, mpert
5029 1692 : do idir1 = 1, 3
5030 1233 : ii = ii + 1
5031 1644 : if (ddb%flg(ii,iblok) == 1) then
5032 603 : write(nunit,'(2i6,2d22.14)')idir1,ipert1,ddb%val(1,ii,iblok),ddb%val(2,ii,iblok)
5033 : end if
5034 : end do
5035 : end do
5036 : end if
5037 :
5038 20 : else if (is_type_d2eig(ddb%typ(iblok))) then
5039 : ! Write the phonon wavevector
5040 80 : write(nunit, '(a,3es16.8,f6.1)' )' qpt',(ddb%qpt(ii,iblok),ii=1,3),ddb%nrm(1,iblok)
5041 : ! Write the matrix elements
5042 : ! GA: Note that isppol is invisible here. It is simply marked as more bands.
5043 : ! To be changed in a future version of text format.
5044 20 : if(choice==2)then
5045 20 : if (eig2d_) then
5046 212 : do ikpt=1,nkpt
5047 192 : write(nunit,'(a,3es16.8)')' K-point:',(kpt(ii,ikpt),ii=1,3)
5048 1332 : do iband=1,mband
5049 1120 : write(nunit,'(a,i3)')' Band:',iband
5050 1120 : ii=0
5051 3296 : do ipert2=1,mpert
5052 9056 : do idir2=1,3
5053 19072 : do ipert1=1,mpert
5054 50496 : do idir1=1,3
5055 33408 : ii=ii+1
5056 44544 : if(ddb%flg(ii,iblok)==1)then
5057 33408 : write(nunit,'(4i4,2d22.14)')idir1,ipert1,idir2,ipert2,blkval2(1,ii,iband,ikpt),blkval2(2,ii,iband,ikpt)
5058 : end if
5059 : end do !idir1
5060 : end do !ipert1
5061 : end do !idir2
5062 : end do !ipert2
5063 : end do !iband
5064 : end do !ikpt
5065 : end if !eig2d_
5066 : end if !choice
5067 : end if !ddb%typ(iblok)
5068 :
5069 2645 : end subroutine ddb_write_block_txt
5070 : !!***
5071 :
5072 : !----------------------------------------------------------------------
5073 :
5074 : !!****f* m_ddb/ddb_write
5075 : !! NAME
5076 : !! ddb_write
5077 : !!
5078 : !! FUNCTION
5079 : !! Write the DDB file in either txt or netcdf format.
5080 : !!
5081 : !! INPUTS
5082 : !! ddb_hdr=ddb header object.
5083 : !! filename=name of the file being written (abo_DS*_DDB)
5084 : !! with_psps
5085 : !! 1-> include information on pseudopotentials
5086 : !! 0-> do not include information on pseudopotentials
5087 : !! comm=MPI communicator
5088 : !!
5089 : !! SOURCE
5090 :
5091 3287 : subroutine ddb_write(ddb, ddb_hdr, filename, with_psps, comm)
5092 :
5093 : !Arguments -------------------------------
5094 : class(ddb_type),intent(inout) :: ddb
5095 : type(ddb_hdr_type),intent(inout) :: ddb_hdr
5096 : character(len=fnlen),intent(in) :: filename
5097 : integer,intent(in),optional :: with_psps
5098 : integer,intent(in),optional :: comm
5099 :
5100 : !Local variables-------------------------------
5101 : character(len=fnlen) :: filename_
5102 : integer :: iomode
5103 : ! ************************************************************************
5104 :
5105 3287 : call ddb_hdr%get_iomode(filename, 2, iomode, filename_)
5106 :
5107 3287 : if (iomode==IO_MODE_ETSF) then
5108 3161 : call ddb%write_nc(ddb_hdr, filename_, comm=comm, with_psps=with_psps)
5109 126 : else if (iomode==IO_MODE_FORTRAN) then
5110 126 : call ddb%write_txt(ddb_hdr, filename_, with_psps=with_psps, comm=comm)
5111 126 : ddb_hdr%mpert = ddb%mpert ! Text format doesnt know about mpert.
5112 : end if
5113 :
5114 3287 : end subroutine ddb_write
5115 : !!***
5116 :
5117 : !----------------------------------------------------------------------
5118 :
5119 : !!****f* m_ddb/ddb_write_txt
5120 : !! NAME
5121 : !! ddb_write_txt
5122 : !!
5123 : !! FUNCTION
5124 : !! Write the DDB file in text format.
5125 : !!
5126 : !! INPUTS
5127 : !! ddb_hdr=ddb header object.
5128 : !! filename=name of the file being written (abo_DS*_DDB)
5129 : !! with_psps
5130 : !! 1-> include information on pseudopoentials
5131 : !! 0-> do not include information on pseudopoentials
5132 : !!
5133 : !! SOURCE
5134 :
5135 144 : subroutine ddb_write_txt(ddb, ddb_hdr, filename, with_psps, comm)
5136 :
5137 : !Arguments -------------------------------
5138 : class(ddb_type),intent(inout) :: ddb
5139 : type(ddb_hdr_type),intent(inout) :: ddb_hdr
5140 : character(len=*),intent(in) :: filename
5141 : integer,intent(in),optional :: with_psps
5142 : integer,intent(in),optional :: comm
5143 :
5144 : !Local variables -------------------------
5145 : !scalars
5146 : integer :: iblok
5147 : integer,parameter :: master=0, choice=2
5148 : ! ************************************************************************
5149 :
5150 144 : if (present(comm)) then
5151 0 : if (xmpi_comm_rank(comm) /= master) return
5152 : end if
5153 :
5154 144 : call ddb_hdr%open_write_txt(filename, with_psps)
5155 :
5156 2769 : do iblok=1,ddb%nblok
5157 2769 : call ddb%write_block_txt(iblok,choice,1,ddb%mpert,ddb%msize,ddb_hdr%nkpt,ddb_hdr%unddb)
5158 : end do
5159 :
5160 144 : call ddb_hdr%close()
5161 :
5162 : end subroutine ddb_write_txt
5163 : !!***
5164 :
5165 : !----------------------------------------------------------------------
5166 :
5167 : !!****f* m_ddb/ddb_write_d2eig
5168 : !! NAME
5169 : !! ddb_write_d2eig
5170 : !!
5171 : !! FUNCTION
5172 : !! Write the current eig2d data as the next block in the ddb file.
5173 : !!
5174 : !! INPUTS
5175 : !! ddb_hdr=ddb header object.
5176 : !! unddb=unit of the open ddb file in text format or netcdf identifier.
5177 : !!
5178 : !!
5179 : !! SOURCE
5180 :
5181 157 : subroutine ddb_write_d2eig(ddb, ddb_hdr, iblok, comm)
5182 : !Arguments -------------------------------
5183 : class(ddb_type),intent(inout) :: ddb
5184 : type(ddb_hdr_type),intent(inout) :: ddb_hdr
5185 : integer,intent(in) :: iblok
5186 : integer,intent(in),optional :: comm
5187 :
5188 : !Local variables -------------------------
5189 : !scalars
5190 : integer,parameter :: master=0
5191 : character(len=500) :: msg
5192 : ! ************************************************************************
5193 :
5194 157 : if (present(comm)) then
5195 112 : if (xmpi_comm_rank(comm) /= master) return
5196 : end if
5197 :
5198 137 : if (ddb_hdr%has_open_file_nc) then
5199 :
5200 117 : call ddb%write_d2eig_nc(ddb_hdr%ncid, iblok)
5201 :
5202 20 : else if (ddb_hdr%has_open_file_txt) then
5203 :
5204 20 : call ddb%write_d2eig_txt(ddb_hdr%unddb, iblok)
5205 :
5206 : else
5207 : write(msg, '(3a)' )&
5208 : ! File has not been opened by ddb_hdr
5209 0 : 'Attempting to write into unopen DDB file.',ch10,&
5210 0 : 'Action: contact Abinit group.'
5211 0 : ABI_ERROR(msg)
5212 : end if
5213 :
5214 : end subroutine ddb_write_d2eig
5215 : !!***
5216 :
5217 : !----------------------------------------------------------------------
5218 :
5219 : !!****f* m_ddb/ddb_write_d2eig_nc
5220 : !! NAME
5221 : !! ddb_write_d2eig_nc
5222 : !!
5223 : !! FUNCTION
5224 : !! Write the current d2eig data in the ddb netcdf file.
5225 : !!
5226 : !! INPUTS
5227 : !! iblok=index of the eig2d block within the d2eig subgroup.
5228 : !! ncid=netcdf identifier of a file open in writing mode.
5229 : !! comm=MPI communicator.
5230 : !!
5231 : !! SOURCE
5232 :
5233 117 : subroutine ddb_write_d2eig_nc(ddb, ncid, iblok, comm)
5234 : !Arguments -------------------------------
5235 : class(ddb_type),intent(inout) :: ddb
5236 : integer,intent(in) :: ncid
5237 : integer,intent(in) :: iblok
5238 : integer,intent(in),optional :: comm
5239 :
5240 : !Local variables -------------------------
5241 : !scalars
5242 : integer,parameter :: master=0
5243 : integer :: iband, jband, bandshift, isppol, mband
5244 : integer :: ikpt, ipert1, idir1, ipert2, idir2, ii
5245 : integer :: ncid_d2eig, ncerr
5246 : real(dp) :: qpt(3)
5247 117 : real(dp), allocatable :: matrix_d2eig(:,:,:,:,:,:,:)
5248 117 : real(dp), allocatable :: matrix_d2eig_isppol(:,:,:,:,:,:,:)
5249 117 : integer, allocatable :: flg_d2eig(:,:,:,:)
5250 : ! ************************************************************************
5251 :
5252 :
5253 117 : if (present(comm)) then
5254 0 : if (xmpi_comm_rank(comm) /= master) return
5255 : end if
5256 :
5257 117 : ncid_d2eig = nctk_idgroup(ncid, 'd2eig')
5258 :
5259 468 : qpt(1:3) = ddb%qpt(1:3,iblok)
5260 : ncerr = nf90_put_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5261 : 'reduced_coordinates_of_qpoints'),&
5262 : qpt,&
5263 351 : start=[1,iblok])
5264 117 : NCF_CHECK(ncerr)
5265 : ncerr = nf90_put_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5266 : 'qpoints_normalization'),&
5267 : ddb%nrm(1,iblok),&
5268 234 : start=[iblok])
5269 117 : NCF_CHECK(ncerr)
5270 :
5271 : ! GA: Here we assume that all blocks are d2eig blocks.
5272 : ! Otherwise, iblok is only the 'local' iblok index
5273 : ! and we would need to figure out the corresponding 'global' index
5274 117 : call ddb%get_d2eig(matrix_d2eig, flg_d2eig, iblok)
5275 :
5276 117 : mband = ddb%nband / ddb%nsppol
5277 819 : ABI_MALLOC(matrix_d2eig_isppol, (2,3,ddb%mpert,3,ddb%mpert,mband,ddb%nkpt))
5278 :
5279 : ! Loop over spin index
5280 235 : do isppol=1,ddb%nsppol
5281 :
5282 118 : bandshift = (isppol - 1) * mband
5283 :
5284 1214 : do iband=1,mband
5285 1096 : jband = bandshift + iband
5286 :
5287 18064 : do ikpt=1,ddb%nkpt
5288 51518 : do ipert1=1,ddb%mpert
5289 151138 : do idir1=1,3
5290 343400 : do ipert2=1,ddb%mpert
5291 937164 : do idir2=1,3
5292 2091120 : do ii=1,2
5293 : matrix_d2eig_isppol(ii,idir2,ipert2,idir1,ipert1,iband,ikpt)=&
5294 1882008 : matrix_d2eig(ii,idir2,ipert2,idir1,ipert1,jband,ikpt)
5295 : end do
5296 : end do
5297 : end do
5298 : end do
5299 : end do
5300 : end do
5301 :
5302 :
5303 : end do ! iband
5304 :
5305 : ncerr = nf90_put_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5306 : 'matrix_values'),&
5307 : matrix_d2eig_isppol,&
5308 1180 : start=[1,1,1,1,1,1,1,isppol,iblok])
5309 : !count=[2,3,ddb%mpert,3,ddb%mpert,ddb%nband,ddb%nkpt,1,1])
5310 : !count=[2,3,ddb%mpert,3,ddb%mpert,ddb%nkpt,ddb%nband,1,1])
5311 235 : NCF_CHECK(ncerr)
5312 :
5313 : end do ! isppol
5314 :
5315 : ncerr = nf90_put_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5316 : 'matrix_mask'),&
5317 : flg_d2eig,&
5318 702 : start=[1,1,1,1,iblok])
5319 117 : NCF_CHECK(ncerr)
5320 :
5321 117 : ABI_SFREE(matrix_d2eig_isppol)
5322 117 : ABI_SFREE(matrix_d2eig)
5323 117 : ABI_SFREE(flg_d2eig)
5324 :
5325 117 : end subroutine ddb_write_d2eig_nc
5326 : !!***
5327 :
5328 : !----------------------------------------------------------------------
5329 :
5330 :
5331 : !!****f* m_ddb/ddb_write_d2eig_txt
5332 : !! NAME
5333 : !! ddb_write_d2eig_txt
5334 : !!
5335 : !! FUNCTION
5336 : !! Write the eig2d data as the next block in text file format.
5337 : !!
5338 : !! INPUTS
5339 : !! ddb_hdr=ddb header object.
5340 : !! unddb=unit of the open ddb file in text format.
5341 : !!
5342 : !!
5343 : !! SOURCE
5344 :
5345 20 : subroutine ddb_write_d2eig_txt(ddb, unddb, iblok)
5346 : !Arguments -------------------------------
5347 : class(ddb_type),intent(in) :: ddb
5348 : integer,intent(in) :: unddb
5349 : integer,intent(in) :: iblok
5350 :
5351 : !Local variables -------------------------
5352 : !scalars
5353 : integer,parameter :: iblok_eig2d=1
5354 : integer,parameter :: choice=2
5355 : ! ************************************************************************
5356 :
5357 : ! GA: This routine is redundant with outbsd.
5358 : ! The present implementation should replace outbsd.
5359 :
5360 : call ddb%write_block_txt(iblok,choice,ddb%nband,ddb%mpert,ddb%msize,ddb%nkpt,unddb, &
5361 20 : ddb%eig2dval(:,:,:,:), ddb%kpt(:,:))
5362 :
5363 20 : end subroutine ddb_write_d2eig_txt
5364 : !!***
5365 :
5366 : !----------------------------------------------------------------------
5367 :
5368 : !!****f* m_ddb/ddb_write_nc
5369 : !! NAME
5370 : !! ddb_write_nc
5371 : !!
5372 : !! FUNCTION
5373 : !! Write the netndf file DDB.nc in the format of version 20230219.
5374 : !!
5375 : !! INPUTS
5376 : !! ddb_hdr=ddb header object with open file.
5377 : !! filename=DDB filename.
5378 : !! comm=MPI communicator.
5379 : !! with_psps
5380 : !! 1-> include information on pseudopoentials
5381 : !! 0-> do not include information on pseudopoentials
5382 : !!
5383 : !! SOURCE
5384 :
5385 3162 : subroutine ddb_write_nc(ddb, ddb_hdr, filename, comm, with_psps)
5386 :
5387 : !Arguments -------------------------------
5388 : class(ddb_type),intent(inout) :: ddb
5389 : type(ddb_hdr_type),intent(inout) :: ddb_hdr
5390 : character(len=*),intent(in) :: filename
5391 : integer,intent(in),optional :: comm
5392 : integer,intent(in),optional :: with_psps
5393 :
5394 : !Local variables -------------------------
5395 : !scalars
5396 : integer,parameter :: master=0
5397 : integer :: ncid, ncerr, ncid_d0E, ncid_d1E, ncid_d2E, ncid_d3E, ncid_d2eig
5398 : integer :: ii,iblok,iblok_d0E,iblok_d1E,iblok_d2E,iblok_d3E,iblok_d2eig
5399 : !arrays
5400 3162 : integer,allocatable :: flg_d1E(:,:)
5401 3162 : integer,allocatable :: flg_d2E(:,:,:,:)
5402 3162 : integer,allocatable :: flg_d3E(:,:,:,:,:,:)
5403 : real(dp) :: qpt(3), qpts(3,3), nrms(3)
5404 : real(dp) :: omega, omegas(3)
5405 3162 : real(dp),allocatable :: matrix_d1E(:,:,:)
5406 3162 : real(dp),allocatable :: matrix_d2E(:,:,:,:,:)
5407 3162 : real(dp),allocatable :: matrix_d3E(:,:,:,:,:,:,:)
5408 : ! ************************************************************************
5409 :
5410 3162 : if (present(comm)) then
5411 0 : if (xmpi_comm_rank(comm) /= master) return
5412 : end if
5413 :
5414 : ! =====================
5415 : ! Header and dimensions
5416 : ! =====================
5417 : ! Copy types and dimensions into the header
5418 3162 : ddb_hdr%mpert = ddb%mpert
5419 3162 : call ddb_hdr%set_typ(ddb%nblok, ddb%typ)
5420 :
5421 3162 : call ddb_hdr%open_write_nc(filename, with_psps=with_psps)
5422 3162 : ncid = ddb_hdr%ncid
5423 :
5424 : ! Get all group id
5425 3162 : ncid_d0E = nctk_idgroup(ncid, 'd0E')
5426 3162 : ncid_d1E = nctk_idgroup(ncid, 'd1E')
5427 3162 : ncid_d2E = nctk_idgroup(ncid, 'd2E')
5428 3162 : ncid_d3E = nctk_idgroup(ncid, 'd3E')
5429 3162 : ncid_d2eig = nctk_idgroup(ncid, 'd2eig')
5430 :
5431 : ! =============================
5432 : ! Loop over block to be written
5433 : ! =============================
5434 :
5435 3162 : iblok_d0E = 0; iblok_d1E = 0; iblok_d2E = 0; iblok_d3E = 0; iblok_d2eig = 0
5436 :
5437 9053 : do iblok=1,ddb%nblok
5438 :
5439 : ! ------------------------
5440 : ! Zeroth-order derivatives
5441 : ! ------------------------
5442 9053 : if (is_type_d0E(ddb%typ(iblok))) then
5443 :
5444 2712 : iblok_d0E = iblok_d0E + 1
5445 :
5446 : ncerr = nf90_put_var(ncid_d0E, nctk_idname(ncid_d0E,&
5447 : 'matrix_values'),&
5448 : ddb%val(1,1,iblok),&
5449 5424 : start=[iblok_d0E])
5450 2712 : NCF_CHECK(ncerr)
5451 :
5452 : ncerr = nf90_put_var(ncid_d0E, nctk_idname(ncid_d0E,&
5453 : 'matrix_mask'),&
5454 : ddb%flg(1,iblok),&
5455 5424 : start=[iblok_d0E])
5456 2712 : NCF_CHECK(ncerr)
5457 :
5458 : ! -----------------------
5459 : ! First-order derivatives
5460 : ! -----------------------
5461 3179 : else if (is_type_d1E(ddb%typ(iblok))) then
5462 :
5463 2719 : iblok_d1E = iblok_d1E + 1
5464 :
5465 2719 : call ddb%get_d1matr(iblok, matrix_d1E, flg_d1E)
5466 :
5467 : ncerr = nf90_put_var(ncid_d1E, nctk_idname(ncid_d1E,&
5468 : 'matrix_values'),&
5469 : matrix_d1E,&
5470 13595 : start=[1,1,1,iblok_d1E])
5471 2719 : NCF_CHECK(ncerr)
5472 :
5473 : ncerr = nf90_put_var(ncid_d1E, nctk_idname(ncid_d1E,&
5474 : 'matrix_mask'),&
5475 : flg_d1E,&
5476 10876 : start=[1,1,iblok_d1E])
5477 2719 : NCF_CHECK(ncerr)
5478 2719 : ABI_SFREE(matrix_d1E)
5479 2719 : ABI_SFREE(flg_d1E)
5480 :
5481 : ! ------------------------
5482 : ! Second-order derivatives
5483 : ! ------------------------
5484 460 : else if (is_type_d2E(ddb%typ(iblok))) then
5485 :
5486 436 : iblok_d2E = iblok_d2E + 1
5487 :
5488 1744 : do ii=1,3
5489 1744 : qpt(ii) = ddb%qpt(ii,iblok)
5490 : end do
5491 : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5492 : 'reduced_coordinates_of_qpoints'),&
5493 : qpt,&
5494 1308 : start=[1,iblok_d2E])
5495 436 : NCF_CHECK(ncerr)
5496 :
5497 : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5498 : 'qpoints_normalization'),&
5499 : (ddb%nrm(1,iblok)),&
5500 872 : start=[iblok_d2E])
5501 436 : NCF_CHECK(ncerr)
5502 :
5503 436 : omega = ddb%omega(1,iblok)
5504 : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5505 : 'frequency'),&
5506 : omega,&
5507 872 : start=[iblok_d2E])
5508 436 : NCF_CHECK(ncerr)
5509 :
5510 436 : call ddb%get_d2matr(iblok, matrix_d2E, flg_d2E)
5511 :
5512 : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5513 : 'matrix_values'),&
5514 : matrix_d2E,&
5515 3052 : start=[1,1,1,1,1,iblok_d2E])
5516 436 : NCF_CHECK(ncerr)
5517 :
5518 : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5519 : 'matrix_mask'),&
5520 : flg_d2E,&
5521 2616 : start=[1,1,1,1,iblok_d2E])
5522 436 : NCF_CHECK(ncerr)
5523 436 : ABI_SFREE(matrix_d2E)
5524 436 : ABI_SFREE(flg_d2E)
5525 :
5526 : ! -----------------------
5527 : ! Third-order derivatives
5528 : ! -----------------------
5529 24 : else if (is_type_d3E(ddb%typ(iblok))) then
5530 :
5531 24 : iblok_d3E = iblok_d3E + 1
5532 :
5533 96 : do ii=1,3
5534 72 : nrms(ii) = ddb%nrm(ii,iblok)
5535 72 : qpts(1,ii) = ddb%qpt(ii,iblok)
5536 72 : qpts(2,ii) = ddb%qpt(ii+3,iblok)
5537 96 : qpts(3,ii) = ddb%qpt(ii+6,iblok)
5538 : end do
5539 :
5540 : ncerr = nf90_put_var(ncid_d3E, nctk_idname(ncid_d3E,&
5541 : 'reduced_coordinates_of_qpoints'),&
5542 : qpts,&
5543 96 : start=[1,1,iblok_d3E])
5544 24 : NCF_CHECK(ncerr)
5545 :
5546 : ncerr = nf90_put_var(ncid_d3E, nctk_idname(ncid_d3E,&
5547 : 'qpoints_normalization'),&
5548 : nrms,&
5549 72 : start=[1,iblok_d3E])
5550 24 : NCF_CHECK(ncerr)
5551 :
5552 24 : omegas(1) = ddb%omega(1,iblok)
5553 24 : omegas(2) = ddb%omega(2,iblok)
5554 24 : omegas(3) = ddb%omega(3,iblok)
5555 :
5556 :
5557 : ncerr = nf90_put_var(ncid_d3E, nctk_idname(ncid_d3E,&
5558 : 'frequency'),&
5559 : omegas,&
5560 72 : start=[1,iblok_d3E])
5561 24 : NCF_CHECK(ncerr)
5562 :
5563 24 : call ddb%get_d3matr(iblok, matrix_d3E, flg_d3E)
5564 :
5565 : ncerr = nf90_put_var(ncid_d3E, nctk_idname(ncid_d3E,&
5566 : 'matrix_values'),&
5567 : matrix_d3E,&
5568 216 : start=[1,1,1,1,1,1,1,iblok_d3E])
5569 24 : NCF_CHECK(ncerr)
5570 :
5571 : ncerr = nf90_put_var(ncid_d3E, nctk_idname(ncid_d3E,&
5572 : 'matrix_mask'),&
5573 : flg_d3E,&
5574 192 : start=[1,1,1,1,1,1,iblok_d3E])
5575 24 : NCF_CHECK(ncerr)
5576 :
5577 24 : ABI_SFREE(matrix_d3E)
5578 24 : ABI_SFREE(flg_d3E)
5579 :
5580 : ! ---------------------------------------
5581 : ! Second-order derivatives of eigenvalues
5582 : ! ---------------------------------------
5583 0 : else if (is_type_d2eig(ddb%typ(iblok))) then
5584 :
5585 0 : iblok_d2eig = iblok_d2eig + 1
5586 :
5587 0 : call ddb%write_d2eig_nc(ncid_d2eig, iblok_d2eig)
5588 :
5589 : end if
5590 : end do
5591 :
5592 3162 : end subroutine ddb_write_nc
5593 : !!***
5594 :
5595 : !----------------------------------------------------------------------
5596 :
5597 : !!****f* m_ddb/ddb_read_d0E_nc
5598 : !! NAME
5599 : !! ddb_read_d0E_nc
5600 : !!
5601 : !! FUNCTION
5602 : !! Read a DDB block containing 0th order derivatives of energy.
5603 : !!
5604 : !!
5605 : !! INPUTS
5606 : !! ncid=netcdf identifier of a file open in reading mode.
5607 : !! iblok=index of the block we are setting.
5608 : !! iblok_d0E=index of the block we are reading in the d0E group.
5609 : !!
5610 : !! OUTPUT
5611 : !!
5612 : !! SOURCE
5613 :
5614 6 : subroutine ddb_read_d0E_nc(ddb, ncid, iblok, iblok_d0E)
5615 :
5616 : !Arguments -------------------------------
5617 : !scalars
5618 : class(ddb_type),intent(inout) :: ddb
5619 : integer,intent(in) :: ncid,iblok,iblok_d0E
5620 :
5621 : !Local variables -------------------------
5622 : !scalars
5623 : integer :: ncid_d0E
5624 : integer :: ncerr
5625 : !arrays
5626 : integer :: flg(1)
5627 : real(dp) :: val(1)
5628 : ! ************************************************************************
5629 :
5630 6 : ncid_d0E = nctk_idgroup(ncid, 'd0E')
5631 :
5632 : ! Allocate temporary arrays
5633 24 : ncerr = nf90_get_var(ncid_d0E, nctk_idname(ncid_d0E, 'matrix_values'), val, start=[1,1,iblok_d0E], count=[1,1,1])
5634 6 : NCF_CHECK(ncerr)
5635 6 : ddb%val(1,1,iblok) = val(1)
5636 6 : ddb%val(2,1,iblok) = zero
5637 18 : ncerr = nf90_get_var(ncid_d0E, nctk_idname(ncid_d0E, 'matrix_mask'), flg, start=[1,iblok_d0E], count=[1,1])
5638 6 : NCF_CHECK(ncerr)
5639 6 : ddb%flg(1,iblok) = flg(1)
5640 :
5641 6 : end subroutine ddb_read_d0E_nc
5642 : !!***
5643 :
5644 : !----------------------------------------------------------------------
5645 :
5646 : !!****f* m_ddb/ddb_read_d1E_nc
5647 : !! NAME
5648 : !! ddb_read_d1E_nc
5649 : !!
5650 : !! FUNCTION
5651 : !! Read a DDB block containing 1st order derivatives of energy.
5652 : !!
5653 : !!
5654 : !! INPUTS
5655 : !! ncid=netcdf identifier of a file open in reading mode.
5656 : !! iblok=index of the block we are setting.
5657 : !! iblok_d1E=index of the block we are reading in the d1E group.
5658 : !!
5659 : !! OUTPUT
5660 : !!
5661 : !! SOURCE
5662 :
5663 10 : subroutine ddb_read_d1E_nc(ddb, ncid, iblok, iblok_d1E)
5664 :
5665 : !Arguments -------------------------------
5666 : !scalars
5667 : class(ddb_type),intent(inout) :: ddb
5668 : integer,intent(in) :: ncid,iblok,iblok_d1E
5669 :
5670 : !Local variables -------------------------
5671 : !scalars
5672 : integer :: ncid_d1E
5673 : integer :: ncerr
5674 : !arrays
5675 : integer,allocatable :: flg_d1E(:,:)
5676 : real(dp),allocatable :: matrix_d1E(:,:,:)
5677 : ! ************************************************************************
5678 :
5679 10 : ncid_d1E = nctk_idgroup(ncid, 'd1E')
5680 :
5681 : ! Allocate temporary arrays
5682 30 : ABI_MALLOC(matrix_d1E, (2,3,ddb%mpert))
5683 30 : ABI_MALLOC(flg_d1E, (3,ddb%mpert))
5684 :
5685 50 : ncerr = nf90_get_var(ncid_d1E, nctk_idname(ncid_d1E, 'matrix_values'), matrix_d1E, start=[1,1,1,iblok_d1E])
5686 10 : NCF_CHECK(ncerr)
5687 40 : ncerr = nf90_get_var(ncid_d1E, nctk_idname(ncid_d1E, 'matrix_mask'), flg_d1E, start=[1,1,iblok_d1E])
5688 10 : NCF_CHECK(ncerr)
5689 :
5690 : ! Reshape
5691 10 : call ddb%set_d1matr(iblok, matrix_d1E, flg_d1E)
5692 :
5693 : ! Free memory
5694 10 : ABI_FREE(matrix_d1E)
5695 10 : ABI_FREE(flg_d1E)
5696 :
5697 10 : end subroutine ddb_read_d1E_nc
5698 : !!***
5699 :
5700 : !----------------------------------------------------------------------
5701 :
5702 : !!****f* m_ddb/ddb_read_d2E_nc
5703 : !! NAME
5704 : !! ddb_read_d2E_nc
5705 : !!
5706 : !! FUNCTION
5707 : !! Read a DDB block containing 2nd order derivatives of energy.
5708 : !!
5709 : !! INPUTS
5710 : !! ncid=netcdf identifier of a file open in reading mode.
5711 : !! iblok=index of the block we are setting.
5712 : !! iblok_d2E=index of the block we are reading in the d2E group.
5713 : !!
5714 : !! OUTPUT
5715 : !!
5716 : !! SOURCE
5717 :
5718 148 : subroutine ddb_read_d2E_nc(ddb, ncid, iblok, iblok_d2E, ddb_version)
5719 :
5720 : !Arguments -------------------------------
5721 : !scalars
5722 : class(ddb_type),intent(inout) :: ddb
5723 : integer,intent(in) :: ncid,iblok,iblok_d2E
5724 : integer,intent(in) :: ddb_version
5725 :
5726 : !Local variables -------------------------
5727 : !scalars
5728 : integer :: ncid_d2E
5729 : integer :: ncerr
5730 : integer, parameter :: cvrsio9_new=20240201
5731 : !arrays
5732 : real(dp) :: qpt(3)
5733 : integer,allocatable :: flg_d2E(:,:,:,:)
5734 : real(dp),allocatable :: matrix_d2E(:,:,:,:,:)
5735 : ! ************************************************************************
5736 :
5737 148 : ncid_d2E = nctk_idgroup(ncid, 'd2E')
5738 :
5739 : ! Allocate temporary arrays
5740 740 : ABI_MALLOC(matrix_d2E, (2,3,ddb%mpert,3,ddb%mpert))
5741 740 : ABI_MALLOC(flg_d2E, (3,ddb%mpert,3,ddb%mpert))
5742 :
5743 444 : ncerr = nf90_get_var(ncid_d2E, nctk_idname(ncid_d2E, 'reduced_coordinates_of_qpoints'), qpt, start=[1,iblok_d2E])
5744 148 : NCF_CHECK(ncerr)
5745 592 : ddb%qpt(1:3,iblok) = qpt(:)
5746 296 : ncerr = nf90_get_var(ncid_d2E, nctk_idname(ncid_d2E, 'qpoints_normalization'), ddb%nrm(1,iblok), start=[iblok_d2E])
5747 148 : NCF_CHECK(ncerr)
5748 : ! Read the perturbation frequency
5749 148 : if (ddb_version>=cvrsio9_new) then
5750 296 : ncerr = nf90_get_var(ncid_d2E, nctk_idname(ncid_d2E, 'frequency'), ddb%omega(1,iblok), start=[iblok_d2E])
5751 148 : NCF_CHECK(ncerr)
5752 : else
5753 0 : ddb%omega(1,iblok)=0.d0
5754 : end if
5755 444 : ddb%omega(2:3,iblok)=0.d0
5756 :
5757 1036 : ncerr = nf90_get_var(ncid_d2E, nctk_idname(ncid_d2E, 'matrix_values'), matrix_d2E, start=[1,1,1,1,1,iblok_d2E])
5758 148 : NCF_CHECK(ncerr)
5759 888 : ncerr = nf90_get_var(ncid_d2E, nctk_idname(ncid_d2E, 'matrix_mask'), flg_d2E, start=[1,1,1,1,iblok_d2E])
5760 148 : NCF_CHECK(ncerr)
5761 :
5762 : ! Reshape
5763 148 : call ddb%set_d2matr(iblok, matrix_d2E, flg_d2E)
5764 :
5765 : ! Free memory
5766 148 : ABI_FREE(matrix_d2E)
5767 148 : ABI_FREE(flg_d2E)
5768 :
5769 148 : end subroutine ddb_read_d2E_nc
5770 : !!***
5771 :
5772 : !----------------------------------------------------------------------
5773 :
5774 : !!****f* m_ddb/ddb_read_d3E_nc
5775 : !! NAME
5776 : !! ddb_read_d3E_nc
5777 : !!
5778 : !! FUNCTION
5779 : !! Read a DDB block containing 3rd order derivatives of energy.
5780 : !!
5781 : !! INPUTS
5782 : !! ncid=netcdf identifier of a file open in reading mode.
5783 : !! iblok=index of the block we are setting.
5784 : !! iblok_d3E=index of the block we are reading in the d3E group.
5785 : !!
5786 : !! OUTPUT
5787 : !!
5788 : !! SOURCE
5789 :
5790 3 : subroutine ddb_read_d3E_nc(ddb, ncid, iblok, iblok_d3E, ddb_version)
5791 :
5792 : !Arguments -------------------------------
5793 : !scalars
5794 : class(ddb_type),intent(inout) :: ddb
5795 : integer,intent(in) :: ncid,iblok,iblok_d3E
5796 : integer,intent(in) :: ddb_version
5797 :
5798 : !Local variables -------------------------
5799 : !scalars
5800 : integer :: blktyp
5801 : integer :: ncid_d3E
5802 : integer :: ncerr
5803 : integer, parameter :: cvrsio9_new=20240201
5804 : !arrays
5805 : real(dp) :: qpt(3), nrm(3), omega(3)
5806 : real(dp),allocatable :: matrix_d3E(:,:,:,:,:,:,:)
5807 : integer,allocatable :: flg_d3E(:,:,:,:,:,:)
5808 : ! ************************************************************************
5809 :
5810 3 : ncid_d3E = nctk_idgroup(ncid, 'd3E')
5811 :
5812 : ! Allocate temporary arrays
5813 21 : ABI_MALLOC(matrix_d3E, (2,3,ddb%mpert,3,ddb%mpert,3,ddb%mpert))
5814 21 : ABI_MALLOC(flg_d3E, (3,ddb%mpert,3,ddb%mpert,3,ddb%mpert))
5815 :
5816 12 : ncerr = nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'reduced_coordinates_of_qpoints'),qpt,start=[1,1,iblok_d3E],count=[1,3,1])
5817 3 : NCF_CHECK(ncerr)
5818 12 : ddb%qpt(1:3,iblok) = qpt(:)
5819 :
5820 12 : ncerr = nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'reduced_coordinates_of_qpoints'),qpt,start=[2,1,iblok_d3E],count=[1,3,1])
5821 3 : NCF_CHECK(ncerr)
5822 12 : ddb%qpt(4:6,iblok) = qpt(:)
5823 :
5824 12 : ncerr = nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'reduced_coordinates_of_qpoints'),qpt,start=[3,1,iblok_d3E],count=[1,3,1])
5825 3 : NCF_CHECK(ncerr)
5826 12 : ddb%qpt(7:9,iblok) = qpt(:)
5827 :
5828 9 : ncerr = nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'qpoints_normalization'), nrm, start=[1,iblok_d3E],count=[3,1])
5829 3 : NCF_CHECK(ncerr)
5830 12 : ddb%nrm(:,iblok) = nrm(:)
5831 3 : if (ddb_version>=cvrsio9_new) then
5832 9 : ncerr = nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'frequency'),omega,start=[1,iblok_d3E],count=[3,1])
5833 3 : NCF_CHECK(ncerr)
5834 12 : ddb%omega(1:3,iblok)=omega(:)
5835 : else
5836 0 : ddb%omega(:,iblok)=0.d0
5837 : end if
5838 :
5839 27 : NCF_CHECK(nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'matrix_values'), matrix_d3E, start=[1,1,1,1,1,1,1,iblok_d3E]))
5840 24 : NCF_CHECK(nf90_get_var(ncid_d3E, nctk_idname(ncid_d3E, 'matrix_mask'), flg_d3E, start=[1,1,1,1,1,1,iblok_d3E]))
5841 :
5842 :
5843 3 : blktyp = ddb%typ(iblok) ! Save block type so it doesnt get overwritten.
5844 :
5845 3 : call ddb%set_d3matr(iblok, matrix_d3E, flg_d3E)
5846 :
5847 3 : ddb%typ(iblok) = blktyp
5848 :
5849 : ! Free memory
5850 3 : ABI_FREE(matrix_d3E)
5851 3 : ABI_FREE(flg_d3E)
5852 :
5853 3 : end subroutine ddb_read_d3E_nc
5854 : !!***
5855 :
5856 : !----------------------------------------------------------------------
5857 :
5858 : !!****f* m_ddb/ddb_read_d2eig_nc
5859 : !! NAME
5860 : !! ddb_read_d2eig_nc
5861 : !!
5862 : !! FUNCTION
5863 : !! Read a DDB block containing 2nd order derivatives of eigenvalues.
5864 : !!
5865 : !! INPUTS
5866 : !! ncid=netcdf identifier of a file open in reading mode.
5867 : !! iblok=index of the block we are setting.
5868 : !! iblok_d2eig=index of the block we are reading in the d2eig group.
5869 : !!
5870 : !! OUTPUT
5871 : !!
5872 : !! SOURCE
5873 :
5874 44 : subroutine ddb_read_d2eig_nc(ddb, ncid, iblok, iblok_d2eig)
5875 :
5876 : !Arguments -------------------------------
5877 : !scalars
5878 : class(ddb_type),intent(inout) :: ddb
5879 : integer,intent(in) :: ncid,iblok
5880 : integer,intent(in),optional :: iblok_d2eig
5881 :
5882 : !Local variables -------------------------
5883 : !scalars
5884 : integer :: ncid_d2eig,ncerr
5885 : integer :: nkpt_file
5886 : integer :: nblok_d2eig
5887 : integer :: iblok_, iblok_d2eig_
5888 : integer :: iband, jband, bandshift, isppol, mband
5889 : integer :: ikpt,ipert1,idir1,ipert2,idir2,ii
5890 : character(len=500) :: msg
5891 : !arrays
5892 44 : integer,allocatable :: flg_d2eig(:,:,:,:)
5893 : real(dp) :: qpt(3)
5894 44 : real(dp),allocatable :: nrm(:)
5895 44 : real(dp),allocatable :: matrix_d2eig(:,:,:,:,:,:,:)
5896 44 : real(dp),allocatable :: matrix_d2eig_isppol(:,:,:,:,:,:,:)
5897 : ! ************************************************************************
5898 :
5899 44 : ncid_d2eig = nctk_idgroup(ncid, 'd2eig')
5900 :
5901 44 : if (present(iblok_d2eig)) then
5902 44 : iblok_d2eig_= iblok_d2eig
5903 : else
5904 : ! Recount the blok index
5905 0 : iblok_d2eig_ = 0
5906 0 : do iblok_=1,iblok
5907 0 : if (is_type_d2eig(ddb%typ(iblok_))) then
5908 0 : iblok_d2eig_ = iblok_d2eig_ + 1
5909 : end if
5910 : end do
5911 : end if
5912 :
5913 : ! Sanity check on dimensions
5914 44 : if (MOD(ddb%nband, ddb%nsppol)/=0) then
5915 0 : write(msg,'(a,i5,a,i5)') 'ddb was allocated with nband=',ddb%nband,&
5916 0 : ' but nsppol=',ddb%nsppol
5917 0 : ABI_ERROR(msg)
5918 : end if
5919 :
5920 : ! Read kpoints
5921 44 : NCF_CHECK(nctk_get_dim(ncid, "number_of_kpoints", nkpt_file))
5922 132 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, 'reduced_coordinates_of_kpoints'), ddb%kpt, count=[3,nkpt_file])
5923 44 : NCF_CHECK(ncerr)
5924 :
5925 44 : mband = ddb%nband / ddb%nsppol
5926 :
5927 : ncerr = nf90_get_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5928 : 'reduced_coordinates_of_qpoints'),&
5929 : qpt,&
5930 132 : start=[1,iblok_d2eig_])
5931 44 : NCF_CHECK(ncerr)
5932 :
5933 440 : ddb%qpt(:,iblok) = zero
5934 176 : ddb%qpt(1:3,iblok) = qpt
5935 :
5936 : !ncerr = nf90_get_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5937 : ! 'qpoints_normalization'),&
5938 : ! nrm(1,iblok),&
5939 : ! start=[iblok_d2eig_])
5940 44 : NCF_CHECK(nctk_get_dim(ncid_d2eig, "number_of_d2eig_blocks", nblok_d2eig))
5941 132 : ABI_MALLOC(nrm, (nblok_d2eig))
5942 : ncerr = nf90_get_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5943 : 'qpoints_normalization'),&
5944 44 : nrm)
5945 44 : NCF_CHECK(ncerr)
5946 176 : ddb%nrm(:,iblok) = zero
5947 44 : ddb%nrm(1,iblok) = nrm(iblok_d2eig_)
5948 44 : ABI_FREE(nrm)
5949 :
5950 :
5951 308 : ABI_MALLOC(matrix_d2eig, (2,3,ddb%mpert,3,ddb%mpert,ddb%nband,ddb%nkpt))
5952 264 : ABI_MALLOC(matrix_d2eig_isppol, (2,3,ddb%mpert,3,ddb%mpert,mband,ddb%nkpt))
5953 220 : ABI_MALLOC(flg_d2eig, (3,ddb%mpert,3,ddb%mpert))
5954 :
5955 88 : do isppol=1,ddb%nsppol
5956 :
5957 : ncerr = nf90_get_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5958 : 'matrix_values'),&
5959 : matrix_d2eig_isppol,&
5960 440 : start=[1,1,1,1,1,1,1,isppol,iblok_d2eig_])
5961 44 : NCF_CHECK(ncerr)
5962 :
5963 88 : if (ddb%nsppol==1) then
5964 366772 : matrix_d2eig(:,:,:,:,:,:,:) = matrix_d2eig_isppol(:,:,:,:,:,:,:)
5965 : else
5966 0 : bandshift = (isppol - 1) * mband
5967 0 : do ikpt=1,ddb%nkpt
5968 0 : do iband=1,ddb%nband
5969 0 : jband = bandshift + iband
5970 0 : do ipert1=1,ddb%mpert
5971 0 : do idir1=1,3
5972 0 : do ipert2=1,ddb%mpert
5973 0 : do idir2=1,3
5974 0 : do ii=1,2
5975 : matrix_d2eig(ii,idir2,ipert2,idir1,ipert1,jband,ikpt)=&
5976 0 : matrix_d2eig_isppol(ii,idir2,ipert2,idir1,ipert1,iband,ikpt)
5977 : end do
5978 : end do
5979 : end do
5980 : end do
5981 : end do
5982 : end do
5983 : end do
5984 : end if
5985 : end do
5986 :
5987 : ncerr = nf90_get_var(ncid_d2eig, nctk_idname(ncid_d2eig,&
5988 : 'matrix_mask'),&
5989 : flg_d2eig,&
5990 264 : start=[1,1,1,1,iblok_d2eig_])
5991 44 : NCF_CHECK(ncerr)
5992 :
5993 : ! Store values
5994 44 : call ddb%set_d2eig(iblok, matrix_d2eig, flg_d2eig)
5995 :
5996 : ! Free memory
5997 44 : ABI_FREE(matrix_d2eig)
5998 44 : ABI_FREE(matrix_d2eig_isppol)
5999 44 : ABI_FREE(flg_d2eig)
6000 :
6001 44 : end subroutine ddb_read_d2eig_nc
6002 : !!***
6003 :
6004 : !----------------------------------------------------------------------
6005 :
6006 : !!****f* m_ddb/ddb_set_d3matr
6007 : !! NAME
6008 : !! ddb_set_d3matr
6009 : !!
6010 : !! FUNCTION
6011 : !! Set values for the third-order derivative matrix.
6012 : !!
6013 : !! INPUTS
6014 : !! iblok=index of the block we are setting.
6015 : !! d2matr=the third-order derivative matrix.
6016 : !! flg=flag to indicate presence of a given element.
6017 : !! lw=whether this type of perturbation correspond to longwave derivatives
6018 : !!
6019 : !! OUTPUT
6020 : !!
6021 : !! SOURCE
6022 :
6023 44 : subroutine ddb_set_d3matr(ddb, iblok, d3matr, flg, lw)
6024 :
6025 : !Arguments -------------------------------
6026 : !array
6027 : class(ddb_type),intent(inout) :: ddb
6028 : real(dp),intent(in) :: d3matr(2,3,ddb%mpert,3,ddb%mpert,3,ddb%mpert)
6029 : integer,intent(in) :: flg(3,ddb%mpert,3,ddb%mpert,3,ddb%mpert)
6030 : !scalars
6031 : integer,intent(in) :: iblok
6032 : logical,intent(in),optional :: lw
6033 :
6034 : !Local variables -------------------------
6035 : !scalars
6036 : integer :: idir1,idir2,idir3,ipert1,ipert2,ipert3,index,mpert
6037 : ! ************************************************************************
6038 :
6039 44 : mpert = ddb%mpert
6040 :
6041 : ! GA: Should be consistent among all ddb_set_dxmatr routines
6042 : ! and alway have options to specify block type...
6043 44 : ddb%typ(iblok) = BLKTYP_d3E_xx
6044 44 : if (present(lw)) then
6045 17 : if (lw) then
6046 17 : ddb%typ(iblok) = BLKTYP_d3E_lw
6047 : end if
6048 : end if
6049 :
6050 502 : do ipert1=1,mpert
6051 1876 : do idir1=1,3
6052 18788 : do ipert2=1,mpert
6053 69198 : do idir2=1,3
6054 835992 : do ipert3=1,mpert
6055 3123540 : do idir3=1,3
6056 :
6057 : index = idir1 + 3*((ipert1-1)+mpert*((idir2-1) + &
6058 2304504 : & 3*((ipert2-1)+mpert*((idir3-1) + 3*(ipert3-1)))))
6059 :
6060 2304504 : ddb%flg(index,iblok) = flg(idir1,ipert1,idir2,ipert2,idir3,ipert3)
6061 7681680 : ddb%val(:,index,iblok)= d3matr(:,idir1,ipert1,idir2,ipert2,idir3,ipert3)
6062 :
6063 : end do
6064 : end do
6065 : end do
6066 : end do
6067 : end do
6068 : end do
6069 :
6070 :
6071 44 : end subroutine ddb_set_d3matr
6072 : !!***
6073 :
6074 : !----------------------------------------------------------------------
6075 :
6076 : !!****f* m_ddb/ddb_get_d3matr
6077 : !! NAME
6078 : !! ddb_get_d3matr
6079 : !!
6080 : !! FUNCTION
6081 : !! Transform the third-order derivative matrix
6082 : !! from flat indices to real tensor d3matr(cplex,ncart,natom,ncart,natom,ncart,natom)
6083 : !!
6084 : !! INPUTS
6085 : !! iblok=index of the block to get.
6086 : !!
6087 : !! OUTPUT
6088 : !! d3matr=the third-order derivative matrix.
6089 : !! flg=flag to indicate presence of a given element.
6090 : !!
6091 : !! SOURCE
6092 :
6093 36 : subroutine ddb_get_d3matr(ddb, iblok, d3matr, flg)
6094 :
6095 : !Arguments -------------------------------
6096 : !array
6097 : class(ddb_type),intent(inout) :: ddb
6098 : integer,intent(in) :: iblok
6099 : real(dp), allocatable, intent(out) :: d3matr(:,:,:,:,:,:,:)
6100 : integer, allocatable, intent(out) :: flg(:,:,:,:,:,:)
6101 : !scalars
6102 :
6103 : !Local variables -------------------------
6104 : !scalars
6105 : integer :: ii,idir1,idir2,idir3,ipert1,ipert2,ipert3
6106 : ! ************************************************************************
6107 :
6108 252 : ABI_MALLOC(d3matr, (2,3,ddb%mpert,3,ddb%mpert,3,ddb%mpert))
6109 252 : ABI_MALLOC(flg, (3,ddb%mpert,3,ddb%mpert,3,ddb%mpert))
6110 :
6111 8794146 : d3matr = zero
6112 :
6113 : ii=0
6114 435 : do ipert3=1,ddb%mpert
6115 1632 : do idir3=1,3
6116 18327 : do ipert2=1,ddb%mpert
6117 68121 : do idir2=1,3
6118 939483 : do ipert1=1,ddb%mpert
6119 3540429 : do idir1=1,3
6120 2617677 : ii=ii+1
6121 2617677 : flg(idir1,ipert1,idir2,ipert2,idir3,ipert3) = ddb%flg(ii,iblok)
6122 3490236 : if (ddb%flg(ii,iblok) > 0) then
6123 4433 : d3matr(1,idir1,ipert1,idir2,ipert2,idir3,ipert3) = ddb%val(1,ii,iblok)
6124 4433 : d3matr(2,idir1,ipert1,idir2,ipert2,idir3,ipert3) = ddb%val(2,ii,iblok)
6125 : end if
6126 : end do
6127 : end do
6128 : end do
6129 : end do
6130 : end do
6131 : end do
6132 :
6133 36 : end subroutine ddb_get_d3matr
6134 : !!***
6135 :
6136 : !----------------------------------------------------------------------
6137 :
6138 : !!****f* m_ddb/ddb_get_d2eig
6139 : !! NAME
6140 : !! ddb_get_d2eig
6141 : !!
6142 : !! FUNCTION
6143 : !! Transform the second-order derivative matrix of eigenvalues
6144 : !! from flat indices to real tensor d2eig(cplex,ncart,natom,ncart,natom,nband,nkpt)
6145 : !!
6146 : !! INPUTS
6147 : !! iblok=index of the block to get.
6148 : !!
6149 : !! OUTPUTS
6150 : !! d2eig(cplex,ncart,natom,ncart,natom,nband,nkpt) =
6151 : !! the second-order derivative matrix of eigenvalues
6152 : !! with the isppol index wrapped in nband.
6153 : !! flg(ncart,natom,ncart,natom)=flag to indicate presence of a given element.
6154 : !!
6155 : !! SOURCE
6156 :
6157 117 : subroutine ddb_get_d2eig(ddb, d2eig, flg, iblok)
6158 :
6159 : !Arguments -------------------------------
6160 : !array
6161 : class(ddb_type),intent(inout) :: ddb
6162 : real(dp), allocatable, intent(out) :: d2eig(:,:,:,:,:,:,:)
6163 : integer,intent(in) :: iblok
6164 : integer, allocatable, intent(out) :: flg(:,:,:,:)
6165 : !scalars
6166 :
6167 : !Local variables -------------------------
6168 : !scalars
6169 : integer :: ii,idir1,idir2,ipert1,ipert2,iband,ikpt
6170 : ! ************************************************************************
6171 :
6172 819 : ABI_MALLOC(d2eig, (2,3,ddb%mpert,3,ddb%mpert,ddb%nband,ddb%nkpt))
6173 585 : ABI_MALLOC(flg, (3,ddb%mpert,3,ddb%mpert))
6174 :
6175 2244086 : d2eig = zero
6176 :
6177 1828 : do ikpt=1,ddb%nkpt
6178 18678 : do iband=1,ddb%nband
6179 16850 : ii=0
6180 52133 : do ipert2=1,ddb%mpert
6181 151138 : do idir2=1,3
6182 343400 : do ipert1=1,ddb%mpert
6183 937164 : do idir1=1,3
6184 627336 : ii=ii+1
6185 627336 : flg(idir1,ipert1,idir2,ipert2) = ddb%flg(ii,iblok)
6186 836448 : if (ddb%flg(ii,iblok) > 0) then
6187 627336 : d2eig(1,idir1,ipert1,idir2,ipert2,iband,ikpt) = ddb%eig2dval(1,ii,iband,ikpt)
6188 627336 : d2eig(2,idir1,ipert1,idir2,ipert2,iband,ikpt) = ddb%eig2dval(2,ii,iband,ikpt)
6189 : end if
6190 : end do
6191 : end do
6192 : end do
6193 : end do
6194 : end do
6195 : end do
6196 :
6197 117 : end subroutine ddb_get_d2eig
6198 : !!***
6199 :
6200 : !----------------------------------------------------------------------
6201 :
6202 : !!****f* m_ddb/ddb_set_d2eig
6203 : !! NAME
6204 : !! ddb_set_d2eig
6205 : !!
6206 : !! FUNCTION
6207 : !! Set values for the second-order derivatives of eigenvalues.
6208 : !!
6209 : !! INPUTS
6210 : !! iblok=index of the block we are setting.
6211 : !! d2eig=the second-order derivative of eigenvalues.
6212 : !! flg=flag to indicate presence of a given element.
6213 : !!
6214 : !! OUTPUT
6215 : !!
6216 : !! NOTE
6217 : !! Does not handle spin index. Also, sometimes, d2eig is available with flat index
6218 : !! SOURCE
6219 :
6220 44 : subroutine ddb_set_d2eig(ddb, iblok, d2eig, flg)
6221 :
6222 : !Arguments -------------------------------
6223 : !array
6224 : class(ddb_type),intent(inout) :: ddb
6225 : real(dp),intent(in) :: d2eig(2,3,ddb%mpert,3,ddb%mpert,ddb%nband,ddb%nkpt)
6226 : integer,intent(in) :: flg(3,ddb%mpert,3,ddb%mpert)
6227 : !scalars
6228 : integer,intent(in) :: iblok
6229 :
6230 : !Local variables -------------------------
6231 : !scalars
6232 : integer :: idir1,idir2,ipert1,ipert2,index,iband,ikpt,ii
6233 : ! ************************************************************************
6234 :
6235 432 : do ikpt=1,ddb%nkpt
6236 2740 : do iband=1,ddb%nband
6237 2308 : ii = 0
6238 7184 : do ipert2=1,ddb%mpert
6239 20260 : do idir2=1,3
6240 52560 : do ipert1=1,ddb%mpert
6241 151896 : do idir1=1,3
6242 103824 : index=idir1+3*((ipert1-1)+ddb%mpert*((idir2-1)+3*(ipert2-1)))
6243 103824 : ddb%eig2dval(1,index,iband,ikpt)=d2eig(1,idir1,ipert1,idir2,ipert2,iband,ikpt)
6244 103824 : ddb%eig2dval(2,index,iband,ikpt)=d2eig(2,idir1,ipert1,idir2,ipert2,iband,ikpt)
6245 138432 : ddb%flg(index,iblok)=flg(idir1,ipert1,idir2,ipert2)
6246 : end do !idir1
6247 : end do !pert1
6248 : end do !idir2
6249 : end do !pert2
6250 : end do !band
6251 : end do !kpt
6252 :
6253 44 : end subroutine ddb_set_d2eig
6254 : !!***
6255 :
6256 : !----------------------------------------------------------------------
6257 :
6258 : !!****f* m_ddb/ddb_set_d2eig_reshape
6259 : !! NAME
6260 : !! ddb_set_d2eig_reshape
6261 : !!
6262 : !! FUNCTION
6263 : !! Set values for the second-order derivatives of eigenvalues
6264 : !! and reshape the array received.
6265 : !!
6266 : !! INPUTS
6267 : !! iblok=index of the block we are setting.
6268 : !! d2eig=the second-order derivative of eigenvalues.
6269 : !! flg=flag to indicate presence of a given element.
6270 : !! blktyp=block type
6271 : !! 5->real part
6272 : !! 6->imaginary part (broadening)
6273 : !!
6274 : !! OUTPUT
6275 : !!
6276 : !! SOURCE
6277 :
6278 137 : subroutine ddb_set_d2eig_reshape(ddb, iblok, d2eig, flg, blktyp)
6279 :
6280 : !Arguments -------------------------------
6281 : !array
6282 : class(ddb_type),intent(inout) :: ddb
6283 : real(dp),intent(in) :: d2eig(2,ddb%nband*ddb%nsppol,ddb%nkpt,3,ddb%mpert,3,ddb%mpert)
6284 : integer,intent(in) :: flg(3,ddb%mpert,3,ddb%mpert)
6285 : !scalars
6286 : integer,intent(in) :: iblok
6287 : integer,intent(in),optional :: blktyp
6288 :
6289 : !Local variables -------------------------
6290 : !scalars
6291 : integer :: idir1,idir2,ipert1,ipert2,index,iband,ikpt,ii,mband
6292 : ! ************************************************************************
6293 :
6294 137 : ddb%typ(iblok) = BLKTYP_d2eig_re
6295 137 : if (present(blktyp)) ddb%typ(iblok) = blktyp
6296 :
6297 : ! Spin polarization is wrapped in band number
6298 137 : mband = ddb%nband * ddb%nsppol
6299 :
6300 2200 : do ikpt=1,ddb%nkpt
6301 22068 : do iband=1,mband
6302 19868 : ii = 0
6303 61539 : do ipert2=1,ddb%mpert
6304 178300 : do idir2=1,3
6305 403760 : do ipert1=1,ddb%mpert
6306 1100136 : do idir1=1,3
6307 735984 : index=idir1+3*((ipert1-1)+ddb%mpert*((idir2-1)+3*(ipert2-1)))
6308 735984 : ddb%flg(index,iblok)=flg(idir1,ipert1,idir2,ipert2)
6309 981312 : if (ddb%flg(index,iblok) > 0) then
6310 735984 : ddb%eig2dval(1,index,iband,ikpt)=d2eig(1,iband,ikpt,idir1,ipert1,idir2,ipert2)
6311 735984 : ddb%eig2dval(2,index,iband,ikpt)=d2eig(2,iband,ikpt,idir1,ipert1,idir2,ipert2)
6312 : end if
6313 : end do !idir1
6314 : end do !pert1
6315 : end do !idir2
6316 : end do !pert2
6317 : end do !band
6318 : end do !kpt
6319 :
6320 137 : end subroutine ddb_set_d2eig_reshape
6321 : !!***
6322 :
6323 : !----------------------------------------------------------------------
6324 :
6325 : !!****f* m_ddb/ddb_to_dtset
6326 : !! NAME
6327 : !! ddb_to_dtset
6328 : !!
6329 : !! FUNCTION
6330 : !! Initialize a dataset object from ddb.
6331 : !!
6332 : !! FIXME: I don't understand the goal of this routine.
6333 : !! The dtset constructed from the DDB won't be equal to the one used to generate the DDB
6334 : !! There's only one safe way to init dtset i.e. from file by calling the parser
6335 : !!
6336 : !! INPUTS
6337 : !!
6338 : !! OUTPUT
6339 : !!
6340 : !! SOURCE
6341 :
6342 :
6343 0 : subroutine ddb_to_dtset(comm, dtset, filename, psps)
6344 :
6345 : !Arguments -------------------------------
6346 : integer,intent(in) :: comm
6347 : type(dataset_type),intent(inout) :: dtset
6348 : type(pseudopotential_type),intent(inout) :: psps
6349 : ! type(pawtab_type),intent(inout) :: pawtab(psps%ntypat*psps%usepaw)
6350 : character(len=*),intent(in) :: filename
6351 : !Local variables -------------------------
6352 : integer :: mxnimage,unddb
6353 : !integer :: ii, nn
6354 0 : type(ddb_hdr_type) :: ddb_hdr
6355 : ! ************************************************************************
6356 :
6357 : ABI_UNUSED(psps%usepaw)
6358 :
6359 : !Set variables
6360 0 : mxnimage = 1 ! Only 1 image in the DDB
6361 :
6362 : ! Must read natom from the DDB before being able to allocate some arrays needed for invars9
6363 0 : unddb = get_unit()
6364 0 : call ddb_hdr%open_read(filename,comm=comm)
6365 0 : call ddb_hdr%close()
6366 : !close ddb file, just want to read the headers
6367 0 : dtset%ngfft = ddb_hdr%ngfft
6368 :
6369 : ! Copy scalars from ddb
6370 0 : dtset%natom = ddb_hdr%natom
6371 0 : dtset%mband = ddb_hdr%mband
6372 0 : dtset%nkpt = ddb_hdr%nkpt
6373 0 : dtset%nsym = ddb_hdr%msym
6374 0 : dtset%ntypat = ddb_hdr%ntypat
6375 0 : dtset%nspden = ddb_hdr%nspden
6376 0 : dtset%nspinor = ddb_hdr%nspinor
6377 0 : dtset%nsppol = ddb_hdr%nsppol
6378 0 : dtset%occopt = ddb_hdr%occopt
6379 0 : dtset%usepaw = ddb_hdr%usepaw
6380 0 : dtset%intxc = ddb_hdr%intxc
6381 0 : dtset%ixc = ddb_hdr%ixc
6382 0 : dtset%iscf = ddb_hdr%iscf
6383 0 : dtset%dilatmx = ddb_hdr%dilatmx
6384 0 : dtset%ecut = ddb_hdr%ecut
6385 0 : dtset%ecutsm = ddb_hdr%ecutsm
6386 0 : dtset%pawecutdg = ddb_hdr%pawecutdg
6387 0 : dtset%kptnrm = ddb_hdr%kptnrm
6388 0 : dtset%dfpt_sciss = ddb_hdr%dfpt_sciss
6389 0 : dtset%tolwfr = 1.0_dp ! dummy
6390 0 : dtset%tphysel = ddb_hdr%tphysel
6391 0 : dtset%tsmear = ddb_hdr%tsmear
6392 :
6393 : ! Copy arrays from ddb
6394 0 : ABI_REMALLOC(dtset%acell_orig, (3,mxnimage))
6395 0 : dtset%acell_orig(1:3,1) = ddb_hdr%acell(:)
6396 :
6397 0 : ABI_REMALLOC(dtset%rprim_orig, (3,3,mxnimage))
6398 0 : dtset%rprim_orig(1:3,1:3,1) = ddb_hdr%rprim(:,:)
6399 :
6400 0 : ABI_REMALLOC(dtset%rprimd_orig, (3,3,mxnimage))
6401 0 : dtset%rprimd_orig(:,1,1) = ddb_hdr%rprim(:,1) * dtset%acell_orig(1,1)
6402 0 : dtset%rprimd_orig(:,2,1) = ddb_hdr%rprim(:,2) * dtset%acell_orig(2,1)
6403 0 : dtset%rprimd_orig(:,3,1) = ddb_hdr%rprim(:,3) * dtset%acell_orig(3,1)
6404 :
6405 0 : ABI_REMALLOC(dtset%amu_orig,(dtset%ntypat,mxnimage))
6406 0 : dtset%amu_orig(:,1) = ddb_hdr%amu(:)
6407 :
6408 0 : ABI_REMALLOC(dtset%typat, (dtset%natom))
6409 0 : dtset%typat(:) = ddb_hdr%typat(1:ddb_hdr%matom)
6410 :
6411 0 : ABI_REMALLOC(dtset%spinat, (3,dtset%natom))
6412 0 : dtset%spinat(:,:) = ddb_hdr%spinat(1:3,1:ddb_hdr%matom)
6413 :
6414 : #ifdef FC_LLVM
6415 : ! LLVM 16 doesn't recognize this macro here
6416 : ABI_REMALLOC(dtset%xred_orig, (3,dtset%natom,mxnimage) )
6417 : #else
6418 0 : ABI_REMALLOC(dtset%xred_orig, (3,dtset%natom,mxnimage))
6419 : #endif
6420 0 : dtset%xred_orig(:,:,1) = ddb_hdr%xred(1:3,1:ddb_hdr%matom)
6421 :
6422 0 : ABI_REMALLOC(dtset%ziontypat, (dtset%ntypat))
6423 0 : dtset%ziontypat(1:ddb_hdr%mtypat) = ddb_hdr%zion(1:ddb_hdr%mtypat)
6424 :
6425 0 : ABI_REMALLOC(dtset%znucl,(dtset%ntypat))
6426 0 : dtset%znucl(:) = ddb_hdr%znucl(1:ddb_hdr%mtypat)
6427 :
6428 0 : ABI_REMALLOC(dtset%nband,(dtset%nkpt))
6429 0 : dtset%nband(:) = ddb_hdr%nband(1:ddb_hdr%mkpt*ddb_hdr%nsppol)
6430 :
6431 0 : ABI_REMALLOC(dtset%symafm,(dtset%nsym))
6432 0 : dtset%symafm(:) = ddb_hdr%symafm(1:ddb_hdr%msym)
6433 :
6434 0 : ABI_REMALLOC(dtset%symrel, (3,3,dtset%nsym) )
6435 0 : dtset%symrel(:,:,:) = ddb_hdr%symrel(1:3,1:3,1:ddb_hdr%msym)
6436 :
6437 0 : ABI_REMALLOC(dtset%tnons,(3,dtset%nsym))
6438 0 : dtset%tnons(:,:) = ddb_hdr%tnons(1:3,1:ddb_hdr%msym)
6439 :
6440 0 : ABI_REMALLOC(dtset%kpt,(3,dtset%nkpt))
6441 0 : dtset%kpt(:,:) = ddb_hdr%kpt(1:3,1:ddb_hdr%mkpt)
6442 :
6443 0 : ABI_REMALLOC(dtset%wtk,(dtset%nkpt))
6444 0 : dtset%wtk(:) = ddb_hdr%wtk(1:ddb_hdr%mkpt)
6445 :
6446 : ! GA: I had way too much problems implementing pawtab_copy.
6447 : ! The script check-libpaw would report all sorts of errors.
6448 : ! Therefore, I do a cheap copy here, copying only the relevant info.
6449 : !call pawtab_copy(pawtab, ddb_hdr%pawtab)
6450 : ! nn=size(pawtab)
6451 : ! if (nn.gt.0) then
6452 : ! do ii=1,nn
6453 : ! pawtab(ii)%basis_size =ddb_hdr%pawtab(ii)%basis_size
6454 : ! pawtab(ii)%lmn_size =ddb_hdr%pawtab(ii)%lmn_size
6455 : ! pawtab(ii)%lmn2_size =ddb_hdr%pawtab(ii)%lmn2_size
6456 : ! pawtab(ii)%rpaw =ddb_hdr%pawtab(ii)%rpaw
6457 : ! pawtab(ii)%rshp =ddb_hdr%pawtab(ii)%rshp
6458 : ! pawtab(ii)%shape_type =ddb_hdr%pawtab(ii)%shape_type
6459 : ! if (allocated(pawtab(ii)%dij0)) then
6460 : ! call alloc_copy(ddb_hdr%pawtab(ii)%dij0, pawtab(ii)%dij0)
6461 : ! end if
6462 : ! end do
6463 : ! end if
6464 :
6465 0 : call ddb_hdr%free()
6466 :
6467 0 : end subroutine ddb_to_dtset
6468 : !!***
6469 :
6470 : !----------------------------------------------------------------------
6471 :
6472 : !!****f* m_ddb/merge_ddb
6473 : !! NAME
6474 : !! merge_ddb
6475 : !!
6476 : !! FUNCTION
6477 : !! Read a list of ddb files and merge them into a single ddb object.
6478 : !!
6479 : !! INPUTS
6480 : !! nddb=number of DDBs to merge
6481 : !! filenames=names of input DDB files
6482 : !! outfile=name of the merged DDB file to be written
6483 : !! dscrpt=string description of the final ddb.
6484 : !! chkopt=option for consistency checks between DDB files
6485 : !! (0 --> do not check header consistency between files)
6486 : !! (1 --> check header consistency between files)
6487 : !!
6488 : !! OUTPUT
6489 : !!
6490 : !! SOURCE
6491 :
6492 47 : subroutine merge_ddb(nddb, filenames, outfile, dscrpt, chkopt)
6493 :
6494 : !Arguments -------------------------------
6495 : !scalars
6496 : integer,intent(in) :: nddb
6497 : integer,intent(in) :: chkopt
6498 : !arrays
6499 : character(len=fnlen),intent(in) :: filenames(nddb)
6500 : character(len=fnlen),intent(in) :: outfile, dscrpt
6501 :
6502 : !Local variables -------------------------
6503 : !scalars
6504 : integer,parameter :: master=0
6505 : integer :: iddb, ddbvsn
6506 : ! integer :: ddbun
6507 : integer :: iddb_mkpt, iddb_psps
6508 : integer :: dimekb, matom, mband, mblok, mkpt, nsppol
6509 : integer :: msize, msize_, mtypat, lmnmax, usepaw, msym, mpert
6510 : integer :: nblok, iblok, iblok1, iblok2
6511 : ! integer :: tmerge, nq, nw
6512 : integer :: comm
6513 : logical :: eig2d, can_merge
6514 : integer,parameter :: prtvol=-1, brav=1
6515 : real(dp),parameter :: qtol=2.0d-8, wtol=2.0d-8
6516 : ! real(dp) :: diff,sdiff
6517 : character(len=500) :: msg
6518 47 : type(ddb_type) :: ddb, ddb2
6519 4841 : type(ddb_hdr_type) :: ddb_hdr, ddb_hdr2
6520 2444 : type(crystal_t) :: crystal
6521 : ! ************************************************************************
6522 :
6523 47 : comm = xmpi_world
6524 :
6525 : ! -----------------------------------------------
6526 : ! Read all headers and evaluate arrays dimensions
6527 : ! -----------------------------------------------
6528 47 : if (xmpi_comm_rank(comm) == master) then
6529 47 : call wrtout(std_out, sjoin(ch10, " merge_ddb: Reading all headers."))
6530 : end if
6531 :
6532 47 : dimekb=0 ; matom=0 ; mband=0 ; mblok=0 ; mkpt=0 ; mpert=0
6533 47 : msize=0 ; mtypat=0 ; lmnmax=0 ; usepaw=0
6534 47 : iddb_mkpt = 1 ; iddb_psps = nddb
6535 47 : msym=192
6536 :
6537 47 : eig2d = .False.
6538 290 : do iddb=1,nddb
6539 :
6540 243 : call ddb_hdr%open_read(filenames(iddb), comm, dimonly=1)
6541 :
6542 243 : matom=max(matom,ddb_hdr%matom)
6543 :
6544 : ! GA: Should get mkpt from the ddb containing d2eig, if any.
6545 : ! In facts, since I removed comparison on the k-points
6546 : ! in ddb_hdr_compare, I should add a check to make sure
6547 : ! k-points are consistent when merging d2eig data.
6548 243 : if (ddb_hdr%mkpt > mkpt) then
6549 59 : mkpt = ddb_hdr%mkpt
6550 59 : iddb_mkpt = iddb
6551 : end if
6552 : !mkpt=max(mkpt,ddb_hdr%mkpt)
6553 243 : mtypat=max(mtypat,ddb_hdr%mtypat)
6554 243 : msym=max(msym,ddb_hdr%msym)
6555 243 : mband=max(mband,ddb_hdr%mband)
6556 243 : dimekb=max(dimekb,ddb_hdr%psps%dimekb)
6557 243 : lmnmax=max(lmnmax,ddb_hdr%psps%lmnmax)
6558 243 : usepaw=max(usepaw,ddb_hdr%usepaw)
6559 243 : nsppol = ddb_hdr%nsppol
6560 :
6561 : ! Count the blocks
6562 243 : mblok=mblok+ddb_hdr%nblok
6563 :
6564 : ! Figure out if we are merging eig2d files
6565 243 : eig2d = ddb_hdr%has_d2eig
6566 :
6567 : ! Figure out if we are merging d3E blocks and compute msize accordingly
6568 243 : mpert = max(mpert,ddb_hdr%mpert)
6569 243 : msize_ = 3 * mpert * 3 * mpert
6570 243 : if (ddb_hdr%has_d3E_xx) msize_ = msize_ * 3 * mpert
6571 243 : msize = max(msize, msize_)
6572 :
6573 290 : if (ddb_hdr%with_psps>0 .or. ddb_hdr%psps%usepaw > 0) then
6574 161 : iddb_psps = iddb
6575 : end if
6576 : end do
6577 :
6578 47 : ddb%nsppol = nsppol
6579 :
6580 : ! ---------------
6581 : ! Allocate arrays
6582 : ! ---------------
6583 47 : if (eig2d) then
6584 : ! GA: We need to multiply mband by nsppol (to keep array rank below 8)
6585 6 : call ddb%malloc(msize, mblok, matom, mtypat, mpert, mkpt, mband * nsppol)
6586 : else
6587 41 : call ddb%malloc(msize, mblok, matom, mtypat, mpert)
6588 : end if
6589 :
6590 : ! -------------------------------------------------------
6591 : ! Initialize the output ddb_hdr using the first input ddb
6592 : ! -------------------------------------------------------
6593 :
6594 : ! GA: The last ddb is usually the one that contains the most info on pseudos
6595 : ! however, we should check them all and figure out which one has
6596 : ! the most info.
6597 :
6598 47 : call ddb_hdr%free() ! GA: why do I need this? Try to remove
6599 : call ddb_hdr%open_read(filenames(1), comm, &
6600 : matom=matom,mtypat=mtypat,mband=mband,mkpt=mkpt,&
6601 47 : msym=msym,dimekb=dimekb,lmnmax=lmnmax,usepaw=usepaw)
6602 47 : call ddb_hdr%close()
6603 47 : ddb_hdr%mpert = mpert
6604 47 : ddb_hdr%msize = msize
6605 :
6606 : ! GA: We are setting mkpt at initialization,
6607 : ! but netcdf file declares dimension with nkpt.
6608 : ! TODO: Should check consistency of nkpt
6609 : ! among of all blocks containing eig2d data.
6610 :
6611 : ! ==================
6612 : ! Read all databases
6613 : ! ==================
6614 :
6615 47 : nblok = 0
6616 :
6617 290 : do iddb=1,nddb
6618 :
6619 : ! Open the corresponding input DDB, and read the database file information
6620 243 : write(msg, '(a,a,i6)' )ch10,' read the input derivative database number',iddb
6621 243 : call wrtout(std_out,msg)
6622 :
6623 : ! Note: it is necessary to specify mkpt, otherwise the comparison will crash
6624 : call ddb_hdr2%open_read(filenames(iddb), comm, &
6625 : matom=matom,mtypat=mtypat,mband=mband,mkpt=mkpt,&
6626 243 : msym=msym,dimekb=dimekb,lmnmax=lmnmax,usepaw=usepaw)
6627 243 : ddbvsn=ddb_hdr2%ddb_version
6628 243 : call ddb_hdr2%close()
6629 :
6630 243 : if (chkopt==1)then
6631 :
6632 : ! Compare the current DDB and input DDB information.
6633 : ! In case of an inconsistency, halt the execution.
6634 243 : call wrtout(std_out, ' compare the current and input DDB information')
6635 243 : call ddb_hdr%compare(ddb_hdr2)
6636 :
6637 : else
6638 : ! No comparison between the current DDB and input DDB information.
6639 0 : call wrtout(std_out,msg)
6640 : write(msg, '(3a)' )&
6641 0 : 'No comparison/check is performed for the current and input DDB information ',ch10,&
6642 0 : 'because argument --nostrict was passed to the command line. '
6643 0 : ABI_COMMENT(msg)
6644 : end if
6645 :
6646 243 : if (chkopt==1 .or. usepaw==1) then
6647 243 : call ddb_hdr%copy_missing_variables(ddb_hdr2)
6648 : end if
6649 :
6650 : ! GA: In principle, this could be done only once,
6651 : ! but I could not managed to do that without failing test v8[07].
6652 243 : if (iddb == iddb_psps) then
6653 47 : call ddb_hdr%copy_psps_from(ddb_hdr2)
6654 : end if
6655 :
6656 243 : call ddb_hdr2%free()
6657 :
6658 : ! Now read the whole DDB
6659 243 : call ddb2%from_file(filenames(iddb), ddb_hdr2, crystal, comm, prtvol, raw=1)
6660 243 : call crystal%free()
6661 243 : call ddb_hdr2%free()
6662 :
6663 : ! --------------------------------------------------------------
6664 : ! Double loop over the blocks of the last ddb and the output ddb
6665 : ! --------------------------------------------------------------
6666 :
6667 527 : do iblok2=1,ddb2%nblok
6668 :
6669 284 : can_merge = .false.
6670 985 : do iblok1=1, nblok
6671 :
6672 784 : can_merge = ddb%can_merge_blocks(ddb2, iblok1, iblok2, ddbvsn)
6673 :
6674 985 : if (can_merge) then
6675 83 : write(msg, '(a,i5,a,a)' )' merge block #',iblok2,' from file ', filenames(iddb)
6676 83 : call wrtout(std_out,msg)
6677 83 : iblok = iblok1 ! Merge with previous block
6678 83 : exit
6679 : end if
6680 : end do
6681 :
6682 284 : if (.not. can_merge) then
6683 201 : write(msg, '(a,i5,a,a)' )' add block #',iblok2,' from file ', filenames(iddb)
6684 201 : call wrtout(std_out,msg)
6685 201 : nblok = nblok + 1
6686 201 : iblok = nblok
6687 : end if
6688 :
6689 527 : call ddb%merge_blocks(ddb2, iblok, iblok2, ddbvsn)
6690 :
6691 : end do ! iblok2
6692 :
6693 : ! Free memory
6694 290 : call ddb2%free()
6695 :
6696 : end do ! iddb
6697 :
6698 :
6699 :
6700 47 : ddb_hdr%nblok = nblok
6701 47 : ddb%nblok = nblok
6702 47 : ddb_hdr%dscrpt = dscrpt
6703 :
6704 47 : call ddb_hdr%set_typ(ddb%nblok, ddb%typ)
6705 :
6706 47 : ddb_hdr%mpert = mpert ! This is done anyway at writing
6707 :
6708 : ! Summarize the merging phase
6709 47 : write(msg, '(a,i6,a)' )' Final DDB has ',nblok,' blocks.'
6710 47 : call wrtout(std_out,msg)
6711 :
6712 : ! Always use format specified with output filename.
6713 : ! GA: Might need an extra variable to enforce a different iomode
6714 47 : ddb_hdr%iomode = iomode_from_fname(outfile)
6715 :
6716 : ! GA: This is because netcdf format has more info than txt
6717 : ! and psps might be initialized even if with_psps==0
6718 : ! Very weird that I have to do this.
6719 : ! TODO Do not enforce with_psps=1. Change the test reference instead.
6720 47 : if (ddb_hdr%iomode/=IO_MODE_ETSF) then
6721 46 : if (ddb_hdr%with_psps==0) then
6722 1 : ddb_hdr%psps%dimekb = 0
6723 1 : ddb_hdr%psps%lmnmax = 0
6724 1 : ABI_SFREE(ddb_hdr%psps%ekb)
6725 1 : ABI_SFREE(ddb_hdr%psps%indlmn)
6726 4 : ABI_MALLOC(ddb_hdr%psps%ekb,(ddb_hdr%psps%dimekb,ddb_hdr%mtypat))
6727 4 : ABI_MALLOC(ddb_hdr%psps%indlmn,(6,ddb_hdr%psps%lmnmax,ddb_hdr%mtypat))
6728 3 : ddb_hdr%psps%ekb = zero
6729 3 : ddb_hdr%psps%indlmn = zero
6730 : end if
6731 : end if
6732 :
6733 : ! Enforce full initialization, regardless of DDB content
6734 47 : ddb_hdr%with_psps=1
6735 47 : ddb_hdr%with_dfpt_vars=1
6736 :
6737 : ! Write the final ddb to file.
6738 47 : if (.not. eig2d) then
6739 41 : call ddb%write(ddb_hdr, outfile)
6740 : end if
6741 :
6742 : ! =================================
6743 : ! Second derivatives of eigenvalues
6744 : ! =================================
6745 : if (eig2d) then
6746 :
6747 : ! GA: Here we assume that the blocks are complete wrt perturbations.
6748 : ! No merging of blocks occurs.
6749 : ! TODO: Implement merging of partial d2eig blocks
6750 :
6751 278 : ddb%kpt(:,:) = ddb_hdr%kpt(:,:)
6752 :
6753 : ! Open the output DDB and write the header
6754 6 : call ddb_hdr%open_write(outfile, with_psps=1, comm=comm)
6755 :
6756 6 : iblok = 0
6757 26 : do iddb=1,nddb
6758 :
6759 : call ddb_hdr2%open_read(filenames(iddb), comm, &
6760 : matom=matom,mtypat=mtypat,mband=mband,mkpt=mkpt,&
6761 20 : msym=msym,dimekb=dimekb,lmnmax=lmnmax,usepaw=usepaw)
6762 :
6763 40 : do iblok2=1,ddb_hdr2%nblok
6764 :
6765 : ! Handle one block at a time
6766 20 : iblok = iblok + 1
6767 20 : call ddb%read_d2eig(ddb_hdr2, iblok, iblok2)
6768 40 : call ddb%write_d2eig(ddb_hdr, iblok)
6769 :
6770 : end do
6771 :
6772 20 : call ddb_hdr2%close() ! Close the file
6773 26 : call ddb_hdr2%free() ! Free memory
6774 :
6775 : end do
6776 :
6777 6 : call ddb_hdr%close()
6778 :
6779 : end if
6780 :
6781 : ! -----------
6782 : ! Free memory
6783 : ! -----------
6784 47 : call ddb_hdr%free()
6785 47 : call ddb%free()
6786 :
6787 47 : end subroutine merge_ddb
6788 : !!***
6789 :
6790 : !----------------------------------------------------------------------
6791 :
6792 : !!****f* m_ddb/lwcart
6793 : !! NAME
6794 : !! lwcart
6795 : !!
6796 : !! FUNCTION
6797 : !! Transform the 3rd-order energy derivative read from the ddb file generated by a long wave
6798 : !! calculation into cartesian coordinates, and also...
6799 : !!
6800 : !! INPUTS
6801 : !! blkflg(3,mpert,3,mpert,3,mpert)= ( 1 if the element of the 3dte
6802 : !! has been calculated ; 0 otherwise )
6803 : !! d3(2,3,mpert,3,mpert,3,mpert)= matrix of the 3DTE
6804 : !! gprimd(3,3)=dimensional primitive translations for reciprocal space(bohr^-1)
6805 : !! mpert =maximum number of ipert
6806 : !! natom= number of atoms
6807 : !! rprimd(3,3)=dimensional primitive translations (bohr)
6808 : !!
6809 : !! OUTPUT
6810 : !! carflg(3,mpert,3,mpert,3,mpert)=1 if the element of d3cart has been calculated, 0 otherwise
6811 : !! d3cart(2,3,mpert,3,mpert,3,mpert)=matrix of third-order energy derivatives in cartesian coordinates
6812 : !!
6813 : !! SOURCE
6814 :
6815 26 : subroutine lwcart(blkflg,carflg,d3,d3cart,gprimd,mpert,natom,rprimd)
6816 :
6817 : !Arguments -------------------------------
6818 : !scalars
6819 : integer,intent(in) :: mpert,natom
6820 : !arrays
6821 : integer,intent(in) :: blkflg(3,mpert,3,mpert,3,mpert)
6822 : integer,intent(out) :: carflg(3,mpert,3,mpert,3,mpert)
6823 : real(dp),intent(in) :: d3(2,3,mpert,3,mpert,3,mpert),gprimd(3,3),rprimd(3,3)
6824 : real(dp),intent(out) :: d3cart(2,3,mpert,3,mpert,3,mpert)
6825 :
6826 : !Local variables -------------------------
6827 : !scalars
6828 : integer :: i1dir,i1pert,i2dir,i2pert,i3dir,i3pert
6829 : integer :: ii
6830 : !arrays
6831 : integer :: flg1(3),flg2(3)
6832 : real(dp) :: vec1(3),vec2(3)
6833 :
6834 : ! *******************************************************************
6835 :
6836 : !Transform to cartesian coordinates
6837 11464528 : d3cart(:,:,:,:,:,:,:) = d3(:,:,:,:,:,:,:)
6838 4635958 : carflg(:,:,:,:,:,:) = 0
6839 :
6840 427 : do i1pert = 1, mpert
6841 7256 : do i2pert = 1, mpert
6842 133685 : do i3pert = 1, mpert
6843 :
6844 505820 : do i2dir = 1, 3
6845 1643915 : do i3dir = 1, 3
6846 3793650 : do ii= 1, 2
6847 9104760 : vec1(:) = d3cart(ii,:,i1pert,i2dir,i2pert,i3dir,i3pert)
6848 9104760 : flg1(:) = blkflg(:,i1pert,i2dir,i2pert,i3dir,i3pert)
6849 2276190 : call cart39(flg1,flg2,gprimd,i1pert,natom,rprimd,vec1,vec2)
6850 9104760 : d3cart(ii,:,i1pert,i2dir,i2pert,i3dir,i3pert) = vec2(:)
6851 10242855 : carflg(:,i1pert,i2dir,i2pert,i3dir,i3pert) = flg2(:)
6852 : end do
6853 : end do
6854 : end do
6855 :
6856 505820 : do i1dir = 1, 3
6857 1643915 : do i3dir = 1, 3
6858 3793650 : do ii= 1, 2
6859 9104760 : vec1(:) = d3cart(ii,i1dir,i1pert,:,i2pert,i3dir,i3pert)
6860 9104760 : flg1(:) = blkflg(i1dir,i1pert,:,i2pert,i3dir,i3pert)
6861 2276190 : call cart39(flg1,flg2,gprimd,i2pert,natom,rprimd,vec1,vec2)
6862 9104760 : d3cart(ii,i1dir,i1pert,:,i2pert,i3dir,i3pert) = vec2(:)
6863 10242855 : carflg(i1dir,i1pert,:,i2pert,i3dir,i3pert) = flg2(:)
6864 : end do
6865 : end do
6866 : end do
6867 :
6868 512649 : do i1dir = 1, 3
6869 1643915 : do i2dir = 1, 3
6870 3793650 : do ii= 1, 2
6871 9104760 : vec1(:) = d3cart(ii,i1dir,i1pert,i2dir,i2pert,:,i3pert)
6872 9104760 : flg1(:) = blkflg(i1dir,i1pert,i2dir,i2pert,:,i3pert)
6873 2276190 : call cart39(flg1,flg2,gprimd,i3pert,natom,rprimd,vec1,vec2)
6874 9104760 : d3cart(ii,i1dir,i1pert,i2dir,i2pert,:,i3pert) = vec2(:)
6875 10242855 : carflg(i1dir,i1pert,i2dir,i2pert,:,i3pert) = flg2(:)
6876 : end do
6877 : end do
6878 : end do
6879 :
6880 : end do
6881 : end do
6882 : end do
6883 :
6884 26 : end subroutine lwcart
6885 : !!***
6886 :
6887 : !----------------------------------------------------------------------
6888 :
6889 : !!****f* m_ddb/dtqdrp
6890 : !! NAME
6891 : !! dtqdrp
6892 : !!
6893 : !! FUNCTION
6894 : !! Reads the Dynamical Quadrupole or the P^(1) Tensor
6895 : !! in the Gamma Block coming from the Derivative Data Base
6896 : !! (long wave third-order derivatives).
6897 : !!
6898 : !! INPUTS
6899 : !! blkval(2,3*mpert*3*mpert*3*mpert)= matrix of third-order energies
6900 : !! ddb_version = 8 digit integer giving date. To mantain compatibility with olderDDB files.
6901 : !! lwsym = 0 do not symmetrize the tensor wrt efield and qvec derivative
6902 : !! |-> 1st gradient of polarization response to atomic displacement
6903 : !! = 1 symmetrize the tensor wrt efield and qvec derivative
6904 : !! |-> dynamic quadrupoles
6905 : !! natom= number of atoms in unit cell
6906 : !! mpert =maximum number of ipert
6907 : !!
6908 : !! OUTPUT
6909 : !! lwtens(3,3,3,natom) = Dynamical Quadrupoles or P^(1) tensor
6910 : !!
6911 : !! SOURCE
6912 :
6913 9 : subroutine dtqdrp(blkval,ddb_version,lwsym,mpert,natom,lwtens)
6914 :
6915 : !Arguments -------------------------------
6916 : !scalars
6917 : integer,intent(in) :: ddb_version,lwsym,mpert,natom
6918 : !arrays
6919 : real(dp),intent(in) :: blkval(2,3*mpert*3*mpert*3*mpert)
6920 : real(dp),intent(out) :: lwtens(3,3,3,natom)
6921 :
6922 : !Local variables -------------------------
6923 : !scalars
6924 : integer,parameter :: cvrsio8=20100401
6925 : integer :: elfd,iatd,iatom,qvecd
6926 : real(dp) :: fac
6927 : logical :: iwrite
6928 : character(len=500) :: msg
6929 : !arrays
6930 18 : real(dp) :: d3cart(2,3,mpert,3,mpert,3,mpert)
6931 :
6932 : ! *********************************************************************
6933 :
6934 1499619 : d3cart(1,:,:,:,:,:,:) = reshape(blkval(1,:),shape = (/3,mpert,3,mpert,3,mpert/))
6935 1499619 : d3cart(2,:,:,:,:,:,:) = reshape(blkval(2,:),shape = (/3,mpert,3,mpert,3,mpert/))
6936 :
6937 : !Define a factor to apply if DDB file has been created with the old version of
6938 : !the longwave driver.
6939 9 : if (ddb_version <= cvrsio8) then
6940 : fac=-two
6941 : else
6942 5 : fac=one
6943 : end if
6944 :
6945 : !Extraction of quadrupoles (need symmetrization wrt qvecd and elfd)
6946 33 : do iatom = 1,natom
6947 105 : do iatd = 1,3
6948 312 : do elfd = 1,3
6949 432 : do qvecd = 1,elfd-1
6950 432 : if (lwsym==1) then
6951 : lwtens(elfd,qvecd,iatd,iatom) = fac * &
6952 162 : (d3cart(2,elfd,natom+2,iatd,iatom,qvecd,natom+8)+d3cart(2,qvecd,natom+2,iatd,iatom,elfd,natom+8))
6953 162 : lwtens(qvecd,elfd,iatd,iatom) = lwtens(elfd,qvecd,iatd,iatom)
6954 54 : else if (lwsym==0) then
6955 54 : lwtens(elfd,qvecd,iatd,iatom) = fac * d3cart(2,elfd,natom+2,iatd,iatom,qvecd,natom+8)
6956 54 : lwtens(qvecd,elfd,iatd,iatom) = fac * d3cart(2,qvecd,natom+2,iatd,iatom,elfd,natom+8)
6957 : end if
6958 : end do
6959 288 : if (lwsym==1) then
6960 162 : lwtens(elfd,elfd,iatd,iatom) = fac * two*d3cart(2,elfd,natom+2,iatd,iatom,elfd,natom+8)
6961 54 : else if (lwsym==0) then
6962 54 : lwtens(elfd,elfd,iatd,iatom) = fac * d3cart(2,elfd,natom+2,iatd,iatom,elfd,natom+8)
6963 : end if
6964 : end do
6965 : end do
6966 : end do
6967 :
6968 9 : iwrite = ab_out > 0
6969 :
6970 9 : if (iwrite) then
6971 9 : if (lwsym==1) then
6972 7 : write(msg,*)' atom dir Qxx Qyy Qzz Qyz Qxz Qxy'
6973 21 : call wrtout([ab_out,std_out],msg)
6974 25 : do iatom= 1, natom
6975 18 : write(msg,'(2x,i3,3x,a3,2x,6f12.6)') iatom, 'x',lwtens(1,1,1,iatom),lwtens(2,2,1,iatom),lwtens(3,3,1,iatom), &
6976 36 : & lwtens(2,3,1,iatom),lwtens(1,3,1,iatom),lwtens(1,2,1,iatom)
6977 54 : call wrtout([ab_out,std_out],msg)
6978 18 : write(msg,'(2x,i3,3x,a3,2x,6f12.6)') iatom, 'y',lwtens(1,1,2,iatom),lwtens(2,2,2,iatom),lwtens(3,3,2,iatom), &
6979 36 : & lwtens(2,3,2,iatom),lwtens(1,3,2,iatom),lwtens(1,2,2,iatom)
6980 54 : call wrtout([ab_out,std_out],msg)
6981 18 : write(msg,'(2x,i3,3x,a3,2x,6f12.6)') iatom, 'z',lwtens(1,1,3,iatom),lwtens(2,2,3,iatom),lwtens(3,3,3,iatom), &
6982 36 : & lwtens(2,3,3,iatom),lwtens(1,3,3,iatom),lwtens(1,2,3,iatom)
6983 61 : call wrtout([ab_out,std_out],msg)
6984 : end do
6985 2 : else if (lwsym==0) then
6986 : write(msg,*) &
6987 2 : & ' atom dir Pxx Pyy Pzz Pyz Pxz Pxy Pzy Pzx Pyx'
6988 6 : call wrtout([ab_out,std_out],msg)
6989 8 : do iatom= 1, natom
6990 6 : write(msg,'(2x,i3,3x,a3,2x,9f12.6)') iatom, 'x',lwtens(1,1,1,iatom),lwtens(2,2,1,iatom),lwtens(3,3,1,iatom), &
6991 6 : & lwtens(2,3,1,iatom),lwtens(1,3,1,iatom),lwtens(1,2,1,iatom), &
6992 12 : & lwtens(3,2,1,iatom),lwtens(3,1,1,iatom),lwtens(2,1,1,iatom)
6993 18 : call wrtout([ab_out,std_out],msg)
6994 6 : write(msg,'(2x,i3,3x,a3,2x,9f12.6)') iatom, 'y',lwtens(1,1,2,iatom),lwtens(2,2,2,iatom),lwtens(3,3,2,iatom), &
6995 6 : & lwtens(2,3,2,iatom),lwtens(1,3,2,iatom),lwtens(1,2,2,iatom), &
6996 12 : & lwtens(3,2,2,iatom),lwtens(3,1,2,iatom),lwtens(2,1,2,iatom)
6997 18 : call wrtout([ab_out,std_out],msg)
6998 6 : write(msg,'(2x,i3,3x,a3,2x,9f12.6)') iatom, 'z',lwtens(1,1,3,iatom),lwtens(2,2,3,iatom),lwtens(3,3,3,iatom), &
6999 6 : & lwtens(2,3,3,iatom),lwtens(1,3,3,iatom),lwtens(1,2,3,iatom), &
7000 12 : & lwtens(3,2,3,iatom),lwtens(3,1,3,iatom),lwtens(2,1,3,iatom)
7001 20 : call wrtout([ab_out,std_out],msg)
7002 : end do
7003 : endif
7004 : end if
7005 :
7006 9 : end subroutine dtqdrp
7007 : !!***
7008 :
7009 : !----------------------------------------------------------------------
7010 :
7011 : !!****f* m_ddb/ddb_lw_copy
7012 : !! NAME
7013 : !! ddb_lw_copy
7014 : !!
7015 : !! FUNCTION
7016 : !! Copy the ddb object after reading the long wave 3rd order derivatives
7017 : !! into a new ddb_lw and resizes ddb as for 2nd order derivatives
7018 : !!
7019 : !! INPUTS
7020 : !! ddb (INOUT) = ddb block datastructure
7021 : !! mpert =maximum number of ipert
7022 : !! natom= number of atoms in unit cell
7023 : !! ntypat= number of atom types
7024 : !!
7025 : !! OUTPUT
7026 : !! ddb_lw= ddb block datastructure
7027 : !!
7028 : !! NOTE
7029 : !! A new ddb is necessary for the longwave quantities in anaddb
7030 : !! due to incompability of it with automatic reshapes that ddb%val and ddb%flg
7031 : !! experience when passed as arguments of some routines.
7032 : !!
7033 : !! SOURCE
7034 :
7035 9 : subroutine ddb_lw_copy(ddb, ddb_lw, ddb_hdr)
7036 :
7037 : !Arguments -------------------------------
7038 : !scalars
7039 : class(ddb_type),intent(inout) :: ddb
7040 : class(ddb_type),intent(out) :: ddb_lw
7041 : type(ddb_hdr_type),intent(in) :: ddb_hdr
7042 : !arrays
7043 :
7044 : !Local variables -------------------------
7045 : !scalars
7046 : integer :: ii,nblok,nsize,cnt
7047 : integer :: mpert,natom,ntypat
7048 : ! *********************************************************************
7049 :
7050 9 : mpert = ddb_hdr%mpert
7051 9 : natom = ddb_hdr%natom
7052 9 : ntypat = ddb_hdr%ntypat
7053 :
7054 9 : call ddb%copy(ddb_lw)
7055 9 : call ddb%free()
7056 9 : nsize=3*mpert*3*mpert
7057 219 : nblok=ddb_lw%nblok-count(ddb_lw%typ(:)==BLKTYP_d3E_lw)
7058 9 : call ddb%malloc(nsize, nblok, natom, ntypat, mpert)
7059 :
7060 : ! Copy dimensions and static variables.
7061 9 : ddb%msize = nsize
7062 9 : ddb%mpert = ddb_lw%mpert
7063 9 : ddb%nblok = nblok
7064 9 : ddb%natom = ddb_lw%natom
7065 9 : ddb%ntypat = ddb_lw%ntypat
7066 9 : ddb%occopt = ddb_lw%occopt
7067 9 : ddb%prtvol = ddb_lw%prtvol
7068 :
7069 117 : ddb%rprim = ddb_lw%rprim
7070 117 : ddb%gprim = ddb_lw%gprim
7071 36 : ddb%acell = ddb_lw%acell
7072 :
7073 : ! Copy the allocatable arrays.
7074 22 : ddb%amu(:) = ddb_lw%amu(:)
7075 9 : cnt = 0
7076 219 : do ii=1,ddb_lw%nblok
7077 219 : if (ddb_lw%typ(ii)/=BLKTYP_d3E_lw) then
7078 201 : cnt = cnt + 1
7079 615882 : ddb%flg(:,cnt) = ddb_lw%flg(1:nsize,ii)
7080 1847244 : ddb%val(:,:,cnt) = ddb_lw%val(:,1:nsize,ii)
7081 201 : ddb%typ(cnt) = ddb_lw%typ(ii)
7082 804 : ddb%nrm(:,cnt) = ddb_lw%nrm(:,ii)
7083 2010 : ddb%qpt(:,cnt) = ddb_lw%qpt(:,ii)
7084 804 : ddb%omega(:,cnt) = ddb_lw%omega(:,ii)
7085 : end if
7086 : end do
7087 :
7088 9 : end subroutine ddb_lw_copy
7089 : !!***
7090 :
7091 : !----------------------------------------------------------------------
7092 : !!****f* m_ddb/symdm9
7093 : !! NAME
7094 : !! symdm9
7095 : !!
7096 : !! FUNCTION
7097 : !! Use the set of special k points calculated by the Monkhorst & Pack Technique.
7098 : !! Check if all the information for the k points are present in
7099 : !! the DDB to determine their dynamical matrices.
7100 : !! Generate the dynamical matrices of the set of k points which
7101 : !! samples homogeneously the entire Brillouin zone.
7102 : !!
7103 : !! INPUTS
7104 : !! %flg(nsize,nblok)= flag of existence for each element of the DDB
7105 : !! %nrm(1,nblok)=norm of qpt providing normalization
7106 : !! %qpt(1<ii<9,nblok)=q vector of a phonon mode (ii=1,2,3)
7107 : !! %typ(nblok)=1 or 2 depending on non-stationary or stationary block 3 for third order derivatives
7108 : !! %val(2,3*mpert*3*mpert,nblok)= all the dynamical matrices
7109 : !! gprimd(3,3)=dimensionlal primitive translations in reciprocal space
7110 : !! indsym = mapping of atoms under symops
7111 : !! mpert =maximum number of ipert
7112 : !! natom=number of atoms in unit cell
7113 : !! %nblok=number of blocks in the DDB
7114 : !! nqpt=number of special q points
7115 : !! nsym=number of space group symmetries
7116 : !! rfmeth =
7117 : !! 1 or -1 if non-stationary block
7118 : !! 2 or -2 if stationary block
7119 : !! 3 or -3 if third order derivatives
7120 : !! 85 if molecular Berry curvature
7121 : !! positive if symmetries are used to set elements to zero whenever possible, negative to prevent this to happen.
7122 : !! rprimd(3,3)=dimensional primitive translations in real space
7123 : !! spqpt(3,nqpt)=set of special q points generated by the Monkhorst & Pack Method
7124 : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (reciprocal space)
7125 : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
7126 : !! comm=MPI communicator.
7127 : !!
7128 : !! OUTPUT
7129 : !! dynmat(2,3,natom,3,natom,nqpt)=dynamical matrices relative to the q points of the B.Z. sampling
7130 : !! [qmissing]=Allocatable array with the indices of the q-points in the BZ that could not be obtained
7131 : !! by symmetry. If qmissing is present, the routine does not stop if the full BZ cannot be reconstructed.
7132 : !! The caller is responsible for filling the missing entries.
7133 : !!
7134 : !! TODO
7135 : !! * A full description of the inputs should be included
7136 : !!
7137 : !! NOTES
7138 : !! Time-reversal symmetry is always assumed
7139 : !! The time-reversal is correctly used for the MBC (Molecular Berry
7140 : !! curvature): G(-k)=G^*(k)
7141 : !!
7142 : !! SOURCE
7143 :
7144 242 : subroutine symdm9(ddb, dynmat, gprimd, indsym, mpert, natom, nqpt, nsym, rfmeth,&
7145 242 : rprimd, spqpt, symrec, symrel, comm, qmissing)
7146 :
7147 : !Arguments -------------------------------
7148 : !scalars
7149 : class(ddb_type),intent(in) :: ddb
7150 : integer,intent(in) :: mpert,natom,nqpt,nsym,rfmeth,comm
7151 : !arrays
7152 : integer,intent(in) :: indsym(4,nsym,natom),symrec(3,3,nsym),symrel(3,3,nsym)
7153 : integer,allocatable,optional,intent(out) :: qmissing(:)
7154 : real(dp),intent(in) :: gprimd(3,3),rprimd(3,3)
7155 : real(dp),intent(in) :: spqpt(3,nqpt)
7156 : real(dp),intent(out) :: dynmat(2,3,natom,3,natom,nqpt)
7157 :
7158 : !Local variables -------------------------
7159 : !scalars
7160 : integer :: ia,ib,iblok,idir1,idir2,ii,ipert1,ipert2,iqpt,isym,jj,kk,ll
7161 : integer :: mu,nu,q1,q2,nqmiss,nprocs,my_rank,ierr,index
7162 : real(dp),parameter :: tol=2.d-8
7163 : real(dp) :: sign1, sign2
7164 : !tolerance for equality of q points between those of the DDB and those of the sampling grid
7165 : real(dp) :: arg1,arg2,im,re,sumi,sumr
7166 : logical :: allow_qmiss
7167 : character(len=500) :: msg
7168 : !arrays
7169 242 : integer,allocatable :: qtest(:,:)
7170 484 : integer :: qmiss_(nqpt)
7171 : real(dp) :: qq(3),qsym(6),ss(3,3)
7172 242 : real(dp),allocatable :: ddd(:,:,:,:,:)
7173 : ! *********************************************************************
7174 :
7175 242 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
7176 :
7177 : ! Initialize output (some q-points might not be reconstructed if qmissing is present)
7178 12537516 : dynmat = zero
7179 242 : allow_qmiss = (present(qmissing))
7180 :
7181 1210 : ABI_MALLOC(ddd,(2,3,natom,3,natom))
7182 : ! Check if the blkqpt points and their symmetrics are sufficient
7183 : ! in the DDB to retrieve all the q points of the B.Z. sampling
7184 :
7185 : !Initialization of a test variable
7186 : ! qtest(iqpt,1)=iblok
7187 : ! qtest(iqpt,2)=isym
7188 : ! qtest(iqpt,3)=time_reversal
7189 726 : ABI_MALLOC(qtest,(nqpt,3))
7190 26542 : do iqpt=1,nqpt
7191 26542 : qtest(iqpt,1)=0
7192 : end do
7193 :
7194 : !Q points coming from the DDB
7195 : !write(std_out,*)' Nbr. of Blocks -> ',nblok
7196 : ! TODO: This part scales badly with nblock/nqpt
7197 : ! One could use listkk or rearrange the loop so that iqpt comes first and then MPI-parallelize.
7198 :
7199 16500 : do iblok=1,ddb%nblok
7200 :
7201 16500 : if (abs(ddb%typ(iblok)) == abs(rfmeth)) then
7202 16178 : qq(1)=ddb%qpt(1,iblok)/ddb%nrm(1,iblok)
7203 16178 : qq(2)=ddb%qpt(2,iblok)/ddb%nrm(1,iblok)
7204 16178 : qq(3)=ddb%qpt(3,iblok)/ddb%nrm(1,iblok)
7205 :
7206 : ! Calculation of the symmetric points (including Time Reversal)
7207 551682 : do isym=1,nsym
7208 535504 : qsym(1)=qq(1)*symrec(1,1,isym)+qq(2)*symrec(1,2,isym)+qq(3)*symrec(1,3,isym)
7209 535504 : qsym(2)=qq(1)*symrec(2,1,isym)+qq(2)*symrec(2,2,isym)+qq(3)*symrec(2,3,isym)
7210 535504 : qsym(3)=qq(1)*symrec(3,1,isym)+qq(2)*symrec(3,2,isym)+qq(3)*symrec(3,3,isym)
7211 :
7212 : ! Dont forget the Time Reversal symmetry
7213 535504 : qsym(4)=-qq(1)*symrec(1,1,isym)-qq(2)*symrec(1,2,isym)-qq(3)*symrec(1,3,isym)
7214 535504 : qsym(5)=-qq(1)*symrec(2,1,isym)-qq(2)*symrec(2,2,isym)-qq(3)*symrec(2,3,isym)
7215 535504 : qsym(6)=-qq(1)*symrec(3,1,isym)-qq(2)*symrec(3,2,isym)-qq(3)*symrec(3,3,isym)
7216 :
7217 : ! Comparison between the q points and their symmetric points
7218 : ! and the set of q points which samples the entire Brillouin zone
7219 187521464 : do iqpt=1,nqpt
7220 :
7221 186969782 : if (mod(abs(spqpt(1,iqpt)-qsym(1))+tol,1._dp)<2*tol)then
7222 23298506 : if (mod(abs(spqpt(2,iqpt)-qsym(2))+tol,1._dp)<2*tol)then
7223 3030084 : if (mod(abs(spqpt(3,iqpt)-qsym(3))+tol,1._dp)<2*tol)then
7224 :
7225 : ! write(std_out,*)' q point from the DDB ! '
7226 : ! write(std_out,*)' block -> ',iblok
7227 : ! write(std_out,*)' sym. -> ',isym
7228 : ! write(std_out,*)' No Time Reversal '
7229 : ! write(std_out,*)'(',qsym(1),',',qsym(2),',',qsym(3),')'
7230 : ! write(std_out,*)' '
7231 507328 : qtest(iqpt,1)=iblok
7232 507328 : qtest(iqpt,2)=isym
7233 507328 : qtest(iqpt,3)=0
7234 : end if
7235 : end if
7236 : end if
7237 :
7238 187505286 : if (mod(abs(spqpt(1,iqpt)-qsym(4))+tol,1._dp)<2*tol)then
7239 23298506 : if (mod(abs(spqpt(2,iqpt)-qsym(5))+tol,1._dp)<2*tol)then
7240 3030084 : if (mod(abs(spqpt(3,iqpt)-qsym(6))+tol,1._dp)<2*tol)then
7241 :
7242 : ! write(std_out,*)' q point from the DDB ! '
7243 : ! write(std_out,*)' block -> ',iblok
7244 : ! write(std_out,*)' sym. -> ',isym
7245 : ! write(std_out,*)' Time Reversal '
7246 : ! write(std_out,*)'(',qsym(4),',',qsym(5),',',qsym(6),')'
7247 : ! write(std_out,*)' '
7248 :
7249 507328 : qtest(iqpt,1)=iblok
7250 507328 : qtest(iqpt,2)=isym
7251 507328 : qtest(iqpt,3)=1
7252 : end if
7253 : end if
7254 : end if
7255 :
7256 : end do ! iqpt
7257 : end do ! isym
7258 :
7259 : end if
7260 : end do ! iblok
7261 :
7262 : ! Check if all the information relatives to the q points sampling are found in the DDB if not => stop message
7263 242 : nqmiss = 0
7264 26542 : do iqpt=1,nqpt
7265 26542 : if (qtest(iqpt,1)==0) then
7266 96 : nqmiss = nqmiss + 1
7267 96 : qmiss_(nqmiss) = iqpt
7268 96 : write(msg, '(3a)' )' symdm9: the bloks found in the DDB are characterized',ch10,' by the following wavevectors :'
7269 96 : call wrtout(std_out,msg)
7270 672 : do iblok=1,ddb%nblok
7271 576 : write(msg, '(a,4d20.12)')' ',ddb%qpt(1,iblok),ddb%qpt(2,iblok),ddb%qpt(3,iblok),ddb%nrm(1,iblok)
7272 672 : call wrtout(std_out,msg)
7273 : end do
7274 : write(msg, '(3a,i0,3a,3es16.6,3a)' )&
7275 96 : 'Information is missing in the DDB file.',ch10,&
7276 96 : 'The dynamical matrix with iqpt= ',iqpt,' cannot be built,',ch10,&
7277 96 : 'since no block with qpt: ',spqpt(1:3,iqpt), ' has been found.',ch10,&
7278 192 : 'Action: add the required block in the DDB, or modify the q-mesh your input file.'
7279 96 : if (.not. allow_qmiss) then
7280 0 : ABI_ERROR(msg)
7281 : else
7282 96 : ABI_COMMENT(msg)
7283 : end if
7284 : end if
7285 : end do
7286 :
7287 : ! Will return a list with the index of the q-points that could not be symmetrized.
7288 242 : if (allow_qmiss) then
7289 3 : ABI_MALLOC(qmissing, (nqmiss))
7290 98 : if (nqmiss > 0) qmissing = qmiss_(1:nqmiss)
7291 : end if
7292 :
7293 : ! Generation of the dynamical matrices relative to the q points
7294 : ! of the set which samples the entire Brillouin zone
7295 26542 : do iqpt=1,nqpt
7296 26300 : if (mod(iqpt, nprocs) /= my_rank) cycle ! mpi-parallelism
7297 :
7298 26292 : q1=qtest(iqpt,1) ! iblok
7299 26292 : q2=qtest(iqpt,2) ! isym
7300 : ! Skip this q-point if don't have enough info and allow_qmiss
7301 26292 : if (allow_qmiss .and. q1==0) cycle
7302 :
7303 : ! Check if the symmetry accompagnied with time reversal : q <- -q
7304 104784 : do ii=1,3
7305 104784 : qq(ii)=ddb%qpt(ii,q1)/ddb%nrm(1,q1)
7306 : end do
7307 67347 : if (qtest(iqpt,3)/=0) qq(:) = -qq(:)
7308 : !
7309 104784 : do ii=1,3
7310 340548 : do jj=1,3
7311 235764 : ss(ii,jj)=zero
7312 1021644 : do kk=1,3
7313 3064932 : do ll=1,3
7314 2829168 : ss(ii,jj) = ss(ii,jj) + rprimd(ii,kk) * symrel(kk,ll,q2) * gprimd(jj,ll)
7315 : end do
7316 : end do
7317 : end do
7318 : end do
7319 :
7320 : ! Check whether all the information is contained in the DDB
7321 106655 : do ipert2=1,natom
7322 348032 : do idir2=1,3
7323 1539917 : do ipert1=1,natom
7324 5113701 : do idir1=1,3
7325 3654243 : index = idir1+ 3*((ipert1-1)+ddb%mpert*((idir2-1)+3*(ipert2-1)))
7326 : !if(ddb%flg(idir1,ipert1,idir2,ipert2,q1)/=1)then
7327 4872324 : if(ddb%flg(index,q1)/=1)then
7328 : write(msg, '(a,a,a,i0,a,a,a,4(i0,1x),a,a,a,a)' )&
7329 0 : 'Elements are missing in the DDB.',ch10,&
7330 0 : 'In block iq1: ',q1,' the following element is missing: ',ch10,&
7331 0 : '(idir1, ipert1, idir2, ipert2): ',idir1,ipert1,idir2,ipert2,ch10,&
7332 0 : 'Action: add the required information in the DDB with mrgddb,',ch10,&
7333 0 : 'and/or check that all irreducible perturbations have been computed.'
7334 0 : ABI_ERROR(msg)
7335 : end if
7336 : end do
7337 : end do
7338 : end do
7339 : end do
7340 :
7341 : ! Read the dynamical matrices in the DDB
7342 106655 : do ipert2=1,natom
7343 348032 : do idir2=1,3
7344 1539917 : do ipert1=1,natom
7345 5113701 : do idir1=1,3
7346 12180810 : ddd(:,idir1,ipert1,idir2,ipert2)=ddb%val(:,idir1+3*(ipert1-1+mpert*(idir2-1+3*(ipert2-1))),q1)
7347 : end do
7348 : end do
7349 : end do
7350 : end do
7351 :
7352 : ! determine sign of complex conjugation
7353 : ! If there is Time Reversal : D.M. <- Complex Conjugate D.M.
7354 : ! MBC <- Complex Conjugate MBC
7355 26196 : if (qtest(iqpt,3)==0) then
7356 : sign1 = one
7357 : sign2 = one
7358 : else ! if timrev -> complex conjugate
7359 13717 : sign1 = one
7360 13717 : sign2 = -one
7361 : end if
7362 :
7363 : ! Calculation of the dynamical matrix of a symmetrical q point
7364 106897 : do ia=1,natom
7365 512786 : do ib=1,natom
7366 : ! write(std_out,*)'atom-> ',ia,indsym(4,q2,ia); write(std_out,*)'atom-> ',ib,indsym(4,q2,ib)
7367 406027 : arg1=two_pi*(qq(1)*indsym(1,q2,ia)+qq(2)*indsym(2,q2,ia)+qq(3)*indsym(3,q2,ia))
7368 406027 : arg2=two_pi*(qq(1)*indsym(1,q2,ib)+qq(2)*indsym(2,q2,ib)+qq(3)*indsym(3,q2,ib))
7369 406027 : re=cos(arg1)*cos(arg2)+sin(arg1)*sin(arg2)
7370 406027 : im=cos(arg2)*sin(arg1)-cos(arg1)*sin(arg2)
7371 1704567 : do mu=1,3
7372 5278351 : do nu=1,3
7373 : sumr=zero
7374 : sumi=zero
7375 14616972 : do ii=1,3
7376 47505159 : do jj=1,3
7377 32888187 : sumr=sumr+ss(mu,ii)*ss(nu,jj)*ddd(1,ii,indsym(4,q2,ia),jj,indsym(4,q2,ib))
7378 43850916 : sumi=sumi+ss(mu,ii)*ss(nu,jj)*ddd(2,ii,indsym(4,q2,ia),jj,indsym(4,q2,ib))
7379 : end do
7380 : end do
7381 :
7382 : ! Dynmat -> Dynamical Matrix for the q point of the sampling
7383 : ! write(std_out,*)' Sumr -> ',mu,nu,sumr; write(std_out,*)' Sumi -> ',mu,nu,sumi
7384 3654243 : dynmat(1,mu,ia,nu,ib,iqpt) = sign1*re*sumr - sign2*im*sumi
7385 4872324 : dynmat(2,mu,ia,nu,ib,iqpt) = sign2*re*sumi + sign1*im*sumr
7386 : end do ! coordinates
7387 : end do
7388 :
7389 : end do ! ia atoms
7390 : end do ! ib atoms
7391 : end do ! q points of the sampling
7392 :
7393 242 : ABI_FREE(ddd)
7394 242 : ABI_FREE(qtest)
7395 :
7396 242 : call xmpi_sum(dynmat, comm, ierr)
7397 :
7398 242 : end subroutine symdm9
7399 : !!***
7400 :
7401 : !----------------------------------------------------------------------
7402 :
7403 384 : end module m_ddb
7404 : !!***
|
