Branch data 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 : 3431 : subroutine ddb_init(ddb, dtset, nblok, mpert, &
467 [ + + + - : 3431 : 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 [ - + ]: 3431 : with_d0E_ = .false. ; if (present(with_d0E)) with_d0E_ = with_d0E
484 [ + + ]: 3431 : with_d1E_ = .false. ; if (present(with_d1E)) with_d1E_ = with_d1E
485 [ + + ]: 3431 : with_d2E_ = .false. ; if (present(with_d2E)) with_d2E_ = with_d2E
486 [ + + ]: 3431 : with_d3E_ = .false. ; if (present(with_d3E)) with_d3E_ = with_d3E
487 [ + + ]: 3431 : with_d2eig_ = .false. ; if (present(with_d2eig)) with_d2eig_ = with_d2eig
488 : :
489 : 3431 : msize_ = 0
490 [ - + ]: 3431 : if (with_d0E_) msize_ = 1
491 [ + + ]: 3431 : if (with_d1E_) msize_ = 3 * mpert
492 [ + + ]: 3431 : if (with_d2E_ .or. with_d2eig_) msize_ = 3 * mpert * 3 * mpert
493 [ + + ]: 3431 : if (with_d3E_) msize_ = 3 * mpert * 3 * mpert * 3 * mpert
494 : :
495 : 3431 : call ddb%malloc(msize_, nblok, dtset%natom, dtset%ntypat, mpert)
496 : :
497 : 3431 : ddb%occopt = dtset%occopt
498 : 3431 : ddb%prtvol = dtset%prtvol
499 : :
500 [ + + + + ]: 44603 : ddb%rprim(:,:) = dtset%rprim_orig(1:3,1:3,1)
501 [ + + ]: 13724 : ddb%acell(:) = dtset%acell_orig(1:3,1)
502 : :
503 : 3431 : call matr3inv(ddb%rprim, ddb%gprim)
504 : :
505 [ + + + + ]: 28463 : ddb%omega(:,:) = zero
506 [ + + + + ]: 66011 : ddb%qpt(:,:) = zero
507 [ + + + + ]: 28463 : ddb%nrm(:,:) = one
508 [ - + ]: 3431 : if (with_d0E_) then
509 [ # # ]: 0 : ddb%typ(:) = BLKTYP_d0E_xx
510 [ + + ]: 3431 : else if (with_d1E_) then
511 [ + + ]: 8495 : ddb%typ(:) = BLKTYP_d1E_xx
512 [ + + ]: 597 : else if (with_d2E_) then
513 [ + + ]: 838 : 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 [ + + + + ]: 2758385 : ddb%flg(:,:) = 0
521 [ + + ]: 7777 : ddb%amu(:) = dtset%amu_orig(:,1)
522 : :
523 : 3431 : ddb%nsppol = dtset%nsppol
524 : :
525 [ + + ]: 3431 : if (present(mband)) then
526 : 137 : ddb%nband = mband
527 : : else
528 : 3294 : ddb%nband = dtset%mband * ddb%nsppol
529 : : end if
530 : :
531 [ + + ]: 3431 : if (present(nkpt)) then
532 : 137 : ddb%nkpt = nkpt
533 : : else
534 : 3294 : ddb%nkpt = dtset%nkpt
535 : : end if
536 : :
537 : : ! TODO: Allocate d2eig here instead of leaving it to the calling routine.
538 [ + + ]: 3431 : if (with_d2eig_) call ddb%malloc_d2eig(ddb%nband*ddb%nsppol, ddb%nkpt)
539 : :
540 [ + + ]: 3431 : 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 : 3431 : 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 : 4136 : subroutine ddb_free(ddb)
563 : :
564 : : !Arguments -------------------------------
565 : : class(ddb_type),intent(inout) :: ddb
566 : : ! ************************************************************************
567 : :
568 : : !integer
569 [ + + ]: 4136 : ABI_SFREE(ddb%flg)
570 [ + + ]: 4136 : ABI_SFREE(ddb%typ)
571 : :
572 : : ! real
573 [ + + ]: 4136 : ABI_SFREE(ddb%amu)
574 [ + + ]: 4136 : ABI_SFREE(ddb%qpt)
575 [ + + ]: 4136 : ABI_SFREE(ddb%omega)
576 [ + + ]: 4136 : ABI_SFREE(ddb%nrm)
577 [ + + ]: 4136 : ABI_SFREE(ddb%val_fs)
578 [ + + ]: 4136 : ABI_SFREE(ddb%val_rs)
579 [ + + ]: 4136 : ABI_SFREE(ddb%kpt)
580 [ + + ]: 4136 : ABI_SFREE(ddb%val)
581 [ + + ]: 4136 : ABI_SFREE(ddb%eig2dval)
582 : :
583 : 4136 : 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 : 3962 : 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 : 3962 : ddb%msize = msize
664 : 3962 : ddb%nblok = nblok
665 : 3962 : ddb%natom = natom
666 : : !ddb%mpert = natom + MPERT_MAX
667 : 3962 : ddb%mpert = mpert
668 : 3962 : ddb%ntypat = ntypat
669 : :
670 : : ! integer
671 [ - + + - : 53911134 : ABI_CALLOC(ddb%flg, (msize, nblok))
- + + - +
- + - - +
- + - + +
+ + + ]
672 [ - + + - : 20926 : ABI_CALLOC(ddb%typ, (nblok))
+ - + - -
+ - + - +
+ + ]
673 : :
674 : : ! real
675 [ - + + - : 11886 : ABI_MALLOC(ddb%amu, (ntypat))
+ - + - -
+ - + -
+ ]
676 [ - + + - : 11886 : ABI_MALLOC(ddb%nrm, (3, nblok))
+ - + - -
+ - + -
+ ]
677 [ - + + - : 7924 : ABI_MALLOC(ddb%omega, (3, nblok))
- + - + -
+ ]
678 [ - + + - : 11886 : ABI_MALLOC(ddb%qpt, (9, nblok))
+ - + - -
+ - + -
+ ]
679 [ - + + - : 15848 : ABI_MALLOC(ddb%val, (2, msize, nblok))
- + + - +
- + - - +
- + - + ]
680 [ + + + + : 161671740 : ddb%val = huge(one)
+ + ]
681 : :
682 : : ! FIXME: should really add nsppol argument (see thmeig).
683 [ + + ]: 3962 : if (present(nkpt) .and. present(nband)) then
684 : 184 : call ddb%malloc_d2eig(nband, nkpt)
685 : : end if
686 : :
687 : 3962 : 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 : 573 : 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 [ + + ]: 5730 : ddb%qpt(:,iblok)=zero
757 [ + + ]: 2292 : ddb%nrm(:,iblok)=one
758 : :
759 [ + + ]: 2292 : ddb%qpt(1:3,iblok) = qpt(1:3)
760 : :
761 [ - + ]: 573 : if (present(qpt2)) then
762 [ # # ]: 0 : ddb%qpt(4:6,iblok) = qpt2(1:3)
763 : : end if
764 : :
765 [ - + ]: 573 : if (present(qpt3)) then
766 [ # # ]: 0 : ddb%qpt(7:9,iblok) = qpt3(1:3)
767 : : end if
768 : :
769 : 573 : 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 : 436 : 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 [ + + ]: 1744 : ddb%omega(:,iblok)=zero
804 : :
805 : 436 : ddb%omega(1,iblok) = omega
806 [ - + ]: 436 : if (present(omega2)) ddb%omega(2,iblok) = omega2
807 [ - + ]: 436 : if (present(omega3)) ddb%omega(3,iblok) = omega3
808 : :
809 : 436 : 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 : 2958 : 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 : 2958 : ii=0
843 [ + + ]: 30659 : do ipert2=1,ddb%mpert
844 [ + + ]: 113762 : do idir2=1,3
845 [ + + ]: 1009115 : do ipert1=1,ddb%mpert
846 [ + + ]: 3676347 : do idir1=1,3
847 : 2694933 : ii=ii+1
848 : 2694933 : ddb%flg(ii,iblok) = flg(idir1,ipert1,idir2,ipert2)
849 : 2694933 : ddb%val(1,ii,iblok) = d2matr(1,idir1,ipert1,idir2,ipert2)
850 : 3593244 : 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 : 2958 : 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 : 671 : 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 [ - + + - : 3355 : ABI_MALLOC(d2matr, (2,3,ddb%mpert,3,ddb%mpert))
+ - - + +
- + - + -
- + - + -
+ ]
893 [ - + + - : 3355 : ABI_MALLOC(flg, (3,ddb%mpert,3,ddb%mpert))
+ - - + +
- + - + -
- + - + -
+ ]
894 : :
895 [ + + + + : 2825475 : d2matr = zero
+ + + + +
+ ]
896 : :
897 : : ii=0
898 [ + + ]: 8007 : do ipert2=1,ddb%mpert
899 [ + + ]: 30015 : do idir2=1,3
900 [ + + ]: 308890 : do ipert1=1,ddb%mpert
901 [ + + ]: 1140192 : do idir1=1,3
902 : 838638 : ii=ii+1
903 : 838638 : flg(idir1,ipert1,idir2,ipert2) = ddb%flg(ii,iblok)
904 [ + + ]: 1118184 : if (ddb%flg(ii,iblok) > 0) then
905 : 44950 : d2matr(1,idir1,ipert1,idir2,ipert2) = ddb%val(1,ii,iblok)
906 : 44950 : 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 : 671 : 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 : 2827 : 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 : 2827 : ddb%typ(iblok) = BLKTYP_d1E_xx
946 : 2827 : indx = 0
947 [ + + ]: 9421 : do iatom = 1, ddb%natom
948 [ + + ]: 29203 : do idir = 1, 3
949 : 19782 : indx = indx + 1
950 : 19782 : ddb%flg(indx,iblok) = 1
951 : 19782 : ddb%val(1,indx,iblok) = gred(idir,iatom)
952 : 26376 : ddb%val(2,indx,iblok) = zero
953 : : end do
954 : : end do
955 : :
956 : 2827 : 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 : 2827 : 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 : 2827 : ddb%typ(iblok) = BLKTYP_d1E_xx
1034 : 2827 : indx = 3*ddb%natom + 6
1035 : :
1036 [ + + ]: 19789 : ddb%flg(indx+1:indx+6,1) = 1
1037 [ + + ]: 19789 : ddb%val(1,indx+1:indx+6,1) = strten(1:6)
1038 [ + + ]: 19789 : ddb%val(2,indx+1:indx+6,1) = zero
1039 : :
1040 : 2827 : 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 : 2761 : 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 [ - + + - : 8283 : ABI_MALLOC(d1matr, (2,3,ddb%mpert))
+ - + - -
+ - + -
+ ]
1077 [ - + + - : 8283 : ABI_MALLOC(flg, (3,ddb%mpert))
+ - + - -
+ - + -
+ ]
1078 : :
1079 [ + + + + : 233441 : d1matr = zero
+ + ]
1080 : :
1081 : : ii=0
1082 [ + + ]: 25829 : do ipert1=1,ddb%mpert
1083 [ + + ]: 95033 : do idir1=1,3
1084 : 69204 : ii=ii+1
1085 : 69204 : flg(idir1,ipert1) = ddb%flg(ii,iblok)
1086 [ + + ]: 92272 : if (ddb%flg(ii,iblok) > 0) then
1087 : 35976 : d1matr(1,idir1,ipert1) = ddb%val(1,ii,iblok)
1088 : 35976 : d1matr(2,idir1,ipert1) = ddb%val(2,ii,iblok)
1089 : : end if
1090 : : end do
1091 : : end do
1092 : :
1093 : 2761 : 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 : 2827 : 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 : 2827 : ddb%typ(iblok) = BLKTYP_d0E_xx
1165 : 2827 : ddb%val(1,1,iblok) = etotal
1166 : 2827 : ddb%val(2,1,iblok) = zero
1167 : 2827 : ddb%flg(1,iblok) = 1
1168 : :
1169 : 2827 : 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 [ + + ]: 41732 : do ipert2=1,mpert
1770 [ + + + + ]: 41732 : if (worki(ipert2,2)==1 .and. ok==1 )then
1771 [ + + ]: 28880 : do idir1=1,3
1772 [ + + - + : 21660 : if (ipert1>natom+11.and.ipert1<=2*natom+11.and.mpdir_(idir1)==0) cycle
+ + ]
1773 [ + + ]: 92144 : do idir2=1,3
1774 [ + + + - : 63693 : if (ipert2>natom+11.and.ipert2<=2*natom+11.and.mpdir_(idir2)==0) cycle
+ + ]
1775 : :
1776 [ + + ]: 84945 : if (nder == 2) then
1777 : 57847 : index=idir1+ 3*((ipert1-1)+mpert*((idir2-1)+3*(ipert2-1)))
1778 [ + + ]: 120158 : if (ddb%flg(index,iblok)/=1) ok=0
1779 : :
1780 [ + + ]: 5438 : 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 : 292 : write(msg,'(a,i0,2a)')' gtblk9: found block number ',iblok,' agree with',' specifications '
1833 : 292 : 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 : 5860 : 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 [ + + + + : 5860 : if( (abs(qphon(1))<qtol .and. abs(qphon(2))<qtol .and. abs(qphon(3))<qtol) .or. abs(qphnrm)<qtol ) then
+ + - + ]
1873 : 2417 : gamma=1
1874 : : else
1875 : 3443 : gamma=0
1876 : : end if
1877 : :
1878 : 5860 : 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 : 2689 : 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 : 2689 : eig2d_ = .false.
4927 [ + + ]: 2689 : if(present(blkval2).and.present(kpt)) eig2d_ = .true.
4928 : :
4929 : :
4930 : : ! Count the number of elements
4931 : 2689 : nelmts=0
4932 [ + + ]: 7321717 : do ii=1,msize
4933 [ + + ]: 7321717 : if(ddb%flg(ii,iblok)==1)nelmts=nelmts+1
4934 : : end do
4935 : :
4936 : : ! Write the block type and number of elements
4937 : 2689 : write(nunit,*)' '
4938 [ + + + - : 2689 : 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 : 2546 : 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 [ + + ]: 2689 : if (is_type_d2E(ddb%typ(iblok))) then
4958 : :
4959 : : ! Write the phonon wavevector
4960 [ + - + + ]: 10192 : 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 : 2548 : write(nunit, '(a,1es16.8)' )' frequency',ddb%omega(1,iblok)
4964 : :
4965 : : ! Write the matrix elements
4966 [ + - ]: 2548 : if(choice==2)then
4967 : 2548 : ii=0
4968 [ + + ]: 26730 : do ipert2=1,mpert
4969 [ + + ]: 99276 : do idir2=1,3
4970 [ + + ]: 905330 : do ipert1=1,mpert
4971 [ + + ]: 3306954 : do idir1=1,3
4972 : 2425806 : ii=ii+1
4973 [ + + ]: 3234408 : if(ddb%flg(ii,iblok)==1)then
4974 : 566394 : write(nunit,'(4i4,2d22.14)') idir1, ipert1, idir2, ipert2, &
4975 : 1132788 : 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 [ + + ]: 2689 : 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 : 3321 : 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 : 3321 : call ddb_hdr%get_iomode(filename, 2, iomode, filename_)
5106 : :
5107 [ + + ]: 3321 : if (iomode==IO_MODE_ETSF) then
5108 : 3193 : call ddb%write_nc(ddb_hdr, filename_, comm=comm, with_psps=with_psps)
5109 [ + - ]: 128 : else if (iomode==IO_MODE_FORTRAN) then
5110 : 128 : call ddb%write_txt(ddb_hdr, filename_, with_psps=with_psps, comm=comm)
5111 : 128 : ddb_hdr%mpert = ddb%mpert ! Text format doesnt know about mpert.
5112 : : end if
5113 : :
5114 : 3321 : 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 : 146 : 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 [ - + ]: 146 : if (present(comm)) then
5151 [ # # ]: 0 : if (xmpi_comm_rank(comm) /= master) return
5152 : : end if
5153 : :
5154 : 146 : call ddb_hdr%open_write_txt(filename, with_psps)
5155 : :
5156 [ + + ]: 2815 : do iblok=1,ddb%nblok
5157 : 2815 : call ddb%write_block_txt(iblok,choice,1,ddb%mpert,ddb%msize,ddb_hdr%nkpt,ddb_hdr%unddb)
5158 : : end do
5159 : :
5160 : 146 : 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 : 3194 : 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 : 3194 : integer,allocatable :: flg_d1E(:,:)
5401 : 3194 : integer,allocatable :: flg_d2E(:,:,:,:)
5402 : 3194 : integer,allocatable :: flg_d3E(:,:,:,:,:,:)
5403 : : real(dp) :: qpt(3), qpts(3,3), nrms(3)
5404 : : real(dp) :: omega, omegas(3)
5405 : 3194 : real(dp),allocatable :: matrix_d1E(:,:,:)
5406 : 3194 : real(dp),allocatable :: matrix_d2E(:,:,:,:,:)
5407 : 3194 : real(dp),allocatable :: matrix_d3E(:,:,:,:,:,:,:)
5408 : : ! ************************************************************************
5409 : :
5410 [ - + ]: 3194 : 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 : 3194 : ddb_hdr%mpert = ddb%mpert
5419 : 3194 : call ddb_hdr%set_typ(ddb%nblok, ddb%typ)
5420 : :
5421 : 3194 : call ddb_hdr%open_write_nc(filename, with_psps=with_psps)
5422 : 3194 : ncid = ddb_hdr%ncid
5423 : :
5424 : : ! Get all group id
5425 : 3194 : ncid_d0E = nctk_idgroup(ncid, 'd0E')
5426 : 3194 : ncid_d1E = nctk_idgroup(ncid, 'd1E')
5427 : 3194 : ncid_d2E = nctk_idgroup(ncid, 'd2E')
5428 : 3194 : ncid_d3E = nctk_idgroup(ncid, 'd3E')
5429 : 3194 : ncid_d2eig = nctk_idgroup(ncid, 'd2eig')
5430 : :
5431 : : ! =============================
5432 : : ! Loop over block to be written
5433 : : ! =============================
5434 : :
5435 : 3194 : iblok_d0E = 0; iblok_d1E = 0; iblok_d2E = 0; iblok_d3E = 0; iblok_d2eig = 0
5436 : :
5437 [ + + ]: 9148 : do iblok=1,ddb%nblok
5438 : :
5439 : : ! ------------------------
5440 : : ! Zeroth-order derivatives
5441 : : ! ------------------------
5442 [ + + ]: 9148 : if (is_type_d0E(ddb%typ(iblok))) then
5443 : :
5444 : 2743 : 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 [ + + ]: 5486 : start=[iblok_d0E])
5450 [ - + ]: 2743 : NCF_CHECK(ncerr)
5451 : :
5452 : : ncerr = nf90_put_var(ncid_d0E, nctk_idname(ncid_d0E,&
5453 : : 'matrix_mask'),&
5454 : : ddb%flg(1,iblok),&
5455 [ + + ]: 5486 : start=[iblok_d0E])
5456 [ - + ]: 2743 : NCF_CHECK(ncerr)
5457 : :
5458 : : ! -----------------------
5459 : : ! First-order derivatives
5460 : : ! -----------------------
5461 [ + + ]: 3211 : else if (is_type_d1E(ddb%typ(iblok))) then
5462 : :
5463 : 2750 : iblok_d1E = iblok_d1E + 1
5464 : :
5465 [ - + - + ]: 2750 : 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 [ + + ]: 13750 : start=[1,1,1,iblok_d1E])
5471 [ - + ]: 2750 : NCF_CHECK(ncerr)
5472 : :
5473 : : ncerr = nf90_put_var(ncid_d1E, nctk_idname(ncid_d1E,&
5474 : : 'matrix_mask'),&
5475 : : flg_d1E,&
5476 [ + + ]: 11000 : start=[1,1,iblok_d1E])
5477 [ - + ]: 2750 : NCF_CHECK(ncerr)
5478 [ + - ]: 2750 : ABI_SFREE(matrix_d1E)
5479 [ + - ]: 2750 : ABI_SFREE(flg_d1E)
5480 : :
5481 : : ! ------------------------
5482 : : ! Second-order derivatives
5483 : : ! ------------------------
5484 [ + + ]: 461 : else if (is_type_d2E(ddb%typ(iblok))) then
5485 : :
5486 : 437 : iblok_d2E = iblok_d2E + 1
5487 : :
5488 [ + + ]: 1748 : do ii=1,3
5489 : 1748 : 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 [ + + ]: 1311 : start=[1,iblok_d2E])
5495 [ - + ]: 437 : NCF_CHECK(ncerr)
5496 : :
5497 : : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5498 : : 'qpoints_normalization'),&
5499 : : (ddb%nrm(1,iblok)),&
5500 [ + + ]: 874 : start=[iblok_d2E])
5501 [ - + ]: 437 : NCF_CHECK(ncerr)
5502 : :
5503 : 437 : omega = ddb%omega(1,iblok)
5504 : : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5505 : : 'frequency'),&
5506 : : omega,&
5507 [ + + ]: 874 : start=[iblok_d2E])
5508 [ - + ]: 437 : NCF_CHECK(ncerr)
5509 : :
5510 [ - + - + ]: 437 : 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 [ + + ]: 3059 : start=[1,1,1,1,1,iblok_d2E])
5516 [ - + ]: 437 : NCF_CHECK(ncerr)
5517 : :
5518 : : ncerr = nf90_put_var(ncid_d2E, nctk_idname(ncid_d2E,&
5519 : : 'matrix_mask'),&
5520 : : flg_d2E,&
5521 [ + + ]: 2622 : start=[1,1,1,1,iblok_d2E])
5522 [ - + ]: 437 : NCF_CHECK(ncerr)
5523 [ + - ]: 437 : ABI_SFREE(matrix_d2E)
5524 [ + - ]: 437 : 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 [ - + - + : 3194 : 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 : 244 : subroutine symdm9(ddb, dynmat, gprimd, indsym, mpert, natom, nqpt, nsym, rfmeth,&
7145 : 244 : 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 : 244 : integer,allocatable :: qtest(:,:)
7170 : 488 : integer :: qmiss_(nqpt)
7171 : : real(dp) :: qq(3),qsym(6),ss(3,3)
7172 : 244 : real(dp),allocatable :: ddd(:,:,:,:,:)
7173 : : ! *********************************************************************
7174 : :
7175 : 244 : 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 [ + + + + : 12579314 : dynmat = zero
+ + + + +
+ + + ]
7179 : 244 : allow_qmiss = (present(qmissing))
7180 : :
7181 [ - + + - : 1220 : 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 [ - + + - : 732 : ABI_MALLOC(qtest,(nqpt,3))
+ - + - -
+ - + ]
7190 [ + + ]: 26868 : do iqpt=1,nqpt
7191 : 26868 : 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 [ + + ]: 16826 : do iblok=1,ddb%nblok
7200 : :
7201 [ + + ]: 16826 : if (abs(ddb%typ(iblok)) == abs(rfmeth)) then
7202 : 16502 : qq(1)=ddb%qpt(1,iblok)/ddb%nrm(1,iblok)
7203 : 16502 : qq(2)=ddb%qpt(2,iblok)/ddb%nrm(1,iblok)
7204 : 16502 : qq(3)=ddb%qpt(3,iblok)/ddb%nrm(1,iblok)
7205 : :
7206 : : ! Calculation of the symmetric points (including Time Reversal)
7207 [ + + ]: 562374 : do isym=1,nsym
7208 : 545872 : qsym(1)=qq(1)*symrec(1,1,isym)+qq(2)*symrec(1,2,isym)+qq(3)*symrec(1,3,isym)
7209 : 545872 : qsym(2)=qq(1)*symrec(2,1,isym)+qq(2)*symrec(2,2,isym)+qq(3)*symrec(2,3,isym)
7210 : 545872 : 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 : 545872 : qsym(4)=-qq(1)*symrec(1,1,isym)-qq(2)*symrec(1,2,isym)-qq(3)*symrec(1,3,isym)
7214 : 545872 : qsym(5)=-qq(1)*symrec(2,1,isym)-qq(2)*symrec(2,2,isym)-qq(3)*symrec(2,3,isym)
7215 : 545872 : 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 [ + + ]: 189211772 : do iqpt=1,nqpt
7220 : :
7221 [ + + ]: 188649398 : if (mod(abs(spqpt(1,iqpt)-qsym(1))+tol,1._dp)<2*tol)then
7222 [ + + ]: 23516234 : if (mod(abs(spqpt(2,iqpt)-qsym(2))+tol,1._dp)<2*tol)then
7223 [ + + ]: 3056004 : 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 : 514240 : qtest(iqpt,1)=iblok
7232 : 514240 : qtest(iqpt,2)=isym
7233 : 514240 : qtest(iqpt,3)=0
7234 : : end if
7235 : : end if
7236 : : end if
7237 : :
7238 [ + + ]: 189195270 : if (mod(abs(spqpt(1,iqpt)-qsym(4))+tol,1._dp)<2*tol)then
7239 [ + + ]: 23516234 : if (mod(abs(spqpt(2,iqpt)-qsym(5))+tol,1._dp)<2*tol)then
7240 [ + + ]: 3056004 : 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 : 514240 : qtest(iqpt,1)=iblok
7250 : 514240 : qtest(iqpt,2)=isym
7251 : 514240 : 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 : 244 : nqmiss = 0
7264 [ + + ]: 26868 : do iqpt=1,nqpt
7265 [ + + ]: 26868 : 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 [ + + ]: 244 : 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 [ + + ]: 26868 : do iqpt=1,nqpt
7296 [ + + ]: 26624 : if (mod(iqpt, nprocs) /= my_rank) cycle ! mpi-parallelism
7297 : :
7298 : 26616 : q1=qtest(iqpt,1) ! iblok
7299 : 26616 : q2=qtest(iqpt,2) ! isym
7300 : : ! Skip this q-point if don't have enough info and allow_qmiss
7301 [ + + ]: 26616 : if (allow_qmiss .and. q1==0) cycle
7302 : :
7303 : : ! Check if the symmetry accompagnied with time reversal : q <- -q
7304 [ + + ]: 106080 : do ii=1,3
7305 : 106080 : qq(ii)=ddb%qpt(ii,q1)/ddb%nrm(1,q1)
7306 : : end do
7307 [ + + + + ]: 68163 : if (qtest(iqpt,3)/=0) qq(:) = -qq(:)
7308 : : !
7309 [ + + ]: 106080 : do ii=1,3
7310 [ + + ]: 344760 : do jj=1,3
7311 : 238680 : ss(ii,jj)=zero
7312 [ + + ]: 1034280 : do kk=1,3
7313 [ + + ]: 3102840 : do ll=1,3
7314 : 2864160 : 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 [ + + ]: 107627 : do ipert2=1,natom
7322 [ + + ]: 350948 : do idir2=1,3
7323 [ + + ]: 1546397 : do ipert1=1,natom
7324 [ + + ]: 5131197 : do idir1=1,3
7325 : 3665907 : index = idir1+ 3*((ipert1-1)+ddb%mpert*((idir2-1)+3*(ipert2-1)))
7326 : : !if(ddb%flg(idir1,ipert1,idir2,ipert2,q1)/=1)then
7327 [ - + ]: 4887876 : 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 [ + + ]: 107627 : do ipert2=1,natom
7343 [ + + ]: 350948 : do idir2=1,3
7344 [ + + ]: 1546397 : do ipert1=1,natom
7345 [ + + ]: 5131197 : do idir1=1,3
7346 [ + + ]: 12219690 : 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 [ + + ]: 26520 : if (qtest(iqpt,3)==0) then
7356 : : sign1 = one
7357 : : sign2 = one
7358 : : else ! if timrev -> complex conjugate
7359 : 13881 : sign1 = one
7360 : 13881 : sign2 = -one
7361 : : end if
7362 : :
7363 : : ! Calculation of the dynamical matrix of a symmetrical q point
7364 [ + + ]: 107871 : do ia=1,natom
7365 [ + + ]: 515054 : do ib=1,natom
7366 : : ! write(std_out,*)'atom-> ',ia,indsym(4,q2,ia); write(std_out,*)'atom-> ',ib,indsym(4,q2,ib)
7367 : 407323 : arg1=two_pi*(qq(1)*indsym(1,q2,ia)+qq(2)*indsym(2,q2,ia)+qq(3)*indsym(3,q2,ia))
7368 : 407323 : arg2=two_pi*(qq(1)*indsym(1,q2,ib)+qq(2)*indsym(2,q2,ib)+qq(3)*indsym(3,q2,ib))
7369 : 407323 : re=cos(arg1)*cos(arg2)+sin(arg1)*sin(arg2)
7370 : 407323 : im=cos(arg2)*sin(arg1)-cos(arg1)*sin(arg2)
7371 [ + + ]: 1710399 : do mu=1,3
7372 [ + + ]: 5295199 : do nu=1,3
7373 : : sumr=zero
7374 : : sumi=zero
7375 [ + + ]: 14663628 : do ii=1,3
7376 [ + + ]: 47656791 : do jj=1,3
7377 : 32993163 : sumr=sumr+ss(mu,ii)*ss(nu,jj)*ddd(1,ii,indsym(4,q2,ia),jj,indsym(4,q2,ib))
7378 : 43990884 : 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 : 3665907 : dynmat(1,mu,ia,nu,ib,iqpt) = sign1*re*sumr - sign2*im*sumi
7385 : 4887876 : 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 [ - + ]: 244 : ABI_FREE(ddd)
7394 [ - + ]: 244 : ABI_FREE(qtest)
7395 : :
7396 : 244 : call xmpi_sum(dynmat, comm, ierr)
7397 : :
7398 : 244 : end subroutine symdm9
7399 : : !!***
7400 : :
7401 : : !----------------------------------------------------------------------
7402 : :
7403 [ - + - - : 384 : end module m_ddb
+ + - + +
- - + - +
+ - - + -
+ - + - +
- + - + -
+ - + -
+ ]
7404 : : !!***
|
