TABLE OF CONTENTS
- ABINIT/m_dvdb
- m_dvdb/calc_eiqr
- m_dvdb/dvdb_check_fform
- m_dvdb/dvdb_close
- m_dvdb/dvdb_find_qpts
- m_dvdb/dvdb_findq
- m_dvdb/dvdb_free
- m_dvdb/dvdb_ftinterp_qpt
- m_dvdb/dvdb_ftinterp_setup
- m_dvdb/dvdb_ftqcache_build
- m_dvdb/dvdb_ftqcache_update_from_ft
- m_dvdb/dvdb_get_ftqbz
- m_dvdb/dvdb_get_maxw
- m_dvdb/dvdb_get_pinfo
- m_dvdb/dvdb_get_v1r_long_range
- m_dvdb/dvdb_get_v1scf_qpt
- m_dvdb/dvdb_get_v1scf_rpt
- m_dvdb/dvdb_interpolate_and_write
- m_dvdb/dvdb_interpolate_v1scf
- m_dvdb/dvdb_list_perts
- m_dvdb/dvdb_load_ddb
- m_dvdb/dvdb_load_efield
- m_dvdb/dvdb_merge_files
- m_dvdb/dvdb_new
- m_dvdb/dvdb_open_read
- m_dvdb/dvdb_print
- m_dvdb/dvdb_qcache_read
- m_dvdb/dvdb_qcache_update_from_file
- m_dvdb/dvdb_qdownsample
- m_dvdb/dvdb_read_onev1
- m_dvdb/dvdb_readsym_allv1
- m_dvdb/dvdb_readsym_qbz
- m_dvdb/dvdb_rewind
- m_dvdb/dvdb_seek
- m_dvdb/dvdb_set_pert_distrib
- m_dvdb/dvdb_t
- m_dvdb/dvdb_test_ftinterp
- m_dvdb/dvdb_test_v1complete
- m_dvdb/dvdb_test_v1rsym
- m_dvdb/dvdb_write_v1qavg
- m_dvdb/find_symeq
- m_dvdb/my_hdr_skip
- m_dvdb/prepare_ftinterp
- m_dvdb/qcache_free
- m_dvdb/qcache_get_mbsize
- m_dvdb/qcache_new
- m_dvdb/qcache_qcache_make_room
- m_dvdb/qcache_report_stats
- m_dvdb/qcache_t
- m_dvdb/rotate_fqg
- m_dvdb/v1phq_complete
- m_dvdb/v1phq_rotate
- m_dvdb/v1phq_rotate_myperts
- m_dvdb/v1phq_symmetrize
ABINIT/m_dvdb [ Modules ]
NAME
m_dvdb
FUNCTION
Objects and methods to extract data from the DVDB file. The DVDB file is Fortran binary file with a collection of DFPT potentials associated to the different phonon perturbations (idir, ipert, qpt). DVDB files are produced with the `mrgdv` utility and used in the EPH code to compute the matrix elements: <k+q| dvscf_{idir, ipert, qpt} |k>.
COPYRIGHT
Copyright (C) 2009-2024 ABINIT group (MG, GA) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
TODO
- Do we still need to support the case in which the potentials are read from file
without interpolation? We know that IO is gonna be terrible.
- Check spin and MPI-parallelism. Can we distributed nsppol?
- Rewrite qcache from scratch, keep only the IBZ of the present iteration
SOURCE
27 #if defined HAVE_CONFIG_H 28 #include "config.h" 29 #endif 30 31 #include "abi_common.h" 32 33 module m_dvdb 34 35 use defs_basis 36 use m_abicore 37 use m_errors 38 use m_xmpi 39 use m_distribfft 40 use m_nctk 41 use m_sort 42 use netcdf 43 use m_hdr 44 use m_ddb 45 use m_ddb_hdr 46 use m_dtset 47 use m_krank 48 49 use defs_abitypes, only : mpi_type 50 use m_fstrings, only : strcat, sjoin, itoa, ktoa, ltoa, ftoa, yesno, endswith 51 use m_time, only : cwtime, cwtime_report, sec2str, timab 52 use m_io_tools, only : open_file, file_exists, delete_file 53 use m_numeric_tools, only : wrap2_pmhalf, vdiff_t, vdiff_eval, vdiff_print, l2int 54 use m_symtk, only : mati3inv, matr3inv, littlegroup_q 55 use m_geometry, only : littlegroup_pert, irreducible_set_pert, mkradim, xcart2xred 56 use m_dynmat, only : canat9, get_bigbox_and_weights 57 use m_copy, only : alloc_copy 58 use m_mpinfo, only : destroy_mpi_enreg, initmpi_seq 59 use m_ioarr, only : read_rhor 60 use m_fftcore, only : ngfft_seq 61 use m_fft_mesh, only : rotate_fft_mesh, times_eigr, times_eikr, ig2gfft, get_gftt, calc_ceikr, calc_eigr 62 use m_fft, only : fourdp, zerosym 63 use m_crystal, only : crystal_t 64 use m_kpts, only : kpts_ibz_from_kptrlatt, listkk, kpts_map, kpts_timrev_from_kptopt 65 use m_spacepar, only : symrhg, setsym 66 use m_fourier_interpol,only : fourier_interpol 67 use m_pawrhoij, only : pawrhoij_type 68 69 implicit none 70 71 private
m_dvdb/calc_eiqr [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
calc_eiqr
FUNCTION
Compute e^{iq.r} for nrpt R-points.
INPUTS
OUTPUT
SOURCE
5206 pure subroutine calc_eiqr(qpt, nrpt, rpt, eiqr) 5207 5208 !Arguments ------------------------------- 5209 !scalars 5210 integer,intent(in) :: nrpt 5211 !arrays 5212 real(dp),intent(in) :: qpt(3), rpt(3, nrpt) 5213 real(dp),intent(out) :: eiqr(2, nrpt) 5214 5215 !Local variables ------------------------- 5216 !scalars 5217 integer :: ir 5218 real(dp) :: qr 5219 5220 ! ********************************************************************* 5221 5222 do ir=1,nrpt 5223 qr = two_pi * dot_product(qpt, rpt(:,ir)) 5224 eiqr(1, ir) = cos(qr); eiqr(2, ir) = sin(qr) 5225 end do 5226 5227 end subroutine calc_eiqr
m_dvdb/dvdb_check_fform [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_check_fform
FUNCTION
Check the value of fform. Return exit status and error message.
INPUTS
fform=Value read from the header
mode="merge_dvdb" to check the value of fform when we are merging POT1 files
"read_dvdb" when we are reading POT1 files from a DVDB file.
OUTPUT
errmsg=String with error message if ierr /= 0
SOURCE
5249 integer function dvdb_check_fform(fform, mode, errmsg) result(ierr) 5250 5251 !Arguments ------------------------------------ 5252 integer,intent(in) :: fform 5253 character(len=*),intent(in) :: mode 5254 character(len=*),intent(out) :: errmsg 5255 5256 ! ************************************************************************* 5257 ierr = 0 5258 5259 ! Here I made a mistake because 102 corresponds to GS potentials 5260 ! as a consequence DVDB files generated with version <= 8.1.6 5261 ! contain list of potentials with fform = 102. 5262 !integer :: fform_pot=102 5263 !integer :: fform_pot=109 5264 !integer :: fform_pot=111 5265 5266 if (fform == 0) then 5267 errmsg = "fform == 0! Either corrupted/nonexistent file or IO error" 5268 ierr = 42; return 5269 end if 5270 5271 select case (mode) 5272 case ("merge_dvdb") 5273 if (all(fform /= [109, 111])) then 5274 errmsg = sjoin("fform:", itoa(fform), "is not supported in `merge_dvdb` mode") 5275 ierr = 1; return 5276 end if 5277 5278 case ("read_dvdb") 5279 if (all(fform /= [102, 109, 111])) then 5280 errmsg = sjoin("fform:", itoa(fform), "is not supported in `read_dvdb` mode") 5281 ierr = 1; return 5282 end if 5283 5284 case default 5285 errmsg = sjoin("Invalid mode:", mode) 5286 ierr = -1; return 5287 end select 5288 5289 end function dvdb_check_fform
m_dvdb/dvdb_close [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_close
FUNCTION
Close the file
SOURCE
883 subroutine dvdb_close(db) 884 885 !Arguments ------------------------------------ 886 !scalars 887 class(dvdb_t),intent(inout) :: db 888 889 !************************************************************************ 890 891 select case (db%iomode) 892 case (IO_MODE_FORTRAN) 893 close(db%fh) 894 case default 895 ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode))) 896 end select 897 898 db%rw_mode = DVDB_NOMODE 899 900 end subroutine dvdb_close
m_dvdb/dvdb_find_qpts [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_find_qpts
FUNCTION
Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed. Returns -1 if not found.
INPUTS
nqpt: Number of q-points qpt(3,nqpt): q-point in reduced coordinates. comm: MPI communicator
OUTPUT
iq2dvdb(nqpt): index of q-points in dvdb%qpts. Set to -1 if not found ierr= Number of points **not** found
SOURCE
4585 integer function dvdb_find_qpts(db, nqpt, qpts, iq2dvdb, comm) result(notfound) 4586 4587 !Arguments ------------------------------------ 4588 !scalars 4589 class(dvdb_t),intent(in) :: db 4590 integer,intent(in) :: nqpt, comm 4591 !arrays 4592 real(dp),intent(in) :: qpts(3, nqpt) 4593 integer,intent(out) :: iq2dvdb(nqpt) 4594 4595 !Local variables------------------------------- 4596 !scalars 4597 integer :: iq, my_rank, nprocs, ierr 4598 4599 ! ************************************************************************* 4600 4601 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 4602 4603 iq2dvdb = 0 4604 do iq=1,nqpt 4605 if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism 4606 iq2dvdb(iq) = db%findq(qpts(:, iq)) 4607 end do 4608 4609 call xmpi_sum(iq2dvdb, comm, ierr) 4610 notfound = count(iq2dvdb == -1) 4611 4612 end function dvdb_find_qpts
m_dvdb/dvdb_findq [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_findq
FUNCTION
Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed. Returns -1 if not found.
INPUTS
qpt(3)=q-point in reduced coordinates.
[qtol]=Optional tolerance for q-point comparison.
For each reduced direction the absolute difference between the coordinates must be less that qtol
SOURCE
4537 integer pure function dvdb_findq(db, qpt, qtol) result(iqpt) 4538 4539 !Arguments ------------------------------------ 4540 !scalars 4541 real(dp),optional,intent(in) :: qtol 4542 class(dvdb_t),intent(in) :: db 4543 !arrays 4544 real(dp),intent(in) :: qpt(3) 4545 4546 !Local variables------------------------------- 4547 !scalars 4548 integer :: iq 4549 real(dp) :: my_qtol 4550 4551 ! ************************************************************************* 4552 4553 my_qtol = tol6; if (present(qtol)) my_qtol = qtol 4554 iqpt = -1 4555 do iq=1,db%nqpt 4556 if (all(abs(db%qpts(:, iq) - qpt) < my_qtol)) then 4557 iqpt = iq; exit 4558 end if 4559 end do 4560 4561 end function dvdb_findq
m_dvdb/dvdb_free [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_free
FUNCTION
Close the file and release the memory allocated.
SOURCE
914 subroutine dvdb_free(db) 915 916 !Arguments ------------------------------------ 917 !scalars 918 class(dvdb_t),intent(inout) :: db 919 920 !************************************************************************ 921 922 ! integer arrays 923 ABI_SFREE(db%my_pinfo) 924 ABI_SFREE(db%pert_table) 925 ABI_SFREE(db%pos_dpq) 926 ABI_SFREE(db%cplex_v1) 927 ABI_SFREE(db%symq_table) 928 ABI_SFREE(db%iv_pinfoq) 929 ABI_SFREE(db%ngfft3_v1) 930 ABI_SFREE(db%my_irpt2tot) 931 932 ! real arrays 933 ABI_SFREE(db%qpts) 934 ABI_SFREE(db%my_rpt) 935 ABI_SFREE(db%wsr) 936 ABI_SFREE(db%my_wratm) 937 ABI_SFREE(db%rhog1_g0) 938 ABI_SFREE(db%zeff) 939 ABI_SFREE(db%zeff_raw) 940 ABI_SFREE(db%qstar) 941 ABI_SFREE(db%v1r_efield) 942 943 ! types 944 call db%hdr_ref%free() 945 call db%cryst%free() 946 call destroy_mpi_enreg(db%mpi_enreg) 947 948 ! Clean cache(s) 949 call db%qcache%free() 950 call db%ft_qcache%free() 951 952 ! Close the file but only if we have performed IO. 953 if (db%rw_mode == DVDB_NOMODE) return 954 call db%close() 955 956 end subroutine dvdb_free
m_dvdb/dvdb_ftinterp_qpt [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_ftinterp_qpt
FUNCTION
Fourier interpolation of potentials for a given q-point Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`. \begin{equation} \partial v^{scf}_{\tilde\qq\kappa\alpha}(\rr) \approx \sum_\RR e^{+i\tilde{\qq}\cdot(\RR - \rr)} W_{\kappa\alpha}(\rr,\RR). \end{equation
INPUTS
qpt(3)=q-point in reduced coordinates (arbitrary point in the BZ). nfft=Number of FFT-points treated by this processors. ngfft(18)=contain all needed information about 3D FFT. comm=MPI communicator for R-points. [add_lr]= If present, use this value for the LR treatment instead of dv%add_lr
OUTPUT
ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point (periodic part)
SOURCE
3424 subroutine dvdb_ftinterp_qpt(db, qpt, nfft, ngfft, ov1r, comm_rpt, add_lr) 3425 3426 !Arguments ------------------------------------ 3427 !scalars 3428 integer,intent(in) :: nfft, comm_rpt 3429 integer,optional,intent(in) :: add_lr 3430 class(dvdb_t),intent(inout) :: db 3431 !arrays 3432 integer,intent(in) :: ngfft(18) 3433 real(dp),intent(in) :: qpt(3) 3434 real(dp),intent(out) :: ov1r(2, nfft, db%nspden, db%my_npert) 3435 3436 !Local variables------------------------------- 3437 !scalars 3438 integer,parameter :: cplex2 = 2 3439 integer :: ispden, imyp, idir, ipert, timerev_q, ierr, my_add_lr !, ifft, ir 3440 !real(dp) :: qmod 3441 !real(sp) :: beta_sp !, wr !,wi 3442 logical :: prev_has_zeff, prev_has_quadrupoles, prev_has_efield 3443 !arrays 3444 integer :: symq(4,2,db%cryst%nsym), rfdir(3) 3445 integer,allocatable :: pertsy(:,:), rfpert(:), pflag(:,:) 3446 !real(dp) :: qcart(3) 3447 real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:,:) 3448 real(sp),allocatable :: weiqr_sp(:,:), ov1r_sp(:, :), eiqr_sp(:,:) 3449 3450 ! ************************************************************************* 3451 3452 my_add_lr = db%add_lr; if (present(add_lr)) my_add_lr = add_lr 3453 3454 !qcart = two_pi * matmul(db%cryst%gprimd, qpt) 3455 !qmod = sqrt(dot_product(qcart, qcart)) 3456 3457 if (my_add_lr >= 4) then 3458 ! Use LR part only and return immediately. 3459 3460 if (my_add_lr > 4) then 3461 prev_has_zeff = db%has_zeff 3462 prev_has_quadrupoles = db%has_quadrupoles 3463 prev_has_efield = db%has_efield 3464 db%has_zeff = .False. 3465 db%has_quadrupoles = .False. 3466 db%has_efield = .False. 3467 if (my_add_lr == 5 .and. prev_has_zeff) db%has_zeff = .True. 3468 if (my_add_lr == 6 .and. prev_has_quadrupoles) db%has_quadrupoles = .True. 3469 if (my_add_lr == 7 .and. prev_has_efield) db%has_efield = .True. 3470 end if 3471 3472 ov1r = zero 3473 do imyp=1,db%my_npert 3474 idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp) 3475 call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, ov1r(:, :, 1, imyp)) 3476 ! Remove the phase to get the lattice-periodic part. 3477 call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, 1, imyp)) 3478 if (db%nspden /= 1) ov1r(:, :, 2, imyp) = ov1r(:, :, 1, imyp) 3479 end do 3480 3481 if (my_add_lr > 4) then 3482 ! Restore input flags. 3483 db%has_zeff = prev_has_zeff 3484 db%has_quadrupoles = prev_has_quadrupoles 3485 db%has_efield = prev_has_efield 3486 end if 3487 3488 return 3489 end if 3490 3491 ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)") 3492 3493 ! Examine the symmetries of the q-wavevector 3494 call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol) 3495 3496 ! Compute long-range part of the coupling potential. 3497 if (my_add_lr > 0) then 3498 !call wrtout(std_out, "dvdb_ftinterp_qpt: Computing long-range part of the coupling potential.") 3499 ABI_MALLOC(v1r_lr, (2, nfft, db%my_npert)) 3500 do imyp=1,db%my_npert 3501 idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp) 3502 call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp)) 3503 end do 3504 end if 3505 3506 ! Compute e^{iq.R} FT phases for this q-point. 3507 ABI_MALLOC(eiqr, (2, db%my_nrpt)) 3508 call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr) 3509 3510 ! Interpolate potentials (results in ov1r) 3511 if (db%nprocs_rpt > 1) ov1r = zero 3512 ABI_MALLOC(ov1r_sp, (2, nfft)) 3513 3514 ABI_MALLOC(weiqr_sp, (db%my_nrpt, 2)) 3515 ABI_MALLOC(eiqr_sp, (db%my_nrpt, 2)) 3516 eiqr_sp = transpose(eiqr) 3517 3518 do imyp=1,db%my_npert 3519 idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp) 3520 3521 weiqr_sp(:, 1) = db%my_wratm(:, ipert) * eiqr_sp(:, 1) 3522 weiqr_sp(:, 2) = db%my_wratm(:, ipert) * eiqr_sp(:, 2) 3523 3524 do ispden=1,db%nspden 3525 3526 ! We need to compute: sum_R W(R, r) e^{iq.R} with W real matrix. 3527 ! Use BLAS2 to compute ov1r = W (x + iy) but need to handle kind conversion as ov1r is double-precision 3528 ! NB: Can use MKL BLAS-like extensions to perform 2 matrix-vector operations: 3529 ! call dgem2vu(m, n, alpha, a, lda, x1, incx1, x2, incx2, beta, y1, incy1, y2, incy2) 3530 ! unfortunately the API does not support transa so one has to transport db%wsr. 3531 ! Alternatively, compute all my_npert with ZGEMM (more memory but it should be more efficient). 3532 3533 call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,1), 1, & 3534 zero_sp, ov1r_sp(1,1), 2) 3535 call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,2), 1, & 3536 zero_sp, ov1r_sp(2,1), 2) 3537 3538 ov1r(:, :, ispden, imyp) = ov1r_sp(:, :) 3539 3540 ! Add the long-range part of the potential 3541 if (my_add_lr > 0) then 3542 !call wrtout(std_out, "Adding the long-range part of the potential") 3543 ov1r(:, :, ispden, imyp) = ov1r(:, :, ispden, imyp) + v1r_lr(:, :, imyp) 3544 end if 3545 3546 ! Remove the phase to get the lattice-periodic part. 3547 call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, ispden, imyp)) 3548 3549 ! Need to collect results if R-points are distributed (TODO Non-blocking API?) 3550 if (db%nprocs_rpt > 1) call xmpi_sum(ov1r(:,:,ispden,imyp), comm_rpt, ierr) 3551 end do ! ispden 3552 3553 ! Be careful with Gamma-point and cplex! 3554 if (db%symv1 == 1) then !(.and. reveiver == -1 .or. receiver == db%comm_rpt%my_rank) 3555 call v1phq_symmetrize(db%cryst, idir, ipert, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, & 3556 db%mpi_enreg, ov1r(:,:,:,imyp)) 3557 end if 3558 end do ! imyp 3559 3560 ABI_FREE(ov1r_sp) 3561 3562 if (db%symv1 == 2) then 3563 ! Symmetrize potentials (this part is seldom executed) 3564 ! Initialize the list of perturbations rfpert and rdfir 3565 ! WARNING: Only phonon perturbations are considered for the time being. 3566 ABI_MALLOC(rfpert, (db%mpert)) 3567 rfpert = 0; rfpert(1:db%cryst%natom) = 1; rfdir = 1 3568 ABI_MALLOC(pertsy, (3, db%mpert)) 3569 ABI_MALLOC(pflag, (3, db%natom)) 3570 3571 ! Determine the symmetrical perturbations. Meaning of pertsy: 3572 ! 0 for non-target perturbations 3573 ! 1 for basis perturbations 3574 ! -1 for perturbations that can be found from basis perturbations 3575 call irreducible_set_pert(db%cryst%indsym,db%mpert,db%cryst%natom,db%cryst%nsym,& 3576 pertsy,rfdir,rfpert,symq,db%cryst%symrec,db%cryst%symrel) 3577 3578 pflag = 0 3579 do imyp=1,3*db%cryst%natom 3580 idir = mod(imyp-1, 3) + 1; ipert = (imyp - idir) / 3 + 1 3581 if (pertsy(idir, ipert) == 1) pflag(idir,ipert) = 1 3582 end do 3583 3584 ! Complete potentials 3585 call v1phq_complete(db%cryst,qpt,ngfft,cplex2,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,ov1r) 3586 3587 ABI_FREE(pertsy) 3588 ABI_FREE(rfpert) 3589 ABI_FREE(pflag) 3590 endif 3591 3592 ! Set imaginary part to zero if gamma point. 3593 if (sum(qpt**2) < tol14) ov1r(2, :, :, :) = zero 3594 3595 ABI_FREE(eiqr) 3596 ABI_FREE(weiqr_sp) 3597 ABI_SFREE(v1r_lr) 3598 ABI_SFREE(eiqr_sp) 3599 3600 end subroutine dvdb_ftinterp_qpt
m_dvdb/dvdb_ftinterp_setup [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_ftinterp_setup
FUNCTION
Precompute the wsr array with with the DFPT potential in the supercell required for the Fourier interpolation This is a collective routine that should be called by all procs inside db%comm. \begin{equation} \label{eq:dfpt_pot_realspace} W_{\kappa\alpha}(\rr,\RR) = \dfrac{1}{N_\qq} \sum_\qq e^{-i\qq\cdot(\RR - \rr)}\, \partial_{\kappa\alpha\qq}{v^{\text{scf}}}(\rr) \end{equation}
INPUTS
ngqpt(3)=Divisions of the ab-initio q-mesh. qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used) nqshift=Number of shifts used to generated the ab-initio q-mesh. qshift(3,nqshift)=The shifts of the ab-initio q-mesh. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT comm_rpt = MPI communicator used to distribute R-lattice points.
SOURCE
2890 subroutine dvdb_ftinterp_setup(db, ngqpt, qptopt, nqshift, qshift, nfft, ngfft, comm_rpt) 2891 2892 !Arguments ------------------------------------ 2893 !scalars 2894 integer,intent(in) :: qptopt,nqshift,nfft,comm_rpt 2895 class(dvdb_t),target,intent(inout) :: db 2896 !arrays 2897 integer,intent(in) :: ngqpt(3), ngfft(18) 2898 real(dp),intent(in) :: qshift(3,nqshift) 2899 2900 !Local variables------------------------------- 2901 !scalars 2902 integer,parameter :: master=0 2903 integer :: iq_ibz,nqibz,iq_bz,nqbz !, timerev_q 2904 integer :: ii,jj,cplex_qibz,ispden,imyp,irpt,idir,ipert,ipc 2905 integer :: iqst, itimrev, isym 2906 integer :: ifft, ierr, my_rstart, my_rstop, iatom 2907 real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all 2908 logical :: isirr_q 2909 character(len=500) :: msg 2910 !arrays 2911 integer :: g0q(3) 2912 !integer :: symq(4,2,db%cryst%nsym) 2913 integer,allocatable :: indqq(:,:), iperm(:), nqsts(:), iqs_dvdb(:), all_cell(:,:) 2914 real(dp) :: qpt_bz(3) 2915 real(dp),allocatable :: qibz(:,:), qbz(:,:), emiqr(:,:), all_rpt(:,:), all_wghatm(:,:,:) 2916 real(dp),allocatable :: v1r_qibz(:,:,:,:), v1r_qbz(:,:,:,:), v1r_lr(:,:,:) 2917 2918 ! ************************************************************************* 2919 2920 ! Set communicator for R-point parallelism. 2921 ! Note that client code is responsible for calling the interpolation routine dvdb_get_ftqbz (R -> q) 2922 ! with all procs inside comm_rpt to avoid MPI deadlocks. 2923 db%comm_rpt = comm_rpt; db%nprocs_rpt = xmpi_comm_size(db%comm_rpt); db%me_rpt = xmpi_comm_rank(db%comm_rpt) 2924 2925 if (db%add_lr >= 4) then 2926 call wrtout(std_out, " Skipping construction of W(R,r) because add_lr >= 4. Wll use LR part only!") 2927 return 2928 end if 2929 2930 call cwtime(cpu_all, wall_all, gflops_all, "start") 2931 2932 call wrtout(std_out, sjoin(ch10, "Building W(R,r) using q-mesh ngqpt: ", ltoa(ngqpt), & 2933 ", with nprocs_rpt:", itoa(db%nprocs_rpt)), do_flush=.True.) 2934 call wrtout(std_out, sjoin(" Using Gaussian filter with qdamp: ", ftoa(db%qdamp, fmt="(f6.1)"))) 2935 !call wrtout(std_out, " Q-mesh shifts:") 2936 !do ii=1,nqshift 2937 ! call wrtout(std_out, ltoa(qshift(:, ii))) 2938 !end do 2939 call wrtout(std_out, "") 2940 call wrtout(std_out, " Note: this part may take some time depending on the number of MPI procs, ngqpt and nfft points.") 2941 call wrtout(std_out, " Use boxcutmin < 2.0 (> 1.1) to decrease nfft, reduce memory requirements and speedup the calculation.") 2942 2943 call prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, & 2944 qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm, db%comm) 2945 2946 nqibz = size(qibz, dim=2); nqbz = size(qbz, dim=2); db%nrtot = size(all_rpt, dim=2) 2947 2948 ! Distribute R-points inside comm_rpt. 2949 call xmpi_split_work(db%nrtot, db%comm_rpt, my_rstart, my_rstop) 2950 2951 ! Select my_rpoints. 2952 ! Use REMALLOC so that we can call this routine multiple times i.e. for changing add_lr 2953 db%my_nrpt = my_rstop - my_rstart + 1 2954 ABI_CHECK(db%my_nrpt /= 0, "my_nrpt == 0!") 2955 2956 ABI_REMALLOC(db%my_rpt, (3, db%my_nrpt)) 2957 db%my_rpt = all_rpt(:, my_rstart:my_rstop) 2958 ABI_REMALLOC(db%my_irpt2tot, (db%my_nrpt)) 2959 do irpt=1,db%my_nrpt 2960 db%my_irpt2tot(irpt) = my_rstart + (irpt - 1) 2961 end do 2962 2963 ! Copy weights for the atoms treated by this proc. 2964 ii = minval(db%my_pinfo(2,:)); jj = maxval(db%my_pinfo(2,:)) 2965 ABI_REMALLOC(db%my_wratm, (db%my_nrpt, ii:jj)) 2966 db%my_wratm = one 2967 if (db%rspace_cell == 1) then 2968 do iatom=1,db%cryst%natom 2969 if (iatom >= ii .and. iatom <= jj) db%my_wratm(:, iatom) = all_wghatm(iatom, iatom, my_rstart:my_rstop) 2970 end do 2971 end if 2972 2973 write(std_out, "(a, i0)")" Using rspace_cell method for integration weights: ", db%rspace_cell 2974 write(std_out, "(a, i0)")" Total number of R-points in real-space big box: ", db%nrtot 2975 write(std_out, "(a, i0)")" Number of R-points treated by this MPI rank: ", db%my_nrpt 2976 write(std_out, "(a, 3(i0, 1x))")" ngfft: ", ngfft(1:3) 2977 write(std_out, "(a, i0)")" dvdb_add_lr: ", db%add_lr 2978 2979 ! Allocate potential in the supercell. Memory is MPI-distributed over my_nrpt and my_npert 2980 call wrtout(std_out, sjoin(" Memory required for W(R,r): ", & 2981 ftoa(two * db%my_nrpt * nfft * db%nspden * db%my_npert * sp * b2Mb, fmt="f8.1"), "[Mb] <<< MEM")) 2982 2983 ABI_SFREE(all_cell) 2984 ABI_SFREE(all_wghatm) 2985 ABI_FREE(all_rpt) 2986 2987 ABI_MALLOC(emiqr, (2, db%my_nrpt)) 2988 ABI_MALLOC(v1r_qbz, (2, nfft, db%nspden, db%natom3)) 2989 ABI_CALLOC(v1r_lr, (2, nfft, db%my_npert)) 2990 2991 ABI_SFREE(db%wsr) 2992 ABI_MALLOC_OR_DIE(db%wsr, (1, db%my_nrpt, nfft, db%nspden, db%my_npert), ierr) 2993 db%wsr = zero 2994 2995 ! TODO: Parallelize this part over q-points using comm_rpt. For the time being only pert parallelism. 2996 iqst = 0 2997 do iq_ibz=1,nqibz 2998 call cwtime(cpu, wall, gflops, "start") 2999 ! 3000 ! Here all procs get all potentials for this IBZ q-point on the real-space FFT mesh. 3001 ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom) 3002 ! Note that here we need all 3*natom perturbations because of v1phq_rotate 3003 call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, db%comm) 3004 3005 ! Reconstruct by symmetry the potentials for the star of this q-point, 3006 ! perform slow FT and accumulate in wsr. Be careful with the gamma point. 3007 do ii=1,nqsts(iq_ibz) 3008 iqst = iqst + 1 3009 !if (mod(ii, nproc) /= my_rank) cycle ! MPI parallelism. 3010 iq_bz = iperm(iqst) 3011 ABI_CHECK(iq_ibz == indqq(1, iq_bz), "iq_ibz !/ indqq(1)") 3012 qpt_bz = qbz(:, iq_bz) 3013 !if (all(abs(qpt_bz) < tol12)) cycle 3014 ! IS(q_ibz) + g0q = q_bz 3015 isym = indqq(2, iq_bz); itimrev = indqq(6, iq_bz) + 1; g0q = indqq(3:5, iq_bz) 3016 isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0)) 3017 !write(std_out, *)"qbz", trim(ktoa(qpt_bz)), " --> qibz ", trim(ktoa(qibz(:,iq_ibz))) 3018 !write(std_out, *)"via isym, itimrev, g0q:", isym, itimrev, g0q 3019 3020 ! Compute long-range part of the coupling potential at qpt_bz. 3021 if (db%add_lr /= 0) then 3022 do imyp=1,db%my_npert 3023 idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp) 3024 call db%get_v1r_long_range(qpt_bz, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp)) 3025 end do 3026 end if 3027 3028 if (cplex_qibz == 1) then 3029 ! Gamma point. 3030 ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)") 3031 ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0") 3032 3033 if (db%add_lr /= 0) then 3034 ! Substract the long-range part of the potential. 3035 do imyp=1,db%my_npert 3036 ipc = db%my_pinfo(3, imyp) 3037 do ispden=1,db%nspden 3038 v1r_qibz(1, :, ispden, ipc) = v1r_qibz(1, :, ispden, ipc) - v1r_lr(1, :, imyp) 3039 end do 3040 end do 3041 end if 3042 3043 ! Slow FT. 3044 do imyp=1,db%my_npert 3045 ipc = db%my_pinfo(3, imyp) 3046 do ispden=1,db%nspden 3047 do ifft=1,nfft 3048 do irpt=1,db%my_nrpt 3049 db%wsr(1, irpt, ifft, ispden, imyp) = db%wsr(1, irpt, ifft, ispden, imyp) + & 3050 v1r_qibz(1, ifft, ispden, ipc) 3051 end do 3052 end do 3053 end do 3054 end do 3055 3056 else 3057 ! q /= Gamma. Get the periodic part of the potential in BZ (v1r_qbz) 3058 if (isirr_q) then 3059 v1r_qbz = v1r_qibz 3060 else 3061 call v1phq_rotate(db%cryst, qibz(:,iq_ibz), isym, itimrev, g0q, & 3062 ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self) 3063 end if 3064 3065 ! Multiply by e^{iqpt_bz.r} 3066 call times_eikr(qpt_bz, ngfft, nfft, db%nspden * db%natom3, v1r_qbz) 3067 3068 if (db%add_lr /= 0) then 3069 ! Substract the long-range part of the potential. 3070 do imyp=1,db%my_npert 3071 ipc = db%my_pinfo(3, imyp) 3072 do ispden=1,db%nspden 3073 v1r_qbz(:, :, ispden, ipc) = v1r_qbz(:, :, ispden, ipc) - v1r_lr(:, :, imyp) 3074 end do 3075 end do 3076 end if 3077 3078 ! Compute FT phases for this qpt_bz. 3079 call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr) 3080 3081 ! Slow FT. 3082 do imyp=1,db%my_npert 3083 ipc = db%my_pinfo(3, imyp) 3084 do ispden=1,db%nspden 3085 do ifft=1,nfft 3086 db%wsr(1, :, ifft, ispden, imyp) = db%wsr(1, :, ifft, ispden, imyp) & 3087 + emiqr(1, :) * v1r_qbz(1, ifft, ispden, ipc) & 3088 - emiqr(2, :) * v1r_qbz(2, ifft, ispden, ipc) 3089 3090 !db%wsr(2, :, ifft, ispden, imyp) = db%wsr(2, :, ifft, ispden, imyp) & 3091 ! + emiqr(1, :) * v1r_qbz(2, ifft, ispden, ipc) & 3092 ! + emiqr(2, :) * v1r_qbz(1, ifft, ispden, ipc) 3093 end do 3094 3095 !call zgerc(db%my_nrpt, nfft, cone, emiqr, 1, v1r_qbz(:,:,ispden,ipc), 1, & 3096 ! db%wsr(:,:,:,ispden,imyp), db%my_nrpt) 3097 3098 end do ! ispden 3099 end do ! imyp 3100 end if 3101 3102 end do ! iqst 3103 3104 write(msg,'(2(a,i0),a)') " IBZ q-point [", iq_ibz, "/", nqibz, "]" 3105 call cwtime_report(msg, cpu, wall, gflops) 3106 ABI_FREE(v1r_qibz) 3107 end do ! iq_ibz 3108 3109 ABI_CHECK(iqst == nqbz, "iqst /= nqbz") 3110 call wrtout(std_out, ch10//ch10) 3111 3112 ABI_FREE(iperm) 3113 ABI_FREE(emiqr) 3114 ABI_FREE(qibz) 3115 ABI_FREE(qbz) 3116 ABI_FREE(indqq) 3117 ABI_FREE(iqs_dvdb) 3118 ABI_FREE(nqsts) 3119 ABI_FREE(v1r_qbz) 3120 ABI_FREE(v1r_lr) 3121 3122 !call xmpi_sum(db%wsr, db%comm, ierr) 3123 db%wsr = db%wsr / nqbz 3124 3125 call cwtime_report(" Construction of W(R,r)", cpu_all, wall_all, gflops_all) 3126 3127 end subroutine dvdb_ftinterp_setup
m_dvdb/dvdb_ftqcache_build [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_ftqcache_build
FUNCTION
This function initializes the internal q-cache from W(R,r). This is a collective routine that must be called by all procs inside comm.
INPUTS
nfft=Number of fft-points treated by this processors
ngfft(18)=contain all needed information about 3D FFT.
nqibz=Number of points in the IBZ.
qibz(3, nqibz)=q-points in the IBZ.
mbsize: Cache size in megabytes.
< 0 to allocate all q-points.
0 has not effect.
> 0 for cache with automatically computed nqpt points.
qselect_ibz(nqibz)=0 to ignore this q-point (global array)
itreatq(nqibz) = 0 if this q-point won't be treated by this CPU else > 0.
Each CPU calls this routine with its own array.
comm=MPI communicator
OUTPUT
SOURCE
3825 subroutine dvdb_ftqcache_build(db, nfft, ngfft, nqibz, qibz, mbsize, qselect_ibz, itreatq, comm) 3826 3827 !Arguments ------------------------------------ 3828 !scalars 3829 integer,intent(in) :: nfft, nqibz, comm 3830 real(dp),intent(in) :: mbsize 3831 class(dvdb_t),intent(inout) :: db 3832 !arrays 3833 integer,intent(in) :: ngfft(18), qselect_ibz(nqibz) 3834 integer(i1b),intent(in) :: itreatq(nqibz) 3835 real(dp),intent(in) :: qibz(3, nqibz) 3836 3837 !Local variables------------------------------- 3838 !scalars 3839 integer :: iq_ibz, cplex, ierr 3840 real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all, my_mbsize, max_mbsize 3841 character(len=500) :: msg 3842 !arrays 3843 real(dp) :: tsec(2) 3844 real(dp),allocatable :: v1scf(:,:,:,:) 3845 3846 ! ************************************************************************* 3847 3848 call timab(1808, 1, tsec) 3849 call cwtime(cpu_all, wall_all, gflops_all, "start") 3850 3851 !call db%ft_qcache%free() 3852 db%ft_qcache = qcache_new(nqibz, nfft, ngfft, mbsize, db%natom3, db%my_npert, db%nspden) 3853 db%ft_qcache%itreatq(:) = itreatq 3854 3855 ! All procs skip this part if qcache is not used. 3856 if (db%ft_qcache%maxnq /= 0) then 3857 3858 call wrtout(std_out, ch10//" Precomputing Vscf(q) from W(R,r) and building qcache...", do_flush=.True.) 3859 3860 ! Note that cplex is always set to 2 here 3861 cplex = 2 3862 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 3863 3864 do iq_ibz=1,nqibz 3865 ! Ignore points reported by the oracle. We can still recompute them on the fly if needed. 3866 if (qselect_ibz(iq_ibz) == 0) cycle 3867 if (itreatq(iq_ibz) == 0) cycle 3868 3869 call cwtime(cpu, wall, gflops, "start") 3870 3871 ! Interpolate my_npert potentials inside comm_rpt 3872 call db%ftinterp_qpt(qibz(:, iq_ibz), nfft, ngfft, v1scf, db%comm_rpt) 3873 3874 ! Points in the IBZ may be distributed to reduce memory. 3875 if (db%ft_qcache%itreatq(iq_ibz) /= 0) then 3876 ABI_MALLOC_OR_DIE(db%ft_qcache%key(iq_ibz)%v1scf, (cplex, nfft, db%nspden, db%my_npert), ierr) 3877 db%ft_qcache%key(iq_ibz)%v1scf = real(v1scf, kind=QCACHE_KIND) 3878 end if 3879 3880 ! Print progress. 3881 if (iq_ibz <= 50 .or. mod(iq_ibz, 100) == 0) then 3882 write(msg,'(2(a,i0),a)') " Interpolating q-point [", iq_ibz, "/", nqibz, "]" 3883 call cwtime_report(msg, cpu, wall, gflops) 3884 end if 3885 end do 3886 3887 ABI_FREE(v1scf) 3888 end if 3889 3890 ! Compute final cache size. 3891 my_mbsize = db%ft_qcache%get_mbsize() 3892 call wrtout(std_out, sjoin(" Memory allocated for Q-cache: ", ftoa(my_mbsize, fmt="f8.1"), " [Mb] <<< MEM")) 3893 call xmpi_max(my_mbsize, max_mbsize, comm, ierr) 3894 call wrtout(std_out, sjoin(" Max memory inside MPI comm: ", ftoa(max_mbsize, fmt="f8.1"), " [Mb] <<< MEM")) 3895 call cwtime_report(" Qcache from W(R, r) + symmetrization", cpu_all, wall_all, gflops_all, end_str=ch10) 3896 call timab(1808, 2, tsec) 3897 3898 ! This barrier seems to be needed on lemaitre3. DO NOT REMOVE! 3899 call xmpi_barrier(comm) 3900 3901 end subroutine dvdb_ftqcache_build
m_dvdb/dvdb_ftqcache_update_from_ft [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_ftqcache_update_from_ft
FUNCTION
Interpolate selected potentials and update the internal q-cache. This is a collective routine that must be called by all procs in comm.
INPUTS
nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT. nqibz=Number of q-points in the IBZ. qibz(3, nqibz)= q-points in the IBZ. ineed_qpt(%nqpt)=1 if this MPI rank requires this q-point. comm=MPI communicator
OUTPUT
SOURCE
3924 subroutine dvdb_ftqcache_update_from_ft(db, nfft, ngfft, nqibz, qibz, ineed_qpt, comm) 3925 3926 !Arguments ------------------------------------ 3927 !scalars 3928 integer,intent(in) :: nfft,comm, nqibz 3929 class(dvdb_t),intent(inout) :: db 3930 !arrays 3931 integer,intent(in) :: ngfft(18), ineed_qpt(nqibz) 3932 real(dp),intent(in) :: qibz(3, nqibz) 3933 3934 !Local variables------------------------------- 3935 !scalars 3936 integer :: iq_ibz, cplex, ierr, qcnt 3937 real(dp) :: cpu_all, wall_all, gflops_all, mbsize, max_mbsize 3938 character(len=500) :: msg 3939 !arrays 3940 real(dp),allocatable :: v1scf(:,:,:,:) 3941 !real(dp) :: tsec(2) 3942 3943 ! ************************************************************************* 3944 3945 if (db%ft_qcache%maxnq == 0) return 3946 qcnt = count(ineed_qpt /= 0) 3947 3948 !ABI_ERROR("Legacy code!") 3949 3950 call cwtime(cpu_all, wall_all, gflops_all, "start") 3951 3952 if (qcnt /= 0) then 3953 !call timab(1807, 1, tsec) 3954 call wrtout(std_out, sjoin(" Need to update Vscf(q) cache with: ", itoa(qcnt), "q-points from FT..."), do_flush=.True.) 3955 if (db%ft_qcache%make_room(ineed_qpt, msg) /= 0) then 3956 ABI_WARNING(msg) 3957 end if 3958 3959 cplex = 2 3960 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 3961 do iq_ibz=1,nqibz 3962 if (ineed_qpt(iq_ibz) == 0) cycle 3963 ! Interpolate my_npert potentials inside comm_rpt. 3964 call db%ftinterp_qpt(qibz(:, iq_ibz), nfft, ngfft, v1scf, db%comm_rpt) 3965 ! Transfer to cache. 3966 if (ineed_qpt(iq_ibz) /= 0) then 3967 ABI_MALLOC_OR_DIE(db%ft_qcache%key(iq_ibz)%v1scf, (cplex, nfft, db%nspden, db%my_npert), ierr) 3968 db%ft_qcache%key(iq_ibz)%v1scf = real(v1scf, kind=QCACHE_KIND) 3969 end if 3970 end do 3971 3972 ABI_FREE(v1scf) 3973 end if 3974 3975 mbsize = db%ft_qcache%get_mbsize() 3976 call wrtout(std_out, sjoin(" Memory allocated for cache: ", ftoa(mbsize, fmt="f8.1"), " [Mb] <<< MEM")) 3977 call xmpi_max(mbsize, max_mbsize, comm, ierr) 3978 call wrtout(std_out, sjoin(" Max memory inside MPI comm: ", ftoa(max_mbsize, fmt="f8.1"), " [Mb] <<< MEM")) 3979 call cwtime_report(" dvdb_ftqcache_update_from_ft", cpu_all, wall_all, gflops_all) 3980 !call timab(1807, 2, tsec) 3981 3982 end subroutine dvdb_ftqcache_update_from_ft
m_dvdb/dvdb_get_ftqbz [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_get_ftqbz
FUNCTION
Fourier interpolation of potentials for a given q-point in the BZ (qbz). Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`. Interpolation is avoided if potential is in ft_qcache
INPUTS
cryst<crystal_t>=crystal structure parameters qbz(3)= q-point in the BZ in reduced coordinates. qibz(3) = Image of qbz in the IBZ. Needed to apply symmetries IBZ --> qbz indq2ibz(6)=Symmetry mapping qbz --> IBZ qpoint produced by listkk. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT
OUTPUT
ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point.
SOURCE
3627 subroutine dvdb_get_ftqbz(db, cryst, qbz, qibz, indq2ibz, cplex, nfft, ngfft, v1scf, comm) 3628 3629 !Arguments ------------------------------------ 3630 !scalars 3631 integer,intent(in) :: nfft, comm 3632 integer,intent(out) :: cplex 3633 type(crystal_t),intent(in) :: cryst 3634 class(dvdb_t),intent(inout) :: db 3635 !arrays 3636 integer,intent(in) :: ngfft(18), indq2ibz(6) 3637 real(dp),intent(in) :: qbz(3), qibz(3) 3638 real(dp),allocatable,intent(out) :: v1scf(:,:,:,:) 3639 3640 !Local variables------------------------------- 3641 !scalars 3642 integer :: iq_ibz, itimrev, isym, ierr, imyp, mu, root 3643 logical :: isirr_q, incache 3644 !!arrays 3645 integer :: g0q(3), requests(db%natom3) 3646 real(dp) :: tsec(2) 3647 real(dp) ABI_ASYNC, allocatable :: work(:,:,:,:), work2(:,:,:,:) 3648 3649 ! ************************************************************************* 3650 3651 ABI_UNUSED(comm) 3652 3653 ! Keep track of total time spent. 3654 call timab(1809, 1, tsec) 3655 3656 iq_ibz = indq2ibz(1) 3657 db%ft_qcache%count_qused(iq_ibz) = db%ft_qcache%count_qused(iq_ibz) + 1 3658 db%ft_qcache%stats(1) = db%ft_qcache%stats(1) + 1 3659 3660 ! IS(q_ibz) + g0q = q_bz 3661 isym = indq2ibz(2); itimrev = indq2ibz(6) + 1; g0q = indq2ibz(3:5) 3662 isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0)) 3663 3664 if (db%ft_qcache%use_3natom_cache .and. db%ft_qcache%v1scf_3natom_request /= xmpi_request_null) then 3665 ! Wait for completion of iallgather. 3666 call xmpi_wait(db%ft_qcache%v1scf_3natom_request, ierr) 3667 end if 3668 3669 !print *, "Have_ibz, need_iq_ibz, isirr_q", db%ft_qcache%stored_iqibz_cplex(1), iq_ibz, isirr_q 3670 3671 if (db%ft_qcache%use_3natom_cache .and. db%ft_qcache%stored_iqibz_cplex(1) == iq_ibz .and. .not. isirr_q) then 3672 !print *, "hello cache" 3673 3674 ! All 3 natom potentials for qibz are in cache. Symmetrize to get Sq for my_npert perturbations 3675 db%ft_qcache%stats(2) = db%ft_qcache%stats(2) + 1 3676 cplex = db%ft_qcache%stored_iqibz_cplex(2) 3677 3678 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 3679 call v1phq_rotate_myperts(cryst, qibz, isym, itimrev, g0q, ngfft, cplex, nfft, & 3680 db%nspden, db%mpi_enreg, db%my_npert, db%my_pinfo, & 3681 db%ft_qcache%v1scf_3natom_qibz, v1scf) 3682 call timab(1809, 2, tsec); return 3683 end if 3684 3685 ! Note that cplex is always set to 2 here 3686 cplex = 2 3687 3688 ! Check whether iq_ibz is in cache. 3689 incache = .False. 3690 3691 if (db%ft_qcache%maxnq > 0) then 3692 ! Get number of perturbations computed for this iq_ibz as well as cplex. 3693 ! Remember that the size of v1scf in qcache depends on db%my_npert 3694 if (allocated(db%ft_qcache%key(iq_ibz)%v1scf)) then 3695 if (size(db%ft_qcache%key(iq_ibz)%v1scf, dim=1) == cplex .and. & 3696 size(db%ft_qcache%key(iq_ibz)%v1scf, dim=2) == nfft) then 3697 ! Potential in cache --> copy it in output v1scf. 3698 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 3699 v1scf = real(db%ft_qcache%key(iq_ibz)%v1scf, kind=QCACHE_KIND) 3700 incache = .True. 3701 db%ft_qcache%stats(3) = db%ft_qcache%stats(3) + 1 3702 else 3703 ABI_ERROR("Found different cplex/nfft in cache.") 3704 end if 3705 else 3706 !call wrtout(std_out, sjoin("Cache miss for iq_ibz. Will try to interpolate it...", itoa(iq_ibz))) 3707 db%ft_qcache%stats(4) = db%ft_qcache%stats(4) + 1 3708 end if 3709 end if 3710 3711 if (.not. incache) then 3712 ! Interpolate the dvscf potentials directly in the **BZ** for my_npert perturbations. 3713 ! This is possible only if all procs inside comm_rpt call this routine else deadlock 3714 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 3715 call db%ftinterp_qpt(qbz, nfft, ngfft, v1scf, db%comm_rpt) 3716 3717 if (db%ft_qcache%use_3natom_cache .and. isirr_q) then 3718 !call wrtout(std_out, " Collecting in cache all 3*natom DFPT potentials for q in the IBZ") 3719 if (cplex /= db%ft_qcache%stored_iqibz_cplex(2)) then 3720 ABI_REMALLOC(db%ft_qcache%v1scf_3natom_qibz, (cplex, nfft, db%nspden, db%natom3)) 3721 end if 3722 db%ft_qcache%stored_iqibz_cplex = [iq_ibz, cplex] 3723 ! Gather 3 * natom potentials on each pert proc. Note non-blocking version with request handle. 3724 call xmpi_iallgather(v1scf, cplex*nfft*db%nspden*db%my_npert, & 3725 db%ft_qcache%v1scf_3natom_qibz, db%comm_pert, db%ft_qcache%v1scf_3natom_request) 3726 end if 3727 3728 call timab(1809, 2, tsec); return 3729 end if 3730 3731 if (.not. isirr_q) then 3732 ! Must rotate iq_ibz to get potential for qpoint in the BZ. 3733 ! Be careful with the shape of output v1scf because the routine returns db%my_npert potentials. 3734 3735 if (db%my_npert == db%natom3) then 3736 ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3)) 3737 work = v1scf 3738 call v1phq_rotate(cryst, qibz, isym, itimrev, g0q, ngfft, cplex, nfft, & 3739 db%nspden, db%mpi_enreg, work, v1scf, db%comm_pert) 3740 ABI_FREE(work) 3741 3742 else 3743 ! Parallelism over perturbations. 3744 ABI_MALLOC(work2, (cplex, nfft, db%nspden, db%natom3)) 3745 3746 if (incache) then 3747 ! Cache is distributed --> have to collect all 3 natom perts inside db%comm_pert. 3748 ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3)) 3749 3750 ! IBCAST is much faster than a naive xmpi_sum. 3751 call timab(1806, 1, tsec) 3752 do mu=1,db%natom3 3753 root = db%pert_table(1, mu) 3754 if (root == db%me_pert) then 3755 imyp = db%pert_table(2, mu) 3756 work(:,:,:,mu) = v1scf(:,:,:,imyp) 3757 end if 3758 call xmpi_ibcast(work(:,:,:,mu), root, db%comm_pert, requests(mu), ierr) 3759 end do 3760 call xmpi_waitall(requests, ierr) 3761 call timab(1806, 2, tsec) 3762 3763 call v1phq_rotate(cryst, qibz, isym, itimrev, g0q, ngfft, cplex, nfft, & 3764 db%nspden, db%mpi_enreg, work, work2, db%comm_pert) 3765 3766 ! Now Store all 3 natom potentials for q in IBZ in cache. 3767 if (db%ft_qcache%use_3natom_cache .and. db%ft_qcache%stored_iqibz_cplex(1) /= iq_ibz) then 3768 if (cplex /= db%ft_qcache%stored_iqibz_cplex(2)) then 3769 ABI_REMALLOC(db%ft_qcache%v1scf_3natom_qibz, (cplex, nfft, db%nspden, db%natom3)) 3770 end if 3771 db%ft_qcache%stored_iqibz_cplex = [iq_ibz, cplex] 3772 db%ft_qcache%v1scf_3natom_qibz = work 3773 end if 3774 ABI_FREE(work) 3775 3776 else 3777 NOT_IMPLEMENTED_ERROR() 3778 ! All 3 natom have been read in v1scf by dvdb_readsym_allv1 3779 !call v1phq_rotate(cryst, qibz, isym, itimrev, g0q, ngfft, cplex, nfft, & 3780 ! db%nspden, db%mpi_enreg, v1scf, work2, db%comm_pert) 3781 end if 3782 3783 ! Reallocate v1scf with my_npert and extract data from work2. 3784 ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 3785 do imyp=1,db%my_npert 3786 v1scf(:,:,:,imyp) = work2(:,:,:,db%my_pinfo(3, imyp)) 3787 end do 3788 ABI_FREE(work2) 3789 end if 3790 end if ! not isirr_q 3791 3792 call timab(1809, 2, tsec) 3793 3794 end subroutine dvdb_get_ftqbz
m_dvdb/dvdb_get_maxw [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_get_maxw
FUNCTION
Compute max_r |W(R,r)|
INPUTS
FUNCTION
m_dvdb/dvdb_get_pinfo [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_get_pinfo
FUNCTION
Return information on the perturbations available for a given q-point index.
INPUTS
iqpt=Index of the q-point
OUTPUT
nperts=Number of perturbations found.
cplex=2 if potentials are complex, 1 for real
pinfo(3,3*db%mpert)=Array with info on the perturbations present on file
pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
SOURCE
1128 integer function dvdb_get_pinfo(db, iqpt, cplex, pinfo) result(nperts) 1129 1130 !Arguments ------------------------------------ 1131 !scalars 1132 type(dvdb_t),intent(in) :: db 1133 integer,intent(in) :: iqpt 1134 integer,intent(out) :: cplex 1135 !arrays 1136 integer,intent(out) :: pinfo(3,3*db%mpert) 1137 1138 !Local variables------------------------------- 1139 !scalars 1140 integer :: idir,ipert,iv1 1141 1142 ! ************************************************************************* 1143 1144 ! Get the number of perturbations computed for this iqpt 1145 pinfo = 0; cplex = 0; nperts = 0 1146 do ipert=1,db%natom ! selects atomic perturbations only. 1147 do idir=1,3 1148 iv1 = db%pos_dpq(idir,ipert,iqpt) 1149 if (iv1 /= 0) then 1150 nperts = nperts + 1 1151 pinfo(:, nperts) = [idir, ipert, idir + (ipert-1)*3] 1152 if (cplex == 0) cplex = db%cplex_v1(iv1) 1153 ABI_CHECK(cplex == db%cplex_v1(iv1), "cplex should be constant for given q!") 1154 end if 1155 end do 1156 end do 1157 1158 end function dvdb_get_pinfo
m_dvdb/dvdb_get_v1r_long_range [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_get_v1r_long_range
FUNCTION
Compute the long-range part of the phonon potential
due to the Born effective charges, PRL 115, 176401 (2015) [[cite:Verdi2015]].
V^L_{iatom,idir}(r) = i (4pi/vol) sum_G (q+G) . Zeff_{iatom,idir}
e^{i (q+G).(r - tau_{iatom})} / ((q+G) . dielt . (q+G))
where Zeff and dielt are the Born effective charge tensor and the dielectric tensor in cart coords,
tau is the atom position, and vol is the volume of the unit cell.
Note that internally the tensors are stored in Cartesian coordinates while in output we need
the contribution due to the displacement of the iatom-sublattice along the reduced direction idir
hence we need to perform some tensor gymnastics to go from Cart to reduced.
INPUTS
db = the DVDB object.
qpt = the q-point in reduced coordinates.
idir = direction index.
iatom = atom index.
nfft = number of fft points.
ngfft(18) = FFT mesh.
[add_qphase]=By default, the routine returns the LR potential with the e^{iqr} phase.
Use add_qphase = 0 to get the lattice-periodic part.
OUTPUT
v1r_lr = dipole potential
SOURCE
6269 subroutine dvdb_get_v1r_long_range(db, qpt, idir, iatom, nfft, ngfft, v1r_lr, add_qphase) 6270 6271 !Arguments ------------------------------------ 6272 !scalars 6273 class(dvdb_t),intent(in) :: db 6274 integer,intent(in) :: idir, iatom, nfft 6275 integer,optional,intent(in) :: add_qphase 6276 !arrays 6277 integer,intent(in) :: ngfft(18) 6278 real(dp),intent(in) :: qpt(3) 6279 real(dp),intent(out) :: v1r_lr(2,nfft) 6280 6281 !Local variables------------------------------- 6282 !scalars 6283 integer :: n1, n2, n3, nfftot, ig, iphase, ii, jj, kk, ll, mm, ifft, ispden 6284 real(dp) :: fac, qGZ, qGS, denom, denom_inv, qtau, re, im, phre, phim, qg_mod, gsq_max 6285 real(dp),parameter :: tol_denom = tol8 6286 !arrays 6287 integer, allocatable :: gfft(:,:) 6288 real(dp) :: gprimd(3,3), rprimd(3,3), dielt_red(3,3) 6289 real(dp) :: qG_red(3), qG_cart(3), Zstar(3), Sstar(3,3), tau_red(3) 6290 real(dp), allocatable :: v1G_lr(:,:), v1G_lr33(:,:,:,:), workr(:,:) 6291 6292 ! ************************************************************************* 6293 6294 ! Return immediately if metals by 6295 !if (db%has_zeff .or. db%has_quadrupoles) then 6296 6297 iphase = 1; if (present(add_qphase)) iphase = add_qphase 6298 6299 ! Make sure FFT parallelism is not used 6300 n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3)) 6301 ABI_CHECK(nfftot == nfft, "FFT parallelism not supported") 6302 6303 ! Allocate memory 6304 ABI_MALLOC(gfft, (3, nfft)) 6305 ABI_MALLOC(v1G_lr, (2, nfft)) 6306 6307 ! Reciprocal and real space primitive vectors 6308 gprimd = db%cryst%gprimd; rprimd = db%cryst%rprimd 6309 6310 ! Prefactor 6311 fac = four_pi / db%cryst%ucvol 6312 6313 ! Transform the Born effective charge tensor from Cartesian to reduced coordinates 6314 ! and select the relevant direction. 6315 Zstar = matmul(transpose(gprimd), matmul(db%zeff(:,:,iatom), rprimd(:,idir))) * two_pi 6316 6317 if (db%has_quadrupoles) then 6318 ! Transform Qstar from Cartesian to reduced coordinates and select the relevant direction. 6319 Sstar = zero 6320 do ii=1,3 6321 do jj=1,3 6322 do kk=1,3 6323 do ll=1,3 6324 do mm=1,3 6325 Sstar(ii,jj) = Sstar(ii,jj) + & 6326 gprimd(mm,jj) * gprimd(ll,ii) * db%qstar(mm,ll,kk,iatom) * rprimd(kk,idir) * two_pi ** 2 6327 end do 6328 end do 6329 end do 6330 end do 6331 end do 6332 end if 6333 6334 ! Transform the dielectric tensor from Cartesian to reduced coordinates. 6335 ! q_cart e_cart q_cart = q_red (G^t e_cart G) q_red 6336 dielt_red = matmul(transpose(gprimd), matmul(db%dielt, gprimd)) * two_pi ** 2 6337 6338 ! Atom position 6339 tau_red = db%cryst%xred(:,iatom) 6340 6341 ! Get the set of G vectors 6342 ! TODO: May use zero-padded FFT with small G-sphere 6343 call get_gftt(ngfft, qpt, db%cryst%gmet, gsq_max, gfft) 6344 6345 ! Compute the long-range potential in G-space due to Z* and Q* (if present) 6346 v1G_lr = zero 6347 if (db%has_zeff .or. db%has_quadrupoles) then 6348 6349 do ig=1,nfft 6350 ! (q + G) 6351 qG_red = qpt + gfft(:,ig) 6352 qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red) 6353 qG_mod = sqrt(sum(qG_cart ** 2)) 6354 ! (q + G) . Zeff(:,idir,iatom) 6355 qGZ = dot_product(qG_red, Zstar) 6356 ! (q + G) . dielt . (q + G) 6357 denom = dot_product(qG_red, matmul(dielt_red, qG_red)) 6358 ! Avoid (q + G) = 0 6359 if (denom < tol_denom) cycle 6360 denom_inv = one / denom 6361 ! HM hard cutoff, in this case qdamp takes the meaning of an energy cutoff in Hartree (hardcoded to 1 for the moment) 6362 !if (half*qG_mod**2 > 1) cycle 6363 if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp)) 6364 qGS = zero 6365 if (db%has_quadrupoles) then 6366 do ii=1,3 6367 do jj=1,3 6368 qGS = qGS + qG_red(ii) * qG_red(jj) * Sstar(ii,jj) / two 6369 end do 6370 end do 6371 end if 6372 6373 ! Phase factor exp(-i (q+G) . tau) 6374 qtau = - two_pi * dot_product(qG_red, tau_red) 6375 phre = cos(qtau); phim = sin(qtau) 6376 !phre = one; phim = zero 6377 6378 re = +fac * qGS * denom_inv !re = zero 6379 im = fac * qGZ * denom_inv 6380 v1G_lr(1,ig) = phre * re - phim * im 6381 v1G_lr(2,ig) = phim * re + phre * im 6382 end do 6383 end if 6384 6385 ! FFT to get the long-range potential in r-space 6386 call fourdp(2, v1G_lr, v1r_lr, 1, db%mpi_enreg, nfft, 1, ngfft, 0) 6387 6388 if (db%has_efield) then 6389 ! Add term due to Electric field. 6390 ! TODO: Change API to account for ispden/isppol. return nspden LR part 6391 ! although only the electric field part depends on nsppden. 6392 !v1r_lr = zero ! Comment this line to have only efield contribution 6393 ABI_CHECK(db%nspden == 1, "nspden != 1 not coded") 6394 ispden = 1 6395 ABI_CALLOC(v1G_lr33, (3, 3, 2, nfft)) 6396 do ig=1,nfft 6397 !if (ig > 1) cycle 6398 ! (q + G) 6399 qG_red = qpt + gfft(:,ig) 6400 qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red) 6401 qG_mod = sqrt(sum(qG_cart ** 2)) 6402 ! (q + G) . Zeff(:,idir,iatom) 6403 !qGZ = dot_product(qG_red, Zstar) 6404 ! (q + G) . dielt . (q + G) 6405 denom = dot_product(qG_red, matmul(dielt_red, qG_red)) 6406 ! Avoid (q + G) = 0 6407 if (denom < tol_denom) cycle 6408 denom_inv = one / denom 6409 if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp)) 6410 fac = (four_pi / db%cryst%ucvol) * denom_inv !* qGZ 6411 ! Phase factor exp(-i (q+G) . tau) 6412 qtau = - two_pi * dot_product(qG_red, tau_red) 6413 phre = cos(qtau); phim = sin(qtau) 6414 !phre = one; phim = zero 6415 6416 do ii=1,3 6417 do jj=1,3 6418 v1G_lr33(ii, jj, 1, ig) = fac * phre * qG_red(ii) * qG_red(jj) 6419 v1G_lr33(ii, jj, 2, ig) = fac * phim * qG_red(ii) * qG_red(jj) 6420 end do 6421 end do 6422 end do ! ig 6423 6424 ABI_MALLOC(workr, (2, nfft)) 6425 do ii=1,3 6426 do jj=1,3 6427 v1G_lr = v1G_lr33(ii, jj, :, :) 6428 call fourdp(2, v1G_lr, workr, 1, db%mpi_enreg, nfft, 1, ngfft, 0) 6429 ! Two pi comes for qpt but we should check whether the gradient wrt E-field is in gprimd or 2pi gprimd coordinates. 6430 ! MG: Remove two_pi factor because jump discontinuity in the real part for G != 0 are overestimated. 6431 do ifft=1,nfft 6432 !v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) * two_pi 6433 v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) ! * two_pi 6434 end do 6435 end do 6436 end do 6437 6438 ABI_FREE(workr) 6439 ABI_FREE(v1G_lr33) 6440 end if 6441 6442 ! Multiply by exp(i q.r) 6443 if (iphase == 1) call times_eikr(qpt, ngfft, nfft, 1, v1r_lr) 6444 6445 ABI_FREE(gfft) 6446 ABI_FREE(v1G_lr) 6447 6448 end subroutine dvdb_get_v1r_long_range
m_dvdb/dvdb_get_v1scf_qpt [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_get_v1scf_qpt
FUNCTION
Fourier interpolation of potentials for a given q-point This routine is meant to replace dvdb_ftinterp_qpt by performing the interpolation one perturbation at a time.
INPUTS
qpt(3)=q-point in reduced coordinates. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT nrpt=Number of R-points = number of q-points in the full BZ nspden=Number of spin densities. ipert=index of the perturbation to be treated [1,natom3] v1scf_rpt(2,nrpt,nfft,nspden)=phonon perturbation potential in real space lattice representation. comm=MPI communicator
OUTPUT
v1scf_qpt(2*nfft, nspden)=Interpolated DFPT potentials at the given q-point.
SOURCE
4354 subroutine dvdb_get_v1scf_qpt(db, cryst, qpt, nfft, ngfft, nrpt, nspden, & 4355 ipert, v1scf_rpt, v1scf_qpt, comm) 4356 4357 !Arguments ------------------------------------ 4358 !scalars 4359 integer,intent(in) :: nfft,nrpt,nspden,ipert,comm 4360 class(dvdb_t),intent(in) :: db 4361 type(crystal_t),intent(in) :: cryst 4362 !arrays 4363 integer,intent(in) :: ngfft(18) 4364 real(dp),intent(in) :: qpt(3) 4365 real(dp),intent(in) :: v1scf_rpt(2,nrpt,nfft,db%nspden) 4366 real(dp),intent(out) :: v1scf_qpt(2,nfft,db%nspden) 4367 4368 !Local variables------------------------------- 4369 !scalars 4370 integer,parameter :: cplex2=2 4371 integer :: ir,ispden,ifft,idir,iat,timerev_q,nproc,my_rank,cnt,ierr 4372 real(dp) :: wr,wi 4373 !arrays 4374 integer :: symq(4,2,db%cryst%nsym) 4375 real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:) 4376 4377 ! ************************************************************************* 4378 4379 !ABI_ERROR("Legacy code!") 4380 4381 ABI_UNUSED(cryst%natom) 4382 ABI_UNUSED(nspden) 4383 4384 my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm) 4385 4386 ABI_MALLOC(v1r_lr, (2,nfft)) 4387 4388 ! Examine the symmetries of the q wavevector 4389 call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol) 4390 4391 ! Compute FT phases for this q-point. 4392 ABI_MALLOC(eiqr, (2, db%my_nrpt)) 4393 call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr) 4394 4395 idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1 4396 4397 ! Compute long-range part of the coupling potential 4398 v1r_lr = zero; cnt = 0 4399 if (db%add_lr > 0) call db%get_v1r_long_range(qpt, idir, iat, nfft, ngfft, v1r_lr) 4400 4401 ! TODO: If high-symmetry q-points, one could save flops by FFT interpolating the independent 4402 ! TODO: Use ZGEMM with MPI 4403 ! perturbations and then rotate ... 4404 v1scf_qpt = zero; cnt = 0 4405 do ispden=1,db%nspden 4406 do ifft=1,nfft 4407 cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI-parallelism 4408 4409 do ir=1,db%my_nrpt 4410 wr = v1scf_rpt(1, ir,ifft,ispden) 4411 wi = v1scf_rpt(2, ir,ifft,ispden) 4412 v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + wr*eiqr(1,ir) - wi * eiqr(2,ir) 4413 v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + wr*eiqr(2,ir) + wi * eiqr(1,ir) 4414 end do 4415 4416 ! Add the long-range part of the potential 4417 if (db%add_lr > 0) then 4418 v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + v1r_lr(1,ifft) 4419 v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + v1r_lr(2,ifft) 4420 end if 4421 if (db%add_lr == 4) then 4422 v1scf_qpt(1,ifft,ispden) = v1r_lr(1,ifft) 4423 v1scf_qpt(2,ifft,ispden) = v1r_lr(2,ifft) 4424 end if 4425 end do ! ifft 4426 4427 call xmpi_sum(v1scf_qpt(:,:,ispden), comm, ierr) 4428 4429 ! Remove the phase. 4430 call times_eikr(-qpt, ngfft, nfft, 1, v1scf_qpt(:,:,ispden)) 4431 end do 4432 4433 ! Be careful with gamma and cplex! 4434 if (db%symv1 == 1) then 4435 call v1phq_symmetrize(db%cryst, idir, iat, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, db%mpi_enreg, v1scf_qpt) 4436 end if 4437 4438 ABI_FREE(eiqr) 4439 ABI_FREE(v1r_lr) 4440 4441 end subroutine dvdb_get_v1scf_qpt
m_dvdb/dvdb_get_v1scf_rpt [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_get_v1scf_rpt
FUNCTION
Compute the phonon perturbation potential in real space lattice representation. This routine is meant to replace dvdb_ftinterp_setup and performs the potential interpolation one perturbation at a time.
INPUTS
ngqpt(3)=Divisions of the ab-initio q-mesh. nqshift=Number of shifts used to generated the ab-initio q-mesh. qshift(3,nqshift)=The shifts of the ab-initio q-mesh. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT nrpt=Number of R-points = number of q-points in the full BZ nspden=Number of spin densities. ipert=index of the perturbation to be treated [1,natom3] comm=MPI communicator
OUTPUT
v1scf_rpt(2,nrpt,nfft,nspden)
SOURCE
4012 subroutine dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, & 4013 nrpt, nspden, ipert, v1scf_rpt, comm) 4014 4015 !Arguments ------------------------------------ 4016 !scalars 4017 integer,intent(in) :: nqshift,nfft,nrpt,nspden,ipert,comm 4018 class(dvdb_t),target,intent(inout) :: db 4019 !arrays 4020 integer,intent(in) :: ngqpt(3),ngfft(18) 4021 real(dp),intent(in) :: qshift(3,nqshift) 4022 real(dp),intent(out) :: v1scf_rpt(2,nrpt,nfft,nspden) 4023 type(crystal_t),intent(in) :: cryst 4024 4025 !Local variables------------------------------- 4026 !scalars 4027 integer,parameter :: sppoldbl1=1, timrev1=1 4028 integer :: my_qptopt,iq_ibz,nqibz,iq_bz,nqbz 4029 integer :: ii,iq_dvdb,cplex_qibz,ispden,irpt,idir,iat 4030 integer :: iqst,nqst,itimrev,tsign,isym,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3 4031 integer :: nproc,my_rank,ifft,cnt,ierr 4032 character(len=500) :: msg 4033 real(dp) :: dksqmax 4034 logical :: isirr_q, found 4035 !arrays 4036 integer :: qptrlatt(3,3),g0q(3) 4037 integer,allocatable :: indqq(:,:),iperm(:),bz2ibz_sort(:),nqsts(:),iqs_dvdb(:) 4038 real(dp) :: qpt_bz(3),shift(3) 4039 real(dp) :: cpu, wall, gflops 4040 real(dp),allocatable :: qibz(:,:),qbz(:,:),wtq(:),emiqr(:,:) 4041 real(dp),allocatable :: v1r_qibz(:,:,:,:),v1r_qbz(:,:,:,:), v1r_lr(:,:) 4042 4043 ! ************************************************************************* 4044 4045 !ABI_ERROR("Legacy code!") 4046 4047 nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm) 4048 4049 nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3); my_qptopt = 1 !; if (present(qptopt)) my_qptopt = qptopt 4050 4051 ! Generate the q-mesh by finding the IBZ and the corresponding weights. 4052 qptrlatt = 0 4053 do ii=1,3 4054 qptrlatt(ii,ii) = ngqpt(ii) 4055 end do 4056 4057 ! Get IBZ and BZ. 4058 call kpts_ibz_from_kptrlatt(cryst, qptrlatt, my_qptopt, nqshift, qshift, & 4059 nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk) 4060 4061 !write(std_out,*)"Irreducible q-points:" 4062 !do iq_ibz=1,nqibz; write(std_out,*)trim(ktoa(qibz(:,iq_ibz))),wtq(iq_ibz)*nqbz; end do 4063 ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift") 4064 ABI_CHECK(nqbz == nrpt, "nqbz /= nrpt") 4065 4066 db%my_nrpt = nqbz 4067 4068 ABI_CHECK(nspden == db%nspden, "nspden /= db%nspden") 4069 4070 ! We want a gamma centered q-mesh for FFT. 4071 ABI_CHECK(nqshift == 1, "nshift > 1 not supported") 4072 ABI_CHECK(all(qshift(:,1) == zero), "qshift != 0 not supported") 4073 4074 ABI_FREE(qbz) 4075 ABI_MALLOC(qbz, (3, nqbz)) 4076 ii = 0 4077 do iz=0,nq3-1 4078 do iy=0,nq2-1 4079 do ix=0,nq1-1 4080 ii = ii + 1 4081 qbz(:, ii) = [ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)] 4082 call wrap2_pmhalf([ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)], qbz(:,ii), shift) 4083 end do 4084 end do 4085 end do 4086 4087 ! Compute real-space points. 4088 ! Use the following indexing (N means ngfft of the adequate direction) 4089 ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc 4090 ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig 4091 ABI_MALLOC(db%my_rpt, (3, db%my_nrpt)) 4092 ii = 0 4093 do iz=1,nq3 4094 r3 = ig2gfft(iz,nq3) 4095 do iy=1,nq2 4096 r2 = ig2gfft(iy,nq2) 4097 do ix=1,nq1 4098 r1 = ig2gfft(ix,nq1) 4099 ii = ii + 1 4100 db%my_rpt(:,ii) = [r1, r2, r3] 4101 end do 4102 end do 4103 end do 4104 4105 ! Find correspondence BZ --> IBZ. Note: 4106 ! q --> -q symmetry is always used for phonons. 4107 ! we use symrec instead of symrel 4108 ABI_MALLOC(indqq, (nqbz*sppoldbl1,6)) 4109 call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,cryst%nsym,& 4110 sppoldbl1,cryst%symafm,cryst%symrec,timrev1,comm,use_symrec=.True.) 4111 4112 !qrank = krank_from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.) 4113 !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, & 4114 ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.) 4115 !call qrank%free() 4116 4117 if (dksqmax > tol12) then 4118 ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ") 4119 end if 4120 4121 ! Construct sorted mapping BZ --> IBZ to speedup qbz search below. 4122 ABI_MALLOC(iperm, (nqbz)) 4123 ABI_MALLOC(bz2ibz_sort, (nqbz)) 4124 iperm = [(ii, ii=1,nqbz)] 4125 bz2ibz_sort = indqq(:,1) 4126 call sort_int(nqbz, bz2ibz_sort, iperm) 4127 4128 ! Reconstruct the IBZ according to what is present in the DVDB. 4129 ABI_MALLOC(nqsts, (nqibz)) 4130 ABI_MALLOC(iqs_dvdb, (nqibz)) 4131 ABI_MALLOC(v1r_lr, (2,nfft)) 4132 4133 iqst = 0 4134 do iq_ibz=1,nqibz 4135 ! In each q-point star, count the number of q-points and find the one present in DVDB. 4136 nqst = 0 4137 found = .false. 4138 do ii=iqst+1,nqbz 4139 if (bz2ibz_sort(ii) /= iq_ibz) exit 4140 nqst = nqst + 1 4141 4142 iq_bz = iperm(ii) 4143 if (.not. found) then 4144 iq_dvdb = db%findq(qbz(:,iq_bz)) 4145 if (iq_dvdb /= -1) then 4146 qibz(:,iq_ibz) = qbz(:,iq_bz) 4147 iqs_dvdb(iq_ibz) = iq_dvdb 4148 found = .true. 4149 end if 4150 end if 4151 end do 4152 4153 ! Check that nqst has been counted properly. 4154 ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst+1) == iq_ibz, "Wrong iqst") 4155 if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then 4156 write(std_out,*)nqst, wtq(iq_ibz) * nqbz 4157 ABI_ERROR("Error in counting q-point star or in the weights.") 4158 end if 4159 4160 ! Check that the q-point has been found in DVDB. 4161 if (.not. found) then 4162 ABI_ERROR(sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file")) 4163 end if 4164 !write(std_out,*)sjoin("qpt irred:",ktoa(qibz(:,iq_ibz))) 4165 4166 iqst = iqst + nqst 4167 nqsts(iq_ibz) = nqst 4168 end do 4169 4170 ! Redo the mapping with the new IBZ 4171 call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,cryst%nsym,& 4172 sppoldbl1,cryst%symafm,cryst%symrec,timrev1,comm,use_symrec=.True.) 4173 4174 !qrank = krank_from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.) 4175 !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, & 4176 ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.) 4177 !call qrank%free() 4178 4179 if (dksqmax > tol12) then 4180 ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ") 4181 end if 4182 4183 ABI_MALLOC(emiqr, (2, db%my_nrpt)) 4184 v1scf_rpt = zero 4185 4186 ABI_MALLOC_OR_DIE(v1r_qbz, (2, nfft, db%nspden, db%natom3), ierr) 4187 !v1r_qbz = huge(one) 4188 4189 iqst = 0 4190 call cwtime(cpu, wall, gflops, "start") 4191 do iq_ibz=1,nqibz 4192 4193 ! Get potentials for this IBZ q-point on the real-space FFT mesh. 4194 ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom) 4195 ! TODO: Interface with qcache 4196 call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, comm) 4197 4198 ! Reconstruct by symmetry the potentials for the star of this q-point, perform FT and accumulate 4199 ! Be careful with the gamma point. 4200 do ii=1,nqsts(iq_ibz) 4201 iqst = iqst + 1 4202 iq_bz = iperm(iqst) 4203 ABI_CHECK(iq_ibz == indqq(iq_bz,1), "iq_ibz !/ ind qq(1)") 4204 isym = indqq(iq_bz,2); itimrev = indqq(iq_bz,6) + 1; g0q = indqq(iq_bz,3:5) ! IS(q_ibz) + g0q = q_bz 4205 tsign = 3-2*itimrev 4206 4207 qpt_bz = qbz(:, iq_bz) 4208 !write(std_out,*)" treating:",trim(ktoa(qpt_bz)) 4209 isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0)) 4210 !ABI_CHECK(all(g0q == 0), "g0q /= 0") 4211 4212 ! Compute long-range part of the coupling potential 4213 !call cwtime(cpu, wall, gflops, "start") 4214 v1r_lr = zero; cnt = 0 4215 if (db%add_lr /= 0) then 4216 idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1 4217 call db%get_v1r_long_range(qpt_bz, idir, iat, nfft, ngfft, v1r_lr) 4218 end if 4219 !call cwtime_report(" dvdb_get_v1r_long_range", cpu, wall, gflops) 4220 4221 if (cplex_qibz == 1) then 4222 ! Gamma point. 4223 ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)") 4224 ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0") 4225 4226 ! Substract the long-range part of the potential 4227 if (db%add_lr /= 0) then 4228 do ispden=1,db%nspden 4229 v1r_qibz(1,:,ispden,ipert) = v1r_qibz(1,:,ispden,ipert) - v1r_lr(1,:) 4230 end do 4231 end if 4232 4233 ! SLOW FT. 4234 !call cwtime(cpu, wall, gflops, "start") 4235 cnt = 0 4236 do ispden=1,db%nspden 4237 do irpt=1,db%my_nrpt 4238 ! MPI-parallelism 4239 cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle 4240 do ifft=1,nfft 4241 v1scf_rpt(1,irpt,ifft,ispden) = v1scf_rpt(1,irpt,ifft,ispden) + & 4242 v1r_qibz(1, ifft, ispden, ipert) 4243 end do 4244 end do 4245 end do 4246 !call cwtime_report(" slow fft", cpu, wall, gflops) 4247 4248 else 4249 ! q /= Gamma 4250 ! Get the periodic part of the potential in BZ (v1r_qbz) 4251 if (isirr_q) then 4252 !write(std_out,*)sjoin("qpt irred:",ktoa(qpt_bz)) 4253 v1r_qbz = v1r_qibz 4254 else 4255 !call cwtime(cpu, wall, gflops, "start") 4256 call v1phq_rotate(cryst, qibz(:,iq_ibz), isym, itimrev, g0q, & 4257 ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self) 4258 !call cwtime_report(" rotate", cpu, wall, gflops) 4259 !v1r_qbz = zero; v1r_qbz = v1r_qibz 4260 4261 !call times_eigr(-tsign * g0q, ngfft, nfft, db%nspden*db%natom3, v1r_qbz) 4262 !call times_eigr(+tsign * g0q, ngfft, nfft, db%nspden*db%natom3, v1r_qbz) 4263 !if (itimrev == 2) v1r_qbz(2,:,:,:) = -v1r_qbz(2,:,:,:) 4264 !call times_eigr(-tsign * g0q, ngfft, nfft, db%nspden*db%natom3, v1r_qbz) 4265 !call times_eigr(+tsign * g0q, ngfft, nfft, db%nspden*db%natom3, v1r_qbz) 4266 end if 4267 4268 ! Multiply by e^{iqpt_bz.r} 4269 call times_eikr(qpt_bz, ngfft, nfft, db%nspden*db%natom3, v1r_qbz) 4270 4271 ! Substract the long-range part of the potential 4272 if (db%add_lr /= 0) then 4273 do ispden=1,db%nspden 4274 v1r_qbz(1,:,ispden,ipert) = v1r_qbz(1,:,ispden,ipert) - v1r_lr(1,:) 4275 v1r_qbz(2,:,ispden,ipert) = v1r_qbz(2,:,ispden,ipert) - v1r_lr(2,:) 4276 end do 4277 end if 4278 4279 ! Compute FT phases for this qpt_bz. 4280 call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr) 4281 !call cwtime_report(" phases", cpu, wall, gflops) 4282 4283 ! SLOW FT. 4284 cnt = 0 4285 do ispden=1,db%nspden 4286 do ifft=1,nfft 4287 cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism. 4288 4289 v1scf_rpt(1,:,ifft,ispden) = v1scf_rpt(1,:,ifft,ispden) & 4290 + emiqr(1,:) * v1r_qbz(1, ifft, ispden, ipert) & 4291 - emiqr(2,:) * v1r_qbz(2, ifft, ispden, ipert) 4292 4293 v1scf_rpt(2,:,ifft,ispden) = v1scf_rpt(2,:,ifft,ispden) & 4294 + emiqr(1,:) * v1r_qbz(2, ifft, ispden, ipert) & 4295 + emiqr(2,:) * v1r_qbz(1, ifft, ispden, ipert) 4296 end do 4297 end do 4298 !call cwtime_report(" slow fft", cpu, wall, gflops) 4299 end if 4300 4301 end do ! iqst 4302 4303 write(msg,'(2(a,i0),a)') " q-point [",iq_ibz,"/",nqibz,"]" 4304 call cwtime_report(msg, cpu, wall, gflops) 4305 4306 ABI_FREE(v1r_qibz) 4307 end do ! iq_ibz 4308 ABI_CHECK(iqst == nqbz, "iqst /= nqbz") 4309 4310 v1scf_rpt = v1scf_rpt / nqbz 4311 call xmpi_sum(v1scf_rpt, comm, ierr) 4312 4313 ABI_FREE(emiqr) 4314 ABI_FREE(qibz) 4315 ABI_FREE(wtq) 4316 ABI_FREE(qbz) 4317 ABI_FREE(indqq) 4318 ABI_FREE(iperm) 4319 ABI_FREE(bz2ibz_sort) 4320 ABI_FREE(iqs_dvdb) 4321 ABI_FREE(nqsts) 4322 ABI_FREE(v1r_qbz) 4323 ABI_FREE(v1r_lr) 4324 4325 end subroutine dvdb_get_v1scf_rpt
m_dvdb/dvdb_interpolate_and_write [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_interpolate_and_write
FUNCTION
Interpolate the phonon potential onto a fine q-point grid and write the data in a new DVDB file.
INPUTS
OUTPUT
SOURCE
6627 subroutine dvdb_interpolate_and_write(dvdb, dtset, new_dvdb_fname, ngfft, ngfftf, cryst, & 6628 ngqpt_coarse, nqshift_coarse, qshift_coarse, comm, custom_qpt) 6629 6630 !Arguments ------------------------------------ 6631 !scalars 6632 integer,intent(in) :: nqshift_coarse, comm 6633 character(len=*),intent(in) :: new_dvdb_fname 6634 type(crystal_t),intent(in) :: cryst 6635 class(dvdb_t),intent(inout) :: dvdb 6636 type(dataset_type),intent(in) :: dtset 6637 !arrays 6638 integer,intent(in) :: ngfft(18), ngfftf(18) 6639 integer,intent(in) :: ngqpt_coarse(3) 6640 real(dp),intent(in) :: qshift_coarse(3,nqshift_coarse) 6641 real(dp),optional,intent(in) :: custom_qpt(:,:) 6642 6643 !Local variables ------------------------------ 6644 !scalars 6645 integer,parameter :: master=0 6646 integer :: fform_pot=111 6647 integer :: my_rank,nproc,idir,ipert,iat,ipc,ispden, ierr 6648 integer :: cplex,db_iqpt,natom,natom3,npc,trev_q,nspden 6649 integer :: nqbz, nqibz, iq, ifft, nqbz_coarse 6650 integer :: nperts_read, nperts_interpolate, nperts 6651 integer :: nqpt_read, nqpt_interpolate, qptopt, qtimrev 6652 integer :: nfft,nfftf, dimv1 6653 integer :: ount, unt, fform 6654 integer :: ncid, ncerr 6655 logical :: use_netcdf 6656 real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all 6657 character(len=500) :: msg 6658 character(len=fnlen) :: tmp_fname 6659 type(hdr_type) :: hdr_ref 6660 !arrays 6661 integer :: qptrlatt(3,3), rfdir(3) 6662 integer :: symq(4,2,cryst%nsym) 6663 integer,allocatable :: pinfo(:,:),rfpert(:),pertsy(:,:,:),iq_read(:),this_pertsy(:,:) 6664 real(dp) :: qpt(3), rhog1_g0(2) 6665 real(dp),allocatable :: v1scf(:,:,:), v1scf_rpt(:,:,:,:),v1(:) 6666 real(dp),allocatable :: wtq(:),qibz(:,:),qbz(:,:),q_interp(:,:),q_read(:,:) 6667 6668 !************************************************************************ 6669 6670 my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm) 6671 6672 write(msg, '(2a)') " Interpolation of the electron-phonon coupling potential", ch10 6673 call wrtout(ab_out, msg, do_flush=.True.); call wrtout(std_out, msg, do_flush=.True.) 6674 6675 call cwtime(cpu_all, wall_all, gflops_all, "start") 6676 6677 if (dtset%eph_task == 5 .or. present(custom_qpt)) then 6678 msg = sjoin(" From coarse q-mesh:", ltoa(ngqpt_coarse), "to:", ltoa(dtset%eph_ngqpt_fine)) 6679 call wrtout([std_out, ab_out], msg) 6680 ! Setup fine q-point grid in the IBZ 6681 ! Generate the list of irreducible q-points in the grid 6682 qptrlatt = 0 6683 qptrlatt(1,1) = dtset%eph_ngqpt_fine(1); qptrlatt(2,2) = dtset%eph_ngqpt_fine(2); qptrlatt(3,3) = dtset%eph_ngqpt_fine(3) 6684 qptopt = 1; if (dtset%qptopt /= 0) qptopt = dtset%qptopt 6685 qtimrev = kpts_timrev_from_kptopt(qptopt) 6686 call wrtout(std_out, sjoin(" Generating q-IBZ for DVDB with qptopt:", itoa(qptopt))) 6687 call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz) 6688 6689 else if (dtset%eph_task == -5) then 6690 msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints") 6691 call wrtout([std_out, ab_out], msg) 6692 ABI_CHECK(dtset%ph_nqpath > 0, "ph_nqpath must be specified when eph_task == -5") 6693 nqibz = dtset%ph_nqpath 6694 ABI_MALLOC(qibz, (3, nqibz)) 6695 qibz = dtset%ph_qpath(:, 1:nqibz) 6696 ABI_CALLOC(wtq, (nqibz)) 6697 nqbz = nqibz 6698 ABI_MALLOC(qbz, (3, nqbz)) 6699 qbz = qibz 6700 6701 else 6702 ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task))) 6703 end if 6704 6705 if (present(custom_qpt)) then 6706 ABI_SFREE(qibz) 6707 ABI_SFREE(wtq) 6708 ABI_SFREE(qbz) 6709 nqibz = size(custom_qpt,dim=2) 6710 ABI_MALLOC(qibz, (3, nqibz)) 6711 qibz = custom_qpt 6712 ABI_CALLOC(wtq, (nqibz)) 6713 nqbz = nqibz 6714 ABI_MALLOC(qbz, (3, nqbz)) 6715 qbz = qibz 6716 end if 6717 6718 nfft = product(ngfft(1:3)); nfftf = product(ngfftf(1:3)) 6719 6720 ! check that ngqpt_coarse is in DVDB. 6721 nqbz_coarse = product(ngqpt_coarse) * nqshift_coarse 6722 6723 ! ========================================== 6724 ! Prepare the header to write the potentials 6725 ! ========================================== 6726 6727 ! Read the first header 6728 if (my_rank == master) then 6729 if (open_file(dvdb%path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then 6730 ABI_ERROR(msg) 6731 end if 6732 read(unt, err=10, iomsg=msg) dvdb%version 6733 read(unt, err=10, iomsg=msg) dvdb%numv1 6734 6735 call hdr_fort_read(hdr_ref, unt, fform) 6736 if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then 6737 ABI_ERROR(sjoin("While reading:", dvdb%path, ch10, msg)) 6738 end if 6739 close(unt) 6740 end if 6741 6742 ! Reset the symmetries of the header 6743 ! One might have disable the symmetries in the response function calculation 6744 ! that produced the initial set of potentials present in the DVDB. 6745 ! This is because the symmetry features are not used in all parts 6746 ! of the response function driver. 6747 !write(std_out,*)hdr_ref%nsym, cryst%nsym 6748 !ABI_CHECK(hdr_ref%nsym == cryst%nsym, "Diff nsym") 6749 ABI_SFREE(hdr_ref%symrel) 6750 ABI_SFREE(hdr_ref%tnons) 6751 ABI_SFREE(hdr_ref%symafm) 6752 hdr_ref%nsym = cryst%nsym 6753 ABI_MALLOC(hdr_ref%symrel, (3,3,hdr_ref%nsym)) 6754 ABI_MALLOC(hdr_ref%tnons, (3,hdr_ref%nsym)) 6755 ABI_MALLOC(hdr_ref%symafm, (hdr_ref%nsym)) 6756 6757 hdr_ref%symrel(:,:,:) = cryst%symrel(:,:,:) 6758 hdr_ref%tnons(:,:) = cryst%tnons(:,:) 6759 hdr_ref%symafm(:) = cryst%symafm(:) 6760 hdr_ref%ngfft = ngfftf(1:3) 6761 6762 ! ======================================= 6763 ! Open DVDB and copy important dimensions 6764 ! ======================================= 6765 6766 call dvdb%open_read(ngfftf, xmpi_comm_self) 6767 6768 ! Besides perturbations with same q-points won't be contiguous on file --> IO is gonna be inefficient. 6769 call dvdb%print(prtvol=dtset%prtvol) 6770 6771 natom = cryst%natom 6772 natom3 = 3 * natom 6773 nspden = dvdb%nspden 6774 6775 ! ================================================== 6776 ! Sort the q-points to read and those to interpolate 6777 ! and find the irreducible perturbations 6778 ! ================================================== 6779 ABI_MALLOC(iq_read, (nqibz)) 6780 ABI_MALLOC(q_read, (3,nqibz)) 6781 ABI_MALLOC(q_interp, (3,nqibz)) 6782 ABI_MALLOC(pertsy, (nqibz,3,dvdb%mpert)) 6783 ABI_MALLOC(this_pertsy, (3,dvdb%mpert)) 6784 ABI_MALLOC(rfpert, (dvdb%mpert)) 6785 ABI_MALLOC(pinfo, (3,3*dvdb%mpert)) 6786 rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1 6787 6788 pertsy = 0 6789 nqpt_read = 0 6790 nperts_read = 0 6791 nqpt_interpolate = 0 6792 nperts_interpolate = 0 6793 6794 do iq=1,nqibz 6795 qpt = qibz(:,iq) 6796 6797 ! Find the index of the q-point in the DVDB. 6798 db_iqpt = dvdb%findq(qpt) 6799 !if (db_iqpt /= 1) db_iqpt = -1 6800 6801 if (db_iqpt /= -1) then 6802 if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt)," found in DVDB with index ",itoa(db_iqpt))) 6803 nqpt_read = nqpt_read + 1 6804 q_read(:,nqpt_read) = qpt(:) 6805 iq_read(nqpt_read) = db_iqpt 6806 6807 ! Count the perturbations 6808 npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo) 6809 do ipc=1,npc 6810 idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc) 6811 if (iat .le. natom) nperts_read = nperts_read + 1 6812 end do 6813 6814 else 6815 if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt), "not found in DVDB. Will interpolate.")) 6816 nqpt_interpolate = nqpt_interpolate + 1 6817 q_interp(:,nqpt_interpolate) = qpt(:) 6818 6819 ! Examine the symmetries of the q wavevector 6820 call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0) 6821 6822 ! Find the list of irreducible perturbations for this q-point. 6823 call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,& 6824 this_pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel) 6825 pertsy(nqpt_interpolate,:,:) = this_pertsy 6826 !pertsy = 1 6827 6828 do iat=1,natom 6829 do idir=1,3 6830 ipert = (iat-1) * 3 + idir 6831 if (pertsy(nqpt_interpolate,idir,iat) == 1) nperts_interpolate = nperts_interpolate + 1 6832 end do 6833 end do 6834 6835 end if 6836 end do 6837 6838 call wrtout([std_out, ab_out], sjoin(" Number of q-points found in input DVDB:", itoa(nqpt_read))) 6839 call wrtout([std_out, ab_out], sjoin(" Number of q-points requiring Fourier interpolation", itoa(nqpt_interpolate))) 6840 6841 ! ================================================= 6842 ! Open the new DVDB file and write preliminary info 6843 ! ================================================= 6844 nperts = nperts_read + nperts_interpolate 6845 6846 if (my_rank == master) then 6847 if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then 6848 ABI_ERROR(msg) 6849 end if 6850 write(ount, err=10, iomsg=msg) dvdb_last_version 6851 write(ount, err=10, iomsg=msg) nperts 6852 end if 6853 6854 ! ================================================================= 6855 ! Master reads all available perturbations and copy in the new DVDB 6856 ! ================================================================= 6857 6858 rhog1_g0 = zero 6859 6860 if (my_rank == master) then 6861 do iq=1,nqpt_read 6862 qpt = q_read(:,iq) 6863 db_iqpt = iq_read(iq) 6864 6865 ! Read each irreducible perturbation potentials 6866 npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo) 6867 ABI_CHECK(npc /= 0, "npc == 0!") 6868 6869 ! These arrays depend on cplex. 6870 ABI_MALLOC(v1scf, (cplex, nfftf, nspden)) 6871 ABI_MALLOC(v1, (cplex*nfftf)) 6872 6873 do ipc=1,npc 6874 idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc) 6875 if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfftf, ngfftf, v1scf, msg) /= 0) then 6876 ABI_ERROR(msg) 6877 end if 6878 6879 ! Write header 6880 hdr_ref%qptn = qpt 6881 hdr_ref%pertcase = ipert 6882 call hdr_ref%fort_write(ount, fform_pot, ierr) 6883 ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0") 6884 6885 do ispden=1,nspden 6886 v1 = reshape(v1scf(:,:,ispden), (/cplex*nfftf/)) 6887 write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf) 6888 end do 6889 if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0 6890 end do 6891 6892 ABI_FREE(v1scf) 6893 ABI_FREE(v1) 6894 end do 6895 end if ! master 6896 6897 call xmpi_barrier(comm) 6898 6899 ! ================================================================ 6900 ! Interpolate the potential for q-points not in the original DVDB 6901 ! ================================================================ 6902 6903 dvdb%my_nrpt = nqbz_coarse 6904 ABI_MALLOC_OR_DIE(v1scf_rpt, (2, dvdb%my_nrpt, nfftf, dvdb%nspden), ierr) 6905 6906 cplex = 2 6907 ABI_MALLOC(v1scf, (cplex,nfftf,nspden)) 6908 ABI_MALLOC(v1, (cplex*nfftf)) 6909 6910 use_netcdf = .False. 6911 ! Create temporary netcdf file used to write Fortran file with contiguous perturbations. 6912 use_netcdf = .True. 6913 if (my_rank == master) then 6914 tmp_fname = strcat(new_dvdb_fname, "_TEMPORARY_TRANSFER_FILE.nc") 6915 dimv1 = cplex * nfftf 6916 NCF_CHECK(nctk_open_create(ncid, tmp_fname, xmpi_comm_self)) 6917 ncerr = nctk_def_dims(ncid, [& 6918 nctkdim_t("dimv1", dimv1), nctkdim_t("nspden", nspden), & 6919 nctkdim_t("natom", natom), nctkdim_t("nqpt_intp", nqpt_interpolate), & 6920 nctkdim_t("nrpt", dvdb%my_nrpt), nctkdim_t("nfft", nfftf), nctkdim_t("natom3", natom * 3) & 6921 ]) 6922 NCF_CHECK(ncerr) 6923 NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1", "dp", "dimv1, nspden, three, natom, nqpt_intp"))) 6924 !NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1scf_rpt", "dp", "two, nrpt, nfft, nspden, natom3"))) 6925 NCF_CHECK(nctk_set_datamode(ncid)) 6926 end if 6927 6928 do iat=1,natom 6929 do idir=1,3 6930 ipert = (iat-1) * 3 + idir 6931 6932 ! Entry set to -1 for perturbations that can be found from basis perturbations. 6933 if (sum(pertsy(:,idir,iat)) == -nqpt_interpolate) cycle 6934 6935 call wrtout(std_out, sjoin(" Interpolating perturbation iat, idir = ",itoa(iat), itoa(idir)), do_flush=.True.) 6936 call cwtime(cpu, wall, gflops, "start") 6937 6938 ! TODO: This part is slow. 6939 ! Compute phonon potential in real space lattice representation. 6940 call dvdb_get_v1scf_rpt(dvdb, cryst, ngqpt_coarse, nqshift_coarse, & 6941 qshift_coarse, nfftf, ngfftf, & 6942 dvdb%my_nrpt, dvdb%nspden, ipert, v1scf_rpt, comm) 6943 6944 !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1scf_rpt"), v1scf_rpt, start=[1,1,1,1,ipert])) 6945 call cwtime_report(" v1scf_rpt built", cpu, wall, gflops) 6946 6947 do iq=1,nqpt_interpolate 6948 if (pertsy(iq,idir,iat) == -1) cycle 6949 qpt = q_interp(:,iq) 6950 6951 ! Interpolate the phonon potential 6952 call dvdb_get_v1scf_qpt(dvdb, cryst, qpt, nfftf, ngfftf, dvdb%my_nrpt, & 6953 dvdb%nspden, ipert, v1scf_rpt, v1scf, comm) 6954 6955 !call wrtout(std_out, sjoin("Writing q-point", itoa(iq))) 6956 if (my_rank == master) then 6957 if (use_netcdf) then 6958 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1"), v1scf, & 6959 start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1]) 6960 NCF_CHECK(ncerr) 6961 else 6962 ! Master writes the file (change also qpt and ipert in hdr%) 6963 hdr_ref%qptn = qpt 6964 hdr_ref%pertcase = ipert 6965 call hdr_ref%fort_write(ount, fform_pot, ierr) 6966 ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0") 6967 6968 do ispden=1,nspden 6969 v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf]) 6970 write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf) 6971 end do 6972 if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0 6973 end if 6974 end if 6975 end do 6976 6977 call cwtime_report(" q-points interpolated and written to new DVDB file.", cpu, wall, gflops) 6978 ABI_FREE(dvdb%my_rpt) 6979 end do 6980 end do 6981 6982 if (use_netcdf .and. my_rank == master) then 6983 do iq=1,nqpt_interpolate 6984 qpt = q_interp(:,iq) 6985 do iat=1,natom 6986 do idir=1,3 6987 if (pertsy(iq,idir,iat) == -1) cycle 6988 ipert = (iat-1) * 3 + idir 6989 hdr_ref%qptn = qpt 6990 hdr_ref%pertcase = ipert 6991 call hdr_ref%fort_write(ount, fform_pot, ierr) 6992 ncerr = nf90_get_var(ncid, nctk_idname(ncid, "v1"), v1scf, & 6993 start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1]) 6994 NCF_CHECK(ncerr) 6995 do ispden=1,nspden 6996 v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf]) 6997 write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf) 6998 end do 6999 if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0 7000 end do 7001 end do 7002 end do 7003 NCF_CHECK(nf90_close(ncid)) 7004 call delete_file(tmp_fname, ierr) 7005 end if 7006 7007 if (my_rank == master) close(ount) 7008 7009 ! Free memory 7010 ABI_FREE(v1scf) 7011 ABI_FREE(v1) 7012 ABI_FREE(v1scf_rpt) 7013 ABI_FREE(qbz) 7014 ABI_FREE(qibz) 7015 ABI_FREE(q_interp) 7016 ABI_FREE(q_read) 7017 ABI_FREE(wtq) 7018 ABI_FREE(iq_read) 7019 ABI_FREE(pertsy) 7020 ABI_FREE(this_pertsy) 7021 ABI_FREE(rfpert) 7022 ABI_FREE(pinfo) 7023 7024 call hdr_ref%free() 7025 7026 write(msg, '(2a)') "Interpolation of the electron-phonon coupling potential completed", ch10 7027 call wrtout([std_out, ab_out], msg, do_flush=.True.) 7028 7029 call cwtime_report(" Overall time:", cpu_all, wall_all, gflops_all) 7030 7031 return 7032 7033 ! Handle Fortran IO error 7034 10 continue 7035 ABI_ERROR(msg) 7036 7037 end subroutine dvdb_interpolate_and_write
m_dvdb/dvdb_interpolate_v1scf [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_interpolate_v1scf
FUNCTION
Interpolate the phonon perturbation potential. This routine is meant to replace dvdb_ftinterp_setup and dvdb_ftinterp_qpt. It performs the interpolation one perturbation at a time.
INPUTS
ngqpt(3)=Divisions of the ab-initio q-mesh. nqshift=Number of shifts used to generated the ab-initio q-mesh. qshift(3,nqshift)=The shifts of the ab-initio q-mesh. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT nfftf=Number of fft-points on the fine grid for interpolated potential ngfftf(18)=information on 3D FFT for interpolated potential comm=MPI communicator
OUTPUT
v1scf(2, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
SOURCE
4470 subroutine dvdb_interpolate_v1scf(db, cryst, qpt, ngqpt, nqshift, qshift, & 4471 nfft, ngfft, nfftf, ngfftf, v1scf, comm) 4472 4473 !Arguments ------------------------------------ 4474 !scalars 4475 integer,intent(in) :: nqshift,nfft,nfftf,comm 4476 class(dvdb_t),target,intent(inout) :: db 4477 !arrays 4478 real(dp),intent(in) :: qpt(3) 4479 integer,intent(in) :: ngqpt(3),ngfft(18),ngfftf(18) 4480 real(dp),intent(in) :: qshift(3,nqshift) 4481 real(dp),allocatable,intent(out) :: v1scf(:,:,:,:) 4482 type(crystal_t),intent(in) :: cryst 4483 4484 !Local variables------------------------------- 4485 !scalars 4486 integer :: ipert, nqbz, ierr, nproc, my_rank 4487 !real(dp) :: work_size 4488 !arrays 4489 real(dp),allocatable :: v1scf_rpt(:,:,:,:) 4490 4491 ! ************************************************************************* 4492 4493 nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm) 4494 4495 nqbz = product(ngqpt) * nqshift 4496 db%my_nrpt = nqbz 4497 4498 ABI_MALLOC_OR_DIE(v1scf, (2,nfftf,db%nspden,db%natom3), ierr) 4499 ABI_MALLOC_OR_DIE(v1scf_rpt, (2,db%my_nrpt,nfft,db%nspden), ierr) 4500 4501 do ipert=1,db%natom3 4502 write(std_out, "(a,i4,a,i4,a)") " Interpolating potential for perturbation ", ipert, " / ", db%natom3, ch10 4503 4504 ! FIXME I think this should be ngfftf and not ngfft 4505 ! Also, other calls to dvdb_ftinterp_setup should use ngfftf. 4506 call dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, & 4507 db%my_nrpt, db%nspden, ipert, v1scf_rpt, comm) 4508 4509 call dvdb_get_v1scf_qpt(db, cryst, qpt, nfftf, ngfftf, db%my_nrpt, db%nspden, & 4510 ipert, v1scf_rpt, v1scf(:,:,:,ipert), comm) 4511 4512 ABI_FREE(db%my_rpt) 4513 end do 4514 4515 ABI_FREE(v1scf_rpt) 4516 4517 end subroutine dvdb_interpolate_v1scf
m_dvdb/dvdb_list_perts [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_list_perts
FUNCTION
Given a q-point mesh, this routine checks if all the (phonon) perturbations are available taking into account symmetries.
INPUTS
ngqpt(3)=Q-mesh divisions. If all(ngqpt == -1), the list of q-points in the DVDB
(i.e. db%qpts) is analyzed instead of the q-points generated from ngqpt.
[unit]=Unit number for output. Default `std_out`.
OUTPUT
npert_miss = Number of missing perturbations.
SOURCE
4867 subroutine dvdb_list_perts(db, ngqpt, npert_miss, unit) 4868 4869 !Arguments ------------------------------------ 4870 class(dvdb_t),target,intent(in) :: db 4871 integer,intent(out) :: npert_miss 4872 integer,optional,intent(in) :: unit 4873 !arrays 4874 integer,intent(in) :: ngqpt(3) 4875 4876 !Local variables------------------------------- 4877 !scalars 4878 integer :: npert_redund,miss_q,idir,ipert,iv1,psy,weird_q,enough 4879 integer :: iq_ibz,nqibz,iq_file,qptopt,nshiftq,ii,timerev_q,unt,nqbz 4880 character(len=500) :: msg,ptype,found 4881 type(crystal_t),pointer :: cryst 4882 !arrays 4883 integer :: rfdir(3),qptrlatt(3,3) 4884 integer,allocatable :: pertsy(:,:),symq(:,:,:),rfpert(:) 4885 real(dp) :: qq(3),shiftq(3,1) 4886 real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:) 4887 4888 ! ************************************************************************* 4889 4890 unt = std_out; if (present(unit)) unt = unit 4891 cryst => db%cryst 4892 4893 if (all(ngqpt == -1)) then 4894 ! Will test the q-points in db 4895 call alloc_copy(db%qpts, qibz) 4896 nqibz = db%nqpt 4897 else 4898 ! Will test the q-points in the IBZ associated to ngqpt hence build IBZ and BZ from ngqpt. 4899 qptopt = 1; shiftq = zero; nshiftq = 1; qptrlatt = 0 4900 do ii=1,3 4901 qptrlatt(ii, ii) = ngqpt(ii) 4902 end do 4903 4904 call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nshiftq, shiftq, nqibz, qibz, wtq, nqbz, qbz) 4905 4906 ABI_FREE(qbz) 4907 ABI_FREE(wtq) 4908 end if 4909 4910 ! Initialize the list of perturbations rfpert and rdfir 4911 ! WARNING: Only phonon perturbations are considered for the time being. 4912 ABI_MALLOC(rfpert,(db%mpert)) 4913 rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1 4914 4915 ABI_MALLOC(symq, (4,2,cryst%nsym)) 4916 ABI_MALLOC(pertsy, (3,db%mpert)) 4917 4918 ! Loop over the q-points in the IBZ and test whether the q-point is present 4919 ! and if all the independent perturbations are available. 4920 ! `npert_miss` is the number of irreducible perturbations not found in the DVDB (critical) 4921 ! `npert_redund` is the number of redundant perturbations found in the DVDB (not critical) 4922 ! 4923 enough = 5; if (db%prtvol > 0) enough = nqibz + 1 4924 npert_miss = 0; npert_redund = 0 4925 do iq_ibz=1,nqibz 4926 if (iq_ibz == enough) then 4927 call wrtout(unt,' More than 20 q-points with prtvol == 0. Only important messages will be printed...') 4928 end if 4929 qq = qibz(:,iq_ibz) 4930 iq_file = db%findq(qq) 4931 4932 ! Examine the symmetries of the q wavevector 4933 call littlegroup_q(cryst%nsym,qq,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=db%prtvol) 4934 4935 ! Determine the symmetrical perturbations. Meaning of pertsy: 4936 ! 0 for non-target perturbations 4937 ! 1 for basis perturbations 4938 ! -1 for perturbations that can be found from basis perturbations 4939 call irreducible_set_pert(cryst%indsym,db%mpert,cryst%natom,cryst%nsym,& 4940 pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel) 4941 4942 if (iq_file /= -1) then 4943 ! This q-point is in the DVDB. Test if all the independent perturbations are available. 4944 if (iq_ibz <= enough) then 4945 call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is present in the DVDB file")) 4946 call wrtout(unt,' The list of irreducible perturbations for this q vector is:') 4947 end if 4948 ii = 0; weird_q = 0; miss_q = 0 4949 do ipert=1,db%mpert 4950 do idir=1,3 4951 psy = pertsy(idir,ipert) 4952 if (psy == 0) cycle 4953 iv1 = db%pos_dpq(idir,ipert,iq_file) 4954 ptype = "independent"; if (psy == -1) ptype = "symmetric" 4955 found = "Yes"; if (iv1 == 0) found = "No" 4956 4957 if (psy == 1 .and. iv1 == 0) miss_q = miss_q + 1 4958 if (psy == -1 .and. iv1 /= 0) weird_q = weird_q + 1 4959 4960 ii=ii+1 4961 if (iq_ibz <= enough) then 4962 write(msg,'(i5,a,i2,a,i4,4a)')ii,') idir=',idir,', ipert=',ipert,", type=",trim(ptype),", found=",trim(found) 4963 call wrtout(unt, msg) 4964 end if 4965 end do 4966 end do 4967 4968 if (weird_q /= 0) then 4969 write(msg,"(a,i0,a)")" DVDB is overcomplete. ",weird_q, " perturbation(s) can be reconstructed by symmetry." 4970 call wrtout(unt, msg) 4971 end if 4972 4973 npert_redund = npert_redund + weird_q 4974 npert_miss = npert_miss + miss_q 4975 if (miss_q /=0) then 4976 call wrtout(unt, sjoin(" WARNING:", itoa(miss_q), "independent perturbation(s) are missing!.")) 4977 end if 4978 4979 else 4980 ! This q-point is not present in dvdb. Print the list of independent perturbations. 4981 call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is NOT present in the DVDB file")) 4982 call wrtout(unt,' The list of irreducible perturbations for this q vector is:') 4983 ii = 0 4984 do ipert=1,db%mpert 4985 do idir=1,3 4986 if (pertsy(idir,ipert) == 1) then 4987 ii=ii+1 4988 write(msg,'(i5,a,i2,a,i4,a)')ii,') idir=',idir,', ipert=',ipert,", type=independent, found=No" 4989 call wrtout(unt, msg) 4990 npert_miss = npert_miss + 1 4991 end if 4992 end do 4993 end do 4994 end if 4995 4996 if (iq_ibz <= enough) call wrtout(unt," ") 4997 end do ! iq_ibz 4998 4999 if (npert_miss /= 0) then 5000 call wrtout(unt, sjoin(ch10, " There are ",itoa(npert_miss), "independent perturbations missing!")) 5001 else 5002 call wrtout(unt, " All the independent perturbations are available") 5003 if (npert_redund /= 0) then 5004 call wrtout(unt, " Note however that the DVDB is overcomplete as symmetric perturbations are present.") 5005 end if 5006 end if 5007 5008 ABI_FREE(qibz) 5009 ABI_FREE(rfpert) 5010 ABI_FREE(symq) 5011 ABI_FREE(pertsy) 5012 5013 end subroutine dvdb_list_perts
m_dvdb/dvdb_load_ddb [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_load_ddb
FUNCTION
Load information about the Born effective charges and dielectric tensor from a DDB file
TODO
Use this function in eph driver
m_dvdb/dvdb_load_efield [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_load_efield
FUNCTION
Load first oder derivatives wrt the electric file from files
INPUTS
pot_paths=List of strings with paths to POT1 files. comm=MPI communicator.
m_dvdb/dvdb_merge_files [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_merge_files
FUNCTION
Merge a list of POT1 files. INPUT nfiles=Number of files to be merged. dvdb_filepath=Name of output DVDB file. prtvol=Verbosity level.
SIDE EFFECTS
v1files=List of file names to merge. This list could be changed if POT1 files in netcdf format are found.
SOURCE
5035 subroutine dvdb_merge_files(nfiles, v1files, dvdb_filepath, prtvol) 5036 5037 !Arguments ------------------------------------ 5038 !scalars 5039 integer,intent(in) :: nfiles,prtvol 5040 character(len=*),intent(in) :: dvdb_filepath 5041 character(len=*),intent(inout) :: v1files(nfiles) 5042 5043 !Local variables------------------------------- 5044 !scalars 5045 ! Here I made a mistake because 102 corresponds to GS potentials 5046 ! as a consequence DVDB files generated with version <= 8.1.6 5047 ! contain list of potentials with fform = 102. 5048 !integer :: fform_pot=102 5049 integer :: fform_pot=111 5050 integer :: ii,jj,fform,ount,cplex,nfft,ifft,ispden,nperts 5051 integer :: n1,n2,n3,v1_varid,ierr, npert_miss 5052 logical :: qeq0 5053 character(len=500) :: msg 5054 type(hdr_type),pointer :: hdr1 5055 type(dvdb_t) :: dvdb 5056 !arrays 5057 integer :: units(nfiles) 5058 real(dp) :: rhog1_g0(2) 5059 real(dp),allocatable :: v1(:) 5060 logical :: has_rhog1_g0(nfiles) 5061 type(hdr_type),target,allocatable :: hdr1_list(:) 5062 5063 !************************************************************************ 5064 5065 if (file_exists(dvdb_filepath)) then 5066 ABI_ERROR(sjoin("Cannot overwrite existing file:", dvdb_filepath)) 5067 end if 5068 5069 ! If a file is not found, try the netcdf version and change v1files accordingly. 5070 do ii=1,nfiles 5071 if (nctk_try_fort_or_ncfile(v1files(ii), msg) /= 0) then 5072 ABI_ERROR(msg) 5073 end if 5074 end do 5075 5076 ! Read the headers 5077 ABI_MALLOC(hdr1_list, (nfiles)) 5078 nperts = size(hdr1_list) 5079 5080 ! Write dvdb file (we only support fortran binary format) 5081 if (open_file(dvdb_filepath, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then 5082 ABI_ERROR(msg) 5083 end if 5084 write(ount, err=10, iomsg=msg) dvdb_last_version 5085 write(ount, err=10, iomsg=msg) nperts 5086 5087 ! Validate headers. 5088 ! TODO: Should perform consistency check on the headers 5089 ! rearrange them in blocks of q-points for efficiency reason. 5090 ! ignore POT1 files that do not correspond to atomic perturbations. 5091 ! Add POT file from GS run to support Sternheimer in eph_task = 4 5092 5093 do ii=1,nfiles 5094 write(std_out,"(a,i0,2a)")"- Reading header of file [",ii,"]: ",trim(v1files(ii)) 5095 5096 if (endswith(v1files(ii), ".nc")) then 5097 NCF_CHECK(nctk_open_read(units(ii), v1files(ii), xmpi_comm_self)) 5098 call hdr_ncread(hdr1_list(ii),units(ii),fform) 5099 else 5100 if (open_file(v1files(ii), msg, newunit=units(ii), form="unformatted", action="read", status="old") /= 0) then 5101 ABI_ERROR(msg) 5102 end if 5103 call hdr_fort_read(hdr1_list(ii), units(ii), fform) 5104 end if 5105 5106 if (dvdb_check_fform(fform, "merge_dvdb", msg) /= 0) then 5107 ABI_ERROR(sjoin("While reading:", v1files(ii), msg)) 5108 end if 5109 if (prtvol > 0) call hdr1_list(ii)%echo(fform, 3, unit=std_out) 5110 if (hdr1_list(ii)%pertcase == 0) then 5111 ABI_ERROR(sjoin("Found GS potential:", v1files(ii))) 5112 end if 5113 !write(std_out,*)"done", trim(v1files(ii)) 5114 5115 ! Supported fform: 5116 ! 109 POT1 files without vh1(G=0) 5117 ! 111 POT1 files with extra record with vh1(G=0) after FFT data. 5118 has_rhog1_g0(ii) = .True. 5119 if (fform == 109) has_rhog1_g0(ii) = .False. 5120 5121 write(std_out,"(a,i0,2a)")"- Merging file [",ii,"]: ",trim(v1files(ii)) 5122 jj = ii 5123 hdr1 => hdr1_list(jj) 5124 call hdr1%fort_write(ount, fform_pot, ierr) 5125 ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0") 5126 5127 qeq0 = (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14) 5128 cplex = 2; if (qeq0) cplex = 1 5129 nfft = product(hdr1%ngfft(1:3)) 5130 n1 = hdr1%ngfft(1); n2 = hdr1%ngfft(2); n3 = hdr1%ngfft(3) 5131 5132 ABI_MALLOC(v1, (cplex*nfft)) 5133 5134 if (.not. endswith(v1files(ii), ".nc")) then 5135 ! Fortran IO 5136 do ispden=1,hdr1%nspden 5137 read(units(jj), err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft) 5138 write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft) 5139 end do 5140 ! Add rhog1(G=0) 5141 rhog1_g0 = zero 5142 if (has_rhog1_g0(jj)) read(units(jj), err=10, iomsg=msg) rhog1_g0 5143 if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0 5144 else 5145 ! Netcdf IO 5146 ! netcdf array has shape [cplex, n1, n2, n3, nspden] 5147 NCF_CHECK(nf90_inq_varid(units(ii), "first_order_potential", v1_varid)) 5148 do ispden=1,hdr1%nspden 5149 NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1])) 5150 write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft) 5151 end do 5152 ! Add rhog1(G=0) 5153 rhog1_g0 = zero 5154 if (has_rhog1_g0(jj)) then 5155 NCF_CHECK(nf90_get_var(units(ii), nctk_idname(units(ii), "rhog1_g0"), rhog1_g0)) 5156 end if 5157 if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0 5158 end if 5159 5160 if (.not. endswith(v1files(ii), ".nc")) then 5161 close(units(ii)) 5162 else 5163 NCF_CHECK(nf90_close(units(ii))) 5164 end if 5165 5166 ABI_FREE(v1) 5167 end do ! nperts 5168 5169 close(ount) 5170 5171 do ii=1,size(hdr1_list) 5172 call hdr1_list(ii)%free() 5173 end do 5174 ABI_FREE(hdr1_list) 5175 5176 write(std_out,"(a,i0,a)")" Merged successfully ", nfiles, " files" 5177 5178 ! List available perturbations. 5179 dvdb = dvdb_new(dvdb_filepath, xmpi_comm_self) 5180 call dvdb%print() 5181 call dvdb%list_perts([-1, -1, -1], npert_miss) 5182 call dvdb%free() 5183 5184 return 5185 5186 ! Handle Fortran IO error 5187 10 continue 5188 ABI_ERROR(sjoin("Error while merging files", ch10, msg)) 5189 5190 end subroutine dvdb_merge_files
m_dvdb/dvdb_new [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_new
FUNCTION
Initialize the object from file. This is a COLLECTIVE procedure that must be called by each process in the MPI communicator comm.
INPUTS
path=DVDB Filename. comm=MPI communicator.
SOURCE
577 type(dvdb_t) function dvdb_new(path, comm) result(new) 578 579 !Arguments ------------------------------------ 580 !scalars 581 character(len=*),intent(in) :: path 582 integer,intent(in) :: comm 583 584 !Local variables------------------------------- 585 !scalars 586 integer,parameter :: master = 0 587 integer :: iv1,ii,ierr,unt,fform,nqpt,iq,iq_found,cplex,trev_q 588 integer :: idir,ipert,my_rank, nprocs, iatom, pertcase 589 real(dp) :: cpu, wall, gflops 590 character(len=500) :: msg 591 type(hdr_type) :: hdr1 592 !arrays 593 integer,allocatable :: tmp_pos(:,:,:) 594 real(dp),allocatable :: tmp_qpts(:,:) 595 real(dp) :: tsec(2) 596 597 !************************************************************************ 598 599 ! Keep track of total time spent. 600 call timab(1800, 1, tsec) 601 602 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 603 new%path = path; new%comm = comm; new%iomode = IO_MODE_FORTRAN 604 605 call wrtout(std_out, sjoin("- Analyzing DVDB file: ", path, "...")) 606 call cwtime(cpu, wall, gflops, "start") 607 608 ! Master reads the header and builds useful tables 609 if (my_rank == master) then 610 611 if (open_file(path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then 612 ABI_ERROR(msg) 613 end if 614 read(unt, err=10, iomsg=msg) new%version 615 read(unt, err=10, iomsg=msg) new%numv1 616 617 ! Get important dimensions from the first header and rewind the file. 618 call hdr_fort_read(new%hdr_ref, unt, fform) 619 if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then 620 ABI_ERROR(sjoin("While reading:", path, ch10, msg)) 621 end if 622 if (new%debug) call new%hdr_ref%echo(fform, 4, unit=std_out) 623 624 rewind(unt) 625 read(unt, err=10, iomsg=msg) 626 read(unt, err=10, iomsg=msg) 627 628 ! The code below must be executed by the other procs if MPI. 629 new%natom = new%hdr_ref%natom 630 new%natom3 = 3 * new%hdr_ref%natom 631 new%nspden = new%hdr_ref%nspden 632 new%nsppol = new%hdr_ref%nsppol 633 new%nspinor = new%hdr_ref%nspinor 634 new%usepaw = new%hdr_ref%usepaw 635 ABI_CHECK(new%usepaw == 0, "PAW not yet supported") 636 637 ! TODO: Write function to return mpert from natom! 638 new%mpert = new%natom + 6 639 640 ABI_MALLOC(tmp_qpts, (3, new%numv1)) 641 ABI_MALLOC(tmp_pos, (3, new%mpert, new%numv1)) 642 tmp_pos = 0 643 644 ABI_MALLOC(new%cplex_v1, (new%numv1)) 645 ABI_MALLOC(new%ngfft3_v1, (3, new%numv1)) 646 ABI_MALLOC(new%iv_pinfoq, (4, new%numv1)) 647 ABI_MALLOC(new%rhog1_g0, (2, new%numv1)) 648 649 nqpt = 0 650 do iv1=1,new%numv1 651 call hdr_fort_read(hdr1, unt, fform) 652 if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then 653 ABI_ERROR(sjoin("While reading hdr of v1 potential of index:", itoa(iv1), ch10, msg)) 654 end if 655 656 ! Save cplex and FFT mesh associated to this perturbation. 657 cplex = 2; if (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14) cplex = 1 658 new%cplex_v1(iv1) = cplex 659 new%ngfft3_v1(:, iv1) = hdr1%ngfft(:3) 660 661 ! Skip the records with v1. 662 do ii=1,hdr1%nspden 663 read(unt, err=10, iomsg=msg) 664 end do 665 ! Read rhog1_g0 (if available) 666 new%rhog1_g0(:, iv1) = zero 667 if (new%version > 1) read(unt, err=10, iomsg=msg) new%rhog1_g0(:, iv1) 668 669 ! Check whether this q-point is already in the list. 670 ! Assume qpoints are grouped so invert the iq loop for better performace. 671 ! This is gonna be slow if lots of q-points and perturbations are not grouped. 672 iq_found = 0 673 do iq=nqpt,1,-1 674 if (all(abs(hdr1%qptn - tmp_qpts(:,iq)) < tol14)) then 675 iq_found = iq; exit 676 end if 677 end do 678 679 ! pertcase = idir + (ipert-1)*3 where ipert=iatom in the interesting cases 680 idir = mod(hdr1%pertcase-1, 3) + 1 681 ipert = (hdr1%pertcase - idir) / 3 + 1 682 683 ! Increment nqpt is new q-points and update tmp_pos 684 if (iq_found == 0) then 685 nqpt = nqpt + 1 686 tmp_qpts(:, nqpt) = hdr1%qptn 687 iq_found = nqpt 688 end if 689 tmp_pos(idir, ipert, iq_found) = iv1 690 new%iv_pinfoq(:,iv1) = [idir, ipert, hdr1%pertcase, iq_found] 691 692 call hdr1%free() 693 end do 694 695 ! Allocate arrays with correct nqpt dimension 696 new%nqpt = nqpt 697 ABI_MALLOC(new%qpts, (3, nqpt)) 698 new%qpts = tmp_qpts(:,1:nqpt) 699 ABI_FREE(tmp_qpts) 700 701 ABI_MALLOC(new%pos_dpq, (3, new%mpert, nqpt)) 702 new%pos_dpq = tmp_pos(:, :, 1:nqpt) 703 ABI_FREE(tmp_pos) 704 705 close(unt) 706 end if 707 708 ! Master broadcasts data. 709 if (xmpi_comm_size(comm) > 1) then 710 call xmpi_bcast(new%version, master, comm, ierr) 711 call xmpi_bcast(new%numv1, master, comm, ierr) 712 call xmpi_bcast(new%nqpt, master, comm, ierr) 713 call new%hdr_ref%bcast(master, my_rank, comm) 714 715 new%natom = new%hdr_ref%natom 716 new%natom3 = 3 * new%hdr_ref%natom 717 new%nspden = new%hdr_ref%nspden 718 new%nsppol = new%hdr_ref%nsppol 719 new%nspinor = new%hdr_ref%nspinor 720 new%usepaw = new%hdr_ref%usepaw 721 new%mpert = new%natom + 6 722 723 if (my_rank /= master) then 724 ABI_MALLOC(new%cplex_v1, (new%numv1)) 725 ABI_MALLOC(new%ngfft3_v1, (3, new%numv1)) 726 ABI_MALLOC(new%iv_pinfoq, (4, new%numv1)) 727 ABI_MALLOC(new%qpts, (3, new%nqpt)) 728 ABI_MALLOC(new%pos_dpq, (3, new%mpert, new%nqpt)) 729 ABI_MALLOC(new%rhog1_g0, (2, new%numv1)) 730 end if 731 732 call xmpi_bcast(new%cplex_v1, master, comm, ierr) 733 call xmpi_bcast(new%ngfft3_v1, master, comm, ierr) 734 call xmpi_bcast(new%iv_pinfoq, master, comm, ierr) 735 call xmpi_bcast(new%qpts, master, comm, ierr) 736 call xmpi_bcast(new%pos_dpq, master, comm, ierr) 737 call xmpi_bcast(new%rhog1_g0, master, comm, ierr) 738 end if 739 740 ! Init crystal_t from the hdr read from file. 741 new%cryst = new%hdr_ref%get_crystal() 742 new%my_npert = new%natom3 743 744 ! Init tables assuming no MPI distribution of perturbations. 745 ABI_MALLOC(new%my_pinfo, (3, new%natom3)) 746 ABI_MALLOC(new%pert_table, (2, new%natom3)) 747 do iatom=1,new%natom 748 do idir=1,3 749 pertcase = idir + (iatom-1) * 3 750 new%my_pinfo(:, pertcase) = [idir, iatom, pertcase] 751 new%pert_table(:, pertcase) = [xmpi_comm_self, pertcase] 752 end do 753 end do 754 755 ! Init Born effective charges 756 ABI_CALLOC(new%zeff, (3, 3, new%natom)) 757 ABI_CALLOC(new%zeff_raw, (3, 3, new%natom)) 758 ABI_CALLOC(new%qstar, (3, 3, 3, new%natom)) 759 760 ! Internal MPI_type needed for calling fourdp! 761 call initmpi_seq(new%mpi_enreg) 762 763 ! Precompute symq_table for all q-points in the DVDB. 764 ABI_ICALLOC(new%symq_table, (4, 2, new%cryst%nsym, new%nqpt)) 765 do iq=1,new%nqpt 766 if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism 767 call littlegroup_q(new%cryst%nsym, new%qpts(:,iq), new%symq_table(:,:,:,iq), & 768 new%cryst%symrec, new%cryst%symafm, trev_q, prtvol=0) 769 end do 770 call xmpi_sum(new%symq_table, comm, ierr) 771 772 call cwtime_report("- dvdb_new", cpu, wall, gflops) 773 call timab(1800, 2, tsec) 774 775 return 776 777 ! Handle Fortran IO error 778 10 continue 779 ABI_ERROR(sjoin("Error while reading:", path, ch10, msg)) 780 781 end function dvdb_new
m_dvdb/dvdb_open_read [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_open_read
FUNCTION
Open the file in read-only mode.
INPUTS
ngfft(18)=Info on the FFT mesh used for the DFPT potentials. Note that ngfft
is the mesh used by the parent. In principle, it can differ from the one
found in the file. In this case a Fourier interpolation is required.
comm=MPI communicator
SOURCE
801 subroutine dvdb_open_read(db, ngfft, comm) 802 803 !Arguments ------------------------------------ 804 !scalars 805 integer,intent(in) :: comm 806 class(dvdb_t),intent(inout) :: db 807 !arrays 808 integer,intent(in) :: ngfft(18) 809 810 !Local variables------------------------------- 811 !scalars 812 integer :: nprocs, unt, ii 813 character(len=500) :: msg 814 !arrays 815 character(len=fnlen) :: pot_paths(3) 816 817 !************************************************************************ 818 819 if (db%rw_mode /= DVDB_NOMODE) then 820 ABI_ERROR("DVDB should be in DVDB_NOMODE when open_read is called.") 821 end if 822 db%rw_mode = DVDB_READMODE 823 824 nprocs = xmpi_comm_size(comm) 825 826 ! Initialize tables to call fourdp in sequential 827 db%ngfft = ngfft 828 call init_distribfft_seq(db%mpi_enreg%distribfft, 'c', ngfft(2), ngfft(3), 'all') 829 call init_distribfft_seq(db%mpi_enreg%distribfft, 'f', ngfft(2), ngfft(3), 'all') 830 831 ! Open the file. 832 select case (db%iomode) 833 case (IO_MODE_FORTRAN) 834 if (open_file(db%path, msg, newunit=db%fh, form="unformatted", status="old", action="read") /= 0) then 835 ABI_ERROR(msg) 836 end if 837 read(db%fh, err=10, iomsg=msg) 838 read(db%fh, err=10, iomsg=msg) 839 db%current_fpos = 1 840 841 case (IO_MODE_MPI) 842 ABI_ERROR("MPI not coded") 843 844 case default 845 ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode))) 846 end select 847 848 ! Read potentials induced by electric fields 849 ! This requires ngfft so for the time being we call it here. 850 ! I should try to add efield perturbations to DVDB but then I also have to handle symmetrization wrt idir! 851 if (file_exists("__EFIELD_POTS__")) then 852 call wrtout(std_out, " Reading Efield potentials from EFIELD_POTS") 853 if (open_file("__EFIELD_POTS__", msg, newunit=unt, form="formatted") /= 0) then 854 ABI_ERROR(msg) 855 end if 856 do ii=1,3 857 read(unt, "(a)") pot_paths(ii) 858 end do 859 close(unt) 860 call db%load_efield(pot_paths, comm) 861 end if 862 863 return 864 865 ! Handle Fortran IO error 866 10 continue 867 ABI_ERROR(sjoin("Error while reading", db%path, ch10, msg)) 868 869 end subroutine dvdb_open_read
m_dvdb/dvdb_print [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_print
FUNCTION
Print info on the object.
INPUTS
[unit]=the unit number for output [prtvol]=verbosity level [mode_paral]=either "COLL" or "PERS"
OUTPUT
Only printing.
SOURCE
978 subroutine dvdb_print(db, header, unit, prtvol, mode_paral) 979 980 !Arguments ------------------------------------ 981 !scalars 982 integer,optional,intent(in) :: prtvol,unit 983 character(len=4),optional,intent(in) :: mode_paral 984 character(len=*),optional,intent(in) :: header 985 class(dvdb_t),intent(in) :: db 986 987 !Local variables------------------------------- 988 !scalars 989 integer :: my_unt,my_prtvol,iv1,iq,idir,ipert,iatom 990 character(len=4) :: my_mode 991 character(len=500) :: msg 992 993 ! ************************************************************************* 994 995 my_unt = std_out; if (present(unit)) my_unt = unit 996 my_prtvol = 0 ; if (present(prtvol)) my_prtvol = prtvol 997 my_mode = 'COLL'; if (present(mode_paral)) my_mode = mode_paral 998 999 msg=' ==== Info on the dvdb% object ==== ' 1000 if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== ' 1001 call wrtout(my_unt,msg,my_mode) 1002 1003 write(my_unt,"(a)")sjoin(" DVDB version:", itoa(db%version)) 1004 write(my_unt,"(a)")sjoin(" File path:", db%path) 1005 write(my_unt,"(a)")sjoin(" Number of v1scf potentials:", itoa(db%numv1)) 1006 write(my_unt,"(a)")sjoin(" Number of q-points in DVDB: ", itoa(db%nqpt)) 1007 ! TODO 1008 !if (with_mpi) then 1009 write(my_unt,"(a)")sjoin("-P Number of CPUs for parallelism over perturbations:", itoa(db%nprocs_pert)) 1010 write(my_unt,"(a)")sjoin("-P Number of perturbations treated by this CPU:", itoa(db%my_npert)) 1011 !end if 1012 write(my_unt,"(a)")sjoin(" Option for symmetrization of v1scf(r):", itoa(db%symv1)) 1013 write(my_unt,"(a)")" List of q-points: min(10, nqpt)" 1014 do iq=1,min(db%nqpt, 10) 1015 write(my_unt,"(a)")sjoin("[", itoa(iq),"]", ktoa(db%qpts(:,iq))) 1016 end do 1017 if (db%nqpt > 10) write(my_unt,"(a)")"..." 1018 1019 write(my_unt,"(a)")sjoin(" Have dielectric tensor:", yesno(db%has_dielt)) 1020 write(my_unt,"(a)")sjoin(" Have Born effective charges:", yesno(db%has_zeff)) 1021 write(my_unt,"(a)")sjoin(" Have quadrupoles:", yesno(db%has_quadrupoles)) 1022 write(my_unt,"(a)")sjoin(" Have electric field:", yesno(db%has_efield)) 1023 write(my_unt,"(a)")sjoin(" Treatment of long-range part in V1scf (add_lr):", itoa(db%add_lr)) 1024 write(my_unt,"(a, f6.1)")" Damping factor for Gaussian filter (qdamp):", db%qdamp 1025 1026 if (db%has_dielt) then 1027 write(my_unt, '(a,3(/,3es16.6))') ' Dielectric tensor in Cart coords:', & 1028 db%dielt(1,1), db%dielt(1,2), db%dielt(1,3), & 1029 db%dielt(2,1), db%dielt(2,2), db%dielt(2,3), & 1030 db%dielt(3,1), db%dielt(3,2), db%dielt(3,3) 1031 end if 1032 if (db%has_zeff) then 1033 call print_zeff(my_unt, db%zeff, db%cryst, title=' Born effectives charges in Cart coords:') 1034 !call print_zeff(my_unt, db%zeff_raw, db%cryst, title=' Born effectives charges before chneut: ') 1035 end if 1036 if (db%has_quadrupoles) then 1037 write(my_unt, '(a)') ' Dynamical Quadrupoles in Cartesian Coordinates: ' 1038 do iatom=1,db%natom 1039 do idir=1,3 1040 write(my_unt,'(2(a,i0),3(/,3es16.6))')' Q* for iatom: ', iatom, ' idir: ', idir, & 1041 db%qstar(1,1,idir,iatom), db%qstar(1,2,idir,iatom), db%qstar(1,3,idir,iatom), & 1042 db%qstar(2,1,idir,iatom), db%qstar(2,2,idir,iatom), db%qstar(2,3,idir,iatom), & 1043 db%qstar(3,1,idir,iatom), db%qstar(3,2,idir,iatom), db%qstar(3,3,idir,iatom) 1044 end do 1045 end do 1046 1047 write(my_unt,"(a)")" Dynamical quadrupoles sum rule: \sum_\iatom Q_{beta,gamma}{iatom,idir} = 0 for nonpolar materials" 1048 do idir=1,3 1049 write(my_unt,'(a,i0,/,3(/,3es16.6))')" Sum rule for idir: ", idir, & 1050 sum(db%qstar(1,1,idir,:)), sum(db%qstar(1,2,idir,:)), sum(db%qstar(1,3,idir,:)), & 1051 sum(db%qstar(2,1,idir,:)), sum(db%qstar(2,2,idir,:)), sum(db%qstar(2,3,idir,:)), & 1052 sum(db%qstar(3,1,idir,:)), sum(db%qstar(3,2,idir,:)), sum(db%qstar(3,3,idir,:)) 1053 end do 1054 end if 1055 1056 if (my_prtvol > 0) then 1057 call db%cryst%print(header="Crystal structure in DVDB file") 1058 write(my_unt,"(a)")"FFT mesh for potentials on file:" 1059 write(my_unt,"(a)")"q-point, idir, ipert, ngfft(:3)" 1060 do iv1=1,db%numv1 1061 idir = db%iv_pinfoq(1, iv1); ipert = db%iv_pinfoq(2, iv1); iq = db%iv_pinfoq(4, iv1) 1062 write(my_unt,"(a)")sjoin(ktoa(db%qpts(:,iq)), itoa(idir), itoa(ipert), ltoa(db%ngfft3_v1(:,iv1))) 1063 end do 1064 end if 1065 1066 contains 1067 1068 subroutine print_zeff(unt, zeff, cryst, title) 1069 1070 !Arguments ------------------------------------ 1071 !scalars 1072 integer,intent(in) :: unt 1073 character(len=*),optional,intent(in) :: title 1074 type(crystal_t),intent(in) :: cryst 1075 real(dp),intent(in) :: zeff(3,3,cryst%natom) 1076 1077 !Local variables------------------------------- 1078 !scalars 1079 integer :: iatom 1080 1081 ! ************************************************************************* 1082 1083 if (present(title)) then 1084 write(unt, "(a)")trim(title) 1085 else 1086 write(unt, '(a)') ' Born effectives charges in Cartesian coordinates: ' 1087 end if 1088 1089 do iatom=1,cryst%natom 1090 write(unt,'(a,i0,1x,2a,3(/,3es16.6),a)')' iatom: ', iatom, ", type: ", cryst%symbol_iatom(iatom), & 1091 zeff(1,1,iatom), zeff(1,2,iatom), zeff(1,3,iatom), & 1092 zeff(2,1,iatom), zeff(2,2,iatom), zeff(2,3,iatom), & 1093 zeff(3,1,iatom), zeff(3,2,iatom), zeff(3,3,iatom), ch10 1094 end do 1095 1096 write(unt,'(2a,3(/,3es16.6),a)')ch10,' Fulfillment of charge neutrality, \sum_{atom} Z^*_{ij,atom} = 0', & 1097 sum(zeff(1,1,:)), sum(zeff(1,2,:)), sum(zeff(1,3,:)), & 1098 sum(zeff(2,1,:)), sum(zeff(2,2,:)), sum(zeff(2,3,:)), & 1099 sum(zeff(3,1,:)), sum(zeff(3,2,:)), sum(zeff(3,3,:)), ch10 1100 1101 end subroutine print_zeff 1102 1103 end subroutine dvdb_print
m_dvdb/dvdb_qcache_read [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_qcache_read
FUNCTION
This function initializes the internal q-cache from file. This is a collective routine that must be called by all procs in comm.
INPUTS
nfft=Number of fft-points treated by this processors
ngfft(18)=contain all needed information about 3D FFT
mbsize: Cache size in megabytes.
< 0 to allocate all q-points.
0 has not effect.
> 0 for cache with automatically computed nqpt points.
qselect_dvdb(%nqpt)=0 to ignore this q-point when reading (global array)
itreatq(%nqpt) = 0 if this q-point won't be treated by this CPU else > 0.
Each CPU calls this routine with its own array.
comm=MPI communicator
OUTPUT
SOURCE
1709 subroutine dvdb_qcache_read(db, nfft, ngfft, mbsize, qselect_dvdb, itreatq, comm) 1710 1711 !Arguments ------------------------------------ 1712 !scalars 1713 integer,intent(in) :: nfft,comm 1714 class(dvdb_t),intent(inout) :: db 1715 real(dp),intent(in) :: mbsize 1716 !arrays 1717 integer,intent(in) :: ngfft(18), qselect_dvdb(db%nqpt) 1718 integer(i1b),intent(in) :: itreatq(db%nqpt) 1719 1720 !Local variables------------------------------- 1721 !scalars 1722 integer :: db_iqpt, cplex, imyp, ipc, ierr !, ii 1723 real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all 1724 character(len=500) :: msg 1725 !arrays 1726 real(dp),allocatable :: v1scf(:,:,:,:) 1727 real(dp) :: tsec(2) 1728 1729 ! ************************************************************************* 1730 1731 call timab(1801, 1, tsec) 1732 call wrtout(std_out, " Loading Vscf(q) from DVDB into qcache...", do_flush=.True.) 1733 call cwtime(cpu_all, wall_all, gflops_all, "start") 1734 1735 db%qcache = qcache_new(db%nqpt, nfft, ngfft, mbsize, db%natom3, db%my_npert, db%nspden) 1736 db%qcache%itreatq(:) = itreatq 1737 1738 do db_iqpt=1,db%nqpt 1739 ! Ignore points reported by the oracle 1740 if (qselect_dvdb(db_iqpt) == 0) cycle 1741 1742 ! All procs are getting the same q-point. Exit when we reach maxnq 1743 ! TODO: Rewrite this part. 1744 !qcnt = 0 1745 !do ii=1,db%nqpt 1746 ! if (allocated(db%qcache%key(ii)%v1scf)) qcnt = qcnt + 1 1747 !end do 1748 !if (qcnt >= db%qcache%maxnq) exit 1749 1750 call cwtime(cpu, wall, gflops, "start") 1751 1752 ! Read all 3*natom potentials inside comm 1753 call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm) 1754 1755 ! Print progress. 1756 if (db_iqpt <= 10 .or. mod(db_iqpt, 50) == 0) then 1757 write(msg,'(2(a,i0),a)') " Reading q-point [",db_iqpt,"/",db%nqpt, "]" 1758 call cwtime_report(msg, cpu, wall, gflops) 1759 end if 1760 1761 ! Transfer to cache taking into account my_npert. Note that IBZ may be distributed. 1762 if (db%qcache%itreatq(db_iqpt) /= 0) then 1763 ABI_MALLOC_OR_DIE(db%qcache%key(db_iqpt)%v1scf, (cplex, nfft, db%nspden, db%my_npert), ierr) 1764 do imyp=1,db%my_npert 1765 ipc = db%my_pinfo(3, imyp) 1766 db%qcache%key(db_iqpt)%v1scf(:,:,:,imyp) = real(v1scf(:,:,:,ipc), kind=QCACHE_KIND) 1767 end do 1768 end if 1769 1770 ABI_FREE(v1scf) 1771 end do 1772 1773 call wrtout(std_out, sjoin(" Memory allocated for cache:", ftoa(db%qcache%get_mbsize(), fmt="f8.1"), " [Mb] <<< MEM"), & 1774 pre_newlines=2) 1775 call cwtime_report(" DVDB qcache IO + symmetrization", cpu_all, wall_all, gflops_all) 1776 call timab(1801, 2, tsec) 1777 1778 end subroutine dvdb_qcache_read
m_dvdb/dvdb_qcache_update_from_file [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_qcache_update_from_file
FUNCTION
Read selected potentials and update the internal q-cache. This is a collective routine that must be called by all procs in comm.
INPUTS
nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT. ineed_qpt(%nqpt)=1 if this MPI rank requires this q-point. comm=MPI communicator
OUTPUT
SOURCE
1801 subroutine dvdb_qcache_update_from_file(db, nfft, ngfft, ineed_qpt, comm) 1802 1803 !Arguments ------------------------------------ 1804 !scalars 1805 integer,intent(in) :: nfft,comm 1806 class(dvdb_t),intent(inout) :: db 1807 !arrays 1808 integer,intent(in) :: ngfft(18), ineed_qpt(db%nqpt) 1809 1810 !Local variables------------------------------- 1811 !scalars 1812 integer,parameter :: master = 0 1813 integer :: db_iqpt, cplex, ierr, imyp, ipc, qcnt 1814 real(dp) :: cpu_all, wall_all, gflops_all, mbsize, max_mbsize 1815 character(len=500) :: msg 1816 !arrays 1817 integer :: qselect(db%nqpt) 1818 real(dp),allocatable :: v1scf(:,:,:,:) 1819 real(dp) :: tsec(2) 1820 1821 ! ************************************************************************* 1822 1823 if (db%qcache%maxnq == 0) return 1824 1825 ! Take the union of the q-points inside comm because we need to perform IO inside comm 1826 qselect = ineed_qpt 1827 call xmpi_sum(qselect, comm, ierr) 1828 qcnt = count(qselect > 0) 1829 if (qcnt == 0) then 1830 call wrtout(std_out, " All qpts in Vscf(q) already in cache. No need to perform IO. Hurrah!", do_flush=.True.) 1831 return 1832 end if 1833 1834 call wrtout(std_out, sjoin(" Need to update cache. Master node will read ", itoa(qcnt), "q-points. It may be slow..."), & 1835 do_flush=.True.) 1836 call timab(1807, 1, tsec) 1837 call cwtime(cpu_all, wall_all, gflops_all, "start") 1838 1839 if (db%qcache%make_room(ineed_qpt, msg) /= 0) then 1840 ABI_WARNING(msg) 1841 end if 1842 1843 do db_iqpt=1,db%nqpt 1844 if (qselect(db_iqpt) == 0) cycle 1845 1846 ! Read all 3*natom potentials inside comm. 1847 call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm) 1848 1849 ! Transfer to cache taking into account my_npert. 1850 if (ineed_qpt(db_iqpt) /= 0) then 1851 ABI_MALLOC_OR_DIE(db%qcache%key(db_iqpt)%v1scf, (cplex, nfft, db%nspden, db%my_npert), ierr) 1852 do imyp=1,db%my_npert 1853 ipc = db%my_pinfo(3, imyp) 1854 db%qcache%key(db_iqpt)%v1scf(:,:,:,imyp) = real(v1scf(:,:,:,ipc), kind=QCACHE_KIND) 1855 end do 1856 end if 1857 1858 ABI_FREE(v1scf) 1859 end do 1860 1861 mbsize = db%ft_qcache%get_mbsize() 1862 call wrtout(std_out, sjoin(" Memory allocated for cache: ", ftoa(mbsize, fmt="f8.1"), " [Mb] <<< MEM")) 1863 call xmpi_max(mbsize, max_mbsize, comm, ierr) 1864 call wrtout(std_out, sjoin(" Max memory inside MPI comm: ", ftoa(max_mbsize, fmt="f8.1"), " [Mb] <<< MEM")) 1865 call cwtime_report(" dvdb_qcache_update_from_file", cpu_all, wall_all, gflops_all) 1866 call timab(1807, 2, tsec) 1867 1868 end subroutine dvdb_qcache_update_from_file
m_dvdb/dvdb_qdownsample [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_qdownsample
FUNCTION
Downsample the q-mesh. Produce new DVDB file
INPUTS
new_dvdb_fname=Path of output DVDB qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used) ngqpt(3)=Division of coarse Q-mesh comm=MPI communicator.
OUTPUT
Only writing
SOURCE
7060 subroutine dvdb_qdownsample(dvdb, new_dvdb_fname, qptopt, ngqpt, comm) 7061 7062 !Arguments ------------------------------------ 7063 !scalars 7064 integer,intent(in) :: comm 7065 class(dvdb_t),intent(inout) :: dvdb 7066 character(len=*),intent(in) :: new_dvdb_fname 7067 !arrays 7068 integer,intent(in) :: qptopt, ngqpt(3) 7069 7070 !Local variables ------------------------------ 7071 !scalars 7072 integer,parameter :: master=0 7073 integer :: fform_pot=111 7074 integer :: ierr,my_rank,nproc,idir,ipert,iat,ipc,ispden 7075 integer :: cplex, db_iqpt, npc, nqbz, nqibz, iq, ifft, nperts_read, nfft, ount 7076 character(len=500) :: msg 7077 !arrays 7078 integer :: qptrlatt(3,3) 7079 integer,allocatable :: iq_read(:), pinfo(:,:) 7080 real(dp) :: rhog1_g0(2) 7081 real(dp),allocatable :: v1scf(:,:,:), v1(:), wtq(:), qibz(:,:), qbz(:,:) 7082 7083 !************************************************************************ 7084 7085 my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm) 7086 if (my_rank /= master) goto 20 7087 7088 nfft = product(dvdb%ngfft(1:3)) 7089 7090 ! ======================= 7091 ! Setup fine q-point grid 7092 ! ======================= 7093 ! Generate the list of irreducible q-points in the coarse grid 7094 qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3) 7095 call kpts_ibz_from_kptrlatt(dvdb%cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz) 7096 7097 ! ======================================= 7098 ! Open DVDB and copy important dimensions 7099 ! ======================================= 7100 7101 ABI_MALLOC(iq_read, (nqibz)) 7102 ABI_MALLOC(pinfo, (3, 3*dvdb%mpert)) 7103 nperts_read = 0 7104 7105 do iq=1,nqibz 7106 ! Find the index of the q-point in the DVDB. 7107 db_iqpt = dvdb%findq(qibz(:, iq)) 7108 ABI_CHECK(db_iqpt /= -1, sjoin("Q-point:", ktoa(qibz(:, iq)), "not found in DVDB!")) 7109 iq_read(iq) = db_iqpt 7110 7111 ! Count the number of perturbations. 7112 npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo) 7113 do ipc=1,npc 7114 idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc) 7115 if (iat <= dvdb%cryst%natom) nperts_read = nperts_read + 1 7116 end do 7117 end do 7118 7119 ! ================================================= 7120 ! Open the new DVDB file and write preliminary info 7121 ! ================================================= 7122 !nperts = nperts_read + nperts_interpolate 7123 if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then 7124 ABI_ERROR(msg) 7125 end if 7126 write(ount, err=10, iomsg=msg) dvdb_last_version 7127 write(ount, err=10, iomsg=msg) nperts_read 7128 7129 ! Read all perturbations on the coarse Q-mesh and write them to the new DVDB 7130 rhog1_g0 = zero 7131 7132 do iq=1,nqibz 7133 db_iqpt = iq_read(iq) 7134 7135 ! Read each irreducible perturbation potentials 7136 npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo) 7137 ABI_CHECK(npc /= 0, "npc == 0!") 7138 7139 ABI_MALLOC(v1scf, (cplex, nfft, dvdb%nspden)) 7140 ABI_MALLOC(v1, (cplex*nfft)) 7141 7142 do ipc=1,npc 7143 idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc) 7144 if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfft, dvdb%ngfft, v1scf, msg) /= 0) then 7145 ABI_ERROR(msg) 7146 end if 7147 7148 ! Change the header. 7149 dvdb%hdr_ref%qptn = qibz(:, iq) 7150 dvdb%hdr_ref%pertcase = ipert 7151 7152 ! Write header 7153 call dvdb%hdr_ref%fort_write(ount, fform_pot, ierr) 7154 ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0") 7155 7156 do ispden=1,dvdb%nspden 7157 v1 = reshape(v1scf(:,:,ispden), [cplex*nfft]) 7158 write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft) 7159 end do 7160 if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0 7161 end do 7162 7163 ABI_FREE(v1scf) 7164 ABI_FREE(v1) 7165 end do 7166 7167 close(ount) 7168 7169 ! Free memory 7170 ABI_FREE(qbz) 7171 ABI_FREE(qibz) 7172 ABI_FREE(wtq) 7173 ABI_FREE(iq_read) 7174 ABI_FREE(pinfo) 7175 7176 write(msg, '(2a)') " Downsampling of the e-ph coupling potential completed", ch10 7177 call wrtout(std_out, msg, do_flush=.True.) 7178 7179 20 continue 7180 call xmpi_barrier(comm) 7181 7182 return 7183 7184 ! Handle Fortran IO error 7185 10 continue 7186 ABI_ERROR(msg) 7187 7188 end subroutine dvdb_qdownsample
m_dvdb/dvdb_read_onev1 [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_read_onev1
FUNCTION
Read the DFPT potential for the specified (idir, ipert, iqpt). Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to get the index from the q-point in reduced coordinates.
INPUTS
idir=Direction of the perturbation ipert=Perturbation type. iqpt=Index of the q-point in dvdb%qpts cplex=1 if real, 2 if complex potentials. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT.
OUTPUT
ierr=Non-zero if error. v1scf(cplex*nfft, nspden)=DFT potential associated to (idir, ipert, iqpt). msg=String with error message if ierr /= 0.
SOURCE
1187 integer function dvdb_read_onev1(db, idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) result(ierr) 1188 1189 !Arguments ------------------------------------ 1190 !scalars 1191 integer,intent(in) :: idir,ipert,iqpt,cplex,nfft 1192 character(len=*),intent(out) :: msg 1193 class(dvdb_t),intent(inout) :: db 1194 !arrays 1195 integer,intent(in) :: ngfft(18) 1196 real(dp),intent(out) :: v1scf(cplex*nfft,db%nspden) 1197 1198 !Local variables------------------------------- 1199 !scalars 1200 integer,save :: enough = 0 1201 integer :: iv1,ispden,nfftot_file,nfftot_out,ifft 1202 type(MPI_type) :: MPI_enreg_seq 1203 !arrays 1204 integer :: ngfft_in(18),ngfft_out(18) 1205 real(dp),allocatable :: v1r_file(:,:),v1g_in(:,:),v1g_out(:,:) 1206 1207 ! ************************************************************************* 1208 1209 ! Consistency checks 1210 ierr = 1 1211 iv1 = db%pos_dpq(idir,ipert,iqpt) 1212 1213 if (iv1 == 0) then 1214 write(msg,"(3(a,i0))")"Cannot find idir: ",idir,", ipert: ",ipert,", iqpt:",iqpt 1215 return 1216 end if 1217 1218 if (cplex /= db%cplex_v1(iv1)) then 1219 write(msg,"(2(a,i0))")"Wrong cplex. Expecting: ",db%cplex_v1(iv1),", received: ",cplex 1220 return 1221 end if 1222 1223 ! Find (idir, ipert, iqpt) and skip the header. 1224 call dvdb_seek(db, idir, ipert, iqpt) 1225 ierr = my_hdr_skip(db%fh, idir, ipert, db%qpts(:,iqpt), msg) 1226 if (ierr /= 0) then 1227 msg = sjoin("In my_hdr_skip:", msg) 1228 return 1229 end if 1230 1231 ! Read v1 from file. 1232 nfftot_out = product(ngfft(:3)); nfftot_file = product(db%ngfft3_v1(:3, iv1)) 1233 1234 if (all(ngfft(:3) == db%ngfft3_v1(:3, iv1))) then 1235 do ispden=1,db%nspden 1236 read(db%fh, err=10, iomsg=msg) (v1scf(ifft, ispden), ifft=1,cplex*nfftot_file) 1237 end do 1238 else 1239 ! The FFT mesh used in the caller differ from the one found in the DVDB --> Fourier interpolation 1240 ! TODO: Add linear interpolation as well. 1241 if (enough == 0) ABI_COMMENT("Performing FFT interpolation of DFPT potentials as input ngfft differs from ngfft_file.") 1242 enough = enough + 1 1243 ABI_MALLOC(v1r_file, (cplex*nfftot_file, db%nspden)) 1244 do ispden=1,db%nspden 1245 read(db%fh, err=10, iomsg=msg) (v1r_file(ifft, ispden), ifft=1,cplex*nfftot_file) 1246 end do 1247 1248 ! Call fourier_interpol to get v1scf on ngfft mesh. 1249 ngfft_in = ngfft; ngfft_out = ngfft 1250 ngfft_in(1:3) = db%ngfft3_v1(1:3, iv1); ngfft_out(1:3) = ngfft(1:3) 1251 ngfft_in(4:6) = ngfft_in(1:3); ngfft_out(4:6) = ngfft_out(1:3) 1252 ngfft_in(9:18) = 0; ngfft_out(9:18) = 0 1253 ngfft_in(10) = 1; ngfft_out(10) = 1 1254 1255 call initmpi_seq(MPI_enreg_seq) 1256 ! Which one is coarse? Note that this part is not very robust and can fail! 1257 if (ngfft_in(2) * ngfft_in(3) < ngfft_out(2) * ngfft_out(3)) then 1258 call init_distribfft_seq(MPI_enreg_seq%distribfft,'c',ngfft_in(2),ngfft_in(3),'all') 1259 call init_distribfft_seq(MPI_enreg_seq%distribfft,'f',ngfft_out(2),ngfft_out(3),'all') 1260 else 1261 call init_distribfft_seq(MPI_enreg_seq%distribfft,'f',ngfft_in(2),ngfft_in(3),'all') 1262 call init_distribfft_seq(MPI_enreg_seq%distribfft,'c',ngfft_out(2),ngfft_out(3),'all') 1263 end if 1264 1265 ABI_MALLOC(v1g_in, (2, nfftot_file)) 1266 ABI_MALLOC(v1g_out, (2, nfftot_out)) 1267 1268 call fourier_interpol(cplex,db%nspden,0,0,nfftot_file,ngfft_in,nfftot_out,ngfft_out,& 1269 MPI_enreg_seq,v1r_file,v1scf,v1g_in,v1g_out) 1270 1271 ABI_FREE(v1g_in) 1272 ABI_FREE(v1g_out) 1273 ABI_FREE(v1r_file) 1274 call destroy_mpi_enreg(MPI_enreg_seq) 1275 end if 1276 1277 ! Skip record with rhog1_g0 (if present) 1278 if (db%version > 1) read(db%fh, err=10, iomsg=msg) 1279 1280 db%current_fpos = db%current_fpos + 1 1281 !write(std_out, *)"incr current_fpos", db%current_fpos 1282 1283 return 1284 1285 ! Handle Fortran IO error 1286 10 continue 1287 ierr = 1 1288 msg = sjoin("Error while reading", db%path, ch10, msg) 1289 1290 end function dvdb_read_onev1
m_dvdb/dvdb_readsym_allv1 [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_readsym_allv1
FUNCTION
Read all 3*natom DFPT potentials for the given iqpt (only atomic perturbations).
The routine will:
1) Reconstruct the potentials by symmetry if the DVDB contains less than 3*natom potentials.
2) interpolate the data if the input FFT mesh defined by `ngfft` differs
from the one used to store data in the file.
Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
get the index from the q-point in reduced coordinates.
INPUTS
iqpt=Index of the q-point in dvdb%qpts nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT comm=MPI communicator
OUTPUT
cplex=1 if real, 2 if complex. v1scf(cplex, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
SOURCE
1323 subroutine dvdb_readsym_allv1(db, iqpt, cplex, nfft, ngfft, v1scf, comm) 1324 1325 !Arguments ------------------------------------ 1326 !scalars 1327 integer,intent(in) :: iqpt,nfft,comm 1328 integer,intent(out) :: cplex 1329 class(dvdb_t),intent(inout) :: db 1330 !arrays 1331 integer,intent(in) :: ngfft(18) 1332 real(dp) ABI_ASYNC ,allocatable,intent(out) :: v1scf(:,:,:,:) 1333 1334 !Local variables------------------------------- 1335 !scalars 1336 integer,parameter :: master=0 1337 integer :: ipc,npc,idir,ipert,pcase,my_rank,nproc,ierr,mu 1338 character(len=500) :: msg 1339 !arrays 1340 integer :: pinfo(3,3*db%mpert),pflag(3, db%natom) 1341 real(dp) :: tsec(2) 1342 integer,allocatable :: requests(:) 1343 1344 ! ************************************************************************* 1345 1346 ! Keep track of total time spent. 1347 call timab(1805, 1, tsec) 1348 1349 my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm) 1350 1351 ! Get number of perturbations computed for this iqpt as well as cplex. 1352 npc = dvdb_get_pinfo(db, iqpt, cplex, pinfo) 1353 ABI_CHECK(npc /= 0, "npc == 0!") 1354 1355 ABI_MALLOC_OR_DIE(v1scf, (cplex, nfft, db%nspden, 3*db%natom), ierr) 1356 1357 ! Master read all available perturbations and broadcasts data (non-blocking to overlap IO and MPI) 1358 ABI_MALLOC(requests, (npc)) 1359 1360 do ipc=1,npc 1361 idir = pinfo(1,ipc); ipert = pinfo(2,ipc); pcase = pinfo(3, ipc) 1362 if (my_rank == master) then 1363 if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf(:,:,:,pcase), msg) /= 0) then 1364 ABI_ERROR(msg) 1365 end if 1366 end if 1367 if (nproc > 1) call xmpi_ibcast(v1scf(:,:,:,pcase), master, comm, requests(ipc), ierr) 1368 end do 1369 1370 if (nproc > 1) call xmpi_waitall(requests, ierr) 1371 ABI_FREE(requests) 1372 1373 ! Return if all perts are available. 1374 if (npc == 3*db%natom) then 1375 if (db%symv1==1) then 1376 if (db%debug) write(std_out,*)"Potentials are available but will call v1phq_symmetrize because of symv1" 1377 do mu=1,db%natom3 1378 !if (mod(mu, nproc) /= my_rank) cycle ! MPI parallelism. 1379 idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1 1380 call v1phq_symmetrize(db%cryst,idir,ipert,db%symq_table(:,:,:,iqpt),ngfft,cplex,nfft,& 1381 db%nspden,db%nsppol,db%mpi_enreg,v1scf(:,:,:,mu)) 1382 !call MPI_Ibcast(void *buffer, int count, MPI_Datatype datatype, int root, MPI_Comm comm, MPI_Request *request) 1383 end do 1384 end if 1385 if (db%debug) write(std_out,*)"All perts available. Returning" 1386 return 1387 end if 1388 1389 ! Perturbation are missing and we have to reconstruct them by symmetry. 1390 ! This is the common case when DFPT calculations are done for independent perturbations only. 1391 if (db%debug) then 1392 write(std_out,*)sjoin("Will use symmetries to recostruct:", itoa(3*db%natom - npc), "perturbations") 1393 end if 1394 1395 ! 0 if pert is not available. 1396 ! 1 if pert is on file. 1397 ! 2 if pert has been reconstructed by symmetry. 1398 pflag = 0 1399 do ipc=1,npc 1400 pflag(pinfo(1,ipc), pinfo(2,ipc)) = 1 1401 end do 1402 1403 call v1phq_complete(db%cryst,db%qpts(:,iqpt),ngfft,cplex,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,v1scf) 1404 1405 call timab(1805, 2, tsec) 1406 1407 end subroutine dvdb_readsym_allv1
m_dvdb/dvdb_readsym_qbz [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_readsym_qbz
FUNCTION
This is the MAIN ENTRY POINT for client code. Reconstruct the DFPT potential for a q-point in the BZ starting from its symmetrical image in the IBZ. Implements caching mechanism to reduce IO.
INPUTS
cryst<crystal_t>=crystal structure parameters qbz(3)=Q-point in BZ. indq2db(6)=Symmetry mapping qbz --> DVDB qpoint produced by listkk. nfft=Number of fft-points treated by this processors ngfft(18)=contain all needed information about 3D FFT comm=MPI communicator (either xmpi_comm_self or comm for perturbations.
OUTPUT
cplex=1 if real, 2 if complex. v1scf(cplex, nfft, nspden, db%my_npert)= v1scf potentials on the real-space FFT mesh for the db%my_npert perturbations treated by this MPI rank.
SOURCE
1436 subroutine dvdb_readsym_qbz(db, cryst, qbz, indq2db, cplex, nfft, ngfft, v1scf, comm) 1437 1438 !Arguments ------------------------------------ 1439 !scalars 1440 integer,intent(in) :: nfft,comm 1441 integer,intent(out) :: cplex 1442 type(crystal_t),intent(in) :: cryst 1443 class(dvdb_t),intent(inout) :: db 1444 !arrays 1445 integer,intent(in) :: ngfft(18) 1446 integer,intent(in) :: indq2db(6) 1447 real(dp),intent(in) :: qbz(3) 1448 real(dp),allocatable,intent(out) :: v1scf(:,:,:,:) 1449 1450 !Local variables------------------------------- 1451 !scalars 1452 integer :: db_iqpt, itimrev, isym, npc, ierr, imyp, mu, root 1453 logical :: isirr_q, incache 1454 !arrays 1455 integer :: pinfo(3,3*db%mpert), g0q(3), requests(db%natom3) 1456 real(dp) :: tsec(2) 1457 real(dp) ABI_ASYNC, allocatable :: work(:,:,:,:), work2(:,:,:,:) 1458 1459 ! ************************************************************************* 1460 ABI_UNUSED(qbz(1)) 1461 1462 ! Keep track of total time spent. 1463 call timab(1802, 1, tsec) 1464 1465 db_iqpt = indq2db(1) 1466 db%qcache%count_qused(db_iqpt) = db%qcache%count_qused(db_iqpt) + 1 1467 db%qcache%stats(1) = db%qcache%stats(1) + 1 1468 1469 ! IS(q_dvdb) + g0q = q_bz 1470 isym = indq2db(2); itimrev = indq2db(6) + 1; g0q = indq2db(3:5) 1471 isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0)) 1472 1473 if (db%qcache%use_3natom_cache .and. db%qcache%stored_iqibz_cplex(1) == db_iqpt .and. .not. isirr_q) then 1474 ! All 3 natom potentials for qibz are in cache. Symmetrize to get Sq without MPI communication. 1475 db%qcache%stats(2) = db%qcache%stats(2) + 1 1476 cplex = db%qcache%stored_iqibz_cplex(2) 1477 ABI_MALLOC(work2, (cplex, nfft, db%nspden, db%natom3)) 1478 call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, & 1479 db%nspden, db%mpi_enreg, db%qcache%v1scf_3natom_qibz, work2, db%comm_pert) 1480 ! Extract my data from work2 1481 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 1482 do imyp=1,db%my_npert 1483 v1scf(:,:,:,imyp) = work2(:,:,:,db%my_pinfo(3, imyp)) 1484 end do 1485 ABI_FREE(work2) 1486 call timab(1802, 2, tsec); return 1487 end if 1488 1489 ! Check whether db_iqpt is in cache. 1490 incache = .False. 1491 if (db%qcache%maxnq > 0) then 1492 ! Get number of perturbations computed for this iqpt as well as cplex. 1493 npc = dvdb_get_pinfo(db, db_iqpt, cplex, pinfo) 1494 ABI_CHECK(npc /= 0, "npc == 0!") 1495 1496 ! Size of v1scf in qcache depends on db%my_npert 1497 if (allocated(db%qcache%key(db_iqpt)%v1scf)) then 1498 if (size(db%qcache%key(db_iqpt)%v1scf, dim=1) == cplex .and. size(db%qcache%key(db_iqpt)%v1scf, dim=2) == nfft) then 1499 ! Potential in cache --> copy it in output v1scf. 1500 ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 1501 v1scf = real(db%qcache%key(db_iqpt)%v1scf, kind=QCACHE_KIND) 1502 incache = .True. 1503 db%qcache%stats(3) = db%qcache%stats(3) + 1 1504 else 1505 ! This to handle the unlikely event in which the caller changes ngfft! 1506 ABI_WARNING("different cplex or nfft!") 1507 end if 1508 else 1509 !call wrtout(std_out, sjoin("Cache miss for db_iqpt. Will read it from file...", itoa(db_iqpt))) 1510 db%qcache%stats(4) = db%qcache%stats(4) + 1 1511 end if 1512 end if 1513 1514 if (.not. incache) then 1515 ! Read the dvscf potentials in the IBZ for all 3*natom perturbations. 1516 ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom) 1517 call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm) 1518 1519 ! Store all 3 natom potentials for q in IBZ in cache. 1520 if (db%qcache%use_3natom_cache .and. db%qcache%stored_iqibz_cplex(1) /= db_iqpt .and. isirr_q) then 1521 if (cplex /= db%qcache%stored_iqibz_cplex(2)) then 1522 ABI_REMALLOC(db%qcache%v1scf_3natom_qibz, (cplex, nfft, db%nspden, db%natom3)) 1523 end if 1524 db%qcache%v1scf_3natom_qibz = v1scf 1525 db%qcache%stored_iqibz_cplex = [db_iqpt, cplex] 1526 end if 1527 end if 1528 1529 if (.not. isirr_q) then 1530 ! Must rotate db_iqpt to get potential for qpoint in the BZ. 1531 ! Be careful with the shape of output v1scf because the routine returns db%my_npert potentials. 1532 1533 if (db%my_npert == db%natom3) then 1534 ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3)) 1535 work = v1scf 1536 call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, & 1537 db%nspden, db%mpi_enreg, work, v1scf, db%comm_pert) 1538 ABI_FREE(work) 1539 1540 else 1541 ! Parallelism over perturbations. 1542 ABI_MALLOC(work2, (cplex, nfft, db%nspden, db%natom3)) 1543 1544 if (incache) then 1545 ! Cache is distributed --> have to collect all 3*natom perts inside db%comm_pert. 1546 ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3)) 1547 1548 ! IBCAST is much faster than a naive xmpi_sum. 1549 call timab(1806, 1, tsec) 1550 do mu=1,db%natom3 1551 root = db%pert_table(1, mu) 1552 if (root == db%me_pert) then 1553 work(:,:,:,mu) = v1scf(:,:,:,db%pert_table(2, mu)) 1554 end if 1555 call xmpi_ibcast(work(:,:,:,mu), root, db%comm_pert, requests(mu), ierr) 1556 end do 1557 call xmpi_waitall(requests, ierr) 1558 call timab(1806, 2, tsec) 1559 1560 ! Store all 3 natom potentials for q in IBZ in cache. 1561 if (db%qcache%use_3natom_cache .and. db%qcache%stored_iqibz_cplex(1) /= db_iqpt) then 1562 if (cplex /= db%qcache%stored_iqibz_cplex(2)) then 1563 ABI_REMALLOC(db%qcache%v1scf_3natom_qibz, (cplex, nfft, db%nspden, db%natom3)) 1564 end if 1565 db%qcache%v1scf_3natom_qibz = work 1566 db%qcache%stored_iqibz_cplex = [db_iqpt, cplex] 1567 end if 1568 1569 ! Now rotate. 1570 call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, & 1571 db%nspden, db%mpi_enreg, work, work2, db%comm_pert) 1572 ABI_FREE(work) 1573 1574 else 1575 ! All 3 natom have been read in v1scf by dvdb_readsym_allv1 1576 call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, & 1577 db%nspden, db%mpi_enreg, v1scf, work2, db%comm_pert) 1578 end if 1579 1580 ! Reallocate v1scf with my_npert and extract data from work2. 1581 ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 1582 do imyp=1,db%my_npert 1583 v1scf(:,:,:,imyp) = work2(:,:,:,db%my_pinfo(3, imyp)) 1584 end do 1585 ABI_FREE(work2) 1586 end if 1587 1588 else 1589 ! Handle potentials read from file in case of parallelism over perturbations. 1590 if (.not. incache .and. db%my_npert /= db%natom3) then 1591 ABI_MALLOC(work, (cplex, nfft, db%nspden, db%my_npert)) 1592 do imyp=1,db%my_npert 1593 work(:,:,:,imyp) = v1scf(:,:,:,db%my_pinfo(3, imyp)) 1594 end do 1595 1596 ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert)) 1597 v1scf = work 1598 ABI_FREE(work) 1599 end if 1600 end if ! not isirr_q 1601 1602 call timab(1802, 2, tsec) 1603 1604 end subroutine dvdb_readsym_qbz
m_dvdb/dvdb_rewind [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_rewind
FUNCTION
Rewind the file and move to the first header. Needed only if dvdb%iomode==IO_MODE_FORTRAN Return exit code and error message in msg if ierr != 0
SOURCE
4771 integer function dvdb_rewind(db, msg) result(ierr) 4772 4773 !Arguments ------------------------------------ 4774 type(dvdb_t),intent(inout) :: db 4775 character(len=*),intent(out) :: msg 4776 4777 ! ************************************************************************* 4778 4779 ierr = 0 4780 if (db%iomode == IO_MODE_FORTRAN) then 4781 rewind(db%fh, err=10, iomsg=msg) 4782 read(db%fh, err=10, iomsg=msg) ! version 4783 read(db%fh, err=10, iomsg=msg) ! numv1 4784 db%current_fpos = 1 4785 4786 else 4787 ierr = -1 4788 msg = "should not be called when iomode /= IO_MODE_FORTRAN" 4789 end if 4790 4791 return 4792 4793 ! Handle Fortran IO error 4794 10 continue 4795 ierr = 1 4796 msg = sjoin("Error while reading", db%path, ch10, msg) 4797 4798 end function dvdb_rewind
m_dvdb/dvdb_seek [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_seek
FUNCTION
Move the internal file pointer so that it points to the block with (idir, ipert, iqpt). Needed only if dvdb%iomode==IO_MODE_FORTRAN
INPUTS
idir,ipert,iqpt = (direction, perturbation, q-point) indices
SIDE EFFECTS
db<type(dvdb_t)>: modifies db%current_fpos.
SOURCE
4683 subroutine dvdb_seek(db, idir, ipert, iqpt) 4684 4685 !Arguments ------------------------------------ 4686 integer,intent(in) :: idir, ipert, iqpt 4687 type(dvdb_t),intent(inout) :: db 4688 4689 !Local variables------------------------------- 4690 integer :: pos_now,pos_wanted,ii,ispden,nn,ierr 4691 real(dp),parameter :: fake_qpt(3)=zero 4692 character(len=500) :: msg 4693 4694 ! ************************************************************************* 4695 4696 if (db%iomode == IO_MODE_FORTRAN) then 4697 pos_now = db%current_fpos 4698 pos_wanted = db%pos_dpq(idir,ipert,iqpt) 4699 ABI_CHECK(pos_wanted /= 0, "pos_wanted cannot be zero!") 4700 4701 ! Optimal access. 4702 if (pos_now == pos_wanted) return 4703 4704 if (pos_wanted < pos_now) then 4705 ! Backspace previous records and header 4706 ! but only if nn <= pos_wanted else rewind file and skip pos_wanted potentials (should be faster) 4707 nn = pos_now - pos_wanted 4708 if (nn <= pos_wanted) then 4709 do ii=1,nn 4710 !write(std_out, *)"backspacing" 4711 if (db%version > 1) backspace(unit=db%fh, err=10, iomsg=msg) 4712 do ispden=1,db%nspden 4713 backspace(unit=db%fh, err=10, iomsg=msg) 4714 end do 4715 ierr = db%hdr_ref%backspace(db%fh, msg) 4716 if (ierr /= 0) goto 10 4717 end do 4718 db%current_fpos = pos_wanted; return 4719 else 4720 ! rewind the file and read it from the beginning 4721 if (dvdb_rewind(db, msg) /= 0) then 4722 ABI_ERROR(msg) 4723 end if 4724 nn = pos_wanted 4725 end if 4726 4727 else 4728 nn = pos_wanted - pos_now + 1 4729 end if 4730 4731 do ii=1,nn-1 4732 !write(std_out,*)"in seek with ii: ",ii,"pos_wanted: ",pos_wanted 4733 if (my_hdr_skip(db%fh, -1, -1, fake_qpt, msg) /= 0) then 4734 ABI_ERROR(msg) 4735 end if 4736 ! Skip the records with v1. 4737 do ispden=1,db%nspden 4738 read(db%fh, err=10, iomsg=msg) 4739 end do 4740 ! Skip record with rhog1_g0 (if present) 4741 if (db%version > 1) read(db%fh, err=10, iomsg=msg) 4742 end do 4743 4744 db%current_fpos = pos_wanted 4745 4746 else 4747 ABI_ERROR("Should not be called when iomode /= IO_MODE_FORTRAN") 4748 end if 4749 4750 return 4751 4752 ! Handle Fortran IO error 4753 10 continue 4754 msg = sjoin("Error while reading", db%path, ch10, msg) 4755 4756 end subroutine dvdb_seek
m_dvdb/dvdb_set_pert_distrib [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_set_pert_distrib
FUNCTION
Activate MPI distribution of the 3*natom perturbations.
INPUTS
my_npert=Number of perturbations treated by this rank
natom3= 3 * natom
my_pinfo(3, my_npert)
my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
pert_table(2, natom3)
pert_table(1, npert): rank of the processor treating this atomic perturbation.
pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
comm_pert=MPI communicator used to distribute the 3*natom perturbations
SOURCE
4636 subroutine dvdb_set_pert_distrib(self, my_npert, natom3, my_pinfo, pert_table, comm_pert) 4637 4638 !Arguments ------------------------------------ 4639 !scalars 4640 class(dvdb_t),intent(inout) :: self 4641 integer,intent(in) :: my_npert, natom3, comm_pert 4642 !arrays 4643 integer,intent(in) :: my_pinfo(3,my_npert), pert_table(2,natom3) 4644 4645 ! ************************************************************************* 4646 4647 self%comm_pert = comm_pert 4648 self%nprocs_pert = xmpi_comm_size(comm_pert) 4649 self%me_pert = xmpi_comm_rank(comm_pert) 4650 self%my_npert = my_npert 4651 4652 ABI_SFREE(self%my_pinfo) 4653 ABI_SFREE(self%pert_table) 4654 call alloc_copy(my_pinfo, self%my_pinfo) 4655 call alloc_copy(pert_table, self%pert_table) 4656 4657 if (self%debug) then 4658 write(std_out, *)"Activating perturbation over perturbations:" 4659 write(std_out, *)"nprocs_pert: ", self%nprocs_pert 4660 write(std_out, *)"my_pinfo: ",self%my_pinfo 4661 write(std_out, *)"pert_table: ",self%pert_table 4662 end if 4663 4664 end subroutine dvdb_set_pert_distrib
m_dvdb/dvdb_t [ Types ]
NAME
dvdb_t
FUNCTION
Database of DFPT results. The database contains `numv1` perturbations and the corresponding first order local potentials in real space on the FFT mesh. Note that one can have different FFT meshes for the different perturbations. Provides methods to Fourier interpolate the potentials including the treatment of long-range behaviour in the FT interpolation in polar semiconductors.
NOTES
natom, nspden, nspinor, and usepaw are global variables in the sense that it's not possible to add new entries to the database if these dimensions differ from the global ones.
SOURCE
198 type,public :: dvdb_t 199 200 integer :: fh 201 ! file handle 202 ! Fortran unit number if iomode==IO_MODE_FORTRAN 203 ! MPI file handler if iomode==IO_MODE_MPI 204 205 integer :: comm 206 ! Global MPI communicator used for IO. 207 208 integer :: comm_rpt = xmpi_comm_self 209 ! MPI communicator used to distributed R-points. 210 211 integer :: nprocs_rpt = 1 212 ! Number of cpus for parallelism over R-points. 213 214 integer :: me_rpt = 0 215 ! My rank in comm_rpt. 216 217 integer :: comm_pert = xmpi_comm_self 218 ! MPI communicator for parallelism over atomic perturbations. 219 220 integer :: nprocs_pert = 1 221 ! Number of cpus for parallelism over atomic perturbations. 222 223 integer :: me_pert = 0 224 ! My rank in comm over atomic perturbations. 225 226 integer :: my_npert 227 ! Number of atomic perturbations or phonon modes treated by this MPI rank 228 229 integer,allocatable :: my_pinfo(:,:) 230 ! my_pinfo(3, my_npert) 231 ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation. 232 ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation. 233 ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3 234 235 integer,allocatable :: pert_table(:,:) 236 ! pert_table(2, natom3) 237 ! pert_table(1, npert): rank of the processor treating this atomic perturbation. 238 ! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert. 239 240 integer :: version 241 ! File format version read from file. 242 243 integer :: iomode = IO_MODE_FORTRAN 244 ! Method used to access the DVDB file: 245 ! IO_MODE_FORTRAN for usual Fortran IO routines 246 ! IO_MODE_MPI if MPI/IO routines. 247 248 integer :: rw_mode = DVDB_NOMODE 249 ! (Read|Write) mode 250 251 integer :: current_fpos 252 ! The current position of the file pointer used for sequential access with Fortran-IO 253 254 integer :: numv1 255 ! Number of v1 potentials present in file. 256 257 integer :: nqpt 258 ! Number of q-points 259 260 integer :: natom 261 ! Number of atoms 262 263 integer :: natom3 264 ! 3 * natom 265 266 integer :: nspden 267 ! Number of spin density components 268 269 integer :: nsppol 270 ! Number of spin polarizations. 271 272 integer :: nspinor 273 ! Number of spinor components. 274 275 integer :: usepaw 276 ! 1 if PAW calculation, 0 otherwise 277 278 integer :: mpert 279 ! Maximum number of perturbations 280 281 integer :: my_nrpt = 0 282 ! Number of real space points used for Fourier interpolation treated by this MPI rank. 283 284 integer :: nrtot = 0 285 ! Total Number of real space points used for Fourier interpolation. 286 287 integer :: prtvol = 0 288 ! Verbosity level 289 290 integer :: brav = 1 291 ! Option for the sampling of the BZ (input variable, the same option is stored in ifc_t) 292 293 real(dp) :: qdamp = 0.1_dp 294 ! Exponential damping used in the Fourier transform of the long-range potentials 295 ! Use negative value to deactivate damping. 296 297 logical :: debug = .False. 298 ! Debug flag 299 300 logical :: has_dielt = .False. 301 ! True if the dielectric tensor is available. 302 303 logical :: has_zeff = .False. 304 ! True if Born effective charges are available. 305 306 logical :: has_quadrupoles = .False. 307 ! True if quadrupoles are available. 308 309 logical :: has_efield = .False. 310 ! True if electric field perturbations are available. 311 312 integer :: add_lr = 1 313 ! Flag defining the treatment of the long range component in the interpolation of the DFPT potentials. 314 ! 315 ! 0 --> No treatment 316 ! 1 --> Remove LR model when building W(R,r). Add it back after W(R,r) --> v(q) Fourier interpolation 317 ! This is the standard approach for polar materials. 318 ! -1 --> Remove LR model when building W(R,r). DO NOT reintroduce it after Fourier interpolation. 319 ! This procedure should be used for homopolar materials with (spurious) non-zero BECS 320 ! in order to remove the long range component from the DFPT potentials. 321 ! 2 --> Similar to 1 but include only the dipole part. Q* are set to zero even if the DDB file contains them. 322 ! 4,5,6,7 --> Use model for the LR part only. 323 ! 4: Use dipole + quadrupole part (if available) 324 ! 5: Use dipole part only. 325 ! 6: Use quadrupole part only. 326 ! 7: Use electric field only. 327 328 integer :: symv1 = 0 329 ! Flag for the symmetrization of v1 potentials. 330 ! 0 --> No symmetrization 331 ! 1 --> Symmetrization in real space 332 ! 2 --> Call v1phq_complete after interpolation of the potentials in ftinterp_qpt 333 334 integer :: rspace_cell = 0 335 ! Flag defining the algorithm for generating the list of R-points and the weigths used to go from W(r,R) to v1scf(r,q) 336 ! 0 --> Use unit supercell for R space. All weights set to 1. 337 ! 1 --> Use Wigner-Seitz super cell and atom dependent weights (same algo as for dynmat) 338 339 type(qcache_t) :: qcache 340 ! Cache used to store potentials if Fourier interpolation is not used 341 ! (see dvdb_readsym_qbz for the implementation) 342 343 type(qcache_t) :: ft_qcache 344 ! Cache used to store potentials if Fourier interpolation is used 345 ! (see dvdb_get_ftqbz for the implementation) 346 347 character(len=fnlen) :: path = ABI_NOFILE 348 ! File name of the DVDB file. 349 350 real(dp) :: dielt(3, 3) = zero 351 ! Dielectric tensor in Cartesian coordinates. 352 ! Used to deal with the long-range component in the Fourier interpolation. 353 354 integer,allocatable :: pos_dpq(:,:,:) 355 ! pos_dpq(3, mpert, nqpt) 356 ! The position of the (idir, ipert, iqpt) potential in the file (in units of POT1 blocks) 357 ! 0 if the corresponding entry is not available. 358 359 integer,allocatable :: cplex_v1(:) 360 ! cplex_v1(numv1) 361 ! The value of cplex for each v1(cplex*nfft, nspden) potential 362 ! 2 if the potential is complex, 1 if real (q==Gamma) 363 364 integer,allocatable :: symq_table(:,:,:,:) 365 ! symq(4,2,nsym,nqpt) 366 ! Table computed by littlegroup_q for all q-points found in the DVDB. 367 ! three first numbers define the G vector; 368 ! fourth number is zero if the q-vector is not preserved, is 1 otherwise 369 ! second index is one without time-reversal symmetry, two with time-reversal symmetry 370 371 integer :: ngfft(18) = -1 372 ! Info on the FFT to be used for the potentials. 373 374 integer,allocatable :: iv_pinfoq(:,:) 375 !iv_pinfoq(4, numv1) 376 ! iv_pinfoq(1, iv1) gives the `idir` index of the iv1 potential 377 ! iv_pinfoq(2, iv1) gives the `ipert` index of the iv1 potential 378 ! iv_pinfoq(3, iv1) gives `pertcase`=idir + (ipert-1)*3 379 ! iv_pinfoq(4, iv1) gives the `iqpt` index of the iv1 potential 380 381 integer,allocatable :: ngfft3_v1(:,:) 382 ! ngfft3_v1(3, numv1) 383 ! The FFT mesh used for each v1 potential (the one used to store data in the file). 384 385 integer,allocatable :: my_irpt2tot(:) 386 ! Mapping my_irpt index to full list of R-points. 387 388 real(dp),allocatable :: qpts(:,:) 389 ! qpts(3,nqpt) 390 ! List of q-points in reduced coordinates. 391 392 real(dp),allocatable :: my_rpt(:,:) 393 ! my_rpt(3, my_nrpt) 394 ! Real space points for Fourier interpolation (MPI distributed if nprocs_rpt > 1) 395 396 real(kind=sp),allocatable :: wsr(:,:,:,:,:) 397 ! DFPT potential in the real space supercell representation. 398 ! wsr(1, my_nrpt, nfft, nspden, my_npert) 399 ! NOTE kind=sp to save memory as much as possible. 400 401 real(dp),allocatable :: my_wratm(:,:) 402 ! my_wratm(my_nrpt, minatom:maxatom) 403 ! Weight for the FT associated to the atom and the R vector. 404 405 real(dp),allocatable :: rhog1_g0(:,:) 406 ! rhog1_g0(2, numv1) 407 ! G=0 component of rhog1. Used to treat the long range component in (polar) semiconductors. 408 ! NB: For the time being, this quantity is not used. Long range term is treated with Verdi's model. 409 410 real(dp),allocatable :: zeff(:,:,:) 411 ! zeff(3, 3, natom) 412 ! Effective charges on each atom, versus electric field and atomic displacement in Cartesian coordinates. 413 ! Used to deal with the long-range componenent in the Fourier interpolation. 414 415 real(dp),allocatable :: zeff_raw(:,:,:) 416 ! Raw Effective charges i.e. values before enforcing the charge-neutrality condition. 417 418 real(dp),allocatable :: qstar(:,:,:,:) 419 ! qstar(3, 3, 3, natom) 420 ! dynamical quadrupole in Cartesian coordinates. 421 ! First two dimension are associated to the q-point, then atomic perturbation in Cart coords. 422 423 real(dp),allocatable :: v1r_efield(:,:,:) 424 ! v1r_efield(nfft, 3, nspden) 425 ! First order potentials due to the three different directions of the electric field perturbation. 426 ! Potentials are in r-space 427 428 type(crystal_t) :: cryst 429 ! Crystalline structure read from the the DVDB file. 430 431 type(hdr_type) :: hdr_ref 432 ! Header associated to the first potential in the DVDB. Used to backspace. 433 ! Gives the number of Fortran records required to backspace the header 434 ! Assume headers with same headform and same basic dimensions e.g. npsp 435 436 type(mpi_type) :: mpi_enreg 437 ! Internal object used to call fourdp 438 439 contains 440 441 procedure :: open_read => dvdb_open_read 442 ! Open the file in read-only mode. 443 444 procedure :: close => dvdb_close 445 ! Close the DVDB file. 446 447 procedure :: free => dvdb_free 448 ! Release the memory allocated and close the file. 449 450 procedure :: print => dvdb_print 451 ! Print info on object. 452 453 procedure :: findq => dvdb_findq 454 ! Returns the index of the q-point. 455 456 procedure :: find_qpts => dvdb_find_qpts 457 ! Returns the index of a list of q-points. 458 459 procedure :: set_pert_distrib => dvdb_set_pert_distrib 460 461 procedure :: read_onev1 => dvdb_read_onev1 462 ! Read and return the DFPT potential for given (idir, ipert, iqpt). 463 464 procedure :: readsym_allv1 => dvdb_readsym_allv1 465 ! Read and return all the 3*natom DFPT potentials (either from file or symmetrized) 466 467 procedure :: readsym_qbz => dvdb_readsym_qbz 468 ! Reconstruct the DFPT potential for a q-point in the BZ starting 469 ! from its symmetrical image in the IBZ. 470 471 procedure :: qcache_read => dvdb_qcache_read 472 ! Allocate internal cache for potentials. 473 ! Read potentials from DVDB file and store them in cache (COLLECTIVE routine) 474 475 procedure :: qcache_update_from_file => dvdb_qcache_update_from_file 476 ! Read selected potentials and update cache (COLLECTIVE routine) 477 478 procedure :: list_perts => dvdb_list_perts 479 ! Check if all the (phonon) perts are available taking into account symmetries. 480 481 procedure :: ftinterp_setup => dvdb_ftinterp_setup 482 ! Prepare the internal tables for Fourier interpolation. 483 484 procedure :: get_maxw => dvdb_get_maxw 485 ! Compute max_r |W(R,r)| 486 487 procedure :: ftinterp_qpt => dvdb_ftinterp_qpt 488 ! Fourier interpolation of potentials for given q-point 489 490 procedure :: get_ftqbz => dvdb_get_ftqbz 491 ! Retrieve Fourier interpolated potential for a given q-point in the BZ. 492 ! Use cache to reduce number of slow FTs. 493 494 procedure :: ftqcache_build => dvdb_ftqcache_build 495 ! This function initializes the internal q-cache from W(R,r) 496 497 procedure :: ftqcache_update_from_ft => dvdb_ftqcache_update_from_ft 498 ! This function initializes the internal q-cache from W(R,r) 499 500 procedure :: get_v1r_long_range => dvdb_get_v1r_long_range 501 ! Long-range part of the phonon potential 502 503 procedure :: load_ddb => dvdb_load_ddb 504 ! Load information about the Born effective charges and dielectric tensor from a DDB file 505 506 procedure :: interpolate_v1scf => dvdb_interpolate_v1scf 507 ! Fourier interpolation of the phonon potentials 508 509 procedure :: get_v1scf_rpt => dvdb_get_v1scf_rpt 510 ! Fourier transform of the phonon potential from qpt to R 511 512 procedure :: get_v1scf_qpt => dvdb_get_v1scf_qpt 513 ! Fourier transform of the phonon potential from R to qpt 514 515 procedure :: load_efield => dvdb_load_efield 516 517 procedure :: interpolate_and_write => dvdb_interpolate_and_write 518 ! Interpolate the phonon potentials and write a new DVDB file. 519 520 procedure :: qdownsample => dvdb_qdownsample 521 ! Downsample the q-mesh. Produce new DVDB file 522 523 procedure :: write_v1qavg => dvdb_write_v1qavg 524 ! Computes the average over the unit cell of the periodic part of the DFPT potentials 525 ! as a function of the q-point and the corresponding quantity obtained with the model for the LR part. 526 527 end type dvdb_t 528 529 public :: dvdb_new ! Create new object. 530 531 ! Utilities 532 public :: dvdb_merge_files ! Merge a list of POT1 files. 533 534 ! debugging tools. 535 public :: dvdb_test_v1rsym ! Check symmetries of the DFPT potentials. 536 public :: dvdb_test_v1complete ! Debugging tool used to test the symmetrization of the DFPT potentials. 537 538 public :: dvdb_test_ftinterp ! Test Fourier interpolation of DFPT potentials. 539 540 !---------------------------------------------------------------------- 541 542 !type, public star_t 543 ! integer :: npts 544 ! real(dp) :: weight 545 ! real(dp) :: ibz_point(3) 546 ! integer,allocatable :: pt2ibz_map(:,:) 547 ! ! (6, npts) 548 ! real(dp), allocatable :: points(:,:) 549 ! ! points(3, npts) 550 !end type kstars_t 551 552 !type, public stars_t 553 ! integer :: nstars 554 ! type(star_t),allocatable :: star(:) 555 ! ! star(nstars) 556 !end type stars_t 557 558 contains
m_dvdb/dvdb_test_ftinterp [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_test_ftinterp
FUNCTION
Debugging tool used to test the Fourier interpolation of the DFPT potentials.
INPUTS
dvdb_filepath=Filename
dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equat to ddb_ngqpt)
dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
qdamp=Defines exponential damping in LR potential
ddb_filepath=Path to DDB file. Used to treat LR part.
prtvol=Verbosity level.
coarse_ngqpt(3)= Coarse q-mesh used to analyze the accuracy of the FT interpolation
Must be divisor of dvdb_ngqpt. Use 0 to disable the test.
comm=MPI communicator.
OUTPUT
Only writing.
SOURCE
6040 subroutine dvdb_test_ftinterp(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, & 6041 ddb_filepath, prtvol, coarse_ngqpt, comm) 6042 6043 !Arguments ------------------------------------ 6044 character(len=*),intent(in) :: dvdb_filepath, ddb_filepath 6045 integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1 6046 real(dp),intent(in) :: dvdb_qdamp 6047 integer,intent(in) :: dvdb_ngqpt(3), coarse_ngqpt(3) 6048 6049 !Local variables------------------------------- 6050 !scalars 6051 integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1 6052 integer :: nfft, iq, cplex, mu, ispden, comm_rpt, iblock_dielt, iblock_dielt_zeff, my_rank, ierr 6053 logical :: autotest 6054 type(dvdb_t) :: dvdb, coarse_dvdb 6055 type(vdiff_t) :: vd_max 6056 type(ddb_type) :: ddb 6057 character(len=fnlen) :: coarse_fname 6058 !arrays 6059 integer :: ngfft(18) 6060 real(dp),allocatable :: file_v1r(:,:,:,:),intp_v1r(:,:,:,:),tmp_v1r(:,:,:,:) 6061 6062 ! ************************************************************************* 6063 6064 my_rank = xmpi_comm_rank(comm) 6065 6066 write(std_out,"(a)")sjoin(" Testing Fourier interpolation of V1(r) with ngqpt:", ltoa(dvdb_ngqpt)) 6067 if (len_trim(ddb_filepath) > 0) then 6068 write(std_out,"(a)")sjoin(" Reading Zeff and eps_inf from DDB file:", ddb_filepath) 6069 write(std_out,"(a)")sjoin(" dvdb_add_lr set to:", itoa(dvdb_add_lr)) 6070 end if 6071 6072 dvdb = dvdb_new(dvdb_filepath, comm) 6073 dvdb%debug = .False. 6074 ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1))) 6075 dvdb%symv1 = symv1 6076 dvdb%add_lr = dvdb_add_lr 6077 dvdb%qdamp = dvdb_qdamp 6078 dvdb%rspace_cell = rspace_cell 6079 6080 !call dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table) 6081 6082 iblock_dielt = 0; iblock_dielt_zeff = 0 6083 if (len_trim(ddb_filepath) > 0) then 6084 call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath) 6085 else 6086 dvdb%add_lr = 0 6087 ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero") 6088 end if 6089 6090 call dvdb%print() 6091 6092 ! Define FFT mesh for real space representation. 6093 call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1)) 6094 nfft = product(ngfft(1:3)) 6095 call dvdb%open_read(ngfft, comm) 6096 6097 ABI_MALLOC(intp_v1r, (2, nfft, dvdb%nspden, dvdb%natom3)) 6098 ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%natom3)) 6099 6100 ! Prepare FT interpolation. 6101 comm_rpt = xmpi_comm_self 6102 6103 autotest = .True. 6104 if (autotest) then 6105 call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt) 6106 6107 ! First step: Use FT interpolation to get q-points in the initial ab-initio mesh. 6108 ! We should get the same result... 6109 do iq=1,dvdb%nqpt 6110 ! Read data from DVDB file and store it in file_v1r 6111 call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm) 6112 6113 if (cplex == 1) then 6114 file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:) 6115 file_v1r(2,:,:,:) = zero 6116 else 6117 file_v1r = tmp_v1r 6118 end if 6119 ABI_FREE(tmp_v1r) 6120 6121 ! Interpolate data at the same q-point. 6122 call dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt) 6123 6124 write(std_out,"(a)")sjoin("=== For q-point:", ktoa(dvdb%qpts(:,iq)), "===") 6125 do mu=1,dvdb%natom3 6126 do ispden=1,dvdb%nspden 6127 write(std_out, "(a)")"--- !DVDB_SELF_DIFF" 6128 write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), "," 6129 write(std_out,"(a,i0,a)")" iqpt: ", iq, "," 6130 write(std_out,"(a,i0,a)")" iatom3: ", mu, "," 6131 write(std_out,"(a,i0,a)")" ispden: ", ispden, "," 6132 call vdiff_print(vdiff_eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), & 6133 dvdb%cryst%ucvol, vd_max=vd_max)) 6134 write(std_out,"(a)")"..." 6135 !do ifft=1,nfft 6136 ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),& 6137 ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu) 6138 !end do 6139 end do 6140 end do 6141 write(std_out,*)" " 6142 end do ! iq 6143 6144 write(std_out, "(/, a)")" Max values over q-points and perturbations" 6145 call vdiff_print(vd_max) 6146 ABI_FREE(dvdb%wsr) 6147 end if 6148 6149 ! Now downsample the q-mesh, build real-space representation with coarse q-mesh and 6150 ! compare with ab-intio values in the initial dvdb. 6151 if (all(coarse_ngqpt /= 0)) then 6152 write(std_out, "(/, 2a)")" Downsampling Q-mesh using coarse_ngqpt:", trim(ltoa(coarse_ngqpt)) 6153 6154 !Flang compiler complains with empty constructors (this bug should be corrected in future versions) 6155 #if defined FC_LLVM || defined FC_ARM || defined FC_NVHPC 6156 vd_max = vdiff_t(zero,zero,zero,zero,zero,zero) 6157 #else 6158 vd_max = vdiff_t() 6159 #endif 6160 6161 coarse_fname = strcat(dvdb_filepath, "_COARSE") 6162 call dvdb%qdownsample(coarse_fname, qptopt1, coarse_ngqpt, comm) 6163 6164 coarse_dvdb = dvdb_new(coarse_fname, comm) 6165 call coarse_dvdb%open_read(ngfft, comm) 6166 !call coarse_dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table) 6167 6168 coarse_dvdb%debug = dvdb%debug 6169 coarse_dvdb%symv1 = dvdb%symv1 6170 coarse_dvdb%add_lr = dvdb%add_lr 6171 coarse_dvdb%has_dielt = dvdb%has_dielt 6172 coarse_dvdb%has_zeff = dvdb%has_zeff 6173 coarse_dvdb%has_quadrupoles = dvdb%has_quadrupoles 6174 coarse_dvdb%has_efield = dvdb%has_efield 6175 coarse_dvdb%dielt = dvdb%dielt 6176 coarse_dvdb%zeff = dvdb%zeff 6177 coarse_dvdb%zeff_raw = dvdb%zeff_raw 6178 coarse_dvdb%qstar = dvdb%qstar 6179 coarse_dvdb%qdamp = dvdb%qdamp 6180 !call coarse_dvdb%print() 6181 6182 ! Prepare FT interpolation using coarse q-mesh. 6183 call coarse_dvdb%ftinterp_setup(coarse_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt) 6184 6185 do iq=1,dvdb%nqpt 6186 ! Read data from DVDB file and store it in file_v1r 6187 call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm) 6188 6189 if (cplex == 1) then 6190 file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:) 6191 file_v1r(2,:,:,:) = zero 6192 else 6193 file_v1r = tmp_v1r 6194 end if 6195 ABI_FREE(tmp_v1r) 6196 6197 ! Interpolate data at the same q-point using the coarse Q-mesh 6198 call coarse_dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt) 6199 6200 write(std_out,"(a)")sjoin("=== For COARSE q-point:", ktoa(dvdb%qpts(:,iq)), "===") 6201 do mu=1,dvdb%natom3 6202 do ispden=1,dvdb%nspden 6203 write(std_out, "(a)")"--- !DVDB_COARSE_DIFF" 6204 write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), "," 6205 write(std_out,"(a,i0,a)")" iqpt: ", iq, "," 6206 write(std_out,"(a,i0,a)")" iatom3: ", mu, "," 6207 write(std_out,"(a,i0,a)")" ispden: ", ispden, "," 6208 call vdiff_print(vdiff_eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), & 6209 dvdb%cryst%ucvol, vd_max=vd_max)) 6210 write(std_out,"(a)")"..." 6211 !do ifft=1,nfft 6212 ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),& 6213 ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu) 6214 !end do 6215 end do 6216 end do 6217 write(std_out,*)" " 6218 end do ! iq 6219 6220 write(std_out, "(/, a)")" COARSE DVDB: Max values over q-points and perturbations" 6221 call vdiff_print(vd_max) 6222 call coarse_dvdb%free() 6223 if (my_rank == master) call delete_file(coarse_fname, ierr) 6224 end if 6225 6226 ABI_FREE(intp_v1r) 6227 ABI_FREE(file_v1r) 6228 6229 call dvdb%free() 6230 call ddb%free() 6231 6232 end subroutine dvdb_test_ftinterp
m_dvdb/dvdb_test_v1complete [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_test_v1complete
FUNCTION
Debugging tool used to test the symmetrization of the DFPT potentials. Assumes DVDB file containing all 3*natom perturbations (generated with nsym == 1 or other specialized variables e.g. prepgkk)
INPUTS
db_path=Filename of the DVDB file. symv1scf=1 to activate symmetrization of DFPT potentials. 0 ti disable it. dump_path=File used to dump potentials (empty string to disable output) comm=MPI communicator.
OUTPUT
Only writing.
SOURCE
5445 subroutine dvdb_test_v1complete(dvdb_filepath, symv1scf, dump_path, comm) 5446 5447 !Arguments ------------------------------------ 5448 character(len=*),intent(in) :: dvdb_filepath,dump_path 5449 integer,intent(in) :: symv1scf, comm 5450 5451 !Local variables------------------------------- 5452 !scalars 5453 integer,parameter :: master = 0 5454 integer :: iqpt,pcase,idir,ipert,cplex,nfft,ispden,timerev_q,ifft,unt,my_rank, ncid 5455 integer :: i1,i2,i3,n1,n2,n3,id1,id2,id3,cnt, npert_miss 5456 integer :: ncerr 5457 character(len=500) :: msg 5458 type(crystal_t),pointer :: cryst 5459 type(dvdb_t),target :: dvdb 5460 !arrays 5461 integer :: ngfft(18), rfdir(3) 5462 integer,allocatable :: pflag(:,:) 5463 real(dp) :: qpt(3) 5464 integer,allocatable :: pertsy(:,:),rfpert(:),symq(:,:,:) 5465 real(dp),allocatable :: file_v1scf(:,:,:,:),symm_v1scf(:,:,:,:), work2(:,:,:,:) 5466 5467 ! ************************************************************************* 5468 5469 my_rank = xmpi_comm_rank(comm) 5470 5471 dvdb = dvdb_new(dvdb_filepath, comm) 5472 dvdb%debug = .false. 5473 dvdb%symv1 = symv1scf 5474 call dvdb%print() 5475 call dvdb%list_perts([-1,-1,-1], npert_miss) 5476 5477 call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1)) 5478 nfft = product(ngfft(1:3)) 5479 call dvdb%open_read(ngfft, comm) 5480 5481 cryst => dvdb%cryst 5482 call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1)) 5483 nfft = product(ngfft(:3)) 5484 5485 n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3) 5486 id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2 5487 5488 ABI_MALLOC(pflag, (3, dvdb%natom)) 5489 5490 ! Initialize the list of perturbations rfpert and rdfir 5491 ! WARNING: Only phonon perturbations are considered for the time being. 5492 ABI_MALLOC(rfpert,(dvdb%mpert)) 5493 rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1 5494 ABI_MALLOC(symq, (4,2,cryst%nsym)) 5495 ABI_MALLOC(pertsy, (3,dvdb%mpert)) 5496 5497 unt = -1; ncid = nctk_noid 5498 if (len_trim(dump_path) /= 0 .and. my_rank == master) then 5499 write(std_out,"(a)")sjoin("Will write potentials to:", dump_path) 5500 if (endswith(dump_path, ".nc")) then 5501 NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self)) 5502 NCF_CHECK(dvdb%cryst%ncwrite(ncid)) 5503 ncerr = nctk_def_dims(ncid, [& 5504 nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), & 5505 nctkdim_t("natom3", cryst%natom * 3), nctkdim_t("mpert", dvdb%mpert), nctkdim_t("nqpt", dvdb%nqpt)], & 5506 defmode=.True.) 5507 NCF_CHECK(ncerr) 5508 NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "symv1scf"])) 5509 NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt"))) 5510 NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("origin_v1scf", "dp", "two, nfft, nspden, natom3, nqpt"))) 5511 NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("recons_v1scf", "dp", "two, nfft, nspden, natom3, nqpt"))) 5512 NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("pertsy_qpt", "int", "three, mpert, nqpt"))) 5513 NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three"))) 5514 NCF_CHECK(nctk_set_datamode(ncid)) 5515 ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: & 5516 "symv1scf"], [symv1scf]) 5517 NCF_CHECK(ncerr) 5518 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts)) 5519 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3))) 5520 else 5521 if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then 5522 ABI_ERROR(msg) 5523 end if 5524 end if 5525 end if 5526 5527 ABI_CALLOC(work2, (2, nfft, dvdb%nspden, dvdb%natom3)) 5528 5529 do iqpt=1,dvdb%nqpt 5530 qpt = dvdb%qpts(:,iqpt) 5531 ! Examine the symmetries of the q wavevector 5532 call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=dvdb%prtvol) 5533 5534 ! Determine the symmetrical perturbations. Meaning of pertsy: 5535 ! 0 for non-target perturbations 5536 ! 1 for basis perturbations 5537 ! -1 for perturbations that can be found from basis perturbations 5538 call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,& 5539 pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel) 5540 5541 ! Read all potentials (here I assume that all perturbations are available) 5542 call dvdb%readsym_allv1(iqpt, cplex, nfft, ngfft, file_v1scf, dvdb%comm) 5543 5544 ! Copy basis perturbations in symm_v1scf and set pflag 5545 ABI_MALLOC(symm_v1scf, (cplex, nfft, dvdb%nspden, dvdb%natom3)) 5546 symm_v1scf = huge(one); pflag = 0 5547 do pcase=1,3*dvdb%cryst%natom 5548 idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1 5549 if (pertsy(idir, ipert) == 1) then 5550 symm_v1scf(:,:,:,pcase) = file_v1scf(:,:,:,pcase) 5551 pflag(idir,ipert) = 1 5552 end if 5553 end do 5554 5555 ! Complete potentials 5556 call v1phq_complete(cryst,qpt,ngfft,cplex,nfft,dvdb%nspden,dvdb%nsppol,dvdb%mpi_enreg,dvdb%symv1,pflag,symm_v1scf) 5557 5558 if (ncid /= nctk_noid) then 5559 work2 = zero 5560 if (cplex == 1) work2(1,:,:,:) = file_v1scf(1,:,:,:) 5561 if (cplex == 2) work2 = file_v1scf 5562 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "origin_v1scf"), work2, start=[1,1,1,1,iqpt]) 5563 NCF_CHECK(ncerr) 5564 if (cplex == 1) work2(1,:,:,:) = symm_v1scf(1,:,:,:) 5565 if (cplex == 2) work2 = symm_v1scf 5566 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "recons_v1scf"), work2, start=[1,1,1,1,iqpt]) 5567 NCF_CHECK(ncerr) 5568 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "pertsy_qpt"), pertsy, start=[1,1,iqpt])) 5569 end if 5570 5571 ! Compare values. 5572 do pcase=1,3*cryst%natom 5573 idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1 5574 if (pflag(idir,ipert) /= 2) cycle 5575 cnt = cnt+1 5576 5577 do ispden=1,dvdb%nspden 5578 !write(std_out,"(5(a,i0),3a,es12.4)")"For cnt: ",cnt ,", iqpt: ", iqpt, ", idir: ", idir, & 5579 ! ", ipert: ", ipert, ", ispden: ", ispden, ", qpt: ", trim(ktoa(qpt)) ,", max_err: ", & 5580 ! maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase))) 5581 !write(std_out,"(a,es10.3)")" max(abs(f1-f2))", maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase))) 5582 call vdiff_print(vdiff_eval(cplex,nfft,file_v1scf(:,:,ispden,pcase),symm_v1scf(:,:,ispden,pcase),cryst%ucvol)) 5583 5584 ! Debug: write potentials to file. 5585 if (unt /= -1) then 5586 write(unt,*)"# count:", cnt 5587 write(unt,*)"# q-point:", trim(ktoa(qpt)), ", iqpt: ", trim(itoa(iqpt)) 5588 write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden 5589 write(unt,*)"# file_v1scf, symmetrized_v1scf, diff" 5590 if (cplex == 1) then 5591 do i3=1,n3 5592 do i2=1,n2 5593 do i1=1,n1 5594 ifft = i1+n1*((i2-1)+n2*(i3-1)) 5595 write(unt,"(3i3,3(es12.4,2x))") & 5596 i1,i2,i3, & 5597 file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), & 5598 file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase) 5599 end do 5600 end do 5601 end do 5602 else 5603 do i3=1,n3 5604 do i2=1,n2 5605 do i1=1,n1 5606 ifft = i1+n1*((i2-1)+n2*(i3-1)) 5607 write(unt, "(3i3,6(es12.4,2x))") & 5608 i1,i2,i3, & 5609 file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), & 5610 file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase), & 5611 file_v1scf(2,ifft,ispden,pcase), symm_v1scf(2,ifft,ispden,pcase), & 5612 file_v1scf(2,ifft,ispden,pcase) - symm_v1scf(2,ifft,ispden,pcase) 5613 end do 5614 end do 5615 end do 5616 end if 5617 write(unt,*) 5618 write(unt,*) 5619 end if 5620 5621 end do 5622 !write(std_out,*)"" 5623 end do 5624 5625 ABI_FREE(symm_v1scf) 5626 ABI_FREE(file_v1scf) 5627 end do 5628 5629 ABI_FREE(work2) 5630 ABI_FREE(pflag) 5631 ABI_FREE(rfpert) 5632 ABI_FREE(symq) 5633 ABI_FREE(pertsy) 5634 5635 call dvdb%free() 5636 5637 if (unt /= -1) close(unt) 5638 if (ncid /= nctk_noid) then 5639 NCF_CHECK(nf90_close(ncid)) 5640 end if 5641 5642 end subroutine dvdb_test_v1complete
m_dvdb/dvdb_test_v1rsym [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_test_v1rsym
FUNCTION
Debugging tool used to check whether the DFPT potentials in real space fulfill the correct symmetries on the real space FFT mesh.
INPUTS
db_path=Filename symv1scf=1 to activate symmetrization of DFPT potentials. 0 to disable it. comm=MPI communicator.
OUTPUT
Only writing.
SOURCE
5310 subroutine dvdb_test_v1rsym(db_path, symv1scf, comm) 5311 5312 !Arguments ------------------------------------ 5313 character(len=*),intent(in) :: db_path 5314 integer,intent(in) :: symv1scf, comm 5315 5316 !Local variables------------------------------- 5317 !scalars 5318 integer,parameter :: rfmeth2=2,syuse0=0 5319 integer :: iqpt,idir,ipert,nsym1,cplex,v1pos 5320 integer :: isym,nfft,ifft,ifft_rot,ispden 5321 real(dp) :: max_err,re,im,vre,vim !,pre,pim 5322 character(len=500) :: msg 5323 logical :: isok 5324 type(dvdb_t),target :: db 5325 type(crystal_t),pointer :: cryst 5326 !arrays 5327 integer :: ngfft(18) 5328 integer,allocatable :: symafm1(:),symrel1(:,:,:),irottb(:,:) 5329 real(dp) :: qpt(3) 5330 real(dp),allocatable :: tnons1(:,:),v1scf(:,:) 5331 5332 ! ************************************************************************* 5333 5334 db = dvdb_new(db_path, comm) 5335 db%debug = .True. 5336 db%symv1 = symv1scf 5337 call db%print() 5338 !call db%list_perts([-1,-1,-1], npert_miss) 5339 5340 call ngfft_seq(ngfft, db%ngfft3_v1(:,1)) 5341 nfft = product(ngfft(1:3)) 5342 call db%open_read(ngfft, comm) 5343 5344 ABI_CHECK(db%nspinor==1, "nspinor == 2 not coded") 5345 5346 cryst => db%cryst 5347 ABI_MALLOC(symafm1, (cryst%nsym)) 5348 ABI_MALLOC(symrel1, (3,3,cryst%nsym)) 5349 ABI_MALLOC(tnons1, (3,cryst%nsym)) 5350 5351 do iqpt=1,db%nqpt 5352 qpt = db%qpts(:, iqpt) 5353 do ipert=1,db%natom 5354 do idir=1,3 5355 v1pos = db%pos_dpq(idir, ipert, iqpt); if (v1pos == 0) cycle 5356 5357 ! Determines the set of symmetries that leaves the perturbation invariant. 5358 call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,& 5359 cryst%symafm,symafm1,db%symq_table(:,:,:,iqpt),cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,& 5360 tnons1,unit=dev_null) 5361 5362 cplex = db%cplex_v1(v1pos) 5363 ngfft(1:3) = db%ngfft3_v1(:, v1pos) 5364 nfft = product(ngfft(:3)) 5365 ABI_MALLOC(v1scf, (cplex*nfft, db%nspden)) 5366 5367 if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) /= 0) then 5368 ABI_ERROR(msg) 5369 end if 5370 5371 ABI_MALLOC(irottb, (nfft,nsym1)) 5372 call rotate_fft_mesh(nsym1,symrel1,tnons1,ngfft,irottb,isok) 5373 if (.not. isok) then 5374 ABI_WARNING("Real space FFT mesh is not compatible with symmetries!") 5375 end if 5376 5377 max_err = zero 5378 do isym=1,nsym1 5379 do ispden=1,db%nspden 5380 do ifft=1,nfft 5381 ifft_rot = irottb(ifft, isym) 5382 !pre = cos(two_pi * dot_product(qpt, tnons1(:,isym))) 5383 !pim = -sin(two_pi * dot_product(qpt, tnons1(:,isym))) 5384 if (cplex == 2) then 5385 re = v1scf(2*ifft_rot-1, ispden) 5386 im = v1scf(2*ifft_rot , ispden) 5387 !vre = re * pre - im * pim 5388 !vim = re * pim + im * pre 5389 vre = re; vim = im 5390 5391 re = v1scf(2*ifft-1, ispden) - vre 5392 im = v1scf(2*ifft , ispden) - vim 5393 else 5394 re = v1scf(ifft, ispden) - v1scf(ifft_rot, ispden) 5395 im = zero 5396 end if 5397 !if (sqrt(re**2 + im**2) > tol6) write(std_out,*)"ifft,isym,err: ",ifft,isym,sqrt(re**2 + im**2) 5398 max_err = max(max_err, sqrt(re**2 + im**2)) 5399 end do 5400 end do 5401 end do 5402 if (nsym1>1) then 5403 write(std_out,"(3(a,i2),a,i2,a,es16.8)")"For iqpt= ",iqpt,& 5404 ", idir= ",idir,", ipert= ",ipert,", nsym= ",nsym1,", max_err= ",max_err 5405 end if 5406 5407 ABI_FREE(irottb) 5408 ABI_FREE(v1scf) 5409 end do 5410 end do 5411 5412 end do ! iqpt 5413 5414 ABI_FREE(symafm1) 5415 ABI_FREE(symrel1) 5416 ABI_FREE(tnons1) 5417 5418 call db%free() 5419 5420 end subroutine dvdb_test_v1rsym
m_dvdb/dvdb_write_v1qavg [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
dvdb_write_v1qavg
FUNCTION
Computes the average over the unit cell of the periodic part of the DFPT potentials
as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
Results are stored in the V1QAVG netcdf file. Two options are available:
eph_task = -15 --> Use list of q-points found in the DVDB file. Mainly used to plot the average
along a q-path. The procedure required to generate a DVDB with a q-path is rather lengthy
as it requires several phonon calculations with WKQ followed by a merge of the POT files.
eph_task = +15 --> Assume DVDB file with q-mesh (dvdb_ngqpt), use Fourier interpolation
to interpolate potentials along the path specified by ph_qpath and ph_nqpath.
INPUTS
dtset<dataset_type>= Input variables. out_ncpath=Filename for output netcdf file.
OUTPUT
Only writing.
SOURCE
5672 subroutine dvdb_write_v1qavg(dvdb, dtset, out_ncpath) 5673 5674 !Arguments ------------------------------------ 5675 class(dvdb_t),target,intent(inout) :: dvdb 5676 type(dataset_type),target,intent(in) :: dtset 5677 character(len=*),intent(in) :: out_ncpath 5678 5679 !Local variables------------------------------- 5680 !scalars 5681 integer,parameter :: master = 0 5682 integer :: nfft, iq, cplex, ispden, comm_rpt, my_rank, idir, ipert, ipc, imyp 5683 integer :: n1, n2, n3, unt, this_nqpt, interpolated 5684 integer :: i1, i2, i3, ifft, ig, ngsmall, ii, qptopt 5685 integer :: ncid, ncerr 5686 real(dp) :: gsq_max, g2 5687 !type(vdiff_t) :: vd_max 5688 logical :: write_v1r 5689 character(len=500) :: msg 5690 character(len=fnlen) :: dump_path 5691 !arrays 5692 integer :: ngfft(18), units(2) 5693 integer, allocatable :: gfft(:,:),ig2ifft(:), gsmall(:,:) 5694 real(dp) :: dvdb_qdamp(1) 5695 real(dp) :: vals2(2) 5696 real(dp),pointer :: this_qpts(:,:) 5697 real(dp),allocatable :: file_v1r(:,:,:,:),long_v1r(:,:,:,:),tmp_v1r(:,:,:,:) 5698 real(dp),allocatable :: maxw(:,:), all_rpt(:,:), all_rmod(:), workg(:,:), work_gsmall(:,:) 5699 5700 ! ************************************************************************* 5701 5702 my_rank = xmpi_comm_rank(dvdb%comm) 5703 units = [std_out, ab_out] 5704 5705 call wrtout(units, " Computing average over the unit cell of the periodic part of the DFPT potentials", newlines=2) 5706 call dvdb%print(unit=std_out) 5707 !call dvdb%print(unit=ab_out) 5708 5709 ! Define FFT mesh 5710 ngfft = dvdb%ngfft 5711 nfft = product(ngfft(1:3)) 5712 n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3) 5713 5714 ! Get list of G-vectors in FFT mesh. 5715 ABI_MALLOC(gfft, (3, nfft)) 5716 call get_gftt(ngfft, [zero, zero, zero], dvdb%cryst%gmet, gsq_max, gfft) 5717 ABI_MALLOC(workg, (2, nfft)) 5718 5719 ! Select G-vectors in small sphere (ratio of gsq_max) 5720 do ii=1,2 5721 if (ii == 2) then 5722 ABI_MALLOC(ig2ifft, (ngsmall)) 5723 end if 5724 ngsmall = 0 5725 do ig=1,nfft 5726 ! Don't include (2pi)**2 to be consistent with get_gftt 5727 g2 = dot_product(gfft(:,ig), matmul(dvdb%cryst%gmet, gfft(:, ig))) 5728 if (g2 <= gsq_max * 0.01_dp) ngsmall = ngsmall + 1 5729 if (ii == 2) ig2ifft(ngsmall) = ig 5730 end do 5731 end do 5732 write(std_out, *)"Found ngsmall", ngsmall 5733 5734 !call ig2fft_sphere(dvdb%cryst%gmet, gfft, ig2ifft) 5735 ABI_MALLOC(gsmall, (3, ngsmall)) 5736 do ig=1,ngsmall 5737 gsmall(:, ig) = gfft(:, ig2ifft(ig)) 5738 end do 5739 ABI_MALLOC(work_gsmall, (2, ngsmall)) 5740 5741 ABI_MALLOC(long_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert)) 5742 ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert)) 5743 5744 unt = -1; dump_path = "" 5745 !dump_path = "V1QAVG.dat" 5746 if (len_trim(dump_path) /= 0 .and. my_rank == master) then 5747 if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then 5748 ABI_ERROR(msg) 5749 end if 5750 write(std_out,"(a)")sjoin(" Will write potentials in text format to:", dump_path) 5751 end if 5752 5753 ! Select list of q-points depending on eph_task (either from DVDB file or interpolated) 5754 write_v1r = .False. 5755 if (dtset%eph_task == -15) then 5756 call wrtout(units, " Using list of q-points found in the DVDB file") 5757 this_nqpt = dvdb%nqpt 5758 this_qpts => dvdb%qpts 5759 interpolated = 0 5760 5761 else if (dtset%eph_task == +15) then 5762 msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints") 5763 call wrtout(units, msg) 5764 ABI_CHECK(dtset%ph_nqpath > 0, "When eph_task = +15, ph_qpath must be given in input.") 5765 this_nqpt = dtset%ph_nqpath 5766 this_qpts => dtset%ph_qpath(:, 1:this_nqpt) 5767 comm_rpt = xmpi_comm_self 5768 qptopt = dtset%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt 5769 call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfft, ngfft, comm_rpt) 5770 interpolated = 1 5771 write_v1r = dtset%prtpot > 0 5772 else 5773 ABI_ERROR(sjoin("Invalid value for eph_task:", itoa(dtset%eph_task))) 5774 end if 5775 5776 call wrtout(units, sjoin(ch10, "- Results stored in: ", out_ncpath)) 5777 call wrtout(units, " Use `abiopen.py out_V1QAVG.nc -e` to visualize results") 5778 5779 if (my_rank == master) then 5780 NCF_CHECK(nctk_open_create(ncid, out_ncpath, xmpi_comm_self)) 5781 NCF_CHECK(dvdb%cryst%ncwrite(ncid)) 5782 ncerr = nctk_def_dims(ncid, [ & 5783 nctkdim_t("nspden", dvdb%nspden), nctkdim_t("natom", dvdb%natom3 / 3), nctkdim_t("nqpt", this_nqpt), & 5784 nctkdim_t("natom3", dvdb%natom3), nctkdim_t("ngsmall", ngsmall)], defmode=.True.) 5785 NCF_CHECK(ncerr) 5786 5787 if (interpolated == 1) then 5788 ! Define arrays for Max_r |W(R, r)| 5789 NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nrpt", dvdb%nrtot), nctkdim_t("nfft", nfft)])) 5790 ncerr = nctk_def_arrays(ncid, [ & 5791 nctkarr_t("ngqpt", "int", "three"), nctkarr_t("rpt", "dp", "three, nrpt"), nctkarr_t("rmod", "dp", "nrpt"), & 5792 nctkarr_t("ngfft", "int", "three"), & 5793 nctkarr_t("maxw", "dp", "nrpt, natom3") & 5794 ]) 5795 NCF_CHECK(ncerr) 5796 end if 5797 5798 ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: & 5799 "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"]) 5800 NCF_CHECK(ncerr) 5801 ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: & 5802 "has_dielt", "has_zeff", "has_quadrupoles", "has_efield", "dvdb_add_lr"]) 5803 NCF_CHECK(ncerr) 5804 NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"])) 5805 ncerr = nctk_def_arrays(ncid, [ & 5806 nctkarr_t("v1scf_avg", "dp", "two, nspden, three, natom, nqpt"), & 5807 nctkarr_t("v1lr_avg", "dp", "two, nspden, three, natom, nqpt"), & 5808 nctkarr_t("v1scfmlr_avg", "dp", "two, nspden, three, natom, nqpt"), & 5809 nctkarr_t("v1scfmlr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), & 5810 nctkarr_t("v1scf_abs_avg", "dp", "two, nspden, three, natom, nqpt"), & 5811 nctkarr_t("v1lr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), & 5812 nctkarr_t("gsmall", "int", "three, ngsmall"), & 5813 nctkarr_t("v1scf_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), & 5814 nctkarr_t("v1lr_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), & 5815 nctkarr_t("qpoints", "dp", "three, nqpt") & 5816 ]) 5817 NCF_CHECK(ncerr) 5818 5819 if (write_v1r) then 5820 ncerr = nctk_def_arrays(ncid, [ & 5821 nctkarr_t("v1r_interpolated", "dp", "two, nfft, nspden, natom3"), & 5822 nctkarr_t("v1r_lrmodel", "dp", "two, nfft, nspden, natom3") & 5823 ]) 5824 NCF_CHECK(ncerr) 5825 end if 5826 5827 NCF_CHECK(nctk_set_datamode(ncid)) 5828 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpoints"), this_qpts)) 5829 ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: & 5830 "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"], & 5831 [dtset%symdynmat, dvdb%symv1, dtset%dvdb_add_lr, interpolated]) 5832 NCF_CHECK(ncerr) 5833 ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: & 5834 "has_dielt", "has_zeff", "has_quadrupoles", "has_efield"], & 5835 l2int([dvdb%has_dielt, dvdb%has_zeff, dvdb%has_quadrupoles, dvdb%has_efield])) 5836 NCF_CHECK(ncerr) 5837 dvdb_qdamp = dvdb%qdamp 5838 NCF_CHECK(nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"], dvdb_qdamp)) 5839 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "gsmall"), gsmall)) 5840 end if 5841 5842 do iq=1,this_nqpt 5843 5844 if (interpolated == 0) then 5845 call wrtout(std_out, sjoin(" Treating qpt:", ktoa(this_qpts(:,iq)))) 5846 5847 ! Read data from DVDB file, reconstruct all 3*natom perturbations in tmp_v1r. 5848 call dvdb%readsym_allv1(dvdb%findq(this_qpts(:, iq)), cplex, nfft, ngfft, tmp_v1r, xmpi_comm_self) 5849 5850 ! Transfer data to file_v1r taking into account my_npert 5851 do imyp=1,dvdb%my_npert 5852 ipc = dvdb%my_pinfo(3, imyp) 5853 if (cplex == 1) then 5854 file_v1r(1,:,:,imyp) = tmp_v1r(1,:,:,ipc) 5855 file_v1r(2,:,:,imyp) = zero 5856 else 5857 file_v1r(:,:,:,imyp) = tmp_v1r(:,:,:,ipc) 5858 end if 5859 end do 5860 ABI_FREE(tmp_v1r) 5861 5862 else 5863 ! Interpolate my_npert potentials for this q-point. 5864 call wrtout(std_out, sjoin(" Interpolating qpt:", ktoa(this_qpts(:,iq)))) 5865 call dvdb%ftinterp_qpt(this_qpts(:, iq), nfft, ngfft, file_v1r, comm_rpt) !, add_lr=?) 5866 cplex = 2 5867 end if 5868 5869 ! Compute the periodic part of the LR term (note add_qphase = 0 because we want the periodic part) 5870 do imyp=1,dvdb%my_npert 5871 idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp) 5872 do ispden=1,min(dvdb%nspden, 2) 5873 call dvdb%get_v1r_long_range(this_qpts(:,iq), idir, ipert, nfft, ngfft, long_v1r(:,:,ispden,imyp), add_qphase=0) 5874 end do 5875 end do 5876 5877 ! Compute average and write to file. 5878 if (my_rank /= master) cycle 5879 5880 if (write_v1r .and. iq == 1) then 5881 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_interpolated"), file_v1r)) 5882 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_lrmodel"), long_v1r)) 5883 end if 5884 5885 do imyp=1,dvdb%my_npert 5886 idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp) 5887 do ispden=1,dvdb%nspden 5888 5889 vals2 = sum(file_v1r(:,:,ispden,imyp), dim=2) / nfft 5890 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_avg"), vals2, & 5891 start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1]) 5892 NCF_CHECK(ncerr) 5893 5894 vals2 = sum(abs(file_v1r(:,:,ispden,imyp)), dim=2) / nfft 5895 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_abs_avg"), vals2, & 5896 start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1]) 5897 NCF_CHECK(ncerr) 5898 5899 vals2 = sum(long_v1r(:,:,ispden,imyp), dim=2) / nfft 5900 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_avg"), vals2, & 5901 start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1]) 5902 NCF_CHECK(ncerr) 5903 vals2 = sum(abs(long_v1r(:,:,ispden,imyp)), dim=2) / nfft 5904 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_abs_avg"), vals2, & 5905 start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1]) 5906 NCF_CHECK(ncerr) 5907 vals2 = sum(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp), dim=2) / nfft 5908 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_avg"), vals2, & 5909 start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1]) 5910 NCF_CHECK(ncerr) 5911 vals2 = sum(abs(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp)), dim=2) / nfft 5912 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_abs_avg"), vals2, & 5913 start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1]) 5914 NCF_CHECK(ncerr) 5915 5916 ! Compute G-components of DFPT potentials and LR model for G in small-sphere and save results to disk 5917 call fourdp(2, workg, file_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0) 5918 do ig=1,ngsmall 5919 work_gsmall(:, ig) = workg(:, ig2ifft(ig)) 5920 end do 5921 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_gsmall"), work_gsmall, & 5922 start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1]) 5923 NCF_CHECK(ncerr) 5924 5925 call fourdp(2, workg, long_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0) 5926 do ig=1,ngsmall 5927 work_gsmall(:, ig) = workg(:, ig2ifft(ig)) 5928 end do 5929 ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_gsmall"), work_gsmall, & 5930 start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1]) 5931 NCF_CHECK(ncerr) 5932 5933 ! Debugging section. 5934 !write(std_out, "(a)")"--- !DVDB_LONGRANGE_DIFF" 5935 !write(std_out,"(3a)")" qpoint: ", trim(ktoa(this_qpts(:,iq))), "," 5936 !write(std_out,"(a,i0,a)")" iq: ", iq, "," 5937 !write(std_out,"(2(a,i0))")" idir: ", idir, ", ipert:", ipert 5938 !write(std_out,"(a,i0,a)")" ispden: ", ispden, "," 5939 !call vdiff_print(vdiff_eval(2, nfft, file_v1r(:,:,ispden,imyp), long_v1r(:,:,ispden,imyp), & 5940 ! dvdb%cryst%ucvol, vd_max=vd_max)) 5941 !write(std_out,"(a)")"..." 5942 5943 ! Debug: write potentials to file. 5944 if (unt /= -1) then 5945 write(unt,*)"# q-point:", trim(ktoa(this_qpts(:,iq))), ", iq: ", trim(itoa(iq)) 5946 write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden 5947 write(unt,*)"# file_v1r, long_v1r, diff" 5948 5949 if (cplex == 1) then 5950 do i3=1,n3 5951 do i2=1,n2 5952 do i1=1,n1 5953 ifft = i1+n1*((i2-1)+n2*(i3-1)) 5954 write(unt,"(3(i0,1x),3(es12.4,2x))") & 5955 i1,i2,i3, & 5956 file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), & 5957 file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp) 5958 end do 5959 end do 5960 end do 5961 else 5962 do i3=1,n3 5963 do i2=1,n2 5964 do i1=1,n1 5965 ifft = i1+n1*((i2-1)+n2*(i3-1)) 5966 write(unt, "(3(i0,1x),6(es12.4,2x))") & 5967 i1,i2,i3, & 5968 file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), & 5969 file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp), & 5970 file_v1r(2,ifft,ispden,imyp), long_v1r(2,ifft,ispden,imyp), & 5971 file_v1r(2,ifft,ispden,imyp) - long_v1r(2,ifft,ispden,imyp) 5972 end do 5973 end do 5974 end do 5975 end if 5976 write(unt,*) 5977 write(unt,*) 5978 end if 5979 5980 end do 5981 end do 5982 !write(std_out,*)" " 5983 end do ! iq 5984 5985 ABI_FREE(long_v1r) 5986 ABI_FREE(file_v1r) 5987 ABI_FREE(workg) 5988 ABI_FREE(gfft) 5989 ABI_FREE(ig2ifft) 5990 ABI_FREE(gsmall) 5991 ABI_FREE(work_gsmall) 5992 5993 if (interpolated == 1) then 5994 ! Compute max_r |W(R,r)| and write data to file. 5995 call dvdb%get_maxw(dtset%ddb_ngqpt, all_rpt, all_rmod, maxw) 5996 if (my_rank == master) then 5997 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), dtset%ddb_ngqpt)) 5998 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rpt"), all_rpt)) 5999 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rmod"), all_rmod)) 6000 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3))) 6001 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "maxw"), maxw)) 6002 end if 6003 ABI_FREE(all_rpt) 6004 ABI_FREE(all_rmod) 6005 ABI_FREE(maxw) 6006 end if 6007 6008 if (my_rank == master) then 6009 NCF_CHECK(nf90_close(ncid)) 6010 end if 6011 6012 end subroutine dvdb_write_v1qavg
m_dvdb/find_symeq [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
find_symeq
FUNCTION
Find symmetry which links to the perturbation specified by (idir, ipert)
INPUTS
cryst<crystal_t>=crystal structure parameters idir=Direction of the perturbation ipert=Perturbation type. symq(4,2,nsym)=Table produced by littlegroup_q pflag(3,natom)= For each atomic perturbation: 0 if pert is not available. 1 if pert is available. 2 if pert can been reconstructed by symmetry.
OUTPUT
ipert_eq isym_eq itirev_eq g0_qpt(3)
SOURCE
2327 subroutine find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0) 2328 2329 !Arguments ------------------------------------ 2330 !scalars 2331 integer,intent(in) :: idir,ipert 2332 integer,intent(out) :: ipert_eq,isym_eq,itirev_eq 2333 type(crystal_t),intent(in) :: cryst 2334 logical,optional :: allow_g0 2335 !arrays 2336 integer,intent(in) :: symq(4,2,cryst%nsym),pflag(3,cryst%natom) 2337 integer,intent(out) :: g0_qpt(3) 2338 2339 !Local variables------------------------------- 2340 !scalars 2341 logical :: do_allow_g0 2342 integer :: isym,idir_eq,ip,itirev 2343 2344 ! ************************************************************************* 2345 2346 isym_eq = -1; ipert_eq = -1 2347 do_allow_g0 = .true.; if (present(allow_g0)) do_allow_g0 = allow_g0 2348 2349 symloop: & 2350 do itirev=1,2 2351 itirev_eq = itirev 2352 do isym=1,cryst%nsym 2353 2354 ! Check that isym preserves the q-point 2355 !if (symq(4,itirev,isym) /= 1 .or. any(symq(1:3,itirev,isym) /= 0)) cycle 2356 if (symq(4,itirev,isym) /= 1) cycle ! .or. any(symq(1:3,itirev,isym) /= 0)) cycle 2357 if (any(symq(1:3,itirev,isym) /= 0) .and. .not.do_allow_g0) cycle 2358 g0_qpt = symq(1:3,itirev,isym) 2359 2360 do ip=1,cryst%natom 2361 !if (.not. cryst%indsym(4,isym,ip) == ipert) cycle 2362 if (.not. cryst%indsym(4,isym,ipert) == ip) cycle 2363 isym_eq = isym; ipert_eq = ip 2364 do idir_eq=1,3 2365 if (idir_eq == idir .and. ip == ipert .and. cryst%symrec(idir,idir_eq,isym) /= 0) isym_eq = -1 2366 if (cryst%symrec(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then 2367 !if (cryst%symrel(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then 2368 !if (idir_eq == idir .and. ip == ipert) cycle 2369 isym_eq = -1 2370 end if 2371 end do 2372 if (isym_eq /= -1) exit symloop 2373 end do 2374 end do 2375 end do symloop 2376 2377 if (isym_eq == -1) then 2378 ipert_eq = -1; itirev_eq = -1 2379 end if 2380 2381 end subroutine find_symeq
m_dvdb/my_hdr_skip [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
my_hdr_skip
FUNCTION
Skip the header without rewinding the file. Return exit code.
NOTES
Because hdr_skip rewinds the file and I'm not gonna change that ugly code.
SOURCE
4815 integer function my_hdr_skip(unit, idir, ipert, qpt, msg) result(ierr) 4816 4817 !Arguments ------------------------------------ 4818 !scalars 4819 integer,intent(in) :: unit,idir,ipert 4820 real(dp),intent(in) :: qpt(3) 4821 character(len=500),intent(out) :: msg 4822 4823 !Local variables------------------------------- 4824 integer :: fform 4825 type(hdr_type) :: tmp_hdr 4826 !************************************************************************ 4827 4828 ierr = 0; msg = "" 4829 call hdr_fort_read(tmp_hdr, unit, fform) 4830 ierr = dvdb_check_fform(fform, "read_dvdb", msg) 4831 if (ierr /= 0) return 4832 4833 if (idir /= -1 .and. ipert /= -1) then 4834 if (idir /= mod(tmp_hdr%pertcase-1, 3) + 1 .or. & 4835 ipert /= (tmp_hdr%pertcase - idir) / 3 + 1 .or. & 4836 any(abs(qpt - tmp_hdr%qptn) > tol14)) then 4837 msg = "Perturbation index on file does not match the one expected by the caller" 4838 ierr = -1 4839 end if 4840 end if 4841 4842 call tmp_hdr%free() 4843 4844 end function my_hdr_skip
m_dvdb/prepare_ftinterp [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
prepare_ftinterp
FUNCTION
Internal helper function used to prepare the Fourier interpolation of the DFPT potentials.
m_dvdb/qcache_free [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
qcache_free
FUNCTION
Free dynamic memory.
SOURCE
1882 subroutine qcache_free(qcache) 1883 1884 !Arguments ------------------------------------ 1885 !scalars 1886 class(qcache_t),intent(inout) :: qcache 1887 1888 !Local variables------------------------------- 1889 !scalars 1890 integer :: iq, ierr 1891 1892 ! ************************************************************************* 1893 1894 if (allocated(qcache%key)) then 1895 do iq=1,size(qcache%key) 1896 ABI_SFREE(qcache%key(iq)%v1scf) 1897 end do 1898 ABI_SFREE(qcache%key) 1899 end if 1900 ABI_SFREE(qcache%count_qused) 1901 ABI_SFREE(qcache%itreatq) 1902 1903 if (qcache%v1scf_3natom_request /= xmpi_request_null) call xmpi_wait(qcache%v1scf_3natom_request, ierr) 1904 ABI_SFREE(qcache%v1scf_3natom_qibz) 1905 1906 end subroutine qcache_free
m_dvdb/qcache_get_mbsize [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
qcache_get_mbsize
FUNCTION
Return the (allocated) size of the cache in Mb.
SOURCE
1966 pure real(dp) function qcache_get_mbsize(qcache) result(mbsize) 1967 1968 !Arguments ------------------------------------ 1969 !scalars 1970 class(qcache_t),intent(in) :: qcache 1971 1972 !Local variables------------------------------- 1973 !scalars 1974 integer :: qcnt, iq 1975 1976 ! ************************************************************************* 1977 1978 mbsize = zero; if (.not. allocated(qcache%key)) return 1979 ! Compute cache size. 1980 qcnt = 0 1981 do iq=1,size(qcache%key) 1982 if (allocated(qcache%key(iq)%v1scf)) qcnt = qcnt + 1 1983 end do 1984 mbsize = qcache%onepot_mb * qcnt 1985 1986 end function qcache_get_mbsize
m_dvdb/qcache_new [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
qcache_new
FUNCTION
Initialize qcache_t object from dimensions.
INPUTS
nqpt=Number of q-points (dvdb%nqpt or nqibz depending on cache type)
nfft=Number of fft-points treated by this processors
ngfft(18)=contain all needed information about 3D FFT
mbsize: Cache size in megabytes.
< 0 to allocate all q-points.
0 has not effect.
> 0 for cache with automatically computed nqpt points.
natom3, my_npert=Total number of perturbations and number of perturbations treated by this CPU.
nspden=Number of spin density components.
OUTPUT
SOURCE
1631 type(qcache_t) function qcache_new(nqpt, nfft, ngfft, mbsize, natom3, my_npert, nspden) result(qcache) 1632 1633 !Arguments ------------------------------------ 1634 !scalars 1635 integer,intent(in) :: nqpt, nfft, natom3, nspden, my_npert 1636 real(dp),intent(in) :: mbsize 1637 !arrays 1638 integer,intent(in) :: ngfft(18) 1639 1640 ! ************************************************************************* 1641 1642 qcache%nqpt = nqpt 1643 ABI_ICALLOC(qcache%count_qused, (nqpt)) 1644 ABI_MALLOC(qcache%key, (nqpt)) 1645 ABI_MALLOC(qcache%itreatq, (nqpt)) 1646 qcache%itreatq = 1 1647 qcache%stats = 0 1648 qcache%max_mbsize = mbsize 1649 1650 qcache%onepot_mb = two * product(ngfft(1:3)) * nspden * QCACHE_KIND * b2Mb 1651 if (abs(mbsize) < tol3) then 1652 qcache%maxnq = 0 1653 else if (mbsize < zero) then 1654 qcache%maxnq = nqpt 1655 else 1656 qcache%maxnq = nint(mbsize / (qcache%onepot_mb * my_npert)) 1657 qcache%maxnq = max(min(qcache%maxnq, nqpt), 1) 1658 end if 1659 1660 ! TODO: Get rid of maxnq, keep use_3natom_cache only. 1661 1662 ! Allocate cache with all the 3*natom perturbations. 1663 ! Disable it if no parallelism over perturbations. 1664 ! Disabled as slow FT R --> q seems to be faster. 1665 qcache%use_3natom_cache = .False. 1666 !qcache%use_3natom_cache = .True. 1667 !if (my_npert == natom3) qcache%use_3natom_cache = .False. 1668 qcache%stored_iqibz_cplex = huge(1) 1669 if (qcache%use_3natom_cache) then 1670 ABI_MALLOC(qcache%v1scf_3natom_qibz, (2, nfft, nspden, natom3)) 1671 end if 1672 qcache%v1scf_3natom_request = xmpi_request_null 1673 1674 call wrtout(std_out, sjoin(" Using cache for Vscf(q) with MAX input size: ", ftoa(mbsize, fmt="f9.2"), " [Mb]")) 1675 call wrtout(std_out, sjoin(" Max number of q-points stored in memory: ", itoa(qcache%maxnq))) 1676 call wrtout(std_out, sjoin(" Use extra cache with 3 natom potentials: ", yesno(qcache%use_3natom_cache))) 1677 call wrtout(std_out, sjoin(" One DFPT potential requires: ", ftoa(qcache%onepot_mb, fmt="f9.2"), " [Mb]")) 1678 call wrtout(std_out, sjoin(" QCACHE_KIND: ", itoa(QCACHE_KIND))) 1679 1680 end function qcache_new
m_dvdb/qcache_qcache_make_room [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
qcache_qcache_make_room
FUNCTION
Deallocate entries in cache taking into account the list of q-points required in the next iteration. Deallocate entries only if the cache size required to treat all the points specified by ineed_qpt would become greater than %max_bsize Return ierr /= 0 and msg if max_bsize constraint cannot be respected.
INPUTS
ineed_qpt(%nqpt) = 0 if this q-points is not required. OUTPUTS msg=Warning message if ierr /= 0
SOURCE
2009 integer function qcache_make_room(qcache, ineed_qpt, msg) result(ierr) 2010 2011 !Arguments ------------------------------------ 2012 !scalars 2013 class(qcache_t),intent(inout) :: qcache 2014 character(len=*),intent(out) :: msg 2015 !arrays 2016 integer,intent(in) :: ineed_qpt(qcache%nqpt) 2017 2018 !Local variables------------------------------- 2019 !scalars 2020 integer :: iq, nq_remove, qcnt, count_qnew 2021 real(dp) :: mbsize_now, mbsize_extra 2022 2023 ! ************************************************************************* 2024 2025 ierr = 0; msg = "" 2026 if (qcache%max_mbsize < zero) return 2027 mbsize_now = qcache%get_mbsize() 2028 2029 ! Count the number of q-points that are not in cache and the extra memory required to allocate everything. 2030 count_qnew = 0 2031 do iq=1,qcache%nqpt 2032 if (ineed_qpt(iq) > 0 .and. .not. allocated(qcache%key(iq)%v1scf)) count_qnew = count_qnew + 1 2033 end do 2034 mbsize_extra = mbsize_now + count_qnew * qcache%onepot_mb 2035 2036 if (mbsize_extra > qcache%max_mbsize) then 2037 ! Try to deallocate nq_remove q-points provided they are not needed. 2038 nq_remove = nint((mbsize_extra - qcache%max_mbsize) / qcache%onepot_mb) 2039 qcnt = 0 2040 do iq=1,qcache%nqpt 2041 if (ineed_qpt(iq) == 0 .and. allocated(qcache%key(iq)%v1scf)) then 2042 ABI_FREE(qcache%key(iq)%v1scf) 2043 qcnt = qcnt + 1 2044 if (qcnt == nq_remove) exit 2045 end if 2046 end do 2047 if (iq == qcache%nqpt + 1) then 2048 ierr = 1 2049 msg = "Couldn't decrease cache size below input limit. Continuing anyway but we may go out of memory!" 2050 end if 2051 end if 2052 2053 end function qcache_make_room
m_dvdb/qcache_report_stats [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
qcache_report_stats
FUNCTION
Print info on q-cache states and reset counters.
SOURCE
1920 subroutine qcache_report_stats(qcache) 1921 1922 !Arguments ------------------------------------ 1923 !scalars 1924 class(qcache_t),intent(inout) :: qcache 1925 1926 ! ************************************************************************* 1927 1928 if (qcache%maxnq == 0) then 1929 !write(std_out, "(/,a)")" MPI-distributed q-cache deactivated as maxnq == 0" 1930 if (qcache%use_3natom_cache) then 1931 write(std_out, "(a,i0,2x,a,f5.1,a)") & 1932 " Cache hit in v1scf_3natom_qibz: ", qcache%stats(2), "(", (100.0_dp * qcache%stats(2)) / qcache%stats(1), "%)" 1933 end if 1934 1935 else if (qcache%maxnq > 0 .and. qcache%stats(1) /= 0) then 1936 write(std_out, "(2a)")ch10, " Qcache stats:" 1937 write(std_out, "(4x,a,i0)")" Total number of calls: ", qcache%stats(1) 1938 write(std_out, "(4x,a,i0,2x,a,f5.1,a)") & 1939 " Cache hit in v1scf_3natom_qibz: ", qcache%stats(2), "(", (100.0_dp * qcache%stats(2)) / qcache%stats(1), "%)" 1940 write(std_out, "(4x,a,i0,2x,a,f5.1,a)") & 1941 " Cache hit in MPI-distributed cache: ", qcache%stats(3), "(", (100.0_dp * qcache%stats(3)) / qcache%stats(1), "%)" 1942 write(std_out, "(4x,a,i0,2x,a,f5.1,a)") & 1943 " Cache miss: ", qcache%stats(4), "(", (100.0_dp * qcache%stats(4)) / qcache%stats(1), "%)" 1944 write(std_out, "(a)")sjoin(" Memory allocated for MPI cache: ", ftoa(qcache%get_mbsize(), fmt="f8.1"), " [Mb] <<< MEM") 1945 write(std_out, "(a)")sjoin(" max_mbsize:", ftoa(qcache%max_mbsize, fmt="f8.1"), & 1946 "(Decrease this value if calculation goes out of memory)") 1947 end if 1948 1949 write(std_out, "(a)") 1950 qcache%stats = 0 1951 1952 end subroutine qcache_report_stats
m_dvdb/qcache_t [ Types ]
NAME
qcache_t
FUNCTION
SOURCE
108 type, private :: qcache_t 109 110 integer :: maxnq = 0 111 ! Max number of q-points in Vscf(q) stored in the cache. 112 ! Note this is not the size of the key array that is dimensioned with 113 ! dvdb%nqpt or nqibz depending on the type of cache in use. 114 115 integer :: nqpt 116 ! Number of q-points in the key array 117 118 !integer :: nspden, my_npert, nfft 119 120 real(dp) :: max_mbsize = zero 121 ! Max cache size in megabytes. 122 ! < 0 to allocate all q-points. 123 ! 0 has not effect. 124 ! > 0 for cache with automatically computed nqpt points. 125 126 real(dp) :: onepot_mb = zero 127 ! Size of 1 DFPT potential in megabytes 128 129 logical :: use_3natom_cache = .False. 130 ! True if v1scf_3natom_qibz cache is used. 131 132 integer :: v1scf_3natom_request = xmpi_request_null 133 ! Reques for v1scf_3natom_qibz iallgather 134 135 integer :: stats(4) 136 ! Total number of calls, number of cache hit in v1scf_3natom_qibz cache, hit in key cache, cache misses. 137 138 integer,allocatable :: count_qused(:) 139 ! count_qused(nq) 140 ! Number of times this q-point has been used in dvdb_readsym_qbz 141 142 integer(i1b),allocatable :: itreatq(:) 143 ! itreatq(nq) 144 ! Table used to distribute q-points in the IBZ among procs. 145 ! 0 if this MPI rank should not store and treat this q-point. 146 ! 1 or 2-9 147 148 real(dp), allocatable :: v1scf_3natom_qibz(:,:,:,:) 149 ! v1scf_3natom(cplex, nfftf, nspden, 3*natom)) 150 ! Store all the 3*natom perturbations associated to `stored_iqibz_cplex` 151 ! Used to reduce the number of MPI communications required to collect all the potentials 152 ! on the MPI rank before computing V(Sq) from V(q). 153 ! IMPORTANT: This cache is beneficial provided client code loops over q-points grouped in stars/shells. 154 ! cplex value is stored in `stored_iqibz_cplex`. 155 156 integer :: stored_iqibz_cplex(2) = huge(1) 157 ! The index of the qpoint in the IBZ/DVDB file associated to v1scf_3natom_qibz. 158 159 type(qcache_entry_t), allocatable :: key(:) 160 ! key(nq) 161 ! array of v1scf potentials (ony a subset is usually allocated) 162 163 contains 164 165 procedure :: free => qcache_free 166 ! Release dynamic memory. 167 168 procedure :: report_stats => qcache_report_stats 169 ! Print info on q-cache stats and reset counters. 170 171 procedure :: get_mbsize => qcache_get_mbsize 172 ! Return the (allocated) size of the cache in Mb. 173 174 procedure :: make_room => qcache_make_room 175 176 end type qcache_t
m_dvdb/rotate_fqg [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
rotate_fqg
FUNCTION
INPUTS
SOURCE
2760 subroutine rotate_fqg(itirev, symm, qpt, tnon, ngfft, nfft, nspden, infg, outfg) 2761 2762 !Arguments ------------------------------------ 2763 !scalars 2764 integer,intent(in) :: itirev,nfft,nspden 2765 !arrays 2766 integer,intent(in) :: symm(3,3),ngfft(18) 2767 real(dp),intent(in) :: qpt(3),tnon(3) 2768 real(dp),intent(in) :: infg(2,nfft,nspden) 2769 real(dp),intent(out) :: outfg(2,nfft,nspden) 2770 2771 !Local variables------------------------------- 2772 !scalars 2773 integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot,isp,tsign 2774 real(dp) :: arg 2775 logical :: has_phase 2776 !arrays 2777 integer :: tsg(3) 2778 real(dp) :: phnon1(2), tsec(2) 2779 2780 ! ************************************************************************* 2781 2782 ! Keep track of total time spent. 2783 call timab(1803, 1, tsec) 2784 2785 n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3)) 2786 ABI_CHECK(nfftot == nfft, "FFT parallelism not supported") 2787 id1 = n1/2+2; id2 = n2/2+2; id3=n3/2+2 2788 2789 ABI_CHECK(any(itirev == [1, 2]), "Wrong itirev") 2790 tsign = 3-2*itirev; has_phase = any(abs(tnon) > tol12) 2791 2792 !outfg = zero 2793 2794 do isp=1,nspden 2795 ind1 = 0 2796 do i3=1,n3 2797 ! Get location of G vector (grid point) centered at 0 0 0 2798 l3 = i3-(i3/id3)*n3-1 2799 do i2=1,n2 2800 l2 = i2-(i2/id2)*n2-1 2801 do i1=1,n1 2802 ind1 = ind1 + 1 2803 !ind1 = 1 + i1 + (i2-1)*n1 + (i3-1)*n1*n2 2804 !if (mod(ind1, nprocs) /= my_rank) cycle 2805 2806 l1 = i1-(i1/id1)*n1-1 2807 2808 ! Get rotated G vector. IS(G) 2809 j1 = tsign * (symm(1,1)*l1+symm(1,2)*l2+symm(1,3)*l3) 2810 j2 = tsign * (symm(2,1)*l1+symm(2,2)*l2+symm(2,3)*l3) 2811 j3 = tsign * (symm(3,1)*l1+symm(3,2)*l2+symm(3,3)*l3) 2812 2813 ! FIXME :TO BE CLARIFIED: 2814 ! We are not working on the G-sphere thus SG may be outside 2815 ! of the box. This check is not done in irrzg!!! 2816 if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. & 2817 (j2 > n2/2 .or. j1 < -(n2-1)/2) .or. & 2818 (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then 2819 !write(std_out,*)"outsize box!" 2820 outfg(:,ind1,isp) = zero 2821 cycle 2822 end if 2823 2824 tsg = [j1,j2,j3] ! +- S^{-1} G 2825 2826 ! Map into [0,n-1] and then add 1 for array index in [1, n] 2827 k1=1+mod(n1+mod(j1,n1),n1) 2828 k2=1+mod(n2+mod(j2,n2),n2) 2829 k3=1+mod(n3+mod(j3,n3),n3) 2830 2831 ! Get linear index of rotated point Gj 2832 ind2 = k1+n1*((k2-1)+n2*(k3-1)) 2833 2834 ! TODO: Here I believe there are lots of cache misses, should perform low-level profiling 2835 ! OMP perhaps can accelerate this part but mind false sharing... 2836 if (has_phase) then 2837 ! compute exp(-2*Pi*I*G dot tau) using original G 2838 arg = two_pi * dot_product(qpt + tsg, tnon) 2839 phnon1(1) = cos(arg); phnon1(2) =-sin(arg) 2840 2841 ! rho(Strans*G)=exp(2*Pi*I*(G) dot tau_S) rho(G) 2842 outfg(1, ind1, isp) = phnon1(1) * infg(1, ind2, isp) - phnon1(2) * infg(2, ind2, isp) 2843 outfg(2, ind1, isp) = phnon1(1) * infg(2, ind2, isp) + phnon1(2) * infg(1, ind2, isp) 2844 else 2845 outfg(1, ind1, isp) = infg(1, ind2, isp) 2846 outfg(2, ind1, isp) = infg(2, ind2, isp) 2847 end if 2848 2849 ! Take complex conjugate if time-reversal is used. 2850 if (tsign == -1) outfg(2, ind1, isp) = -outfg(2, ind1, isp) 2851 end do 2852 end do 2853 end do 2854 end do ! isp 2855 2856 !call xmpi_sum(comm, outfg, ierr) 2857 call timab(1803, 2, tsec) 2858 2859 end subroutine rotate_fqg
m_dvdb/v1phq_complete [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
v1phq_complete
FUNCTION
Use the symmetries of the little group of the q-point to reconstruct the first order potentials starting from an initial irreducible set.
INPUTS
cryst<crystal_t>=crystal structure parameters qpt(3)=q-point in reduced coordinates. ngfft(18)=Info of FFT grid. cplex=1 if real potentials (qpt==gamma), 2 if complex nfft=(effective) number of FFT grid points (for this proc). nspden=number of spin-density components nsppol=Number of independent spin polarizations mpi_enreg=information about MPI parallelization symv1=If 1, the new potentials are symmetrized using the set of symmetries that leaves the perturbation invariant.
SIDE EFFECTS
pflag(3,natom)= For each atomic perturbation:
0 if pert is not available. 1 if pert is available. 2 if pert has been reconstructed by symmetry.
Initialized by the caller. Changed in output.
v1scf(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials.
in input: filled with the irreducible potentials (corresponding pflag set to 1)
output: Contains full set of perturbations.
SOURCE
2088 subroutine v1phq_complete(cryst,qpt,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,symv1,pflag,v1scf) 2089 2090 !Arguments ------------------------------------ 2091 !scalars 2092 integer,intent(in) :: cplex,nfft,nspden,nsppol 2093 integer,intent(in) :: symv1 2094 type(crystal_t),intent(in) :: cryst 2095 type(MPI_type),intent(in) :: mpi_enreg 2096 !arrays 2097 integer,intent(in) :: ngfft(18) 2098 integer,intent(inout) :: pflag(3, cryst%natom) 2099 real(dp),intent(in) :: qpt(3) 2100 real(dp),intent(inout) :: v1scf(cplex*nfft,nspden,3*cryst%natom) 2101 2102 !Local variables------------------------------- 2103 !scalars 2104 integer,parameter :: syuse0=0,rfmeth2=2,tim_fourdp0=0 2105 integer :: idir,ipert,tsign,isym_eq,itirev_eq,ipert_eq !,itirev 2106 integer :: pcase,trev_q,idir_eq,pcase_eq,ispden,cnt 2107 integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot 2108 real(dp) :: arg 2109 logical :: has_phase 2110 logical,parameter :: debug=.False. 2111 character(len=500) :: msg 2112 !integer,save :: enough=0 2113 !arrays 2114 integer :: symrel_eq(3,3),symrec_eq(3,3),g0_qpt(3),l0(3),tsm1g(3) !symm(3,3), 2115 integer :: symq(4,2,cryst%nsym) 2116 real(dp) :: phnon1(2),tnon(3) 2117 real(dp),allocatable :: workg(:,:), workg_eq(:,:),v1g(:,:,:) 2118 2119 ! ************************************************************************* 2120 2121 n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3)) 2122 ABI_CHECK(nfftot == nfft, "FFT parallelism not supported") 2123 id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2 2124 2125 ABI_MALLOC(v1g, (2,nfft,nspden)) 2126 ABI_MALLOC(workg_eq, (2, nfft)) 2127 ABI_MALLOC(workg, (2, nfft)) 2128 2129 ! Examine the symmetries of the q wavevector 2130 call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0) 2131 2132 pcase_loop: & 2133 do pcase=1,3*cryst%natom 2134 idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1 2135 if (pflag(idir, ipert) /= 0) cycle ! This pcase is available 2136 2137 ! Find symmetry which links to the perturbation requested (pcase) 2138 call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.) 2139 !if (isym_eq == -1) then 2140 ! call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.) 2141 !end if 2142 2143 if (isym_eq == -1) then 2144 if (debug) write(std_out,*)"Cannot find isym eq for idir, ipert:", idir,ipert 2145 cycle pcase_loop 2146 end if 2147 2148 ! set flag since we will reconstruct pcase from isym_eq. 2149 pflag(idir, ipert) = 2 2150 2151 symrel_eq = cryst%symrel(:,:,isym_eq) 2152 symrec_eq = cryst%symrec(:,:,isym_eq) 2153 tsign = 3-2*itirev_eq 2154 2155 ! Phase due to L0 + R^{-1}tau 2156 l0 = cryst%indsym(1:3,isym_eq,ipert) 2157 2158 tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym_eq)) 2159 has_phase = any(abs(tnon) > tol12) 2160 ! FIXME 2161 !ABI_CHECK(.not. has_phase, "has phase must be tested") 2162 !if (has_phase) then 2163 ! enough = enough + 1 2164 ! if (enough == 1) ABI_WARNING("has phase must be tested") 2165 !end if 2166 2167 workg = zero 2168 2169 ! Reconstruct DFPT potential. Final results stored in v1g. 2170 if (debug) write(std_out,*)"Reconstructing idir:", idir, ", ipert:", ipert 2171 v1g = zero; cnt = 0 2172 do idir_eq=1,3 2173 if (symrec_eq(idir, idir_eq) == 0) cycle 2174 cnt = cnt + 1 2175 pcase_eq = idir_eq + (ipert_eq-1)*3 2176 if (debug) write(std_out,*) "idir_eq: ", idir_eq, ", ipert_eq: ", ipert_eq, ", tsign: ", tsign 2177 2178 if (pflag(idir_eq, ipert_eq) == 0) then 2179 write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero" 2180 ABI_ERROR(msg) 2181 end if 2182 2183 !if (pflag(idir_eq, ipert_eq) == 0) then 2184 ! write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero" 2185 ! ABI_ERROR(msg) 2186 !end if 2187 2188 do ispden=1,nspden 2189 ! Get symmetric perturbation in G-space in workg_eq array. 2190 call fourdp(cplex,workg_eq,v1scf(:,ispden,pcase_eq),-1,mpi_enreg,nfft,1,ngfft,tim_fourdp0) 2191 !call zerosym(workg_eq,cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft) 2192 2193 !call rotate_fqg(itirev_eq,symrec_eq,qpt,tnon,ngfft,nfft,nspden,workg_eq,workg) 2194 ind1=0 2195 do i3=1,n3 2196 ! Get location of G vector (grid point) centered at 0 0 0 2197 l3 = i3-(i3/id3)*n3-1 2198 do i2=1,n2 2199 l2 = i2-(i2/id2)*n2-1 2200 do i1=1,n1 2201 ind1=ind1+1 2202 2203 l1 = i1-(i1/id1)*n1-1 2204 2205 ! Get rotated G vector Gj for each symmetry element 2206 ! -- here we use the TRANSPOSE of symrel_eq; assuming symrel_eq expresses 2207 ! the rotation in real space, the transpose is then appropriate 2208 ! for G space symmetrization (p. 1172d,e of notes, 2 June 1995). 2209 j1 = tsign * (symrel_eq(1,1)*l1+symrel_eq(2,1)*l2+symrel_eq(3,1)*l3) 2210 j2 = tsign * (symrel_eq(1,2)*l1+symrel_eq(2,2)*l2+symrel_eq(3,2)*l3) 2211 j3 = tsign * (symrel_eq(1,3)*l1+symrel_eq(2,3)*l2+symrel_eq(3,3)*l3) 2212 2213 ! FIXME :TO BE CLARIFIED: 2214 ! We are not working on the G-sphere thus SG may be outside 2215 ! of the box. This check is not done in irrzg!!! 2216 if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. & 2217 (j2 > n2/2 .or. j1 < -(n2-1)/2) .or. & 2218 (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then 2219 !write(std_out,*)"got it" 2220 workg(:, ind1) = zero; cycle 2221 end if 2222 2223 tsm1g = [j1,j2,j3] ! +- S^{-1} G 2224 2225 ! Map into [0,n-1] and then add 1 for array index in [1,n] 2226 k1=1+mod(n1+mod(j1,n1),n1) 2227 k2=1+mod(n2+mod(j2,n2),n2) 2228 k3=1+mod(n3+mod(j3,n3),n3) 2229 2230 ! Get linear index of rotated point Gj 2231 ind2 = k1+n1*((k2-1)+n2*(k3-1)) 2232 2233 if (has_phase) then 2234 ! compute exp(-2*Pi*I*G dot tau) using original G 2235 ! NB: this phase is same as that in irrzg and phnons1, and corresponds 2236 ! to complex conjugate of phase from G to Gj; 2237 ! we use it immediately below, to go _to_ workg_eq(ind1) 2238 arg = two_pi * dot_product(qpt + tsm1g, tnon) 2239 phnon1(1) = cos(arg); phnon1(2) = -sin(arg) 2240 2241 ! rho(Strans*G)=exp(2*Pi*I*(G) dot tau_S) rho(G) 2242 workg(1, ind1) = phnon1(1) * workg_eq(1, ind2) - phnon1(2) * workg_eq(2, ind2) 2243 workg(2, ind1) = phnon1(1) * workg_eq(2, ind2) + phnon1(2) * workg_eq(1, ind2) 2244 else 2245 workg(1, ind1) = workg_eq(1, ind2) 2246 workg(2, ind1) = workg_eq(2, ind2) 2247 end if 2248 2249 ! Take complex conjugate if time-reversal is used. 2250 if (tsign == -1) workg(2, ind1) = -workg(2, ind1) 2251 end do 2252 end do 2253 end do 2254 2255 v1g(:,:,ispden) = v1g(:,:,ispden) + workg * symrec_eq(idir, idir_eq) 2256 end do ! ispden 2257 end do ! idir_eq 2258 !if (debug) write(std_out,*)"Used ",cnt," equivalent perturbations" 2259 2260 ! Get potential in real space (results in v1scf) 2261 do ispden=1,nspden 2262 !call zerosym(v1g(:,:,ispden),cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft) 2263 call fourdp(cplex,v1g(:,:,ispden),v1scf(:,ispden,pcase),+1,mpi_enreg,nfft,1,ngfft,tim_fourdp0) 2264 2265 ! IS(q) = q + G0 2266 ! we want q so we have to multiply by exp(iG0r) in real space. 2267 if (any(g0_qpt /= 0)) then 2268 ABI_CHECK(cplex==2, "cplex == 1") 2269 if (debug) write(std_out,*)"Found not zero g0_qpt", g0_qpt ! for idir: ", idir, ", ipert: ", ipert 2270 call times_eigr(g0_qpt, ngfft, nfft, 1, v1scf(:,ispden,pcase)) 2271 end if 2272 end do 2273 2274 if (symv1 == 1) then 2275 if (debug) write(std_out,*)" Calling v1phq_symmetrize" 2276 call v1phq_symmetrize(cryst,idir,ipert,symq,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,v1scf(:,:,pcase)) 2277 end if 2278 end do pcase_loop 2279 2280 ABI_FREE(v1g) 2281 ABI_FREE(workg) 2282 ABI_FREE(workg_eq) 2283 2284 ! Handle possible error. 2285 if (any(pflag == 0)) then 2286 write(std_out,"(2a)")"The following perturbations cannot be recostructed by symmetry for q-point: ",trim(ktoa(qpt)) 2287 do ipert=1,cryst%natom 2288 do idir=1,3 2289 if (pflag(idir, ipert) == 0) write(std_out,"(2(a,i0))")"idir= ",idir,", ipert= ",ipert 2290 end do 2291 end do 2292 write(msg,"(5a)")& 2293 "Cannot recostruct all 3*natom atomic perturbations from file",ch10,& 2294 "This usually happens when the DVDB does not contain all the independent perturbations for this q-point",ch10,& 2295 "See above message for further information." 2296 ABI_ERROR(msg) 2297 end if 2298 2299 end subroutine v1phq_complete
m_dvdb/v1phq_rotate [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
v1phq_rotate
FUNCTION
Reconstruct all the DFPT potential for a q-point in the BZ starting from its symmetrical image in the IBZ.
INPUTS
cryst<crystal_t>=crystal structure parameters qpt_ibz(3)=q-point in the IBZ in reduced coordinates. ngfft=array of dimensions for different FFT grids isym, itimrev, g0q: qpt_bz = I(itimrev) S(isym) q_ibz + g0q ngfft(18)=contain all needed information about 3D FFT. cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90) nspden=number of spin-density components mpi_enreg=information about MPI parallelization v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the irreducible q-point `qpt_ibz` comm: MPI communicator to distribute natom3 * nspden FFT calls
OUTPUT
v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
SOURCE
2413 subroutine v1phq_rotate(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, & 2414 mpi_enreg, v1r_qibz, v1r_qbz, comm) 2415 2416 !Arguments ------------------------------------ 2417 !scalars 2418 integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, comm 2419 type(crystal_t),intent(in) :: cryst 2420 type(MPI_type),intent(in) :: mpi_enreg 2421 !arrays 2422 integer,intent(in) :: g0q(3),ngfft(18) 2423 real(dp),intent(in) :: qpt_ibz(3) 2424 real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom) 2425 real(dp) ABI_ASYNC, intent(out) :: v1r_qbz(cplex*nfft,nspden,3*cryst%natom) 2426 2427 !Local variables------------------------------- 2428 !scalars 2429 integer,parameter :: tim_fourdp0 = 0 2430 !integer,save :: enough = 0 2431 integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,my_rank,nproc,ierr,root 2432 !arrays 2433 integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3), 2434 real(dp) :: tnon(3), tsec(2) 2435 real(dp) ABI_ASYNC, allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:) 2436 integer :: requests(nspden, 3*cryst%natom), requests_v1r_qbz(3*cryst%natom) 2437 logical :: requests_v1g_qibz_done(nspden, 3*cryst%natom) 2438 2439 ! ************************************************************************* 2440 2441 ! Keep track of total time spent. 2442 call timab(1804, 1, tsec) 2443 2444 ABI_CHECK(cplex == 2, "cplex != 2") 2445 2446 nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm) 2447 natom3 = 3 * cryst%natom; tsign = 3-2*itimrev 2448 2449 ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G) 2450 ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3)) 2451 requests_v1g_qibz_done = .False. 2452 cnt = 0 2453 do mu=1,natom3 2454 do ispden=1,nspden 2455 cnt = cnt + 1; root = mod(cnt, nproc) 2456 if (root == my_rank) then ! Non-blocking 2457 call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0) 2458 end if 2459 call xmpi_ibcast(v1g_qibz(:,ispden,mu), root, comm, requests(ispden, mu), ierr) 2460 end do 2461 end do 2462 2463 ABI_MALLOC(workg, (2*nfft, nspden)) 2464 ABI_MALLOC(v1g_mu, (2*nfft, nspden)) 2465 2466 symrec_eq = cryst%symrec(:,:,isym) 2467 call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1) 2468 2469 ! For each perturbation. 2470 do mu=1,natom3 2471 root = mod(mu, nproc) 2472 ! MPI parallelism. 2473 if (root == my_rank) then 2474 idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1 2475 2476 ! Phase due to L0 + R^{-1}tau 2477 l0 = cryst%indsym(1:3,isym,ipert) 2478 tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym)) 2479 !if (.not. all(abs(tnon) < tol12)) then 2480 ! enough = enough + 1 2481 ! if (enough == 1) ABI_WARNING("tnon must be tested!") 2482 !end if 2483 2484 ipert_eq = cryst%indsym(4, isym, ipert) 2485 2486 v1g_mu = zero; cnt = 0 2487 do idir_eq=1,3 2488 if (symrec_eq(idir, idir_eq) == 0) cycle 2489 mu_eq = idir_eq + (ipert_eq - 1) * 3 2490 cnt = cnt + 1 2491 2492 ! Wait for request before operating on v1g_qibz 2493 if (.not. all(requests_v1g_qibz_done(:, mu_eq))) then 2494 do ispden=1,nspden 2495 call xmpi_wait(requests(ispden, mu_eq), ierr) 2496 requests_v1g_qibz_done(ispden, mu_eq) = .True. 2497 end do 2498 end if 2499 2500 ! Rotate in G-space and accumulate in workg 2501 call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg) 2502 v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq) 2503 end do ! idir_eq 2504 2505 ABI_CHECK(cnt /= 0, "cnt should not be zero!") 2506 2507 ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz. 2508 do ispden=1,nspden 2509 call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, mu), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0) 2510 call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, mu)) 2511 !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,mu)) 2512 end do 2513 2514 end if ! root == myrank 2515 2516 call xmpi_ibcast(v1r_qbz(:,:,mu), root, comm, requests_v1r_qbz(mu), ierr) 2517 end do ! mu 2518 2519 ! Relase all requests 2520 call xmpi_waitall(requests, ierr) 2521 call xmpi_waitall(requests_v1r_qbz, ierr) 2522 2523 ABI_FREE(workg) 2524 ABI_FREE(v1g_mu) 2525 ABI_FREE(v1g_qibz) 2526 2527 call timab(1804, 2, tsec) 2528 2529 end subroutine v1phq_rotate
m_dvdb/v1phq_rotate_myperts [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
v1phq_rotate_myperts
FUNCTION
Reconstruct all the DFPT potential for a q-point in the BZ starting from its symmetrical image in the IBZ.
INPUTS
cryst<crystal_t>=crystal structure parameters qpt_ibz(3)=q-point in the IBZ in reduced coordinates. ngfft=array of dimensions for different FFT grids isym, itimrev, g0q: qpt_bz = I(itimrev) S(isym) q_ibz + g0q ngfft(18)=contain all needed information about 3D FFT. cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90) nspden=number of spin-density components mpi_enreg=information about MPI parallelization v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the irreducible q-point `qpt_ibz`
OUTPUT
v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
SOURCE
2560 subroutine v1phq_rotate_myperts(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, & 2561 mpi_enreg, my_npert, my_pinfo, v1r_qibz, v1r_qbz) 2562 2563 !Arguments ------------------------------------ 2564 !scalars 2565 integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, my_npert 2566 type(crystal_t),intent(in) :: cryst 2567 type(MPI_type),intent(in) :: mpi_enreg 2568 !arrays 2569 integer,intent(in) :: g0q(3), ngfft(18), my_pinfo(3, my_npert) 2570 real(dp),intent(in) :: qpt_ibz(3) 2571 real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom) 2572 real(dp),intent(out) :: v1r_qbz(cplex*nfft,nspden,my_npert) 2573 2574 !Local variables------------------------------- 2575 !scalars 2576 integer,parameter :: tim_fourdp0 = 0 2577 !integer,save :: enough = 0 2578 integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,imyp !ierr, 2579 !arrays 2580 integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3), 2581 logical :: fourdp_done(3*cryst%natom) 2582 real(dp) :: tnon(3), tsec(2) 2583 real(dp), allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:) 2584 2585 ! ************************************************************************* 2586 2587 ! Keep track of total time spent. 2588 call timab(1804, 1, tsec) 2589 2590 ABI_CHECK(cplex == 2, "cplex != 2") 2591 2592 natom3 = 3 * cryst%natom; tsign = 3-2*itimrev 2593 2594 ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G) 2595 fourdp_done = .False. 2596 ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3)) 2597 !do mu=1,natom3 2598 ! do ispden=1,nspden 2599 ! call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0) 2600 ! end do 2601 !end do 2602 2603 ABI_MALLOC(workg, (2*nfft, nspden)) 2604 ABI_MALLOC(v1g_mu, (2*nfft, nspden)) 2605 2606 symrec_eq = cryst%symrec(:,:,isym) 2607 call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1) 2608 2609 ! For each perturbation treated by this MPI proc 2610 do imyp=1,my_npert 2611 idir = my_pinfo(1, imyp); ipert = my_pinfo(2, imyp); mu = my_pinfo(3, imyp) 2612 2613 ! Phase due to L0 + R^{-1}tau 2614 l0 = cryst%indsym(1:3,isym,ipert) 2615 tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym)) 2616 !if (.not. all(abs(tnon) < tol12)) then 2617 ! enough = enough + 1 2618 ! if (enough == 1) ABI_WARNING("tnon must be tested!") 2619 !end if 2620 2621 ipert_eq = cryst%indsym(4, isym, ipert) 2622 2623 v1g_mu = zero; cnt = 0 2624 do idir_eq=1,3 2625 if (symrec_eq(idir, idir_eq) == 0) cycle 2626 mu_eq = idir_eq + (ipert_eq - 1) * 3 2627 cnt = cnt + 1 2628 2629 if (.not. fourdp_done(mu_eq)) then 2630 do ispden=1,nspden 2631 call fourdp(cplex, v1g_qibz(:,ispden,mu_eq), v1r_qibz(:,ispden,mu_eq), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0) 2632 end do 2633 fourdp_done(mu_eq) = .True. 2634 end if 2635 2636 ! Rotate in G-space and accumulate in workg 2637 call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg) 2638 v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq) 2639 end do ! idir_eq 2640 2641 ABI_CHECK(cnt /= 0, "cnt should not be zero!") 2642 2643 ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz. 2644 do ispden=1,nspden 2645 call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, imyp), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0) 2646 call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, imyp)) 2647 !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,imyp)) 2648 end do 2649 2650 end do ! imyp 2651 2652 ABI_FREE(workg) 2653 ABI_FREE(v1g_mu) 2654 ABI_FREE(v1g_qibz) 2655 2656 call timab(1804, 2, tsec) 2657 2658 end subroutine v1phq_rotate_myperts
m_dvdb/v1phq_symmetrize [ Functions ]
[ Top ] [ m_dvdb ] [ Functions ]
NAME
v1phq_symmetrize
FUNCTION
Enforce spatial-symmetry on the DFPT potential.
INPUTS
cryst<crystal_t>=crystal structure parameters idir=Direction of the perturbation ipert=Perturbation type. symq(4,2,nsym)= Table computed by littlegroup_q. three first numbers define the G vector; fourth number is zero if the q-vector is not preserved, is 1 otherwise second index is one without time-reversal symmetry, two with time-reversal symmetry ngfft=array of dimensions for different FFT grids cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90) nspden=number of spin-density components mpi_enreg=information about MPI parallelization
SIDE EFFECTS
v1r(cplex*nfft,nspden)=Array with first order potentials in real space. Symmetrized in output.
SOURCE
2687 subroutine v1phq_symmetrize(cryst, idir, ipert, symq, ngfft, cplex, nfft, nspden, nsppol ,mpi_enreg, v1r) 2688 2689 !Arguments ------------------------------------ 2690 !scalars 2691 integer,intent(in) :: idir, ipert, cplex, nfft, nspden, nsppol 2692 type(crystal_t),intent(in) :: cryst 2693 type(MPI_type),intent(in) :: mpi_enreg 2694 !arrays 2695 integer,intent(in) :: symq(4,2,cryst%nsym),ngfft(18) 2696 real(dp),intent(inout) :: v1r(cplex*nfft,nspden) 2697 2698 !Local variables------------------------------- 2699 integer,parameter :: syuse0 = 0, rfmeth2 = 2, iscf1 = 1 2700 integer :: nsym1, nfftot 2701 !arrays 2702 integer :: symafm1(cryst%nsym),symrel1(3,3,cryst%nsym),symrc1(3,3,cryst%nsym) 2703 integer,allocatable :: irrzon1(:,:,:),indsy1(:,:,:) 2704 real(dp) :: tnons1(3,cryst%nsym) 2705 real(dp),allocatable :: phnons1(:,:,:),v1g(:,:) 2706 2707 ! ************************************************************************* 2708 2709 if (cryst%nsym == 1) return 2710 2711 nfftot = product(ngfft(1:3)) 2712 ABI_CHECK(nfft == nfftot, "MPI-FFT not coded") 2713 2714 ! Symmetrize (copied from dfpt_looppert) 2715 ! Determines the set of symmetries that leaves the perturbation invariant. 2716 call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,& 2717 cryst%symafm,symafm1,symq,cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,tnons1,unit=dev_null) 2718 2719 ! Set up corresponding symmetry data 2720 ABI_MALLOC(irrzon1, (nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4))) 2721 ABI_MALLOC(phnons1, (2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4))) 2722 ABI_MALLOC(indsy1,(4,nsym1,cryst%natom)) 2723 2724 call setsym(indsy1,irrzon1,iscf1,cryst%natom,nfft,ngfft,nspden,nsppol,& 2725 nsym1,phnons1,symafm1,symrc1,symrel1,tnons1,cryst%typat,cryst%xred) 2726 2727 !if (psps%usepaw==1) then 2728 ! ! Allocate/initialize only zarot in pawang1 datastructure 2729 ! call pawang_init(pawang1,0,0,pawang%l_max-1,0,0,nsym1,0,0,0,0) 2730 ! call setsym_ylm(gprimd,pawang1%l_max-1,pawang1%nsym,0,rprimd,symrc1,pawang1%zarot) 2731 !end if 2732 2733 ! FIXME Be careful here because symrhg was written for densities! 2734 ABI_CHECK(nsppol == 1 .and. nspden == 1, "symrhg was written for densities, not for potentials") 2735 2736 ABI_MALLOC(v1g, (2,nfft)) 2737 call symrhg(cplex,cryst%gprimd,irrzon1,mpi_enreg,nfft,nfftot,ngfft,nspden,nsppol,nsym1,& 2738 phnons1,v1g,v1r,cryst%rprimd,symafm1,symrel1,tnons1) 2739 2740 ABI_FREE(irrzon1) 2741 ABI_FREE(phnons1) 2742 ABI_FREE(indsy1) 2743 ABI_FREE(v1g) 2744 2745 end subroutine v1phq_symmetrize