scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

resolved merge request conflict in PHonon/PH/phq_readin.f90, reading the &inputph namelist

This commit is contained in:
Alberto Otero de la Roza 2019-08-07 11:10:42 +02:00
parent 54e5239530 a757b6cf1a
commit 8846383a5f
464 changed files with 93921 additions and 56762 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
.ci/cineca.yml
View File

@ -1,6 +1,11 @@
# UtilXlib UnitTesting
# ====================
# UtilXlib UnitTesting
# ====================
build:cudampiomp:
tags: [galileo]
only:
- /utilxlib/i
script:
- module load profile/advanced pgi/17.10 cuda/8.0.61
- ./configure --enable-openmp
@ -9,6 +14,8 @@ build:cudampiomp:
build:intelmpiomp:
tags: [galileo]
only:
- /utilxlib/i
script:
- module load profile/advanced intel intelmpi
- ./configure --enable-openmp
@ -17,6 +24,8 @@ build:intelmpiomp:
build:cudampi:
tags: [galileo]
only:
- /utilxlib/i
script:
- module load profile/advanced pgi/17.10 cuda/8.0.61
- ./configure
@ -25,6 +34,8 @@ build:cudampi:
build:intelmpi:
tags: [galileo]
only:
- /utilxlib/i
script:
- module load profile/advanced intel intelmpi
- ./configure
@ -103,10 +114,6 @@ build:cudafortran:
- module purge
- module load profile/global pgi/17.10 cuda/8.0.61
- module list
#- git checkout develop
#- git merge -X ours --no-edit origin/configcuda
#- git merge -X theirs --no-edit origin/mpicuda
#- git merge -X theirs --no-edit origin/cudadiag
- ./configure --enable-openmp --with-cuda=$CUDA_HOME
- make pw cp
- make clean

1
CPV/src/Makefile
View File

@ -37,7 +37,6 @@ exx_module.o \
exx_pair.o \
exx_psi.o \
exx_vofr.o \
fft.o \
forces.o \
fromscra.o \
gram.o \

16
CPV/src/chargedensity.f90
View File

@ -505,7 +505,7 @@ SUBROUTINE drhov(irb,eigrb,rhovan,drhovan,rhog,rhor,drhog,drhor)
USE uspp_param, ONLY: nhm, nh, nvb
USE electrons_base, ONLY: nspin
USE smallbox_gvec, ONLY: ngb
USE smallbox_subs, ONLY: fft_oned2box
USE smallbox_subs, ONLY: fft_oned2box, box2grid
USE cell_base, ONLY: ainv
USE qgb_mod, ONLY: qgb, dqgb
USE fft_interfaces, ONLY: fwfft, invfft
@ -671,8 +671,8 @@ SUBROUTINE drhov(irb,eigrb,rhovan,drhovan,rhog,rhor,drhog,drhor)
!
! add qv(r) to v(r), in real space on the dense grid
!
CALL box2grid( irb(1,isa), 1, qv, v )
IF (nfft.EQ.2) CALL box2grid(irb(1,isa+1),2,qv,v)
CALL box2grid( irb(:,isa), 1, qv, v )
IF (nfft.EQ.2) CALL box2grid(irb(:,isa+1),2,qv,v)
isa = isa + nfft
!
@ -751,7 +751,7 @@ SUBROUTINE drhov(irb,eigrb,rhovan,drhovan,rhog,rhor,drhog,drhor)
!
! add qv(r) to v(r), in real space on the dense grid
!
CALL box2grid2(irb(1,isa),qv,v)
CALL box2grid(irb(:,isa),qv,v)
!
25 isa = isa + 1
!
@ -799,7 +799,7 @@ SUBROUTINE rhov(irb,eigrb,rhovan,rhog,rhor)
USE uspp, ONLY: deeq
USE electrons_base, ONLY: nspin
USE smallbox_gvec, ONLY: ngb
USE smallbox_subs, ONLY: fft_oned2box
USE smallbox_subs, ONLY: fft_oned2box, box2grid
USE cell_base, ONLY: omega
USE small_box, ONLY: omegab
USE control_flags, ONLY: iprint, iverbosity, tpre
@ -958,8 +958,8 @@ SUBROUTINE rhov(irb,eigrb,rhovan,rhog,rhor)
!
! add qv(r) to v(r), in real space on the dense grid
!
CALL box2grid(irb(1,isa),1,qv,v)
IF (nfft.EQ.2) CALL box2grid(irb(1,isa+1),2,qv,v)
CALL box2grid(irb(:,isa),1,qv,v)
IF (nfft.EQ.2) CALL box2grid(irb(:,isa+1),2,qv,v)
isa = isa + nfft
!
@ -1065,7 +1065,7 @@ SUBROUTINE rhov(irb,eigrb,rhovan,rhog,rhor)
!
! add qv(r) to v(r), in real space on the dense grid
!
CALL box2grid2(irb(1,isa),qv,v)
CALL box2grid(irb(:,isa),qv,v)
25 isa=isa+1
!
END DO

506
CPV/src/cp_restart_new.f90
View File

@ -29,6 +29,9 @@ MODULE cp_restart_new
qexsd_init_dipole_info, qexsd_init_total_energy, &
qexsd_init_forces,qexsd_init_stress, qexsd_xf, &
qexsd_init_outputElectricField
USE qexsd_copy, ONLY: qexsd_copy_geninfo, qexsd_copy_parallel_info, &
qexsd_copy_atomic_species, qexsd_copy_atomic_structure, &
qexsd_copy_basis_set, qexsd_copy_dft, qexsd_copy_band_structure
USE io_files, ONLY : iunpun, xmlpun_schema, prefix, tmp_dir, postfix, &
qexsd_fmt, qexsd_version, create_directory
USE io_base, ONLY : write_wfc, read_wfc, write_rhog
@ -92,7 +95,7 @@ MODULE cp_restart_new
USE tsvdw_module, ONLY : vdw_isolated, vdw_econv_thr
USE wrappers, ONLY : f_copy
USE uspp, ONLY : okvan
USE input_parameters, ONLY : vdw_corr, london, starting_ns_eigenvalue
USE input_parameters, ONLY : vdw_corr, starting_ns_eigenvalue
USE qexsd_module, ONLY: qexsd_init_vdw, qexsd_init_hybrid, qexsd_init_dftU
USE qexsd_input, ONLY: qexsd_init_k_points_ibz
@ -167,28 +170,28 @@ MODULE cp_restart_new
INTEGER :: natomwfc, nbnd_, nb, ib
REAL(DP), ALLOCATABLE :: mrepl(:,:)
LOGICAL :: exst
INTEGER :: inlc
TYPE(output_type) :: output_obj
LOGICAL :: is_hubbard(ntypx), empirical_vdw
TYPE(occupations_type) :: bands_occu
TYPE(k_points_IBZ_type) :: k_points_IBZ
CHARACTER(LEN=6), EXTERNAL :: int_to_char
TYPE (vdW_type),POINTER :: vdW_ =>NULL()
TYPE (dftU_type),POINTER :: dftU_ => NULL()
TYPE (hybrid_type),POINTER :: hybrid_ => NULL()
TYPE (vdW_type),POINTER :: vdW_
TYPE (dftU_type),POINTER :: dftU_
TYPE (hybrid_type),POINTER :: hybrid_
REAL(DP),ALLOCATABLE :: london_c6_(:)
CHARACTER(LEN=3),ALLOCATABLE :: species_(:)
REAL(DP),TARGET :: lond_rcut_, lond_s6_, ts_vdw_econv_thr_
REAL(DP),POINTER :: london_s6_pt, lonrcut_opt, ts_thr_opt
INTEGER,POINTER :: nbnd_pt, nbnd_up_pt, nbnd_dw_pt
CHARACTER(LEN=20),TARGET :: non_locc_, vdw_corr_
CHARACTER(LEN=20),POINTER :: non_locc_opt=>NULL(), vdw_corr_opt=>NULL()
LOGICAL,POINTER :: ts_isol_opt => NULL()
CHARACTER(LEN=20),POINTER :: non_locc_opt, vdw_corr_opt
LOGICAL,POINTER :: ts_isol_opt
LOGICAL,TARGET :: ts_vdW_isolated_
!
! ... subroutine body
!
NULLIFY( london_s6_pt, lonrcut_opt, ts_thr_opt, nbnd_pt, nbnd_up_pt, nbnd_dw_pt)
NULLIFY ( vdW_, dftU_, hybrid_, non_locc_opt, vdw_corr_opt, ts_isol_opt )
CALL start_clock('restart')
!
IF( force_pairing ) &
@ -268,7 +271,8 @@ MODULE cp_restart_new
! ... HEADER
!-------------------------------------------------------------------------------
!
CALL qexsd_openschema(TRIM( dirname ) // TRIM( xmlpun_schema ), 'CPV' )
CALL qexsd_openschema(TRIM( dirname ) // TRIM( xmlpun_schema ), 'CPV',&
title)
output_obj%tagname="output"
output_obj%lwrite = .TRUE.
!-------------------------------------------------------------------------------
@ -503,19 +507,20 @@ MODULE cp_restart_new
!
! ... copy pseudopotential files into the .save directory
!
DO is = 1, nsp
sourcefile= TRIM(pseudo_dir)//psfile(is)
filename = TRIM(dirname)//psfile(is)
IF ( TRIM(sourcefile) /= TRIM(filename) ) &
ierr = f_copy(sourcefile, filename)
END DO
inlc = get_inlc()
IF ( inlc > 0 ) THEN
sourcefile= TRIM(kernel_file_name)
filename = TRIM(dirname)//TRIM(vdw_table_name)
IF ( TRIM(sourcefile) /= TRIM(filename) ) &
ierr = f_copy(sourcefile, filename)
END IF
IF ( ionode ) THEN
DO is = 1, nsp
sourcefile= TRIM(pseudo_dir)//psfile(is)
filename = TRIM(dirname)//psfile(is)
IF ( TRIM(sourcefile) /= TRIM(filename) ) &
ierr = f_copy(sourcefile, filename)
END DO
IF ( get_inlc() > 0 ) THEN
sourcefile= TRIM(kernel_file_name)
filename = TRIM(dirname)//TRIM(vdw_table_name)
IF ( TRIM(sourcefile) /= TRIM(filename) ) &
ierr = f_copy(sourcefile, filename)
END IF
END IF
!
!-------------------------------------------------------------------------------
! ... CHARGE DENSITY
@ -676,7 +681,6 @@ MODULE cp_restart_new
INTEGER, ALLOCATABLE :: isrt_(:)
REAL(DP), ALLOCATABLE :: tau_(:,:)
REAL(DP), ALLOCATABLE :: occ_(:,:), et_(:,:)
CHARACTER(LEN=256) :: psfile_(ntypx)
CHARACTER(LEN=80) :: pos_unit
REAL(DP), ALLOCATABLE :: mrepl(:,:)
LOGICAL :: md_found, exist_wfc
@ -685,11 +689,11 @@ MODULE cp_restart_new
TYPE (parallel_info_type) :: parinfo_obj
TYPE (general_info_type ) :: geninfo_obj
TYPE (Node),POINTER :: root, nodePointer
CHARACTER(LEN=20) :: dft_name
CHARACTER(LEN=20) :: dft_name, vdw_corr
CHARACTER(LEN=32) :: exxdiv_treatment, U_projection
CHARACTER(LEN=256):: vdw_corr
INTEGER :: nq1, nq2, nq3, lda_plus_U_kind, inlc
REAL(dp):: ecutfock, exx_fraction, screening_parameter, ecutvcut
LOGICAL :: ldftd3
INTEGER :: nq1, nq2, nq3, lda_plus_U_kind
REAL(dp):: exx_fraction, screening_parameter, ecutfock, ecutvcut,local_thr
LOGICAL :: x_gamma_extrapolation
REAL(dp):: hubbard_dum(3,nsp)
CHARACTER(LEN=6), EXTERNAL :: int_to_char
@ -750,14 +754,14 @@ MODULE cp_restart_new
ierr = 0
!
CALL destroy (root)
CALL qexsd_copy_general_info (geninfo_obj, qexsd_fmt, qexsd_version)
CALL qexsd_copy_geninfo (geninfo_obj, qexsd_fmt, qexsd_version)
!
CALL qexsd_copy_parallel_info (parinfo_obj, nproc_file, &
nproc_pool_file, nproc_image_file, ntask_groups_file, &
nproc_bgrp_file, nproc_ortho_file)
!
CALL qexsd_copy_atomic_species (output_obj%atomic_species, nsp_, atm, &
psfile_, amass_)
CALL qexsd_copy_atomic_species (output_obj%atomic_species, nsp_, &
atm, amass_ )
IF ( nsp_ /= nsp ) CALL errore ('cp_readfile', 'wrong nsp read', 1)
ALLOCATE ( tau_(3,nat), ityp_(nat), isrt_(nat) )
@ -790,12 +794,13 @@ MODULE cp_restart_new
CALL qexsd_copy_dft ( output_obj%dft, nsp, atm, dft_name, &
nq1, nq2, nq3, ecutfock, exx_fraction, screening_parameter, &
exxdiv_treatment, x_gamma_extrapolation, ecutvcut, &
exxdiv_treatment, x_gamma_extrapolation, ecutvcut, local_thr, &
lda_plus_U, lda_plus_U_kind, U_projection, Hubbard_l, Hubbard_lmax,&
Hubbard_U, Hubbard_dum(1,:), Hubbard_dum(2,:), Hubbard_dum(3,:), &
Hubbard_dum, &
vdw_corr, llondon, ts_vdw, lxdm, inlc, vdw_table_name, scal6, &
lon_rcut, vdw_isolated)
vdw_corr, vdw_table_name, scal6, lon_rcut, vdw_isolated)
CALL set_vdw_corr (vdw_corr, llondon, ldftd3, ts_vdw, lxdm )
IF ( ldftd3 ) CALL errore('cp_readfile','DFT-D3 not implemented',1)
!
lsda_ = output_obj%magnetization%lsda
IF ( lsda_ .AND. (nspin /= 2) ) CALL errore('cp_readfile','wrong spin',1)
@ -803,8 +808,8 @@ MODULE cp_restart_new
nbnd_ = nupdwn(1)
ALLOCATE( occ_(nbnd_, nspin), et_(nbnd_, nspin) )
CALL qexsd_copy_band_structure( output_obj%band_structure, lsda_, &
nk_, isk_, natomwfc, nbnd_up, nbnd_dw, nelec_, wk_, occ_, &
ef, ef_up, ef_dw, et_ )
nk_, isk_, natomwfc, nbnd, nbnd_up, nbnd_dw, nelec_, xk, &
wk_, occ_, ef, ef_up, ef_dw, et_ )
! FIXME: in the call, the same array is passed as both occ0 and occm!
DO iss = 1, nspin
ib = iupdwn(iss)
@ -843,435 +848,6 @@ MODULE cp_restart_new
!
END SUBROUTINE cp_readfile
!
!-------------------------------------------------------------------------------
SUBROUTINE qexsd_copy_general_info (geninfo_obj, qexsd_fmt, qexsd_version)
!-------------------------------------------------------------------------------
!
USE qes_types_module, ONLY: general_info_type
!
IMPLICIT NONE
!
CHARACTER(LEN=*), INTENT(OUT) :: qexsd_fmt, qexsd_version
TYPE (general_info_type ),INTENT(IN) :: geninfo_obj
!
qexsd_fmt = TRIM (geninfo_obj%xml_format%NAME)
qexsd_version = TRIM ( geninfo_obj%xml_format%VERSION)
!
END SUBROUTINE qexsd_copy_general_info
!
!---------------------------------------------------------------------------
SUBROUTINE qexsd_copy_parallel_info (parinfo_obj, nproc_file, &
nproc_pool_file, nproc_image_file, ntask_groups_file, &
nproc_bgrp_file, nproc_ortho_file)
!--------------------------------------------------------------------------- !
USE qes_types_module, ONLY : parallel_info_type
!
IMPLICIT NONE
!
TYPE ( parallel_info_type ),INTENT(IN) :: parinfo_obj
INTEGER, INTENT(OUT) :: nproc_file, nproc_pool_file, &
nproc_image_file, ntask_groups_file, &
nproc_bgrp_file, nproc_ortho_file
!
nproc_file = parinfo_obj%nprocs
nproc_pool_file = nproc_file/parinfo_obj%npool
nproc_image_file = nproc_file
ntask_groups_file = parinfo_obj%ntasks
nproc_bgrp_file = nproc_image_file / parinfo_obj%npool / parinfo_obj%nbgrp
nproc_ortho_file = parinfo_obj%ndiag
!
END SUBROUTINE qexsd_copy_parallel_info
!--------------------------------------------------------------------------
SUBROUTINE qexsd_copy_atomic_species (atomic_species, nsp, atm, psfile, amass)
!--------------------------------------------------------------------------- !
USE qes_types_module, ONLY : atomic_species_type
!
IMPLICIT NONE
!
TYPE ( atomic_species_type ),INTENT(IN) :: atomic_species
INTEGER, INTENT(out) :: nsp
CHARACTER(LEN=*), INTENT(out) :: atm(:), psfile(:)
REAL(dp), INTENT(out) :: amass(:)
!
INTEGER :: isp
!
nsp = atomic_species%ntyp
DO isp = 1, nsp
amass(isp) = 0.d0
IF (atomic_species%species(isp)%mass_ispresent) &
amass(isp) = atomic_species%species(isp)%mass
atm(isp) = TRIM ( atomic_species%species(isp)%name )
psfile(isp) = TRIM ( atomic_species%species(isp)%pseudo_file)
END DO
!
END SUBROUTINE qexsd_copy_atomic_species
!--------------------------------------------------------------------------
SUBROUTINE qexsd_copy_atomic_structure (atomic_structure, nsp, atm, &
nat, tau, ityp, alat, a1, a2, a3, ibrav )
!--------------------------------------------------------------------------
USE qes_types_module, ONLY : atomic_structure_type
USE constants, ONLY : pi
!
IMPLICIT NONE
!
TYPE ( atomic_structure_type ),INTENT(IN) :: atomic_structure
INTEGER, INTENT(in) :: nsp
CHARACTER(LEN = 3), INTENT(in) :: atm(:)
!
INTEGER, INTENT(out) :: nat, ibrav, ityp(:)
REAL(dp), INTENT(out) :: alat, a1(:), a2(:), a3(:), tau(:,:)
!
CHARACTER(LEN=3), ALLOCATABLE :: symbols(:)
INTEGER :: iat, idx, isp
!
nat = atomic_structure%nat
alat = atomic_structure%alat
IF ( atomic_structure%bravais_index_ispresent ) THEN
ibrav = atomic_structure%bravais_index
ELSE
ibrav = 0
END IF
ALLOCATE ( symbols(nat) )
loop_on_atoms:DO iat = 1, nat
idx = atomic_structure%atomic_positions%atom(iat)%index
tau(:,idx) = atomic_structure%atomic_positions%atom(iat)%atom
symbols(idx) = TRIM ( atomic_structure%atomic_positions%atom(idx)%name)
loop_on_species:DO isp = 1, nsp
IF ( TRIM(symbols(idx)) == TRIM (atm(isp))) THEN
ityp(iat) = isp
exit loop_on_species
END IF
END DO loop_on_species
END DO loop_on_atoms
DEALLOCATE (symbols)
IF ( atomic_structure%alat_ispresent ) alat = atomic_structure%alat
a1(:) = atomic_structure%cell%a1
a2(:) = atomic_structure%cell%a2
a3(:) = atomic_structure%cell%a3
END SUBROUTINE qexsd_copy_atomic_structure
!--------------------------------------------------------------------------
SUBROUTINE qexsd_copy_basis_set ( basis_set, gamma_only, ecutwfc, ecutrho, &
nr1s, nr2s, nr3s, nr1, nr2, nr3, nr1b, nr2b, nr3b, &
ngm_g, ngms_g, npw_g, b1, b2, b3 )
!--------------------------------------------------------------------------
!
USE qes_types_module, ONLY : basis_set_type
!
IMPLICIT NONE
TYPE ( basis_set_type ),INTENT(IN) :: basis_set
LOGICAL, INTENT(out) :: gamma_only
INTEGER, INTENT(out) :: ngm_g, ngms_g, npw_g
INTEGER, INTENT(out) :: nr1s, nr2s, nr3s, nr1, nr2, nr3
INTEGER, INTENT(inout) :: nr1b, nr2b, nr3b
REAL(dp), INTENT(out) :: ecutwfc, ecutrho, b1(:), b2(:), b3(:)
!
ecutwfc = basis_set%ecutwfc
ecutrho = basis_set%ecutrho
gamma_only= basis_set%gamma_only
nr1 = basis_set%fft_grid%nr1
nr2 = basis_set%fft_grid%nr2
nr3 = basis_set%fft_grid%nr3
nr1s= basis_set%fft_smooth%nr1
nr2s= basis_set%fft_smooth%nr2
nr3s= basis_set%fft_smooth%nr3
IF ( basis_set%fft_box_ispresent ) THEN
nr1b = basis_set%fft_box%nr1
nr2b = basis_set%fft_box%nr2
nr3b = basis_set%fft_box%nr3
END IF
ngm_g = basis_set%ngm
ngms_g = basis_set%ngms
npw_g = basis_set%npwx
!
b1 = basis_set%reciprocal_lattice%b1
b2 = basis_set%reciprocal_lattice%b2
b3 = basis_set%reciprocal_lattice%b3
!
END SUBROUTINE qexsd_copy_basis_set
!
!-----------------------------------------------------------------------
SUBROUTINE qexsd_copy_dft ( dft_obj, nsp, atm, &
dft_name, nq1, nq2, nq3, ecutfock, exx_fraction, screening_parameter, &
exxdiv_treatment, x_gamma_extrapolation, ecutvcut, &
lda_plus_U, lda_plus_U_kind, U_projection, Hubbard_l, Hubbard_lmax, &
Hubbard_U, Hubbard_J0, Hubbard_alpha, Hubbard_beta, Hubbard_J, &
vdw_corr, llondon, ts_vdw, lxdm, inlc, vdw_table_name, scal6, &
lon_rcut, vdw_isolated)
!-------------------------------------------------------------------
!
USE qes_types_module, ONLY : dft_type
!
IMPLICIT NONE
TYPE ( dft_type ),INTENT(in) :: dft_obj
INTEGER, INTENT(in) :: nsp
CHARACTER(LEN=*), INTENT(in) :: atm(nsp)
!
CHARACTER(LEN=*), INTENT(out) :: dft_name
! Variables that may or may not be present should be intent(inout)
! so that they do not forget their default value (if any)
CHARACTER(LEN=*), INTENT(inout) :: exxdiv_treatment
REAL(dp), INTENT(inout) :: ecutfock, exx_fraction, screening_parameter, &
ecutvcut
INTEGER, INTENT(inout) :: nq1, nq2, nq3
LOGICAL, INTENT(inout) :: x_gamma_extrapolation
!
LOGICAL, INTENT(out) :: lda_plus_U
INTEGER, INTENT(inout) :: lda_plus_U_kind, Hubbard_lmax
CHARACTER(LEN=*), INTENT(inout) :: U_projection
INTEGER, INTENT(inout) :: Hubbard_l(:)
REAL(dp), INTENT(inout) :: Hubbard_U(:), Hubbard_J0(:), Hubbard_J(:,:), &
Hubbard_alpha(:), Hubbard_beta(:)
!
CHARACTER(LEN=256), INTENT(out) :: vdw_corr
CHARACTER(LEN=256), INTENT(inout) :: vdw_table_name
LOGICAL, INTENT(out) :: llondon, ts_vdw, lxdm
INTEGER, INTENT(inout):: inlc
REAL(dp), INTENT(inout) :: scal6, lon_rcut
LOGICAL, INTENT(inout) :: vdw_isolated
!
CHARACTER(LEN=256 ) :: label
CHARACTER(LEN=3 ) :: symbol
INTEGER :: ihub, isp
!
dft_name = TRIM(dft_obj%functional)
IF ( dft_obj%hybrid_ispresent ) THEN
nq1 = dft_obj%hybrid%qpoint_grid%nqx1
nq2 = dft_obj%hybrid%qpoint_grid%nqx2
nq3 = dft_obj%hybrid%qpoint_grid%nqx3
ecutfock = dft_obj%hybrid%ecutfock
exx_fraction = dft_obj%hybrid%exx_fraction
screening_parameter = dft_obj%hybrid%screening_parameter
exxdiv_treatment = dft_obj%hybrid%exxdiv_treatment
x_gamma_extrapolation = dft_obj%hybrid%x_gamma_extrapolation
ecutvcut = dft_obj%hybrid%ecutvcut
END IF
!
lda_plus_u = dft_obj%dftU_ispresent
IF ( lda_plus_u ) THEN
lda_plus_u_kind = dft_obj%dftU%lda_plus_u_kind
U_projection = TRIM ( dft_obj%dftU%U_projection_type )
Hubbard_l =-1
IF ( dft_obj%dftU%Hubbard_U_ispresent) THEN
loop_on_hubbardU:DO ihub =1, dft_obj%dftU%ndim_Hubbard_U
symbol = TRIM(dft_obj%dftU%Hubbard_U(ihub)%specie)
label = TRIM(dft_obj%dftU%Hubbard_U(ihub)%label )
loop_on_speciesU:DO isp = 1, nsp
IF ( TRIM(symbol) == TRIM ( atm(isp) ) ) THEN
Hubbard_U(isp) = dft_obj%dftU%Hubbard_U(ihub)%HubbardCommon
SELECT CASE ( TRIM (label))
CASE ( '1s', '2s', '3s', '4s', '5s', '6s', '7s' )
Hubbard_l(isp) = 0
CASE ( '2p', '3p', '4p', '5p', '6p' )
Hubbard_l(isp) = 1
CASE ( '3d', '4d', '5d' )
Hubbard_l( isp ) = 2
CASE ( '4f', '5f' )
Hubbard_l(isp ) = 3
CASE default
IF (Hubbard_U(isp)/=0) &
CALL errore ("pw_readschema:", "unrecognized label for Hubbard "//label, 1 )
END SELECT
EXIT loop_on_speciesU
END IF
END DO loop_on_speciesU
END DO loop_on_hubbardU
END IF
IF ( dft_obj%dftU%Hubbard_J0_ispresent ) THEN
loop_on_hubbardj0:DO ihub =1, dft_obj%dftU%ndim_Hubbard_J0
symbol = TRIM(dft_obj%dftU%Hubbard_J0(ihub)%specie)
loop_on_speciesj0:DO isp = 1, nsp
IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN
Hubbard_J0(isp) = dft_obj%dftU%Hubbard_J0(ihub)%HubbardCommon
EXIT loop_on_speciesj0
END IF
END DO loop_on_speciesj0
END DO loop_on_hubbardj0
END IF
IF ( dft_obj%dftU%Hubbard_alpha_ispresent) THEN
loop_on_hubbardAlpha:DO ihub =1, dft_obj%dftU%ndim_Hubbard_alpha
symbol = TRIM(dft_obj%dftU%Hubbard_alpha(ihub)%specie)
loop_on_speciesAlpha:DO isp = 1, nsp
IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN
Hubbard_alpha(isp) = dft_obj%dftU%Hubbard_alpha(ihub)%HubbardCommon
EXIT loop_on_speciesAlpha
END IF
END DO loop_on_speciesAlpha
END DO loop_on_hubbardAlpha
END IF
IF ( dft_obj%dftU%Hubbard_beta_ispresent) THEN
loop_on_hubbardBeta:DO ihub =1, dft_obj%dftU%ndim_Hubbard_beta
symbol = TRIM(dft_obj%dftU%Hubbard_beta(ihub)%specie)
loop_on_speciesBeta:DO isp = 1, nsp
IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN
Hubbard_beta(isp) = dft_obj%dftU%Hubbard_beta(ihub)%HubbardCommon
EXIT loop_on_speciesBeta
END IF
END DO loop_on_speciesBeta
END DO loop_on_hubbardBeta
END IF
IF ( dft_obj%dftU%Hubbard_J_ispresent) THEN
loop_on_hubbardJ:DO ihub =1, dft_obj%dftU%ndim_Hubbard_J
symbol = TRIM(dft_obj%dftU%Hubbard_J(ihub)%specie)
loop_on_speciesJ:DO isp = 1, nsp
IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN
Hubbard_J(:,isp) = dft_obj%dftU%Hubbard_J(ihub)%HubbardJ
EXIT loop_on_speciesJ
END IF
END DO loop_on_speciesJ
END DO loop_on_hubbardJ
END IF
Hubbard_lmax = MAXVAL( Hubbard_l(1:nsp) )
END IF
IF ( dft_obj%vdW_ispresent ) THEN
vdw_corr = TRIM( dft_obj%vdW%vdw_corr )
ELSE
vdw_corr = ''
END IF
SELECT CASE( TRIM( dft_obj%vdW%vdw_corr ) )
!
CASE( 'grimme-d2', 'Grimme-D2', 'DFT-D', 'dft-d' )
!
llondon= .TRUE.
ts_vdw= .FALSE.
lxdm = .FALSE.
!
CASE( 'TS', 'ts', 'ts-vdw', 'ts-vdW', 'tkatchenko-scheffler' )
!
llondon= .FALSE.
ts_vdw= .TRUE.
lxdm = .FALSE.
!
CASE( 'XDM', 'xdm' )
!
llondon= .FALSE.
ts_vdw= .FALSE.
lxdm = .TRUE.
!
CASE DEFAULT
!
llondon= .FALSE.
ts_vdw = .FALSE.
lxdm = .FALSE.
!
END SELECT
IF ( dft_obj%vdW_ispresent ) THEN
SELECT CASE ( TRIM (dft_obj%vdW%non_local_term))
CASE ('vdw1')
inlc = 1
CASE ('vdw2')
inlc = 2
CASE ('vv10' )
inlc = 3
CASE ( 'vdW-DF-x')
inlc = 4
CASE ( 'vdW-DF-y')
inlc = 5
CASE ( 'vdW-DF-z')
inlc = 6
CASE default
inlc = 0
END SELECT
IF (inlc == 0 ) THEN
vdw_table_name = ' '
ELSE IF ( inlc == 3 ) THEN
vdw_table_name = 'rVV10_kernel_table'
ELSE
vdw_table_name = 'vdW_kernel_table'
END IF
IF (dft_obj%vdW%london_s6_ispresent ) THEN
scal6 = dft_obj%vdW%london_s6
END IF
IF ( dft_obj%vdW%london_rcut_ispresent ) THEN
lon_rcut = dft_obj%vdW%london_rcut
END IF
IF (dft_obj%vdW%ts_vdW_isolated_ispresent ) THEN
vdW_isolated = dft_obj%vdW%ts_vdW_isolated
END IF
END IF
END SUBROUTINE qexsd_copy_dft
!
!------------------------------------------------------------------------
SUBROUTINE qexsd_copy_band_structure( band_struct_obj, lsda, nkstot, &
isk, natomwfc, nbnd_up, nbnd_dw, nelec, wk, wg, ef, ef_up, ef_dw, et )
!------------------------------------------------------------------------
!
USE qes_types_module, ONLY : band_structure_type
!
IMPLICIT NONE
TYPE ( band_structure_type) :: band_struct_obj
LOGICAL, INTENT(out) :: lsda
INTEGER, INTENT(out) :: nkstot, natomwfc, nbnd_up, nbnd_dw, isk(:)
REAL(dp), INTENT(out):: nelec, wk(:), wg(:,:)
REAL(dp), INTENT(out):: ef, ef_up, ef_dw, et(:,:)
!
INTEGER :: ik, nbnd
!
lsda = band_struct_obj%lsda
nkstot = band_struct_obj%nks
IF ( lsda) THEN
nkstot = nkstot * 2
isk(1:nkstot/2) = 1
isk(nkstot/2+1:nkstot) = 2
ELSE
isk(1:nkstot) = 1
END IF
!
nelec = band_struct_obj%nelec
nbnd = band_struct_obj%nbnd
natomwfc = band_struct_obj%num_of_atomic_wfc
IF ( band_struct_obj%fermi_energy_ispresent) THEN
ef = band_struct_obj%fermi_energy
ef_up = 0.d0
ef_dw = 0.d0
ELSE IF ( band_struct_obj%two_fermi_energies_ispresent ) THEN
ef = 0.d0
ef_up = band_struct_obj%two_fermi_energies(1)
ef_dw = band_struct_obj%two_fermi_energies(2)
ELSE
ef = 0.d0
ef_up = 0.d0
ef_dw = 0.d0
END IF
DO ik =1, band_struct_obj%ndim_ks_energies
IF ( band_struct_obj%lsda) THEN
IF ( band_struct_obj%nbnd_up_ispresent .AND. band_struct_obj%nbnd_dw_ispresent) THEN
nbnd_up = band_struct_obj%nbnd_up
nbnd_dw = band_struct_obj%nbnd_dw
ELSE IF ( band_struct_obj%nbnd_up_ispresent ) THEN
nbnd_up = band_struct_obj%nbnd_up
nbnd_dw = band_struct_obj%ks_energies(ik)%eigenvalues%size - nbnd_up
ELSE IF ( band_struct_obj%nbnd_dw_ispresent ) THEN
nbnd_dw = band_struct_obj%nbnd_dw
nbnd_up = band_struct_obj%ks_energies(ik)%eigenvalues%size - nbnd_dw
ELSE
nbnd_up = band_struct_obj%ks_energies(ik)%eigenvalues%size/2
nbnd_dw = band_struct_obj%ks_energies(ik)%eigenvalues%size/2
END IF
wk(ik) = band_struct_obj%ks_energies(ik)%k_point%weight
wk( ik + band_struct_obj%ndim_ks_energies ) = wk(ik)
et(1:nbnd_up,ik) = band_struct_obj%ks_energies(ik)%eigenvalues%vector(1:nbnd_up)
et(1:nbnd_dw,ik+band_struct_obj%ndim_ks_energies) = &
band_struct_obj%ks_energies(ik)%eigenvalues%vector(nbnd_up+1:nbnd_up+nbnd_dw)
wg(1:nbnd_up,ik) = band_struct_obj%ks_energies(ik)%occupations%vector(1:nbnd_up)*wk(ik)
wg(1:nbnd_dw,ik+band_struct_obj%ndim_ks_energies) = &
band_struct_obj%ks_energies(ik)%occupations%vector(nbnd_up+1:nbnd_up+nbnd_dw)*wk(ik)
ELSE
wk(ik) = band_struct_obj%ks_energies(ik)%k_point%weight
nbnd = band_struct_obj%ks_energies(ik)%eigenvalues%size
et (1:nbnd,ik) = band_struct_obj%ks_energies(ik)%eigenvalues%vector(1:nbnd)
wg (1:nbnd,ik) = band_struct_obj%ks_energies(ik)%occupations%vector(1:nbnd)*wk(ik)
nbnd_up = nbnd
nbnd_dw = nbnd
END IF
END DO
END SUBROUTINE qexsd_copy_band_structure
!------------------------------------------------------------------------
SUBROUTINE cp_writecp( xf, nfi, simtime, &
ekin, eht, esr, eself, epseu, enl, exc, vave, enthal, &
@ -1904,11 +1480,11 @@ MODULE cp_restart_new
INTEGER :: ibrav_
INTEGER :: nat_
INTEGER :: nsp_
INTEGER :: ityp_(nat)
INTEGER, ALLOCATABLE :: ityp_(:)
REAL(DP) :: alat_
REAL(DP) :: a1_(3), a2_(3), a3_(3)
REAL(DP) :: b1_(3), b2_(3), b3_(3)
REAL(DP) :: tau_(3,nat)
REAL(DP), ALLOCATABLE :: tau_(:,:)
CHARACTER(LEN=3) :: atm_(ntypx)
TYPE(output_type) :: output_obj
TYPE(Node),POINTER :: root, simpleNode, timestepsNode, cellNode, stepNode

194
CPV/src/cplib.f90
View File

@ -1729,12 +1729,12 @@ END SUBROUTINE print_lambda_x
!
INTEGER :: k, is, ia, iv, jv, i, j, inl, isa, iss, nss, istart, ir, ic, nr, nc, ibgrp_i
INTEGER :: n1, n2, m1, m2, nrcx
REAL(DP), ALLOCATABLE :: temp(:,:), tmpbec(:,:),tmpdr(:,:)
INTEGER :: nrr(nspin), irr, nrrx
REAL(DP), EXTERNAL :: ddot
REAL(DP), ALLOCATABLE :: temp(:,:), tmpbec(:,:),tmpdr(:,:), tmplam(:,:,:)
REAL(DP), ALLOCATABLE :: fion_tmp(:,:)
REAL(DP), ALLOCATABLE :: bec(:,:,:)
REAL(DP), ALLOCATABLE :: becdr(:,:,:,:)
REAL(DP), ALLOCATABLE :: bec_g(:,:)
REAL(DP), ALLOCATABLE :: becdr_g(:,:,:)
INTEGER, ALLOCATABLE :: ibgrp_l2g(:,:)
!
CALL start_clock( 'nlfl' )
!
@ -1744,77 +1744,65 @@ END SUBROUTINE print_lambda_x
!
nrcx = MAXVAL( descla( : )%nrcx )
!
ALLOCATE( temp( nrcx, nrcx ), tmpbec( nhm, nrcx ), tmpdr( nrcx, nhm ) )
ALLOCATE( bec( nhsa, nrcx, nspin ), becdr( nhsa, nrcx, nspin, 3 ) )
! redistribute bec, becdr according to the ortho subgroup
! this is required because they are combined with "lambda" matrixes
DO iss = 1, nspin
IF( descla( iss )%active_node > 0 ) THEN
nss = nupdwn( iss )
istart = iupdwn( iss )
ic = descla( iss )%ic
nc = descla( iss )%nc
DO i=1,nc
ibgrp_i = ibgrp_g2l( i+istart-1+ic-1 )
IF( ibgrp_i > 0 ) THEN
bec( :, i, iss ) = bec_bgrp( :, ibgrp_i )
ELSE
bec( :, i, iss ) = 0.0d0
END IF
END DO
ir = descla( iss )%ir
nr = descla( iss )%nr
DO i=1,nr
ibgrp_i = ibgrp_g2l( i+istart-1+ir-1 )
IF( ibgrp_i > 0 ) THEN
becdr(:,i,iss,1) = becdr_bgrp( :, ibgrp_i, 1 )
becdr(:,i,iss,2) = becdr_bgrp( :, ibgrp_i, 2 )
becdr(:,i,iss,3) = becdr_bgrp( :, ibgrp_i, 3 )
ELSE
becdr(:,i,iss,1) = 0.0d0
becdr(:,i,iss,2) = 0.0d0
becdr(:,i,iss,3) = 0.0d0
END IF
END DO
ELSE
bec(:,:,iss) = 0.0d0
becdr(:,:,iss,1) = 0.0d0
becdr(:,:,iss,2) = 0.0d0
becdr(:,:,iss,3) = 0.0d0
END IF
END DO
CALL mp_sum( bec, inter_bgrp_comm )
CALL mp_sum( becdr, inter_bgrp_comm )
CALL compute_nrr( nrr )
nrrx = MAXVAL(nrr)
IF( nrrx > 0 ) THEN
ALLOCATE( tmplam( nrrx, nrcx, nspin ) )
ALLOCATE( ibgrp_l2g( nrrx, nspin ) )
END IF
CALL get_local_bec()
CALL get_local_lambda()
!
!$omp parallel default(none), &
!$omp shared(nrrx,nhm,nrcx,nvb,na,nspin,nrr,nupdwn,iupdwn,descla,nh,ish,qq_nt,bec,becdr_bgrp,ibgrp_l2g,tmplam,fion_tmp), &
!$omp private(tmpdr,temp,tmpbec,is,k,ia,isa,i,iss,nss,istart,ic,nc,jv,iv,inl,ir,nr)
IF( nrrx > 0 ) THEN
ALLOCATE( tmpdr( nrrx, nhm ) )
ALLOCATE( temp( nrrx, nrcx ) )
END IF
ALLOCATE( tmpbec( nhm, nrcx ) )
DO k=1,3
isa = 0
DO is=1,nvb
!$omp do
DO ia=1,na(is)
isa = isa + 1
isa = 0
DO i = 1, is - 1
isa = isa + na(i)
END DO
isa = isa + ia
!
DO iss = 1, nspin
!
IF( nrr(iss) == 0 ) CYCLE
!
nss = nupdwn( iss )
istart = iupdwn( iss )
!
tmpbec = 0.d0
tmpdr = 0.d0
!
IF( descla( iss )%active_node > 0 ) THEN
! tmpbec distributed by columns
ic = descla( iss )%ic
nc = descla( iss )%nc
DO iv=1,nh(is)
DO jv=1,nh(is)
inl=ish(is)+(jv-1)*na(is)+ia
DO jv=1,nh(is)
inl=ish(is)+(jv-1)*na(is)+ia
DO iv=1,nh(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
DO i=1,nc
tmpbec(iv,i)=tmpbec(iv,i) + qq_nt(iv,jv,is)*bec(inl,i,iss)
END DO
ENDIF
END IF
END DO
END DO
! tmpdr distributed by rows
@ -1822,38 +1810,42 @@ END SUBROUTINE print_lambda_x
nr = descla( iss )%nr
DO iv=1,nh(is)
inl=ish(is)+(iv-1)*na(is)+ia
DO i=1,nr
tmpdr(i,iv) = becdr( inl, i, iss, k )
DO i=1,nrr(iss)
tmpdr(i,iv) = becdr_bgrp( inl, ibgrp_l2g(i,iss), k )
END DO
END DO
END IF
!
IF(nh(is).GT.0)THEN
!
IF( nh(is) > 0 )THEN
IF( descla( iss )%active_node > 0 ) THEN
ir = descla( iss )%ir
ic = descla( iss )%ic
nr = descla( iss )%nr
nc = descla( iss )%nc
CALL dgemm( 'N', 'N', nr, nc, nh(is), 1.0d0, tmpdr, nrcx, tmpbec, nhm, 0.0d0, temp, nrcx )
CALL dgemm( 'N', 'N', nrr(iss), nc, nh(is), 1.0d0, tmpdr, nrrx, tmpbec, nhm, 0.0d0, temp, nrrx )
DO j = 1, nc
DO i = 1, nr
fion_tmp(k,isa) = fion_tmp(k,isa) + 2D0 * temp( i, j ) * lambda( i, j, iss )
DO i = 1, nrr(iss)
fion_tmp(k,isa) = fion_tmp(k,isa) + 2D0 * temp( i, j ) * tmplam( i, j, iss )
END DO
END DO
END IF
!
ENDIF
END IF
ENDIF
END DO
!
END DO
!$omp end do
END DO
END DO
!
DEALLOCATE( bec, becdr )
DEALLOCATE( temp, tmpbec, tmpdr )
DEALLOCATE( tmpbec )
!
IF(ALLOCATED(temp)) DEALLOCATE( temp )
IF(ALLOCATED(tmpdr)) DEALLOCATE( tmpdr )
!$omp end parallel
DEALLOCATE( bec )
IF(ALLOCATED(tmplam)) DEALLOCATE( tmplam )
IF(ALLOCATED(ibgrp_l2g)) DEALLOCATE( ibgrp_l2g )
!
CALL mp_sum( fion_tmp, inter_bgrp_comm )
CALL mp_sum( fion_tmp, intra_bgrp_comm )
!
fion = fion + fion_tmp
@ -1864,9 +1856,73 @@ END SUBROUTINE print_lambda_x
!
RETURN
CONTAINS
SUBROUTINE compute_nrr( nrr )
INTEGER, INTENT(OUT) :: nrr(:)
nrr = 0
DO iss = 1, nspin
nss = nupdwn( iss )
istart = iupdwn( iss )
IF( descla( iss )%active_node > 0 ) THEN
ir = descla( iss )%ir
nr = descla( iss )%nr
DO i=1,nr
ibgrp_i = ibgrp_g2l( i+istart-1+ir-1 )
IF( ibgrp_i > 0 ) THEN
nrr(iss) = nrr(iss) + 1
END IF
END DO
END IF
END DO
END SUBROUTINE compute_nrr
SUBROUTINE get_local_bec
ALLOCATE( bec( nhsa, nrcx, nspin ) )
DO iss = 1, nspin
nss = nupdwn( iss )
istart = iupdwn( iss )
IF( descla( iss )%active_node > 0 ) THEN
ic = descla( iss )%ic
nc = descla( iss )%nc
DO i=1,nc
ibgrp_i = ibgrp_g2l( i+istart-1+ic-1 )
IF( ibgrp_i > 0 ) THEN
bec( :, i, iss ) = bec_bgrp( :, ibgrp_i )
ELSE
bec( :, i, iss ) = 0.0d0
END IF
END DO
ELSE
bec(:,:,iss) = 0.0d0
END IF
END DO
CALL mp_sum( bec, inter_bgrp_comm )
END SUBROUTINE get_local_bec
SUBROUTINE get_local_lambda
DO iss = 1, nspin
nss = nupdwn( iss )
istart = iupdwn( iss )
IF( descla( iss )%active_node > 0 ) THEN
ir = descla( iss )%ir
nr = descla( iss )%nr
irr = 0
DO i=1,nr
ibgrp_i = ibgrp_g2l( i+istart-1+ir-1 )
IF( ibgrp_i > 0 ) THEN
irr = irr + 1
tmplam(irr,:,iss) = lambda(i,:,iss)
ibgrp_l2g(irr,iss) = ibgrp_i
END IF
END DO
tmplam( irr + 1 : nrrx , :, iss ) = 0.0d0
tmplam( 1 : nrrx , descla( iss )%nc + 1 : nrcx, iss ) = 0.0d0
END IF
END DO
END SUBROUTINE get_local_lambda
END SUBROUTINE nlfl_bgrp_x
!
!-----------------------------------------------------------------------
SUBROUTINE pbc(rin,a1,a2,a3,ainv,rout)

327
CPV/src/exch_corr.f90
View File

@ -360,208 +360,6 @@
return
end subroutine gradh
!=----------------------------------------------------------------------------=!
!
! This wrapper interface CP/FPMD to the PW xc and gga functionals
!
! tested with PP/xctest.f90 code
!
!=----------------------------------------------------------------------------=!
subroutine exch_corr_wrapper(nnr, nspin, grhor, rhor, etxc, v, h)
use kinds, only: DP
use funct, only: dft_is_gradient, get_igcc, &
xc, xc_spin, gcxc, gcx_spin, gcc_spin, gcc_spin_more
implicit none
integer, intent(in) :: nnr
integer, intent(in) :: nspin
real(DP), intent(in) :: grhor( 3, nnr, nspin )
real(DP) :: h( nnr, nspin, nspin )
real(DP), intent(in) :: rhor( nnr, nspin )
real(DP) :: v( nnr, nspin )
real(DP) :: etxc
integer :: ir, is, k
real(DP) :: rup, rdw, ex, ec, vx(2), vc(2)
real(DP) :: rh, grh2, zeta
real(DP) :: sx, sc, v1x, v2x, v1c, v2c
real(DP) :: rhox, arhox, e2
real(DP) :: grho2(2), arho, segno
real(DP) :: v1xup, v1xdw, v2xup, v2xdw
real(DP) :: v1cup, v1cdw
real(DP) :: grhoup, grhodw, grhoud
real(DP) :: v2cup, v2cdw, v2cud
integer :: neg(3)
real(DP), parameter :: epsr = 1.0d-10, epsg = 1.0d-10
logical :: debug_xc = .false.
logical :: igcc_is_lyp
igcc_is_lyp = (get_igcc() == 3)
!
e2 = 1.0d0
etxc = 0.0d0
if( nspin == 1 ) then
!
! spin-unpolarized case
!
!$omp parallel do private( rhox, arhox, ex, ec, vx, vc ), reduction(+:etxc)
do ir = 1, nnr
rhox = rhor (ir, nspin)
arhox = abs (rhox)
if (arhox.gt.1.d-30) then
CALL xc( arhox, ex, ec, vx(1), vc(1) )
v(ir,nspin) = e2 * (vx(1) + vc(1) )
etxc = etxc + e2 * (ex + ec) * rhox
else
v(ir,nspin) = 0.0D0
endif
enddo
!$omp end parallel do
!
else
!
! spin-polarized case
!
neg (1) = 0
neg (2) = 0
neg (3) = 0
do ir = 1, nnr
rhox = rhor(ir,1) + rhor(ir,2)
arhox = abs(rhox)
if (arhox.gt.1.d-30) then
zeta = ( rhor(ir,1) - rhor(ir,2) ) / arhox
if (abs(zeta) .gt.1.d0) then
neg(3) = neg(3) + 1
zeta = sign(1.d0,zeta)
endif
! WRITE(6,*) rhox, zeta
if (rhor(ir,1) < 0.d0) neg(1) = neg(1) + 1
if (rhor(ir,2) < 0.d0) neg(2) = neg(2) + 1
call xc_spin (arhox, zeta, ex, ec, vx(1), vx(2), vc(1), vc(2) )
do is = 1, nspin
v(ir,is) = e2 * (vx(is) + vc(is) )
enddo
etxc = etxc + e2 * (ex + ec) * rhox
else
do is = 1, nspin
v(ir,is) = 0.0D0
end do
endif
enddo
endif
if( debug_xc ) then
open(unit=17,form='unformatted')
write(17) nnr, nspin
write(17) rhor
write(17) grhor
close(17)
debug_xc = .false.
end if
! now come the corrections
if( dft_is_gradient() ) then
if (nspin == 1) then
!
! This is the spin-unpolarised case
!
!$omp parallel do &
!$omp private( is, grho2, arho, segno, sx, sc, v1x, v2x, v1c, v2c ), reduction(+:etxc)
do k = 1, nnr
!
grho2 (1) = grhor(1, k, 1)**2 + grhor(2, k, 1)**2 + grhor(3, k, 1)**2
arho = abs (rhor (k, 1) )
segno = sign (1.d0, rhor (k, 1) )
if (arho > epsr .and. grho2 (1) > epsg) then
call gcxc (arho, grho2(1), sx, sc, v1x, v2x, v1c, v2c)
!
! first term of the gradient correction : D(rho*Exc)/D(rho)
v (k, 1) = v (k, 1) + e2 * (v1x + v1c)
! HERE h contains D(rho*Exc)/D(|grad rho|) / |grad rho|
!
h (k, 1, 1) = e2 * (v2x + v2c)
etxc = etxc + e2 * (sx + sc) * segno
else
h (k, 1, 1) = 0.d0
endif
!
end do
!$omp end parallel do
!
else
!
! spin-polarised case
!
do k = 1, nnr
do is = 1, nspin
grho2 (is) = grhor(1, k, is)**2 + grhor(2, k, is)**2 + grhor(3, k, is)**2
enddo
rup = rhor (k, 1)
rdw = rhor (k, 2)
call gcx_spin ( rup, rdw, grho2 (1), grho2 (2), sx, v1xup, v1xdw, v2xup, v2xdw)
!
rh = rhor (k, 1) + rhor (k, 2)
!
if (rh.gt.epsr) then
if( igcc_is_lyp ) then
grhoup = grhor(1,k,1)**2 + grhor(2,k,1)**2 + grhor(3,k,1)**2
grhodw = grhor(1,k,2)**2 + grhor(2,k,2)**2 + grhor(3,k,2)**2
grhoud = grhor(1,k,1)* grhor(1,k,2)
grhoud = grhoud + grhor(2,k,1)* grhor(2,k,2)
grhoud = grhoud + grhor(3,k,1)* grhor(3,k,2)
call gcc_spin_more(rup, rdw, grhoup, grhodw, grhoud, sc, &
v1cup, v1cdw, v2cup, v2cdw, v2cud)
else
zeta = (rhor (k, 1) - rhor (k, 2) ) / rh
!
grh2 = (grhor (1, k, 1) + grhor (1, k, 2) ) **2 + &
(grhor (2, k, 1) + grhor (2, k, 2) ) **2 + &
(grhor (3, k, 1) + grhor (3, k, 2) ) **2
call gcc_spin (rh, zeta, grh2, sc, v1cup, v1cdw, v2c)
v2cup = v2c
v2cdw = v2c
v2cud = v2c
end if
else
sc = 0.d0
v1cup = 0.d0
v1cdw = 0.d0
v2c = 0.d0
v2cup = 0.0d0
v2cdw = 0.0d0
v2cud = 0.0d0
endif
!
! first term of the gradient correction : D(rho*Exc)/D(rho)
!
v (k, 1) = v (k, 1) + e2 * (v1xup + v1cup)
v (k, 2) = v (k, 2) + e2 * (v1xdw + v1cdw)
!
! HERE h contains D(rho*Exc)/D(|grad rho|) / |grad rho|
!
h (k, 1, 1) = e2 * (v2xup + v2cup) ! Spin UP-UP
h (k, 1, 2) = e2 * v2cud ! Spin UP-DW
h (k, 2, 1) = e2 * v2cud ! Spin DW-UP
h (k, 2, 2) = e2 * (v2xdw + v2cdw) ! Spin DW-DW
!
etxc = etxc + e2 * (sx + sc)
!
!
enddo
!
endif
!
end if
return
end subroutine exch_corr_wrapper
!=----------------------------------------------------------------------------=!
!
! For CP we need a further small interface subroutine
@ -569,18 +367,33 @@ end subroutine exch_corr_wrapper
!=----------------------------------------------------------------------------=!
subroutine exch_corr_cp(nnr,nspin,grhor,rhor,etxc)
use kinds, only: DP
use funct, only: dft_is_gradient
use kinds, only: DP
use funct, only: dft_is_gradient, get_igcc
use xc_lda_lsda, only: xc
use xc_gga, only: xc_gcx, change_threshold_gga
implicit none
integer, intent(in) :: nnr
integer, intent(in) :: nspin
real(DP) :: grhor( 3, nnr, nspin )
real(DP) :: rhor( nnr, nspin )
real(DP) :: etxc
integer :: k, ipol
real(DP), parameter :: epsr = 1.0d-10
real(DP), parameter :: e2=1.0_dp
integer :: ir, is, k, ipol, neg(3)
real(DP) :: grup, grdw
real(DP), allocatable :: v(:,:)
real(DP), allocatable :: h(:,:,:)
real(DP), allocatable :: rhox (:,:)!^
real(DP), allocatable :: ex(:), ec(:)
real(DP), allocatable :: vx(:,:), vc(:,:)
REAL(DP), allocatable :: sx(:), sc(:)
REAL(DP), allocatable :: v1x(:,:), v2x(:,:), v1c(:,:), v2c(:,:)
real(dp), allocatable :: v2c_ud(:)
real(dp) :: zetas
!
logical :: debug_xc = .false.
logical :: igcc_is_lyp
!
allocate( v( nnr, nspin ) )
if( dft_is_gradient() ) then
@ -589,7 +402,109 @@ subroutine exch_corr_cp(nnr,nspin,grhor,rhor,etxc)
allocate( h( 1, 1, 1 ) )
endif
!
call exch_corr_wrapper(nnr,nspin,grhor,rhor,etxc,v,h)
igcc_is_lyp = (get_igcc() == 3)
!
etxc = 0.0d0
!
allocate ( ex(nnr), ec(nnr), vx(nnr,nspin), vc(nnr,nspin) )
IF ( nspin == 1 ) THEN
!
! spin-unpolarized case
!
CALL xc( nnr, nspin, nspin, rhor, ex, ec, vx, vc )
!
v(:,nspin) = e2 * (vx(:,1) + vc(:,1) )
etxc = e2 * SUM( (ex + ec)*rhor(:,nspin) )
!
ELSE
!
! spin-polarized case
!
neg(1) = 0
neg(2) = 0
neg(3) = 0
!
allocate ( rhox(nnr,2) ) !^
rhox(:,1) = rhor(:,1) + rhor(:,2)
rhox(:,2) = rhor(:,1) - rhor(:,2)
!
CALL xc( nnr, 2, 2, rhox, ex, ec, vx, vc )
!
DO ir = 1, nnr
!
DO is = 1, nspin
v(ir,is) = e2 * (vx(ir,is) + vc(ir,is))
ENDDO
etxc = etxc + e2 * (ex(ir) + ec(ir)) * rhox(ir,1)
!
zetas = rhox(ir,2) / rhox(ir,1)
IF (rhor(ir,1) < 0.d0) neg(1) = neg(1) + 1
IF (rhor(ir,2) < 0.d0) neg(2) = neg(2) + 1
IF (ABS(zetas) > 1.d0) neg(3) = neg(3) + 1
!
ENDDO
!
deallocate ( rhox ) !^
!
ENDIF
deallocate ( vc, vx, ec, ex )
!
if( debug_xc ) then
open(unit=17,form='unformatted')
write(17) nnr, nspin
write(17) rhor
write(17) grhor
close(17)
debug_xc = .false.
end if
!
! gradient corrections
!
if ( dft_is_gradient() ) then
!
call change_threshold_gga( epsr )
!
allocate ( sx(nnr), sc(nnr), v1x(nnr,nspin), v1c(nnr,nspin), &
v2x(nnr,nspin), v2c(nnr,nspin) )
if (nspin == 1) then
!
! ... This is the spin-unpolarised case
!
call xc_gcx( nnr, nspin, rhor, grhor, sx, sc, v1x, v2x, v1c, v2c )
!
do k = 1, nnr
! first term of the gradient correction: D(rho*Exc)/D(rho)
v(k,1) = v(k,1) + e2 * (v1x(k,1) + v1c(k,1))
! HERE h contains D(rho*Exc)/D(|grad rho|) / |grad rho|
h(k, 1, 1) = e2 * (v2x(k,1) + v2c(k,1))
etxc = etxc + e2 * (sx(k) + sc(k))
enddo
!
else
!
! ... Spin-polarised case
!
allocate (v2c_ud(nnr))
call xc_gcx( nnr, 2, rhor, grhor, sx, sc, v1x, v2x, v1c, v2c, v2c_ud )
!
! first term of the gradient correction : D(rho*Exc)/D(rho)
!
v = v + e2*( v1x + v1c )
!
! HERE h contains D(rho*Exc)/D(|grad rho|) / |grad rho|
!
h(:,1,1) = e2 * (v2x(:,1) + v2c(:,1)) ! Spin UP-UP
h(:,1,2) = e2 * v2c_ud(:) ! Spin UP-DW
h(:,2,1) = e2 * v2c_ud(:) ! Spin DW-UP
h(:,2,2) = e2 * (v2x(:,2) + v2c(:,2)) ! Spin DW-DW
!
etxc = etxc + e2 * SUM( sx(:)+sc(:) )
!
deallocate (v2c_ud)
endif
!
deallocate ( v2c, v2x, v1c, v1x, sc, sx )
end if
if( dft_is_gradient() ) then
!

180
CPV/src/fft.f90
View File

@ -1,180 +0,0 @@
!
! Copyright (C) 2002-2009 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
! ----------------------------------------------
! These subroutines written by Carlo Cavazzoni
! ----------------------------------------------
!-----------------------------------------------------------------------
SUBROUTINE box2grid(irb,nfft,qv,vr)
!-----------------------------------------------------------------------
!
! add array qv(r) on box grid to array vr(r) on dense grid
! irb : position of the box in the dense grid
! nfft=1 add real part of qv(r) to real part of array vr(r)
! nfft=2 add imaginary part of qv(r) to real part of array vr(r)
!
USE kinds, ONLY: dp
USE fft_base, ONLY: dfftp, dfftb
USE mp_global, ONLY: me_bgrp
IMPLICIT NONE
INTEGER, INTENT(in):: nfft, irb(3)
REAL(dp), INTENT(in):: qv(2,dfftb%nnr)
COMPLEX(dp), INTENT(inout):: vr(dfftp%nnr)
!
INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig
INTEGER me
IF(nfft.LE.0.OR.nfft.GT.2) CALL errore('box2grid','wrong data',nfft)
me = me_bgrp + 1
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
IF(ibig3.LT.1.OR.ibig3.GT.dfftp%nr3) &
& CALL errore('box2grid','ibig3 wrong',ibig3)
ibig3=ibig3-dfftp%my_i0r3p
IF ( ibig3 .GT. 0 .AND. ibig3 .LE. ( dfftp%my_nr3p ) ) THEN
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
IF(ibig2.LT.1.OR.ibig2.GT.dfftp%nr2) &
& CALL errore('box2grid','ibig2 wrong',ibig2)
ibig2=ibig2-dfftp%my_i0r2p
IF ( ibig2 .GT. 0 .AND. ibig2 .LE. ( dfftp%my_nr2p ) ) THEN
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
IF(ibig1.LT.1.OR.ibig1.GT.dfftp%nr1) &
& CALL errore('box2grid','ibig1 wrong',ibig1)
ibig=ibig1+(ibig2-1)*dfftp%nr1x+(ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir=ir1+(ir2-1)*dfftb%nr1x+(ir3-1)*dfftb%nr1x*dfftb%nr2x
!$omp critical
vr(ibig) = vr(ibig)+qv(nfft,ir)
!$omp end critical
END DO
END IF
END DO
END IF
END DO
!
RETURN
END SUBROUTINE box2grid
!-----------------------------------------------------------------------
SUBROUTINE box2grid2(irb,qv,v)
!-----------------------------------------------------------------------
!
! add array qv(r) on box grid to array v(r) on dense grid
! irb : position of the box in the dense grid
!
USE kinds, ONLY: dp
USE fft_base, ONLY: dfftp, dfftb
USE mp_global, ONLY: me_bgrp
!
IMPLICIT NONE
!
INTEGER, INTENT(in):: irb(3)
COMPLEX(dp), INTENT(in):: qv(dfftb%nnr)
COMPLEX(dp), INTENT(inout):: v(dfftp%nnr)
!
INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig
INTEGER me
me = me_bgrp + 1
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
IF(ibig3.LT.1.OR.ibig3.GT.dfftp%nr3) &
& CALL errore('box2grid2','ibig3 wrong',ibig3)
ibig3=ibig3-dfftp%my_i0r3p
IF (ibig3.GT.0.AND.ibig3.LE. dfftp%my_nr3p ) THEN
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
IF(ibig2.LT.1.OR.ibig2.GT.dfftp%nr2) &
& CALL errore('box2grid2','ibig2 wrong',ibig2)
ibig2=ibig2-dfftp%my_i0r2p
IF (ibig2.GT.0.AND.ibig2.LE. dfftp%my_nr2p ) THEN
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
IF(ibig1.LT.1.OR.ibig1.GT.dfftp%nr1) &
& CALL errore('box2grid2','ibig1 wrong',ibig1)
ibig=ibig1+(ibig2-1)*dfftp%nr1x+(ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir=ir1+(ir2-1)*dfftb%nr1x+(ir3-1)*dfftb%nr1x*dfftb%nr2x
v(ibig) = v(ibig)+qv(ir)
END DO
END IF
END DO
END IF
END DO
RETURN
END SUBROUTINE box2grid2
!-----------------------------------------------------------------------
REAL(8) FUNCTION boxdotgrid(irb,nfft,qv,vr)
!-----------------------------------------------------------------------
!
! Calculate \sum_i qv(r_i)*vr(r_i) with r_i on box grid
! array qv(r) is defined on box grid, array vr(r)on dense grid
! irb : position of the box in the dense grid
! nfft=1 (2): use real (imaginary) part of qv(r)
! Parallel execution: remember to sum the contributions from other nodes
!
USE kinds, ONLY: dp
USE fft_base, ONLY: dfftp, dfftb
USE mp_global, ONLY: me_bgrp
IMPLICIT NONE
INTEGER, INTENT(in):: nfft, irb(3)
REAL(dp), INTENT(in):: qv(2,dfftb%nnr), vr(dfftp%nnr)
!
INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig
INTEGER me
!
!
IF(nfft.LE.0.OR.nfft.GT.2) CALL errore('boxdotgrid','wrong data',nfft)
me = me_bgrp + 1
boxdotgrid=0.d0
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
ibig3=ibig3-dfftp%my_i0r3p
IF (ibig3.GT.0.AND.ibig3.LE. dfftp%my_nr3p ) THEN
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
ibig2=ibig2-dfftp%my_i0r2p
IF (ibig2.GT.0.AND.ibig2.LE. dfftp%my_nr2p ) THEN
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
ibig=ibig1 + (ibig2-1)*dfftp%nr1x + (ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir =ir1 + (ir2-1)*dfftb%nr1x + (ir3-1)*dfftb%nr1x*dfftb%nr2x
boxdotgrid = boxdotgrid + qv(nfft,ir)*vr(ibig)
END DO
ENDIF
END DO
ENDIF
END DO
RETURN
END FUNCTION boxdotgrid

52
CPV/src/gram.f90
View File

@ -12,6 +12,7 @@ SUBROUTINE gram_bgrp( betae, bec_bgrp, nkbx, cp_bgrp, ngwx )
! gram-schmidt orthogonalization of the set of wavefunctions cp
!
USE uspp, ONLY : nkb, nhsavb=> nkbus
USE uspp, ONLY : qq_nt
USE gvecw, ONLY : ngw
USE electrons_base, ONLY : nbspx_bgrp, ibgrp_g2l, nupdwn, iupdwn, nbspx, iupdwn_bgrp, nspin
USE kinds, ONLY : DP
@ -116,13 +117,12 @@ CONTAINS
!
DO is=1,nvb
DO iv=1,nh(is)
inl=ish(is)+(iv-1)*na(is)
DO jv=1,nh(is)
jnl=ish(is)+(jv-1)*na(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
DO ia=1,na(is)
inl=ish(is)+(iv-1)*na(is)+ia
jnl=ish(is)+(jv-1)*na(is)+ia
rsum = rsum + &
& qq_nt(iv,jv,is)*bec(inl,i)*bec(jnl,i)
rsum = rsum + qq_nt(iv,jv,is)*bec(inl+ia,i)*bec(jnl+ia,i)
END DO
ENDIF
END DO
@ -147,7 +147,7 @@ CONTAINS
USE electrons_base, ONLY: ispin, ispin_bgrp, nbspx_bgrp, ibgrp_g2l, iupdwn, nupdwn, nbspx
USE gvecw, ONLY: ngw
USE mp, ONLY: mp_sum
USE mp_global, ONLY: intra_bgrp_comm, inter_bgrp_comm
USE mp_global, ONLY: intra_bgrp_comm, inter_bgrp_comm, me_bgrp, nproc_bgrp
USE kinds, ONLY: DP
USE gvect, ONLY: gstart
!
@ -165,6 +165,9 @@ CONTAINS
COMPLEX(DP), ALLOCATABLE :: cp_tmp(:)
REAL(DP), ALLOCATABLE :: bec_tmp(:)
REAL(DP), ALLOCATABLE :: csc2( : )
#if defined(_OPENMP)
INTEGER :: mytid, ntids, omp_get_thread_num, omp_get_num_threads
#endif
!
! calculate csc(k)=<cp(i)|cp(k)>, k<i
!
@ -174,6 +177,7 @@ CONTAINS
ALLOCATE( bec_tmp( nkbx ) )
ALLOCATE( csc2( SIZE( csc ) ) )
cp_tmp = 0.0d0
csc = 0.0d0
@ -192,7 +196,6 @@ CONTAINS
ibgrp_k = ibgrp_g2l( k )
IF( ibgrp_k > 0 ) THEN
DO ig = 1, ngw
!temp(ig) = cp_bgrp(1,ig,ibgrp_k) * cp_tmp(1,ig) + cp_bgrp(2,ig,ibgrp_k) * cp_tmp(2,ig)
temp(ig) = DBLE( cp_bgrp(ig,ibgrp_k) * CONJG(cp_tmp(ig)) )
END DO
csc(k) = 2.0d0 * SUM(temp)
@ -212,8 +215,6 @@ CONTAINS
DO inl=1,nhsavb
DO ig=1,ngw
temp(ig) = DBLE( cp_bgrp(ig,ibgrp_i) * CONJG(betae(ig,inl)) )
! temp(ig)=cp_bgrp(1,ig,ibgrp_i)* DBLE(betae(ig,inl))+ &
! & cp_bgrp(2,ig,ibgrp_i)*AIMAG(betae(ig,inl))
END DO
bec_bgrp(inl,ibgrp_i)=2.d0*SUM(temp)
IF (gstart == 2) bec_bgrp(inl,ibgrp_i)= bec_bgrp(inl,ibgrp_i)-temp(1)
@ -238,20 +239,33 @@ CONTAINS
! calculate csc(k)=<cp(i)|S|cp(k)>, k<i
!
csc2 = 0.0d0
!$omp parallel do default(shared), private( k, is, iv, jv, ia, inl, jnl, rsum, ibgrp_k )
!$omp parallel default(none), &
!$omp shared(iupdwn,iss,kmax,nproc_bgrp,me_bgrp,ispin,i,ibgrp_g2l,nh,ish,qq_nt,na,bec_tmp,bec_bgrp,csc2,nvb), &
!$omp private( k, is, iv, jv, ia, inl, jnl, rsum, ibgrp_k, ntids, mytid )
#if defined(_OPENMP)
mytid = omp_get_thread_num() ! take the thread ID
ntids = omp_get_num_threads() ! take the number of threads
#endif
DO k=iupdwn(iss), kmax
IF ( MOD( k, nproc_bgrp ) /= me_bgrp ) CYCLE
#if defined(_OPENMP)
! distribute bands round robin to threads
IF( MOD( k / nproc_bgrp, ntids ) /= mytid ) CYCLE
#endif
IF (ispin(i).EQ.ispin(k)) THEN
rsum=0.d0
ibgrp_k = ibgrp_g2l( k )
IF( ibgrp_k > 0 ) THEN
DO is=1,nvb
DO iv=1,nh(is)
inl=ish(is)+(iv-1)*na(is)
DO jv=1,nh(is)
jnl=ish(is)+(jv-1)*na(is)
IF(ABS(qq_nt(iv,jv,is)).GT.1.e-5) THEN
DO ia=1,na(is)
inl=ish(is)+(iv-1)*na(is)+ia
jnl=ish(is)+(jv-1)*na(is)+ia
rsum = rsum + qq_nt(iv,jv,is)*bec_tmp(inl)*bec_bgrp(jnl,ibgrp_k)
rsum = rsum + qq_nt(iv,jv,is)*bec_tmp(inl+ia)*bec_bgrp(jnl+ia,ibgrp_k)
END DO
ENDIF
END DO
@ -261,24 +275,30 @@ CONTAINS
csc2(k)=csc2(k)+rsum
ENDIF
END DO
!$omp end parallel do
!$omp end parallel
!
! orthogonalized cp(i) : |cp(i)>=|cp(i)>-\sum_k<i csc(k)|cp(k)>
!
! corresponing bec: bec(i)=<cp(i)|beta>-csc(k)<cp(k)|beta>
!
CALL mp_sum( csc2, intra_bgrp_comm )
CALL mp_sum( csc2, inter_bgrp_comm )
csc = csc + csc2
bec_tmp = 0.0d0
DO k = iupdwn(iss), kmax
ibgrp_k = ibgrp_g2l( k )
IF( ibgrp_k > 0 ) THEN
DO inl=1,nkbx
bec_tmp(inl)=bec_tmp(inl)-csc(k)*bec_bgrp(inl,ibgrp_k)
END DO
END IF
END DO
nk = 0
DO k = iupdwn(iss), kmax
ibgrp_k = ibgrp_g2l( k )
IF( ibgrp_k > 0 ) THEN
nk = nk + 1
DO inl=1,nkbx
bec_tmp(inl)=bec_tmp(inl)-csc(k)*bec_bgrp(inl,ibgrp_k)
END DO
csc( nk ) = csc( k )
END IF
END DO

8
CPV/src/make.depend
View File

@ -144,6 +144,7 @@ cp_restart_new.o : ../../Modules/qes_libs_module.o
cp_restart_new.o : ../../Modules/qes_read_module.o
cp_restart_new.o : ../../Modules/qes_types_module.o
cp_restart_new.o : ../../Modules/qexsd.o
cp_restart_new.o : ../../Modules/qexsd_copy.o
cp_restart_new.o : ../../Modules/qexsd_input.o
cp_restart_new.o : ../../Modules/recvec.o
cp_restart_new.o : ../../Modules/run_info.o
@ -347,6 +348,8 @@ exch_corr.o : ../../Modules/kind.o
exch_corr.o : ../../Modules/mp_global.o
exch_corr.o : ../../Modules/recvec.o
exch_corr.o : ../../Modules/uspp.o
exch_corr.o : ../../Modules/xc_gga_drivers.o
exch_corr.o : ../../Modules/xc_lda_lsda_drivers.o
exch_corr.o : ../../UtilXlib/mp.o
exch_corr.o : cp_interfaces.o
exch_corr.o : mainvar.o
@ -434,9 +437,6 @@ exx_vofr.o : ../../Modules/kind.o
exx_vofr.o : ../../Modules/mp_global.o
exx_vofr.o : ../../UtilXlib/parallel_include.o
exx_vofr.o : exx_module.o
fft.o : ../../Modules/fft_base.o
fft.o : ../../Modules/kind.o
fft.o : ../../Modules/mp_global.o
forces.o : ../../FFTXlib/fft_helper_subroutines.o
forces.o : ../../FFTXlib/fft_interfaces.o
forces.o : ../../Modules/cell_base.o
@ -717,6 +717,7 @@ manycp.o : ../../Modules/read_input.o
manycp.o : input.o
metaxc.o : ../../Modules/funct.o
metaxc.o : ../../Modules/kind.o
metaxc.o : ../../Modules/xc_mgga_drivers.o
modules.o : ../../Modules/kind.o
modules.o : ../../Modules/uspp.o
move_electrons.o : ../../Modules/cell_base.o
@ -1080,6 +1081,7 @@ smallbox_lib.o : smallbox_gvec.o
smallbox_subs.o : ../../Modules/fft_base.o
smallbox_subs.o : ../../Modules/io_global.o
smallbox_subs.o : ../../Modules/kind.o
smallbox_subs.o : ../../Modules/mp_global.o
smallbox_subs.o : smallbox.o
smallbox_subs.o : smallbox_gvec.o
spinsq.o : ../../Modules/cell_base.o

242
CPV/src/metaxc.f90
View File

@ -10,190 +10,96 @@
SUBROUTINE tpssmeta(nnr, nspin,grho,rho,kedtau,etxc)
! ===================
!--------------------------------------------------------------------
use kinds, only: dp
use funct, only: tau_xc, tau_xc_spin, tau_xc_array, tau_xc_array_spin, get_meta
use kinds, only: dp
use funct, only: get_meta
use xc_mgga, only: xc_metagcx, change_threshold_mgga !, &
!tau_xc_array, tau_xc_array_spin
!
IMPLICIT NONE
!
! input
integer nspin , nnr
real(dp) grho(3,nnr,nspin), rho(nnr,nspin),kedtau(nnr,nspin)
integer :: nspin, nnr
real(dp) :: grho(3,nnr,nspin), rho(nnr,nspin), kedtau(nnr,nspin)
! output: excrho: exc * rho ; E_xc = \int excrho(r) d_r
! output: rhor: contains the exchange-correlation potential
real(dp) etxc
real(dp) :: etxc
REAL(dp) :: zeta, rh, grh2
INTEGER :: k, ipol, is
REAL(dp), PARAMETER :: epsr = 1.0d-6, epsg = 1.0d-10
INTEGER :: imeta
!
etxc = 0.d0
! calculate the gradient of rho+rho_core in real space
imeta = get_meta()
if (imeta.eq.5.or.imeta.eq.6.or.imeta.eq.7) then
call exch_corr_meta_array_mode() !HK/MCA: currently only implmented for SCAN
else
call exch_corr_meta_scalar_mode() !HK/MCA: compatibility for the original implementation
end if
!
call exch_corr_meta() !HK/MCA
!
RETURN
contains
subroutine exch_corr_meta_array_mode()
implicit none
real(dp) :: grho_(3,nnr,nspin) !MCA/HK : store grho only in nspin=2
REAL(dp) :: arho(nnr), segno(nnr), grho2 (nnr), &
& sx(nnr), sc(nnr), &
& v1x(nnr,nspin), v2x(nnr,nspin*2-1), v3x(nnr,nspin), & !MCA/HK
& v1c(nnr,nspin), v2c(nnr,nspin*2-1), v3c(nnr,nspin) !MCA/HK
IF (nspin == 1) THEN
!
!$omp parallel do
do k = 1, nnr
!
grho2(k) = grho(1,k,1)**2 + grho(2,k,1)**2 + grho(3,k,1)**2
arho(k) = ABS (rho (k,1) )
segno(k) = SIGN (1.d0, rho (k,1) )
!
end do !k
!$omp end parallel do
!
CALL tau_xc_array (nnr,arho,grho2,kedtau,sx,sc,v1x,v2x,v3x,v1c,v2c,v3c)
!
! store potentials
!
rho (:, 1) = ( v1x(:,1) + v1c(:,1) )
kedtau(:,1) = ( v3x(:,1) + v3c(:,1) ) *0.5_dp
!
! v2 contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho|
!
DO ipol = 1, 3
grho(ipol,:,1) = ( v2x(:,1) + v2c(:,1) )*grho (ipol,:,1)
ENDDO
!
ELSE
!
!MCA/HK: only SCAN is available
CALL tau_xc_array_spin (nnr, rho, grho, kedtau, sx, sc, v1x, v2x, &
& v3x, v1c, v2c, v3c)
!
! MCA/HK : store grho to compute v2x cross terms
!
grho_ = grho
!
DO is = 1,nspin
!
rho(:, is) = v1x(:,is) + v1c(:,is)
!
DO ipol = 1, 3 !MCA/HK: second line is the cross term
grho(ipol,:,is) = ( v2x(:,2*is-1) + v2c(:,2*is-1) ) * grho(ipol,:,is) &
& + 0.5_dp * ( v2x(:,2) + v2c(:,2) ) * grho_(ipol,:,MOD(is,2)+1)
ENDDO
!
kedtau(:,is)= ( v3x(:,is) + v3c(:,is) ) *0.5d0
!
segno = 1.0 !MCA: not the most efficient way
!
ENDDO
!
ENDIF
!
!
contains
!
!
subroutine exch_corr_meta()
!
! compute exc energy contribution from the current process
!
etxc = 0.0_dp
!$omp parallel do reduction(+:etxc)
do k = 1, nnr
etxc = etxc + (sx(k) + sc(k)) * segno(k)
end do !k
!$omp end parallel do
return
end subroutine exch_corr_meta_array_mode
subroutine exch_corr_meta_scalar_mode()
implicit none
REAL(dp) :: grho2 (2), sx, sc, v1x, v2x, v3x,v1c, v2c, v3c, &
v1xup, v1xdw, v2xup, v2xdw, v1cup, v1cdw ,v2cup(3),v2cdw(3), &
v3xup, v3xdw,grhoup(3),grhodw(3),v3cup, v3cdw, segno, arho, atau
DO k = 1, nnr
DO is = 1, nspin
grho2 (is) = grho(1,k, is)**2 + grho(2,k,is)**2 + grho(3,k,is)**2
ENDDO
IF (nspin == 1) THEN
!
! This is the spin-unpolarised case
!
arho = ABS (rho (k, 1) )
segno = SIGN (1.d0, rho (k, 1) )
atau = kedtau(k,1)
IF (arho.GT.epsr.AND.grho2 (1) .GT.epsg.AND.ABS(atau).GT.epsr) THEN
CALL tau_xc (arho, grho2(1), atau, sx, sc, &
v1x, v2x, v3x, v1c, v2c, v3c)
rho (k, 1) = (v1x + v1c )
kedtau(k,1)= (v3x + v3c) *0.5d0
! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho|
DO ipol = 1, 3
grho(ipol,k,1) = (v2x + v2c)*grho (ipol,k,1)
ENDDO
etxc = etxc + (sx + sc) * segno
ELSE
DO ipol = 1, 3
grho (ipol,k,1) = 0.d0
ENDDO
kedtau(k,1)=0.d0
ENDIF
ELSE
!
! spin-polarised case
!
!CALL tpsscx_spin(rho (k, 1), rho (k, 2), grho2 (1), grho2 (2), &
! kedtau(k,1),kedtau(k,2),sx, &
! v1xup,v1xdw,v2xup,v2xdw,v3xup,v3xdw)
rh = rho (k, 1) + rho (k, 2)
IF (rh.GT.epsr) THEN
!zeta = (rho (k, 1) - rho (k, 2) ) / rh
DO ipol=1,3
grhoup(ipol)=grho(ipol,k,1)
grhodw(ipol)=grho(ipol,k,2)
END DO
! atau=kedtau(k,1)+kedtau(k,2)
call tau_xc_spin (rho(k,1), rho(k,2), grhoup, grhodw, &
kedtau(k,1), kedtau(k,2), sx, sc, v1xup, v1xdw, v2xup, v2xdw, &
v3xup, v3xdw, v1cup, v1cdw, v2cup, v2cdw,&
v3cup, v3cdw)
!CALL tpsscc_spin(rh,zeta,grhoup,grhodw, &
! atau,sc,v1cup,v1cdw,v2cup,v2cdw,v3c)
ELSE
sx = 0.d0
sc = 0.d0
v1xup = 0.d0
v1xdw = 0.d0
v2xup=0.d0
v2xdw=0.d0
v3xup=0.d0
v3xdw=0.d0
v1cup = 0.d0
v1cdw = 0.d0
v2cup=0.d0
v2cdw=0.d0
v3cup=0.d0
v3cdw=0.d0
!
ENDIF
!
! first term of the gradient correction : D(rho*Exc)/D(rho)
!
rho(k, 1) = (v1xup + v1cup)
rho(k, 2) = (v1xdw + v1cdw)
!
! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho|
!
DO ipol = 1, 3
grho(ipol,k,1) = (v2xup*grho(ipol,k,1) + v2cup(ipol))
grho(ipol,k,2) = (v2xdw*grho(ipol,k,2) + v2cdw(ipol))
ENDDO
kedtau(k,1)= (v3xup + v3cup) *0.5d0
kedtau(k,2)= (v3xdw + v3cdw) *0.5d0
etxc = etxc + (sx + sc)
ENDIF
ENDDO
!
INTEGER :: np
REAL(DP), ALLOCATABLE :: sx(:), v1x(:,:), v2x(:,:), v3x(:,:), &
sc(:), v1c(:,:), v2c(:,:,:), v3c(:,:)
!
np=1
if (nspin==2) np=3
!
allocate( sx(nnr), v1x(nnr,nspin), v2x(nnr,nspin), v3x(nnr,nspin) )
allocate( sc(nnr), v1c(nnr,nspin), v2c(np,nnr,nspin), v3c(nnr,nspin) )
!
if (nspin==1) then
!
call change_threshold_mgga( epsr, epsg, epsr )
!
call xc_metagcx( nnr, 1, np, rho, grho, kedtau, sx, sc, &
v1x, v2x, v3x, v1c, v2c, v3c )
!
rho(:,1) = v1x(:,1) + v1c(:,1)
kedtau(:,1) = (v3x(:,1) + v3c(:,1)) * 0.5d0
! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho|
do ipol = 1, 3
grho(ipol,:,1) = (v2x(:,1) + v2c(1,:,1))*grho(ipol,:,1)
enddo
etxc = SUM( (sx(:) + sc(:)) * SIGN(1.d0,rho(:,1)) )
!
else
!
call change_threshold_mgga( epsr )
!
call xc_metagcx( nnr, 2, np, rho, grho, kedtau, sx, sc, &
v1x, v2x, v3x, v1c, v2c, v3c )
!
rho(:,1) = v1x(:,1) + v1c(:,1)
rho(:,2) = v1x(:,2) + v1c(:,2)
!
! h contains D(rho*Exc)/D(|grad rho|) * (grad rho) / |grad rho|
!
do ipol = 1, 3
grho(ipol,:,1) = (v2x(:,1)*grho(ipol,:,1) + v2c(ipol,:,1))
grho(ipol,:,2) = (v2x(:,2)*grho(ipol,:,2) + v2c(ipol,:,2))
enddo
!
kedtau(:,1) = (v3x(:,1) + v3c(:,1)) * 0.5d0
kedtau(:,2) = (v3x(:,2) + v3c(:,2)) * 0.5d0
etxc = etxc + SUM( sx(:) + sc(:) )
!
endif
!
deallocate( sx, v1x, v2x, v3x )
deallocate( sc, v1c, v2c, v3c )
!
!
return
end subroutine exch_corr_meta_scalar_mode
!
end subroutine exch_corr_meta
!
END SUBROUTINE tpssmeta
!-----------------------------------------------------------------------

17
CPV/src/newd.f90
View File

@ -22,7 +22,7 @@
USE ions_base, ONLY: nat, nsp, na
USE constants, ONLY: pi, fpi
USE smallbox_gvec, ONLY: ngb, gxb
USE smallbox_subs, ONLY: fft_oned2box, fft_add_oned2box
USE smallbox_subs, ONLY: fft_oned2box, fft_add_oned2box, boxdotgrid
USE small_box, ONLY: omegab, tpibab
USE qgb_mod, ONLY: qgb
USE electrons_base, ONLY: nspin
@ -43,11 +43,10 @@
REAL(DP) fion(3,nat)
! local
INTEGER isup,isdw,iss, iv,ijv,jv, ik, nfft, isa, ia, is, ig
REAL(DP) fvan(3,nat,nvb), fac, fac1, fac2, boxdotgrid, res
REAL(DP) fvan(3,nat,nvb), fac, fac1, fac2, res
COMPLEX(DP) ci, facg1, facg2
COMPLEX(DP), ALLOCATABLE :: qv(:), fg1(:), fg2(:)
INTEGER :: na_bgrp, ia_bgrp
EXTERNAL boxdotgrid
#if defined(_OPENMP)
INTEGER :: itid, mytid, ntids, omp_get_thread_num, omp_get_num_threads
@ -128,12 +127,12 @@
CALL invfft( qv, dfftb, isa )
!
DO iss=1,nspin
res = boxdotgrid(irb(1,isa),1,qv,vr(1,iss))
res = boxdotgrid(irb(:,isa),1,qv,vr(:,iss))
deeq(iv,jv,isa,iss) = fac * res
IF (iv.NE.jv) &
& deeq(jv,iv,isa,iss)=deeq(iv,jv,isa,iss)
IF (nfft.EQ.2) THEN
res = boxdotgrid(irb(1,isa+1),2,qv,vr(1,iss))
res = boxdotgrid(irb(:,isa+1),2,qv,vr(:,iss))
deeq(iv,jv,isa+1,iss) = fac * res
IF (iv.NE.jv) &
& deeq(jv,iv,isa+1,iss)=deeq(iv,jv,isa+1,iss)
@ -243,11 +242,11 @@
!
CALL invfft( qv, dfftb, isa)
!
res = boxdotgrid(irb(1,isa),1,qv,vr(1,iss))
res = boxdotgrid(irb(:,isa),1,qv,vr(:,iss))
fvan(ik,ia,is) = res
!
IF (nfft.EQ.2) THEN
res = boxdotgrid(irb(1,isa+1),2,qv,vr(1,iss))
res = boxdotgrid(irb(:,isa+1),2,qv,vr(:,iss))
fvan(ik,ia+1,is) = res
END IF
END DO
@ -304,8 +303,8 @@
CALL invfft( qv, dfftb, isa)
!
fvan(ik,ia,is) = &
& boxdotgrid(irb(1,isa),isup,qv,vr(1,isup)) + &
& boxdotgrid(irb(1,isa),isdw,qv,vr(1,isdw))
& boxdotgrid(irb(:,isa),isup,qv,vr(:,isup)) + &
& boxdotgrid(irb(:,isa),isdw,qv,vr(:,isdw))
END DO
25 isa = isa+1
END DO

40
CPV/src/nl_base.f90
View File

@ -692,8 +692,6 @@ end subroutine dennl_x
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
subroutine nlfq_bgrp_x( c_bgrp, eigr, bec_bgrp, becdr_bgrp, fion )
!-----------------------------------------------------------------------
@ -707,7 +705,8 @@ subroutine nlfq_bgrp_x( c_bgrp, eigr, bec_bgrp, becdr_bgrp, fion )
use electrons_base, only : nbsp_bgrp, f_bgrp, nbspx_bgrp, ispin_bgrp
use gvecw, only : ngw
use constants, only : pi, fpi
use mp_global, only : intra_bgrp_comm, nbgrp, inter_bgrp_comm
use mp_global, only : intra_bgrp_comm, nbgrp, inter_bgrp_comm, world_comm
use mp_global, only : me_bgrp, nproc_bgrp
use mp, only : mp_sum
use cp_interfaces, only : nlsm2_bgrp
!
@ -738,32 +737,38 @@ subroutine nlfq_bgrp_x( c_bgrp, eigr, bec_bgrp, becdr_bgrp, fion )
!
fion_loc = 0.0d0
!
DO k = 1, 3
!$omp parallel default(none), &
!$omp shared(becdr_bgrp,bec_bgrp,fion_loc,k,f_bgrp,deeq,dvan,nbsp_bgrp,ish,nh,na,nsp,nhm,nbspx_bgrp,ispin_bgrp), &
!$omp private(tmpbec,tmpdr,isa,is,ia,iv,jv,inl,temp,i,mytid,ntids,sum_tmpdr)
!$omp shared(becdr_bgrp,bec_bgrp,fion_loc,f_bgrp,deeq,dvan,nbsp_bgrp,ish,nh,na, &
!$omp nat,nsp,nhm,nbspx_bgrp,ispin_bgrp,nproc_bgrp,me_bgrp), &
!$omp private(tmpbec,tmpdr,isa,is,ia,iv,jv,k,inl,temp,i,mytid,ntids,sum_tmpdr)
#if defined(_OPENMP)
mytid = omp_get_thread_num() ! take the thread ID
ntids = omp_get_num_threads() ! take the number of threads
mytid = omp_get_thread_num() ! take the thread ID
ntids = omp_get_num_threads() ! take the number of threads
#endif
allocate ( tmpbec( nhm, nbspx_bgrp ), tmpdr( nhm, nbspx_bgrp ) )
allocate ( tmpbec( nhm, nbspx_bgrp ), tmpdr( nhm, nbspx_bgrp ) )
isa = 0
!
DO k = 1, 3
DO is=1,nsp
DO ia=1,na(is)
isa=isa+1
isa = 0
DO i = 1, is - 1
isa = isa + na(i)
END DO
isa = isa + ia
! better if we distribute to MPI tasks too!
!
IF( MOD( isa + (k-1)*nat, nproc_bgrp ) /= me_bgrp ) CYCLE
#if defined(_OPENMP)
! distribute atoms round robin to threads
!
IF( MOD( isa, ntids ) /= mytid ) CYCLE
IF( MOD( ( isa + (k-1)*nat ) / nproc_bgrp, ntids ) /= mytid ) CYCLE
#endif
tmpbec = 0.d0
tmpdr = 0.d0
@ -795,11 +800,12 @@ subroutine nlfq_bgrp_x( c_bgrp, eigr, bec_bgrp, becdr_bgrp, fion )
END DO
END DO
deallocate ( tmpbec, tmpdr )
END DO
deallocate ( tmpbec, tmpdr )
!$omp end parallel
END DO
!
CALL mp_sum( fion_loc, intra_bgrp_comm )
IF( nbgrp > 1 ) THEN
CALL mp_sum( fion_loc, inter_bgrp_comm )
END IF

15
CPV/src/nlcc.f90
View File

@ -174,7 +174,7 @@
USE kinds, ONLY: DP
use electrons_base, only: nspin
use smallbox_gvec, only: gxb, ngb
use smallbox_subs, only: fft_oned2box
use smallbox_subs, only: fft_oned2box, boxdotgrid
use cell_base, only: omega
use ions_base, only: nsp, na, nat
use small_box, only: tpibab
@ -194,11 +194,10 @@
real(dp), intent(inout):: fion1(3,nat)
! local
integer :: iss, ix, ig, is, ia, nfft, isa
real(dp) :: fac, res, boxdotgrid
real(dp) :: fac, res
complex(dp) ci, facg
complex(dp), allocatable :: qv(:), fg1(:), fg2(:)
real(dp), allocatable :: fcc(:,:)
external boxdotgrid
#if defined(_OPENMP)
INTEGER :: itid, mytid, ntids, omp_get_thread_num, omp_get_num_threads
@ -282,10 +281,10 @@
! note that a factor 1/2 is hidden in fac if nspin=2
!
do iss=1,nspin
res = boxdotgrid(irb(1,ia +isa),1,qv,vxc(1,iss))
res = boxdotgrid(irb(:,ia +isa),1,qv,vxc(:,iss))
fcc(ix,ia+isa) = fcc(ix,ia+isa) + fac * res
if (nfft.eq.2) then
res = boxdotgrid(irb(1,ia+1+isa),2,qv,vxc(1,iss))
res = boxdotgrid(irb(:,ia+1+isa),2,qv,vxc(:,iss))
fcc(ix,ia+1+isa) = fcc(ix,ia+1+isa) + fac * res
end if
end do
@ -328,7 +327,7 @@
use ions_base, only: nsp, na, nat
use uspp_param, only: upf
use smallbox_gvec, only: ngb
use smallbox_subs, only: fft_oned2box
use smallbox_subs, only: fft_oned2box, box2grid
use control_flags, only: iprint
use core, only: rhocb
use fft_interfaces, only: invfft
@ -414,8 +413,8 @@
!
call invfft( qv, dfftb, isa+ia )
!
call box2grid(irb(1,ia+isa),1,qv,wrk1)
if (nfft.eq.2) call box2grid(irb(1,ia+1+isa),2,qv,wrk1)
call box2grid(irb(:,ia+isa),1,qv,wrk1)
if (nfft.eq.2) call box2grid(irb(:,ia+1+isa),2,qv,wrk1)
!
end do
isa = isa + na(is)

39
CPV/src/ortho_base.f90
View File

@ -1049,8 +1049,7 @@ CONTAINS
INTEGER :: i, j, ig, is, iv, ia, inl, nr, nc, ir, ic, nx0, ngwx, nkbx, iss, nrcx
INTEGER :: ipr, ipc, root, i1, i2, nss, istart
INTEGER :: ibgrp_i, ibgrp_i_first, nbgrp_i, i_first
REAL(DP), ALLOCATABLE :: wtemp(:,:)
REAL(DP), ALLOCATABLE :: xd(:,:)
REAL(DP), ALLOCATABLE :: xd(:,:)
REAL(DP), ALLOCATABLE :: bephi_tmp(:,:)
INTEGER :: np( 2 ), coor_ip( 2 )
TYPE(la_descriptor) :: desc_ip
@ -1090,12 +1089,9 @@ CONTAINS
DO i = 1, nss
ibgrp_i = ibgrp_g2l( i + istart - 1 )
IF( ibgrp_i > 0 ) THEN
DO inl = 1, nkbus
bec_bgrp( inl, ibgrp_i ) = becp_bgrp( inl, ibgrp_i )
END DO
bec_bgrp( :, ibgrp_i ) = becp_bgrp( :, ibgrp_i )
END IF
END DO
ALLOCATE( wtemp( nrcx, nkb ) )
ALLOCATE( bephi_tmp( nkbx, nrcx ) )
END IF
@ -1115,7 +1111,9 @@ CONTAINS
!
! broadcast the block to all processors
!
IF( me_bgrp == root ) bephi_tmp = bephi(:,i1:i2)
IF( me_bgrp == root ) THEN
bephi_tmp(:,:) = bephi(:, i1 : i1+nrcx-1 )
END IF
CALL mp_bcast( bephi_tmp, root, intra_bgrp_comm )
!
END IF
@ -1168,25 +1166,21 @@ CONTAINS
END IF
IF( nvb > 0 )THEN
! updating of the <beta|c(n,g)>
!
! bec of vanderbilt species are updated
!
CALL dgemm( 'N', 'T', nr, nkbus, nc, 1.0d0, xd, nrcx, bephi_tmp, nkbx, 0.0d0, wtemp, nrcx )
!
! here nr and ir are still valid, since they are the same for all procs in the same row
!
!$omp parallel do default(none) private(ibgrp_i,inl) shared(nr,ibgrp_g2l,istart,ir,nkbus,bec_bgrp,wtemp)
nbgrp_i = 0
DO i = 1, nr
ibgrp_i = ibgrp_g2l( i + istart + ir - 2 )
IF( ibgrp_i > 0 ) THEN
DO inl = 1, nkbus
bec_bgrp( inl, ibgrp_i ) = bec_bgrp( inl, ibgrp_i ) + wtemp( i, inl )
END DO
IF( nbgrp_i == 0 ) THEN
ibgrp_i_first = ibgrp_i
i_first = i
END IF
nbgrp_i = nbgrp_i + 1
END IF
END DO
!$omp end parallel do
IF( nbgrp_i > 0 ) THEN
CALL dgemm( 'N', 'T', nkbus, nbgrp_i, nc, 1.0d0, &
bephi_tmp, nkbx, xd(i_first,1), nrcx, 1.0d0, bec_bgrp( 1, ibgrp_i_first ), SIZE(bec_bgrp,1) )
END IF
!
END IF
@ -1195,7 +1189,6 @@ CONTAINS
END DO
IF( nvb > 0 )THEN
DEALLOCATE( wtemp )
DEALLOCATE( bephi_tmp )
END IF
!
@ -1217,7 +1210,7 @@ CONTAINS
END DO
ENDIF
!
DEALLOCATE( xd )
DEALLOCATE(xd)
!
END DO
!

4
CPV/src/restart.f90
View File

@ -53,7 +53,7 @@
REAL(DP) :: ht(3,3), htm(3,3), htvel(3,3), gvel(3,3)
INTEGER :: nk = 1, ispin, i, ib, ierr
REAL(DP) :: xk(3,1) = 0.0d0, wk(1) = 2.0d0
REAL(DP) :: xk(3,2)=0.0_dp, wk(2)=1.0_dp
COMPLEX(DP), ALLOCATABLE :: ctot(:,:)
REAL(DP), ALLOCATABLE :: eitot(:,:)
INTEGER :: nupdwn_tot( 2 ), iupdwn_tot( 2 )
@ -152,7 +152,7 @@
!
REAL(DP) :: ht(3,3), htm(3,3), htvel(3,3), gvel(3,3)
integer :: nk = 1, ispin, i, ib, ierr
REAL(DP) :: xk(3,1) = 0.0d0, wk(1) = 2.0d0
REAL(DP) :: xk(3,2), wk(2)
REAL(DP), ALLOCATABLE :: occ_ ( : )
REAL(DP) :: b1(3) , b2(3), b3(3)

264
CPV/src/smallbox_subs.f90
View File

@ -5,6 +5,9 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
! -------------------------------------------------
! These subroutines were written by Carlo Cavazzoni
! -------------------------------------------------
!
!=----------------------------------------------------------------------=
MODULE smallbox_subs
@ -21,7 +24,21 @@ MODULE smallbox_subs
PRIVATE
SAVE
INTERFACE fft_oned2box
MODULE PROCEDURE fft_oned2box_dp
END INTERFACE
INTERFACE fft_add_oned2box
MODULE PROCEDURE fft_add_oned2box_dp
END INTERFACE
INTERFACE boxdotgrid
MODULE PROCEDURE boxdotgrid_dp, boxdotgridcplx_dp
END INTERFACE
INTERFACE box2grid
MODULE PROCEDURE box2grid_dp, box2grid2_dp
END INTERFACE
PUBLIC :: ggenb, gcalb, fft_oned2box, fft_add_oned2box
PUBLIC :: boxdotgrid, box2grid
!=----------------------------------------------------------------------=
CONTAINS
@ -288,7 +305,7 @@ CONTAINS
RETURN
END SUBROUTINE gcalb
!
SUBROUTINE fft_oned2box( qv, fg1, fg2 )
SUBROUTINE fft_oned2box_dp( qv, fg1, fg2 )
USE kinds, ONLY: DP
IMPLICIT NONE
COMPLEX(DP), INTENT(OUT) :: qv(:)
@ -311,9 +328,9 @@ CONTAINS
END DO
END IF
RETURN
END SUBROUTINE fft_oned2box
END SUBROUTINE fft_oned2box_dp
SUBROUTINE fft_add_oned2box( qv, fg1, fg2 )
SUBROUTINE fft_add_oned2box_dp( qv, fg1, fg2 )
USE kinds, ONLY: DP
IMPLICIT NONE
COMPLEX(DP), INTENT(INOUT) :: qv(:)
@ -335,9 +352,248 @@ CONTAINS
END DO
END IF
RETURN
END SUBROUTINE fft_add_oned2box
END SUBROUTINE fft_add_oned2box_dp
!-----------------------------------------------------------------------
SUBROUTINE box2grid_dp(irb,nfft,qv,vr)
!-----------------------------------------------------------------------
!
! add array qv(r) on box grid to array vr(r) on dense grid
! irb : position of the box in the dense grid
! nfft=1 add real part of qv(r) to real part of array vr(r)
! nfft=2 add imaginary part of qv(r) to real part of array vr(r)
!
USE kinds, ONLY: dp
USE fft_base, ONLY: dfftp, dfftb
USE mp_global, ONLY: me_bgrp
IMPLICIT NONE
INTEGER, INTENT(in):: nfft, irb(3)
COMPLEX(dp), INTENT(in):: qv(dfftb%nnr)
COMPLEX(dp), INTENT(inout):: vr(dfftp%nnr)
!
INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig
INTEGER me
IF(nfft.LE.0.OR.nfft.GT.2) CALL errore('box2grid','wrong data',nfft)
me = me_bgrp + 1
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
IF(ibig3.LT.1.OR.ibig3.GT.dfftp%nr3) &
& CALL errore('box2grid','ibig3 wrong',ibig3)
ibig3=ibig3-dfftp%my_i0r3p
IF ( ibig3 .GT. 0 .AND. ibig3 .LE. ( dfftp%my_nr3p ) ) THEN
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
IF(ibig2.LT.1.OR.ibig2.GT.dfftp%nr2) &
& CALL errore('box2grid','ibig2 wrong',ibig2)
ibig2=ibig2-dfftp%my_i0r2p
IF ( ibig2 .GT. 0 .AND. ibig2 .LE. ( dfftp%my_nr2p ) ) THEN
!$omp critical
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
IF(ibig1.LT.1.OR.ibig1.GT.dfftp%nr1) &
& CALL errore('box2grid','ibig1 wrong',ibig1)
ibig=ibig1+(ibig2-1)*dfftp%nr1x+(ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir=ir1+(ir2-1)*dfftb%nr1x+(ir3-1)*dfftb%nr1x*dfftb%nr2x
IF( nfft == 1 ) THEN
vr(ibig) = vr(ibig)+REAL(qv(ir))
ELSE
vr(ibig) = vr(ibig)+AIMAG(qv(ir))
END IF
END DO
!$omp end critical
END IF
END DO
END IF
END DO
!
RETURN
END SUBROUTINE box2grid_dp
!-----------------------------------------------------------------------
SUBROUTINE box2grid2_dp(irb,qv,v)
!-----------------------------------------------------------------------
!
! add array qv(r) on box grid to array v(r) on dense grid
! irb : position of the box in the dense grid
!
USE kinds, ONLY: dp
USE fft_base, ONLY: dfftp, dfftb
USE mp_global, ONLY: me_bgrp
!
IMPLICIT NONE
!
INTEGER, INTENT(in):: irb(3)
COMPLEX(dp), INTENT(in):: qv(dfftb%nnr)
COMPLEX(dp), INTENT(inout):: v(dfftp%nnr)
!
INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig
INTEGER me
me = me_bgrp + 1
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
IF(ibig3.LT.1.OR.ibig3.GT.dfftp%nr3) &
& CALL errore('box2grid2','ibig3 wrong',ibig3)
ibig3=ibig3-dfftp%my_i0r3p
IF (ibig3.GT.0.AND.ibig3.LE. dfftp%my_nr3p ) THEN
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
IF(ibig2.LT.1.OR.ibig2.GT.dfftp%nr2) &
& CALL errore('box2grid2','ibig2 wrong',ibig2)
ibig2=ibig2-dfftp%my_i0r2p
IF (ibig2.GT.0.AND.ibig2.LE. dfftp%my_nr2p ) THEN
!$omp critical
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
IF(ibig1.LT.1.OR.ibig1.GT.dfftp%nr1) &
& CALL errore('box2grid2','ibig1 wrong',ibig1)
ibig=ibig1+(ibig2-1)*dfftp%nr1x+(ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir=ir1+(ir2-1)*dfftb%nr1x+(ir3-1)*dfftb%nr1x*dfftb%nr2x
v(ibig) = v(ibig)+qv(ir)
END DO
!$omp end critical
END IF
END DO
END IF
END DO
RETURN
END SUBROUTINE box2grid2_dp
!-----------------------------------------------------------------------
REAL(8) FUNCTION boxdotgrid_dp(irb,nfft,qv,vr)
!-----------------------------------------------------------------------
!
! Calculate \sum_i qv(r_i)*vr(r_i) with r_i on box grid
! array qv(r) is defined on box grid, array vr(r)on dense grid
! irb : position of the box in the dense grid
! nfft=1 (2): use real (imaginary) part of qv(r)
! Parallel execution: remember to sum the contributions from other nodes
!
USE kinds, ONLY: dp
USE fft_base, ONLY: dfftp, dfftb
USE mp_global, ONLY: me_bgrp
IMPLICIT NONE
INTEGER, INTENT(in):: nfft, irb(3)
COMPLEX(dp), INTENT(in):: qv(dfftb%nnr)
REAL(dp), INTENT(in):: vr(dfftp%nnr)
!
INTEGER ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig
INTEGER me
!
!
IF(nfft.LE.0.OR.nfft.GT.2) CALL errore('boxdotgrid','wrong data',nfft)
me = me_bgrp + 1
boxdotgrid_dp=0.d0
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
ibig3=ibig3-dfftp%my_i0r3p
IF (ibig3.GT.0.AND.ibig3.LE. dfftp%my_nr3p ) THEN
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
ibig2=ibig2-dfftp%my_i0r2p
IF (ibig2.GT.0.AND.ibig2.LE. dfftp%my_nr2p ) THEN
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
ibig=ibig1 + (ibig2-1)*dfftp%nr1x + (ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir =ir1 + (ir2-1)*dfftb%nr1x + (ir3-1)*dfftb%nr1x*dfftb%nr2x
IF( nfft == 1 ) THEN
boxdotgrid_dp = boxdotgrid_dp + REAL(qv(ir))*vr(ibig)
ELSE
boxdotgrid_dp = boxdotgrid_dp + AIMAG(qv(ir))*vr(ibig)
END IF
END DO
ENDIF
END DO
ENDIF
END DO
RETURN
END FUNCTION boxdotgrid_dp
!-----------------------------------------------------------------------
FUNCTION boxdotgridcplx_dp(irb,qv,vr)
!-----------------------------------------------------------------------
!
! Calculate \sum_i qv(r_i)*vr(r_i) with r_i on box grid
! array qv(r) is defined on box grid, array vr(r)on dense grid
! irb : position of the box in the dense grid
! Parallel execution: remember to sum the contributions from other nodes
!
! use ion_parameters
!
USE kinds, ONLY : DP
USE fft_base, ONLY : dfftp, dfftb
USE mp_global, ONLY : me_bgrp
!
IMPLICIT NONE
!
INTEGER, INTENT(IN):: irb(3)
COMPLEX(DP), INTENT(IN):: qv(dfftb%nnr), vr(dfftp%nnr)
COMPLEX(DP) :: boxdotgridcplx_dp
!
INTEGER :: ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig, me
!
me = me_bgrp + 1
!
boxdotgridcplx_dp = 0.0_DP
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
#if defined(__MPI)
ibig3 = ibig3 - dfftp%my_i0r3p
IF (ibig3.GT.0.AND.ibig3.LE.dfftp%my_nr3p) THEN
#endif
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
#if defined(__MPI)
ibig2 = ibig2 - dfftp%my_i0r2p
IF (ibig2.GT.0.AND.ibig2.LE.dfftp%my_nr2p) THEN
#endif
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
ibig=ibig1 + (ibig2-1)*dfftp%nr1x + (ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir =ir1 + (ir2-1)*dfftb%nr1x + (ir3-1)*dfftb%nr1x*dfftb%nr2x
boxdotgridcplx_dp = boxdotgridcplx_dp + qv(ir)*vr(ibig)
END DO
#if defined(__MPI)
ENDIF
#endif
END DO
#if defined(__MPI)
ENDIF
#endif
END DO
!
RETURN
!
END FUNCTION boxdotgridcplx_dp
!
!=----------------------------------------------------------------------=
END MODULE smallbox_subs

68
CPV/src/wf.f90
View File

@ -28,7 +28,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
USE cell_base, ONLY : omega, at, alat, h, ainv
USE electrons_base, ONLY : nbspx, nbsp, nupdwn, iupdwn, nspin
USE smallbox_gvec, ONLY : ngb
USE smallbox_subs, ONLY : fft_oned2box
USE smallbox_subs, ONLY : fft_oned2box, boxdotgrid
USE gvecw, ONLY : ngw
USE gvect, ONLY : gstart
USE control_flags, ONLY : iverbosity,conv_elec
@ -90,8 +90,6 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
REAL(DP) :: te(6)
INTEGER :: iunit
COMPLEX(DP), EXTERNAL :: boxdotgridcplx
!
#if defined (__MPI)
!
INTEGER :: proc, ntot, ncol, mc, ngpwpp(nproc_bgrp)
@ -331,7 +329,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
CALL invfft(qv,dfftb,isa)
iqv=1
qvt=(0.D0,0.D0)
qvt=boxdotgridcplx(irb(1,isa),qv,expo(1,inw))
qvt=boxdotgrid(irb(:,isa),qv,expo(:,inw))
#if defined(__MPI)
CALL mp_sum( qvt, intra_bgrp_comm )
@ -369,7 +367,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
CALL invfft(qv,dfftb,isa)
iqv=1
qvt=0.D0
qvt=boxdotgridcplx(irb(1,isa),qv,expo(1,inw))
qvt=boxdotgrid(irb(:,isa),qv,expo(:,inw))
#if defined(__MPI)
CALL mp_sum( qvt, intra_bgrp_comm )
#endif
@ -1957,66 +1955,6 @@ SUBROUTINE small_box_wf( i_1, j_1, k_1, nw1 )
RETURN
END SUBROUTINE small_box_wf
!
!-----------------------------------------------------------------------
FUNCTION boxdotgridcplx(irb,qv,vr)
!-----------------------------------------------------------------------
!
! Calculate \sum_i qv(r_i)*vr(r_i) with r_i on box grid
! array qv(r) is defined on box grid, array vr(r)on dense grid
! irb : position of the box in the dense grid
! Parallel execution: remember to sum the contributions from other nodes
!
! use ion_parameters
!
USE kinds, ONLY : DP
USE fft_base, ONLY : dfftp, dfftb
USE mp_global, ONLY : me_bgrp
!
IMPLICIT NONE
!
INTEGER, INTENT(IN):: irb(3)
COMPLEX(DP), INTENT(IN):: qv(dfftb%nnr), vr(dfftp%nnr)
COMPLEX(DP) :: boxdotgridcplx
!
INTEGER :: ir1, ir2, ir3, ir, ibig1, ibig2, ibig3, ibig, me
!
me = me_bgrp + 1
!
boxdotgridcplx = ZERO
DO ir3=1,dfftb%nr3
ibig3=irb(3)+ir3-1
ibig3=1+MOD(ibig3-1,dfftp%nr3)
#if defined(__MPI)
ibig3 = ibig3 - dfftp%my_i0r3p
IF (ibig3.GT.0.AND.ibig3.LE.dfftp%my_nr3p) THEN
#endif
DO ir2=1,dfftb%nr2
ibig2=irb(2)+ir2-1
ibig2=1+MOD(ibig2-1,dfftp%nr2)
#if defined(__MPI)
ibig2 = ibig2 - dfftp%my_i0r2p
IF (ibig2.GT.0.AND.ibig2.LE.dfftp%my_nr2p) THEN
#endif
DO ir1=1,dfftb%nr1
ibig1=irb(1)+ir1-1
ibig1=1+MOD(ibig1-1,dfftp%nr1)
ibig=ibig1 + (ibig2-1)*dfftp%nr1x + (ibig3-1)*dfftp%nr1x*dfftp%my_nr2p
ir =ir1 + (ir2-1)*dfftb%nr1x + (ir3-1)*dfftb%nr1x*dfftb%nr2x
boxdotgridcplx = boxdotgridcplx + qv(ir)*vr(ibig)
END DO
#if defined(__MPI)
ENDIF
#endif
END DO
#if defined(__MPI)
ENDIF
#endif
END DO
!
RETURN
!
END FUNCTION boxdotgridcplx
!
!----------------------------------------------------------------------------
SUBROUTINE write_rho_g( rhog )

BIN
Doc/brillouin_zones.pdf
View File

Binary file not shown.

BIN
Doc/constraints_HOWTO.pdf
View File

Binary file not shown.

BIN
Doc/developer_man.pdf
View File

Binary file not shown.

19
Doc/developer_man.tex
View File

@ -1297,6 +1297,23 @@ read\_namelists.f90 )
\end{verbatim}
\end{enumerate}
\subsection{Updating documentation}
Input variable documentation for most codes is contained into a
\texttt{*/Doc/INPUT\_*.def} file. Simple utilities may have instead
the input documentation in the header of the code source.
Files .def are processed to produce .xml, .txt, .html files.
The latter is the most important, being the one that is available
online in the web site.
The documentation must be processed with command ``make doc'' before
the release. Note that:
\begin{itemize}
\item in order to produce .xml, .txt, .html file,
"tcl", "tcllib", "xsltproc" are needed;
\item in order to build .pdf files from LaTeX, "pdflatex" is needed;
\item in order to build html files for user guide and developer manual,
"latex2html" and "convert" (from Image-Magick) are needed.
\end{itemize}
\section{Using git}
\label{Sec:git}
@ -1452,7 +1469,7 @@ The test-suite is also used by different Buildbot test-farm to automatically tes
The currently active test-farm machine can be accessed at
\texttt{test-farm.quantum-espresso.org} (points to a machine at CINECA:
\verb|{http://130.186.13.198:8010/#/}|
\verb|{http://130.186.13.169:8010/#/}|
\subsection{How to add tests for a new executable}

BIN
Doc/plumed_quick_ref.pdf
View File

Binary file not shown.

45
Doc/release-notes
View File

@ -1,3 +1,48 @@
New in development branch:
* turbo_eels code of TDDFPT module now works with ultrasoft pseudopotentials
and spin-orbit coupling together (Oleksandr Motornyi, Andrea Dal Corso,
Nathalie Vast). lr_sm1_psi.f90 of LR_Modules is rewritten and simplified.
Problems fixed in development branch :
* at2celldm wasn't properly converting vectors into celldm parameters
in the ibtrav=91 case (Tone)
* PP: plot_num=1 wasn't working any longer as expected due to forgotten
local potential term (noticed by Manoar Hossain, NISER)
* DOS calculation wasn't honoring "bz_sum='smearing'" if the nscf
calculation was performed with tetrahedra, contrary to what stated
in the documentation (noticed by Mohammedreza Hosseini, Modares Univ.)
* Time reversal symmetry in tetrahedron routine incorrectly detected
after a restart in phonon (reported by T. Tadano)
* pp.x with plot_num=11 in spin-polarized case was issuing a segmentation
fault error (noticed by Mauricio Chagas da Silva)
* pp.x with plot_num=17 in spin-polarized case was issuing a bogus
error (noticed by Shoaib Muhammad, Sungkyunkwan U.)
* vc-relax with cell_dofree='z' wasn't working exactly as expected
(noticed by Daniel Marchand, fixed by Lorenzo Paulatto)
* Incorrect link to wannier90 package (thanks to Nikolas Garofil)
* Bug in spin-polarized meta-GGA (noticed by Shoaib Muhammad,
Sungkyunkwan U.)
* Unphysical fractional translations (tau/n with n/=2,3,4,6) were not
explicitly discarded, thus leading in unfortunate cases to strange
values for FFT factors and grids. Also: if "nosym" is true, inversion
symmetry flag (invsym) and info on FFT factors (fft_fact) must also
be reset (problem spotted by Thomas Brumme, Leipzig)
* PPACF wasn't working any longer in v.6.4 and 6.4.1 for nspin=2 and
for hybrid functionals (fixed by Yang Jiao, Chalmers)
* option "write_unkg" of pw2wannier90.f90 wasn't working as expected
* Input parameters (for restarting DFPT+U calculations) read_dns_bare
and d2ns_type were missing in the PH input namelist, and moreover
they were not broadcasted.
Incompatible changes in development branch :
* Initialization has been reorganized, so some initialization routines
do not perform exactly the same operations as before - should have no
consequences for codes calling "read_file" to start the calculation,
but codes separately calling initialization routines may be affected
* fractional translations "ftau" in FFT grid units no longer existing as
global variables: replaced by "ft", in crystal axis, computed locally
where needed (in real-space symmetrization only)
New in 6.4.1 branch :
* A warning is issued if the lattice parameter seems to be a conversion
factor instead of a true lattice parameter. Conversion should be achieved

BIN
Doc/user_guide.pdf
View File

Binary file not shown.

636
EPW/bin/pp-xml.py → EPW/bin/pp-xml-depreciated.py
View File

@ -1,317 +1,319 @@
#!/usr/bin/python
#
# Post-processing script from of PH data in format used by EPW
# 14/07/2015 - Creation of the script - Samuel Ponce
# 14/03/2018 - Automatically reads the number of q-points - Michael Waters
# 14/03/2018 - Detect if SOC is included in the calculation - Samuel Ponce
# 13/11/2018 - Write dyn files in xml format for SOC case - Shunhong Zhang (USTC)
#
import numpy as np
import os
from xml.dom import minidom
# Convert the dyn files to the xml form, for SOC case - Shunhong Zhang (USTC)
def dyn2xml(prefix):
ndyn=int(os.popen('head -2 {0}.dyn0|tail -1'.format(prefix)).read())
for idyn in range(1,ndyn+1):
print '{0}.dyn{1} to {0}.dyn_q{1}.xml'.format(prefix,idyn)
dynmat=dyn(prefix,idyn)
dynmat._write_xml()
def get_geom_info():
if os.path.isfile('ph.out')==False:
print 'cannot extract geometry info from ph.out'
return 1
else:
volm=float(os.popen('grep -a volume ph.out 2>/dev/null|tail -1').readline().split()[-2])
get_at=os.popen('grep -a -A 3 "crystal axes" ph.out 2>/dev/null|tail -3').readlines()
at=np.array([[float(item) for item in line.split()[3:6]] for line in get_at])
get_bg=os.popen('grep -a -A 3 "reciprocal axes" ph.out 2>/dev/null|tail -3').readlines()
bg=np.array([[float(item) for item in line.split()[3:6]] for line in get_bg])
return volm,at,bg
class dyn(object):
def __init__(self,prefix,idyn):
self._prefix=prefix
self._idyn=idyn
fil='{0}.dyn{1}'.format(prefix,idyn)
f=open(fil)
self._comment=f.readline()
f.readline()
line=f.readline().split()
self._ntype=int(line[0])
self._natom=int(line[1])
self._ibrav=int(line[2])
self._nspin=1
self._cell_dim=np.array([float(ii) for ii in line[3:]])
self._volm=0
self._at=np.zeros((3,3),float)
self._bg=np.zeros((3,3),float)
try: self._volm,self._at,self._bg = get_geom_info()
except: print 'warning: lattice info not found'
self._species=[];
self._mass=[]
for i in range(self._ntype):
line=f.readline().split()
self._species.append(line[1].strip("'"))
self._mass.append(float(line[-1])/911.4442) # normalize to atomic mass
self._atom_type=np.zeros(self._natom,int)
self._pos=np.zeros((self._natom,3),float)
for i in range(self._natom):
line=f.readline().split()
self._atom_type[i]=int(line[1])
for j in range(3): self._pos[i,j]=float(line[j+2])
self._nqpt=int(os.popen('grep -c "Dynamical Matrix" {0}'.format(fil)).read().split()[0])
self._qpt=[]
self._dynmat=np.zeros((self._nqpt,self._natom,self._natom,3,3,2),float)
f.readline()
for iqpt in range(self._nqpt):
f.readline();
f.readline()
line=f.readline().split()
self._qpt.append(np.array([float(item) for item in line[3:6]]))
f.readline()
for i in range(self._natom):
for j in range(self._natom):
f.readline()
data=np.fromfile(f,sep=' ',count=18,dtype=float).reshape(3,3,2)
self._dynmat[iqpt,i,j]=data
self._qpt=np.array(self._qpt)
for i in range(5): f.readline()
self._freq=np.zeros((self._natom*3,2),float)
self._disp=np.zeros((self._natom*3,self._natom,3,2),float)
for i in range(self._natom*3):
line=f.readline().split()
self._freq[i,0]=float(line[4])
self._freq[i,1]=float(line[7])
for j in range(self._natom):
line=f.readline().split()[1:-1]
data=np.array([float(item) for item in line]).reshape(3,2)
self._disp[i,j]=data
def _write_xml(self):
doc=minidom.Document()
root = doc.createElement('Root')
doc.appendChild(root)
geom_info=doc.createElement('GEOMETRY_INFO')
tags=('NUMBER_OF_TYPES','NUMBER_OF_ATOMS','BRAVAIS_LATTICE_INDEX','SPIN_COMPONENTS')
numbers=(self._ntype,self._natom,self._ibrav,self._nspin)
for i,(tag,num) in enumerate(zip(tags,numbers)):
inode=doc.createElement(tag)
inode.setAttribute('type','integer')
inode.setAttribute('size','1')
inode.text=num
inode.appendChild(doc.createTextNode(str(num)))
geom_info.appendChild(inode)
cell_dim=doc.createElement('CELL_DIMENSIONS')
cell_dim.setAttribute('type','real')
cell_dim.setAttribute('size','6')
for i in range(6):
cell_dim.appendChild(doc.createTextNode('{0:16.10f}'.format(self._cell_dim[i])))
geom_info.appendChild(cell_dim)
tags=['AT','BG']
for tag,lat in zip(tags,(self._at,self._bg)):
inode=doc.createElement(tag)
inode.setAttribute('type','real')
inode.setAttribute('size','9')
inode.setAttribute('columns','3')
for i in range(3):
text=' '.join(['{0:16.10f}'.format(item) for item in lat[i]])
inode.appendChild(doc.createTextNode(text))
geom_info.appendChild(inode)
volm=doc.createElement('UNIT_CELL_VOLUME_AU')
volm.setAttribute('type','real')
volm.setAttribute('size','1')
volm.appendChild(doc.createTextNode('{0:16.10f}'.format(self._volm)))
geom_info.appendChild(volm)
for itype in range(self._ntype):
nt=doc.createElement('TYPE_NAME.{0}'.format(itype+1))
nt.setAttribute('type','character')
nt.setAttribute('size','1')
nt.setAttribute('len','3')
nt.appendChild(doc.createTextNode('{0}'.format(self._species[itype])))
na=doc.createElement('MASS.{0}'.format(itype+1))
na.setAttribute('type','real')
na.setAttribute('size','1')
na.appendChild(doc.createTextNode('{0:16.10f}'.format(self._mass[itype])))
geom_info.appendChild(nt)
geom_info.appendChild(na)
for iat in range(self._natom):
at=doc.createElement('ATOM.{0}'.format(iat+1))
at.setAttribute('SPECIES','{0}'.format(self._species[self._atom_type[iat]-1]))
at.setAttribute('INDEX',str(iat+1))
pos=' '.join(['{0:16.10f}'.format(item) for item in self._pos[iat]])
at.setAttribute('TAU',pos)
geom_info.appendChild(at)
nqpt=doc.createElement('NUMBER_OF_Q')
nqpt.setAttribute('type','integer')
nqpt.setAttribute('size','1')
nqpt.appendChild(doc.createTextNode(str(self._nqpt)))
geom_info.appendChild(nqpt)
root.appendChild(geom_info)
for iqpt in range(self._nqpt):
dynmat=doc.createElement('DYNAMICAL_MAT_.{0}'.format(iqpt+1))
qpt=doc.createElement('Q_POINT')
qpt.setAttribute('type','real')
qpt.setAttribute('size','3')
qpt.setAttribute('columns','3')
tnode=doc.createTextNode(' '.join(['{0:16.10f}'.format(item) for item in self._qpt[iqpt]]))
qpt.appendChild(tnode)
dynmat.appendChild(qpt)
for iat in range(self._natom):
for jat in range(self._natom):
ph=doc.createElement('PHI.{0}.{1}'.format(iat+1,jat+1))
ph.setAttribute('type','complex')
ph.setAttribute('size','9')
ph.setAttribute('columns','3')
for i in range(3):
for j in range(3):
text='{0:16.10f} {1:16.10f}'.format(self._dynmat[iqpt,iat,jat,i,j,0],self._dynmat[iqpt,iat,jat,i,j,1])
ph.appendChild(doc.createTextNode(text))
dynmat.appendChild(ph)
root.appendChild(dynmat)
mode=doc.createElement('FREQUENCIES_THZ_CMM1')
for iomega in range(self._natom*3):
inode=doc.createElement('OMEGA.{0}'.format(iomega+1))
inode.setAttribute('type','real')
inode.setAttribute('size','2')
inode.setAttribute('columns','2')
inode.appendChild(doc.createTextNode('{0:16.10f} {1:16.10f}'.format(self._freq[iomega,0],self._freq[iomega,1])))
idisp=doc.createElement('DISPLACEMENT.{0}'.format(iomega+1))
idisp.setAttribute('tpye','complex')
idisp.setAttribute('size','3')
for iat in range(self._natom):
for j in range(3):
tnode=doc.createTextNode('{0:16.10f} {1:16.10f}'.format(self._disp[iomega,iat,j,0],self._disp[iomega,iat,j,1]))
idisp.appendChild(tnode)
mode.appendChild(inode)
mode.appendChild(idisp)
root.appendChild(mode)
fp = open('{0}.dyn_q{1}.xml'.format(self._prefix,self._idyn), 'w')
doc.writexml(fp, addindent=' ', newl='\n')
# Return the number of q-points in the IBZ
def get_nqpt(prefix):
fname = '_ph0/' +prefix+'.phsave/control_ph.xml'
fid = open(fname,'r')
lines = fid.readlines() # these files are relatively small so reading the whole thing shouldn't be an issue
fid.close()
line_number_of_nqpt = 0
while 'NUMBER_OF_Q_POINTS' not in lines[line_number_of_nqpt]: # increment to line of interest
line_number_of_nqpt +=1
line_number_of_nqpt +=1 # its on the next line after that text
nqpt = int(lines[line_number_of_nqpt])
return nqpt
# Check if the calculation include SOC
def hasSOC(prefix):
fname = prefix+'.save/data-file-schema.xml'
xmldoc = minidom.parse(fname)
item = xmldoc.getElementsByTagName('spinorbit')[0]
lSOC = item.childNodes[0].data
return lSOC
# Check if the calculation was done in sequential
def isSEQ(prefix):
fname = '_ph0/'+str(prefix)+'.dvscf'
if (os.path.isfile(fname)):
lseq = True
else:
lseq = False
return lseq
# Enter the number of irr. q-points
user_input = raw_input('Enter the prefix used for PH calculations (e.g. diam)\n')
prefix = str(user_input)
# Test if SOC
SOC = hasSOC(prefix)
# If SOC detected, but dyn is not in XML and we want to convert it
if SOC=='true':
user_input = raw_input('Calculation with SOC detected. Do you want to convert dyn in XML format [y/n]?\n')
if str(user_input) == 'y':
dyn2xml(prefix)
os.system('mv {0}.dyn*.xml save'.format(prefix))
# If no SOC detected, do you want to convert into XML format
if SOC=='false':
user_input = raw_input('Calculation without SOC detected. Do you want to convert to xml anyway [y/n]?\n')
if str(user_input) == 'y':
SOC = 'true'
dyn2xml(prefix)
os.system('mv {0}.dyn*.xml save'.format(prefix))
# Test if seq. or parallel run
SEQ = isSEQ(prefix)
if True: # this gets the nqpt from the outputfiles
nqpt = get_nqpt(prefix)
else:
# Enter the number of irr. q-points
user_input = raw_input('Enter the number of irreducible q-points\n')
nqpt = user_input
try:
nqpt = int(user_input)
except ValueError:
raise Exception('The value you enter is not an integer!')
os.system('mkdir save 2>/dev/null')
for iqpt in np.arange(1,nqpt+1):
label = str(iqpt)
# Case calculation in seq.
if SEQ:
# Case with SOC
if SOC == 'true':
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix+'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
# Case without SOC
if SOC == 'false':
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q'+label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
else:
# Case with SOC
if SOC == 'true':
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix+'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
# Case without SOC
if SOC == 'false':
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q'+label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
#!/usr/bin/python
#
# Post-processing script from of PH data in format used by EPW
# 14/07/2015 - Creation of the script - Samuel Ponce
# 14/03/2018 - Automatically reads the number of q-points - Michael Waters
# 14/03/2018 - Detect if SOC is included in the calculation - Samuel Ponce
# 13/11/2018 - Write dyn files in xml format for SOC case - Shunhong Zhang (USTC)
#
import numpy as np
import os
from xml.dom import minidom
# Convert the dyn files to the xml form, for SOC case - Shunhong Zhang (USTC)
def dyn2xml(prefix):
ndyn=int(os.popen('head -2 {0}.dyn0|tail -1'.format(prefix)).read())
for idyn in range(1,ndyn+1):
print '{0}.dyn{1} to {0}.dyn_q{1}.xml'.format(prefix,idyn)
dynmat=dyn(prefix,idyn)
dynmat._write_xml()
def get_geom_info():
if os.path.isfile('ph.out')==False:
print 'cannot extract geometry info from ph.out'
return 1
else:
volm=float(os.popen('grep -a volume ph.out 2>/dev/null|tail -1').readline().split()[-2])
get_at=os.popen('grep -a -A 3 "crystal axes" ph.out 2>/dev/null|tail -3').readlines()
at=np.array([[float(item) for item in line.split()[3:6]] for line in get_at])
get_bg=os.popen('grep -a -A 3 "reciprocal axes" ph.out 2>/dev/null|tail -3').readlines()
bg=np.array([[float(item) for item in line.split()[3:6]] for line in get_bg])
return volm,at,bg
class dyn(object):
def __init__(self,prefix,idyn):
self._prefix=prefix
self._idyn=idyn
fil='{0}.dyn{1}'.format(prefix,idyn)
f=open(fil)
self._comment=f.readline()
f.readline()
line=f.readline().split()
self._ntype=int(line[0])
self._natom=int(line[1])
self._ibrav=int(line[2])
self._nspin=1
self._cell_dim=np.array([float(ii) for ii in line[3:]])
self._volm=0
self._at=np.zeros((3,3),float)
self._bg=np.zeros((3,3),float)
try: self._volm,self._at,self._bg = get_geom_info()
except: print 'warning: lattice info not found'
for i in range(0, 4):
f.readline()
self._species=[];
self._mass=[]
for i in range(self._ntype):
line=f.readline().split()
self._species.append(line[1].strip("'"))
self._mass.append(float(line[-1])/911.4442) # normalize to atomic mass
self._atom_type=np.zeros(self._natom,int)
self._pos=np.zeros((self._natom,3),float)
for i in range(self._natom):
line=f.readline().split()
self._atom_type[i]=int(line[1])
for j in range(3): self._pos[i,j]=float(line[j+2])
self._nqpt=int(os.popen('grep -c "Dynamical Matrix" {0}'.format(fil)).read().split()[0])
self._qpt=[]
self._dynmat=np.zeros((self._nqpt,self._natom,self._natom,3,3,2),float)
f.readline()
for iqpt in range(self._nqpt):
f.readline();
f.readline()
line=f.readline().split()
self._qpt.append(np.array([float(item) for item in line[3:6]]))
f.readline()
for i in range(self._natom):
for j in range(self._natom):
f.readline()
data=np.fromfile(f,sep=' ',count=18,dtype=float).reshape(3,3,2)
self._dynmat[iqpt,i,j]=data
self._qpt=np.array(self._qpt)
for i in range(5): f.readline()
self._freq=np.zeros((self._natom*3,2),float)
self._disp=np.zeros((self._natom*3,self._natom,3,2),float)
for i in range(self._natom*3):
line=f.readline().split()
self._freq[i,0]=float(line[4])
self._freq[i,1]=float(line[7])
for j in range(self._natom):
line=f.readline().split()[1:-1]
data=np.array([float(item) for item in line]).reshape(3,2)
self._disp[i,j]=data
def _write_xml(self):
doc=minidom.Document()
root = doc.createElement('Root')
doc.appendChild(root)
geom_info=doc.createElement('GEOMETRY_INFO')
tags=('NUMBER_OF_TYPES','NUMBER_OF_ATOMS','BRAVAIS_LATTICE_INDEX','SPIN_COMPONENTS')
numbers=(self._ntype,self._natom,self._ibrav,self._nspin)
for i,(tag,num) in enumerate(zip(tags,numbers)):
inode=doc.createElement(tag)
inode.setAttribute('type','integer')
inode.setAttribute('size','1')
inode.text=num
inode.appendChild(doc.createTextNode(str(num)))
geom_info.appendChild(inode)
cell_dim=doc.createElement('CELL_DIMENSIONS')
cell_dim.setAttribute('type','real')
cell_dim.setAttribute('size','6')
for i in range(6):
cell_dim.appendChild(doc.createTextNode('{0:16.10f}'.format(self._cell_dim[i])))
geom_info.appendChild(cell_dim)
tags=['AT','BG']
for tag,lat in zip(tags,(self._at,self._bg)):
inode=doc.createElement(tag)
inode.setAttribute('type','real')
inode.setAttribute('size','9')
inode.setAttribute('columns','3')
for i in range(3):
text=' '.join(['{0:16.10f}'.format(item) for item in lat[i]])
inode.appendChild(doc.createTextNode(text))
geom_info.appendChild(inode)
volm=doc.createElement('UNIT_CELL_VOLUME_AU')
volm.setAttribute('type','real')
volm.setAttribute('size','1')
volm.appendChild(doc.createTextNode('{0:16.10f}'.format(self._volm)))
geom_info.appendChild(volm)
for itype in range(self._ntype):
nt=doc.createElement('TYPE_NAME.{0}'.format(itype+1))
nt.setAttribute('type','character')
nt.setAttribute('size','1')
nt.setAttribute('len','3')
nt.appendChild(doc.createTextNode('{0}'.format(self._species[itype])))
na=doc.createElement('MASS.{0}'.format(itype+1))
na.setAttribute('type','real')
na.setAttribute('size','1')
na.appendChild(doc.createTextNode('{0:16.10f}'.format(self._mass[itype])))
geom_info.appendChild(nt)
geom_info.appendChild(na)
for iat in range(self._natom):
at=doc.createElement('ATOM.{0}'.format(iat+1))
at.setAttribute('SPECIES','{0}'.format(self._species[self._atom_type[iat]-1]))
at.setAttribute('INDEX',str(iat+1))
pos=' '.join(['{0:16.10f}'.format(item) for item in self._pos[iat]])
at.setAttribute('TAU',pos)
geom_info.appendChild(at)
nqpt=doc.createElement('NUMBER_OF_Q')
nqpt.setAttribute('type','integer')
nqpt.setAttribute('size','1')
nqpt.appendChild(doc.createTextNode(str(self._nqpt)))
geom_info.appendChild(nqpt)
root.appendChild(geom_info)
for iqpt in range(self._nqpt):
dynmat=doc.createElement('DYNAMICAL_MAT_.{0}'.format(iqpt+1))
qpt=doc.createElement('Q_POINT')
qpt.setAttribute('type','real')
qpt.setAttribute('size','3')
qpt.setAttribute('columns','3')
tnode=doc.createTextNode(' '.join(['{0:16.10f}'.format(item) for item in self._qpt[iqpt]]))
qpt.appendChild(tnode)
dynmat.appendChild(qpt)
for iat in range(self._natom):
for jat in range(self._natom):
ph=doc.createElement('PHI.{0}.{1}'.format(iat+1,jat+1))
ph.setAttribute('type','complex')
ph.setAttribute('size','9')
ph.setAttribute('columns','3')
for i in range(3):
for j in range(3):
text='{0:16.10f} {1:16.10f}'.format(self._dynmat[iqpt,iat,jat,i,j,0],self._dynmat[iqpt,iat,jat,i,j,1])
ph.appendChild(doc.createTextNode(text))
dynmat.appendChild(ph)
root.appendChild(dynmat)
mode=doc.createElement('FREQUENCIES_THZ_CMM1')
for iomega in range(self._natom*3):
inode=doc.createElement('OMEGA.{0}'.format(iomega+1))
inode.setAttribute('type','real')
inode.setAttribute('size','2')
inode.setAttribute('columns','2')
inode.appendChild(doc.createTextNode('{0:16.10f} {1:16.10f}'.format(self._freq[iomega,0],self._freq[iomega,1])))
idisp=doc.createElement('DISPLACEMENT.{0}'.format(iomega+1))
idisp.setAttribute('tpye','complex')
idisp.setAttribute('size','3')
for iat in range(self._natom):
for j in range(3):
tnode=doc.createTextNode('{0:16.10f} {1:16.10f}'.format(self._disp[iomega,iat,j,0],self._disp[iomega,iat,j,1]))
idisp.appendChild(tnode)
mode.appendChild(inode)
mode.appendChild(idisp)
root.appendChild(mode)
fp = open('{0}.dyn_q{1}.xml'.format(self._prefix,self._idyn), 'w')
doc.writexml(fp, addindent=' ', newl='\n')
# Return the number of q-points in the IBZ
def get_nqpt(prefix):
fname = '_ph0/' +prefix+'.phsave/control_ph.xml'
fid = open(fname,'r')
lines = fid.readlines() # these files are relatively small so reading the whole thing shouldn't be an issue
fid.close()
line_number_of_nqpt = 0
while 'NUMBER_OF_Q_POINTS' not in lines[line_number_of_nqpt]: # increment to line of interest
line_number_of_nqpt +=1
line_number_of_nqpt +=1 # its on the next line after that text
nqpt = int(lines[line_number_of_nqpt])
return nqpt
# Check if the calculation include SOC
def hasSOC(prefix):
fname = prefix+'.save/data-file-schema.xml'
xmldoc = minidom.parse(fname)
item = xmldoc.getElementsByTagName('spinorbit')[0]
lSOC = item.childNodes[0].data
return lSOC
# Check if the calculation was done in sequential
def isSEQ(prefix):
fname = '_ph0/'+str(prefix)+'.dvscf'
if (os.path.isfile(fname)):
lseq = True
else:
lseq = False
return lseq
# Enter the number of irr. q-points
user_input = raw_input('Enter the prefix used for PH calculations (e.g. diam)\n')
prefix = str(user_input)
# Test if SOC
SOC = hasSOC(prefix)
# If SOC detected, but dyn is not in XML and we want to convert it
if SOC=='true':
user_input = raw_input('Calculation with SOC detected. Do you want to convert dyn in XML format [y/n]?\n')
if str(user_input) == 'y':
dyn2xml(prefix)
os.system('mv {0}.dyn*.xml save'.format(prefix))
# If no SOC detected, do you want to convert into XML format
if SOC=='false':
user_input = raw_input('Calculation without SOC detected. Do you want to convert to xml anyway [y/n]?\n')
if str(user_input) == 'y':
SOC = 'true'
dyn2xml(prefix)
os.system('mv {0}.dyn*.xml save'.format(prefix))
# Test if seq. or parallel run
SEQ = isSEQ(prefix)
if True: # this gets the nqpt from the outputfiles
nqpt = get_nqpt(prefix)
else:
# Enter the number of irr. q-points
user_input = raw_input('Enter the number of irreducible q-points\n')
nqpt = user_input
try:
nqpt = int(user_input)
except ValueError:
raise Exception('The value you enter is not an integer!')
os.system('mkdir save 2>/dev/null')
for iqpt in np.arange(1,nqpt+1):
label = str(iqpt)
# Case calculation in seq.
if SEQ:
# Case with SOC
if SOC == 'true':
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix+'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
# Case without SOC
if SOC == 'false':
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q'+label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
else:
# Case with SOC
if SOC == 'true':
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix+'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
# Case without SOC
if SOC == 'false':
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q'+label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )

223
EPW/bin/pp.py
View File

@ -3,120 +3,167 @@
# Post-processing script from of PH data in format used by EPW
# 14/07/2015 - Creation of the script - Samuel Ponce
# 14/03/2018 - Automatically reads the number of q-points - Michael Waters
# 14/03/2018 - Detect if SOC is included in the calculation - Samuel Ponce
#
import numpy as np
# 14/03/2018 - Detect if SOC is included in the calculation - Samuel Ponce
# 05/06/2019 - Removed SOC for xml detection instead - Felix Goudreault
#
from __future__ import print_function
try:
from builtins import input
except ImportError:
print('Install future. e.g. "pip install --user future"')
# import numpy as np
import os
from xml.dom import minidom
# Return the number of q-points in the IBZ
def get_nqpt(prefix):
fname = '_ph0/' +prefix+'.phsave/control_ph.xml'
fname = '_ph0/' + prefix + '.phsave/control_ph.xml'
fid = open(fname,'r')
lines = fid.readlines() # these files are relatively small so reading the whole thing shouldn't be an issue
fid.close()
fid = open(fname, 'r')
lines = fid.readlines()
# these files are relatively small so reading the whole thing shouldn't
# be an issue
fid.close()
line_number_of_nqpt = 0
while 'NUMBER_OF_Q_POINTS' not in lines[line_number_of_nqpt]: # increment to line of interest
line_number_of_nqpt +=1
line_number_of_nqpt +=1 # its on the next line after that text
line_number_of_nqpt = 0
while 'NUMBER_OF_Q_POINTS' not in lines[line_number_of_nqpt]:
# increment to line of interest
line_number_of_nqpt += 1
line_number_of_nqpt += 1 # its on the next line after that text
nqpt = int(lines[line_number_of_nqpt])
nqpt = int(lines[line_number_of_nqpt])
return nqpt
return nqpt
# Check if the calculation include SOC
def hasSOC(prefix):
fname = prefix+'.save/data-file-schema.xml'
fname = prefix+'.save/data-file-schema.xml'
xmldoc = minidom.parse(fname)
item = xmldoc.getElementsByTagName('spinorbit')[0]
lSOC = item.childNodes[0].data
return lSOC
# check if calculation used xml files (irrelevant of presence of SOC)
def hasXML(prefix):
# check for a file named prefix.dyn1.xml
# if it exists => return True else return False
fname = os.path.join(prefix + ".dyn1.xml")
if os.path.isfile(fname):
return True
# check if the other without .xml extension exists
# if not raise an error
fname_no_xml = fname.strip(".xml")
class FileNotFoundError(Exception):
pass
if not os.path.isfile(fname_no_xml):
raise FileNotFoundError(
"No dyn0 file found cannot tell if xml format was used.")
return False
xmldoc = minidom.parse(fname)
item = xmldoc.getElementsByTagName('spinorbit')[0]
lSOC = item.childNodes[0].data
return lSOC
# Check if the calculation was done in sequential
def isSEQ(prefix):
fname = '_ph0/'+str(prefix)+'.dvscf'
if (os.path.isfile(fname)):
lseq = True
else:
lseq = False
return lseq
fname = '_ph0/'+str(prefix)+'.dvscf'
if (os.path.isfile(fname)):
lseq = True
else:
lseq = False
return lseq
# Enter the number of irr. q-points
user_input = raw_input('Enter the prefix used for PH calculations (e.g. diam)\n')
user_input = input(
'Enter the prefix used for PH calculations (e.g. diam)\n')
prefix = str(user_input)
# Test if SOC
SOC = hasSOC(prefix)
# # Test if SOC
# SOC = hasSOC(prefix)
# Test if '.xml' files are used
XML = hasXML(prefix)
# Test if seq. or parallel run
SEQ = isSEQ(prefix)
if True: # this gets the nqpt from the outputfiles
nqpt = get_nqpt(prefix)
if True: # this gets the nqpt from the outputfiles
nqpt = get_nqpt(prefix)
else:
# Enter the number of irr. q-points
user_input = raw_input('Enter the number of irreducible q-points\n')
nqpt = user_input
try:
nqpt = int(user_input)
except ValueError:
raise Exception('The value you enter is not an integer!')
# Enter the number of irr. q-points
user_input = input(
'Enter the number of irreducible q-points\n')
nqpt = user_input
try:
nqpt = int(user_input)
except ValueError:
raise Exception('The value you enter is not an integer!')
os.system('mkdir save 2>/dev/null')
for iqpt in np.arange(1,nqpt+1):
label = str(iqpt)
# Case calculation in seq.
if SEQ:
# Case with SOC
if SOC == 'true':
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix+'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
# Case without SOC
if SOC == 'false':
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q'+label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
else:
# Case with SOC
if SOC == 'true':
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix+'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
# Case without SOC
if SOC == 'false':
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q'+label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*' )
for iqpt in range(1, nqpt+1):
label = str(iqpt)
# Case calculation in seq.
if SEQ:
# Case with XML files
if XML:
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix
+ '.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf* save/'+prefix+'.dvscf_q'
+ label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix +
'.dvscf* save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*')
# Case without XML files
else:
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q' +
label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf save/'+prefix+'.dvscf_q' +
label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix +
'.dvscf save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*')
else:
# Case with XML format
if XML:
os.system('cp '+prefix+'.dyn0 '+prefix+'.dyn0.xml')
os.system('cp '+prefix+'.dyn'+str(iqpt)+'.xml save/'+prefix +
'.dyn_q'+label+'.xml')
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q' +
label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc.xml save/ifc.q2r.xml')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix +
'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*')
# Case without XML format
else:
os.system('cp '+prefix+'.dyn'+str(iqpt)+' save/'+prefix+'.dyn_q' +
label)
if (iqpt == 1):
os.system('cp _ph0/'+prefix+'.dvscf1 save/'+prefix+'.dvscf_q' +
label)
os.system('cp -r _ph0/'+prefix+'.phsave save/')
os.system('cp '+prefix+'.fc save/ifc.q2r')
else:
os.system('cp _ph0/'+prefix+'.q_'+str(iqpt)+'/'+prefix +
'.dvscf1 save/'+prefix+'.dvscf_q'+label)
os.system('rm _ph0/'+prefix+'.q_'+str(iqpt)+'/*wfc*')

1
EPW/src/Makefile
View File

@ -38,7 +38,6 @@ transport_iter.o \
wigner.o \
a2f.o \
adddvscf2.o \
allocate_epwq.o \
bcast_epw_input.o \
bloch2wan.o \
broyden.o \

62
EPW/src/a2f.f90
View File

@ -29,7 +29,7 @@
USE phcom, ONLY : nmodes
USE cell_base, ONLY : omega
USE epwcom, ONLY : degaussq, delta_qsmear, nqsmear, nqstep, nsmear, eps_acustic, &
delta_smear, degaussw, fsthick
delta_smear, degaussw, fsthick, nc
USE elph2, ONLY : nqtotf, wf, wqf, lambda_all, lambda_v_all
USE constants_epw, ONLY : ryd2mev, ryd2ev, kelvin2eV, two, zero, kelvin2Ry, pi
USE mp, ONLY : mp_barrier, mp_sum
@ -54,32 +54,32 @@
!
!
CALL start_clock('a2F')
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
!
DO isig = 1, nsmear
!
IF ( isig .lt. 10 ) THEN
IF ( isig < 10 ) THEN
WRITE(fila2f_suffix,'(a,a6,i1)') TRIM(prefix),'.a2f.0', isig
ELSE
WRITE(fila2f_suffix,'(a,a5,i2)') TRIM(prefix),'.a2f.', isig
ENDIF
OPEN (unit = iua2ffil, file = fila2f_suffix, form = 'formatted')
!
IF ( isig .lt. 10 ) THEN
IF ( isig < 10 ) THEN
WRITE(fila2ftr,'(a,a9,i1)') TRIM(prefix),'.a2f_tr.0', isig
ELSE
WRITE(fila2ftr,'(a,a8,i2)') TRIM(prefix),'.a2f_tr.', isig
ENDIF
OPEN (unit = iua2ftrfil, file = fila2ftr, form = 'formatted')
!
IF ( isig .lt. 10 ) THEN
IF ( isig < 10 ) THEN
WRITE(filres,'(a,a6,i1)') TRIM(prefix),'.res.0', isig
ELSE
WRITE(filres,'(a,a5,i2)') TRIM(prefix),'.res.', isig
ENDIF
OPEN (unit = iures, file = filres, form = 'formatted')
!
IF ( isig .lt. 10 ) THEN
IF ( isig < 10 ) THEN
WRITE(fildos,'(a,a8,i1)') TRIM(prefix),'.phdos.0', isig
ELSE
WRITE(fildos,'(a,a7,i2)') TRIM(prefix),'.phdos.', isig
@ -90,16 +90,16 @@
WRITE(stdout,'(5x,"Eliashberg Spectral Function in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') REPEAT('=',67)
!
IF ( .not. ALLOCATED(a2F) ) ALLOCATE( a2F(nqstep, nqsmear) )
IF ( .not. ALLOCATED(a2F_tr) ) ALLOCATE( a2F_tr(nqstep, nqsmear) )
IF ( .not. ALLOCATED(dosph) ) ALLOCATE( dosph(nqstep, nqsmear) )
IF ( .not. ALLOCATED(l_a2F) ) ALLOCATE( l_a2F(nqsmear) )
IF ( .not. ALLOCATED(l_a2F_tr) ) ALLOCATE( l_a2F_tr(nqsmear) )
IF ( .not. ALLOCATED(logavg) ) ALLOCATE( logavg(nqsmear) )
IF ( .NOT. ALLOCATED(a2F) ) ALLOCATE ( a2F(nqstep, nqsmear) )
IF ( .NOT. ALLOCATED(a2F_tr) ) ALLOCATE ( a2F_tr(nqstep, nqsmear) )
IF ( .NOT. ALLOCATED(dosph) ) ALLOCATE ( dosph(nqstep, nqsmear) )
IF ( .NOT. ALLOCATED(l_a2F) ) ALLOCATE ( l_a2F(nqsmear) )
IF ( .NOT. ALLOCATED(l_a2F_tr) ) ALLOCATE ( l_a2F_tr(nqsmear) )
IF ( .NOT. ALLOCATED(logavg) ) ALLOCATE ( logavg(nqsmear) )
!
! The resitivity is computed for temperature between 0K-1000K by step of 10
! This is hardcoded and needs to be changed here if one wants to modify it
IF ( .not. ALLOCATED(rho) ) ALLOCATE( rho(100, nqsmear) )
IF ( .NOT. ALLOCATED(rho) ) ALLOCATE ( rho(100, nqsmear) )
!
!om_max = ( MAXVAL( wf(:,:) ) - MINVAL( wf(:,:) ) ) + 5.d0/ryd2mev
!om_max = MAXVAL( wf(:,:) ) + 1.d0 / ryd2mev
@ -131,10 +131,10 @@
!
w0 = wf(imode,iq)
!
IF ( w0 .gt. eps_acustic ) THEN
IF ( w0 > eps_acustic ) THEN
!
l = lambda_all(imode,iq,isig)
IF (lambda_all(imode,iq,isig) .lt. 0.d0) l = 0.d0 ! sanity check
IF (lambda_all(imode,iq,isig) < 0.d0) l = 0.d0 ! sanity check
!
a2F_tmp = wqf(iq) * w0 * l / two
!
@ -143,7 +143,7 @@
dosph(iw,ismear) = dosph(iw,ismear) + wqf(iq) * weight
!
l_tr = lambda_v_all(imode,iq,isig)
IF (lambda_v_all(imode,iq,isig) .lt. 0.d0) l_tr = 0.d0 !sanity check
IF (lambda_v_all(imode,iq,isig) < 0.d0) l_tr = 0.d0 !sanity check
!
a2F_tr_tmp = wqf(iq) * w0 * l_tr / two
!
@ -157,13 +157,13 @@
!
! output a2F
!
IF (ismear .eq. nqsmear) WRITE (iua2ffil, '(f12.7, 15f12.7)') iomega*ryd2mev, a2F(iw,:)
IF (ismear .eq. nqsmear) WRITE (iua2ftrfil, '(f12.7, 15f12.7)') iomega*ryd2mev, a2F_tr(iw,:)
IF (ismear .eq. nqsmear) WRITE (iudosfil, '(f12.7, 15f12.7)') iomega*ryd2mev, dosph(iw,:)/ryd2mev
IF (ismear == nqsmear) WRITE (iua2ffil, '(f12.7, 15f12.7)') iomega*ryd2mev, a2F(iw,:)
IF (ismear == nqsmear) WRITE (iua2ftrfil, '(f12.7, 15f12.7)') iomega*ryd2mev, a2F_tr(iw,:)
IF (ismear == nqsmear) WRITE (iudosfil, '(f12.7, 15f12.7)') iomega*ryd2mev, dosph(iw,:)/ryd2mev
!
! do the integral 2 int (a2F(w)/w dw)
!
!IF (iomega .gt. eps_acustic) &
!IF (iomega > eps_acustic) &
l_a2F(ismear) = l_a2F(ismear) + two * a2F(iw,ismear) / iomega * dw
l_a2F_tr(ismear) = l_a2F_tr(ismear) + two * a2F_tr(iw,ismear) / iomega * dw
logavg(ismear) = logavg(ismear) + two * a2F(iw,ismear) * log(iomega) / iomega * dw
@ -176,9 +176,9 @@
!
DO iq = 1, nqtotf ! loop over q-points
DO imode = 1, nmodes ! loop over modes
IF (lambda_all(imode,iq,isig) .gt. 0.d0 .and. wf(imode,iq) .gt. eps_acustic ) &
IF (lambda_all(imode,iq,isig) > 0.d0 .and. wf(imode,iq) > eps_acustic ) &
lambda_tot = lambda_tot + wqf(iq) * lambda_all(imode,iq,isig)
IF (lambda_v_all(imode,iq,isig) .gt. 0.d0 .and. wf(imode,iq) .gt. eps_acustic ) &
IF (lambda_v_all(imode,iq,isig) > 0.d0 .and. wf(imode,iq) > eps_acustic ) &
lambda_tr_tot = lambda_tr_tot + wqf(iq) * lambda_v_all(imode,iq,isig)
ENDDO
ENDDO
@ -214,7 +214,7 @@
! Usually this means "the number of electrons that contribute to the mobility" and so it is typically 8 (full shell)
! but not always. You might want to check this.
!
n = 8.0 / omega
n = nc / omega
!print*,'omega ',omega
WRITE (iures, '(a)') '# Temperature [K] Resistivity [micro Ohm cm] for different Phonon smearing (meV) '
WRITE (iures, '("# ", 15f12.7)') ( (degaussq+(ismear-1)*delta_qsmear)*ryd2mev,ismear=1,nqsmear )
@ -236,7 +236,7 @@
! Conductivity 1 a.u. = 2.2999241E6 S/m
! Now to go from Ohm*m to micro Ohm cm we need to multiply by 1E8
rho(itemp,ismear) = rho(itemp,ismear) * 1E8 / 2.2999241E6
IF (ismear .eq. nqsmear) WRITE (iures, '(i8, 15f12.7)') itemp * 10, rho(itemp,:)
IF (ismear == nqsmear) WRITE (iures, '(i8, 15f12.7)') itemp * 10, rho(itemp,:)
ENDDO
ENDDO
CLOSE(iures)
@ -261,13 +261,13 @@
!
CLOSE(iudosfil)
!
IF ( ALLOCATED(l_a2F) ) DEALLOCATE(l_a2F)
IF ( ALLOCATED(l_a2F_tr) ) DEALLOCATE(l_a2F_tr)
IF ( ALLOCATED(a2F) ) DEALLOCATE(a2F)
IF ( ALLOCATED(a2F_tr) ) DEALLOCATE(a2F_tr)
IF ( ALLOCATED(rho) ) DEALLOCATE(rho)
IF ( ALLOCATED(dosph) ) DEALLOCATE(dosph)
IF ( ALLOCATED(logavg) ) DEALLOCATE(logavg)
IF ( ALLOCATED(l_a2F) ) DEALLOCATE (l_a2F)
IF ( ALLOCATED(l_a2F_tr) ) DEALLOCATE (l_a2F_tr)
IF ( ALLOCATED(a2F) ) DEALLOCATE (a2F)
IF ( ALLOCATED(a2F_tr) ) DEALLOCATE (a2F_tr)
IF ( ALLOCATED(rho) ) DEALLOCATE (rho)
IF ( ALLOCATED(dosph) ) DEALLOCATE (dosph)
IF ( ALLOCATED(logavg) ) DEALLOCATE (logavg)
!
ENDDO ! isig
!

11
EPW/src/adddvscf2.f90
View File

@ -25,7 +25,8 @@
USE kinds, ONLY : DP
USE uspp_param, ONLY : upf, nh
USE uspp, ONLY : vkb, okvan
USE lsda_mod, ONLY : lsda, current_spin, isk
USE lsda_mod, ONLY : lsda, current_spin
USE klist_epw, ONLY : isk_loc
USE ions_base, ONLY : ntyp => nsp, nat, ityp
USE wvfct, ONLY : npwx
USE lrus, ONLY : int3, int3_nc, becp1
@ -72,17 +73,17 @@
COMPLEX(kind=DP) :: sum_nc(npol)
!! auxiliary sum variable non-collinear case
!
IF (.not.okvan) RETURN
IF (.NOT. okvan) RETURN
!
CALL start_clock('adddvscf2')
!
IF (lsda) current_spin = isk(ik)
IF (lsda) current_spin = isk_loc(ik)
!
ijkb0 = 0
DO nt = 1, ntyp
IF ( upf(nt)%tvanp ) THEN
DO na = 1, nat
IF (ityp(na) .eq. nt) THEN
IF (ityp(na) == nt) THEN
!
! we multiply the integral for the becp term and the beta_n
!
@ -123,7 +124,7 @@
ENDDO
ELSE
DO na = 1, nat
IF (ityp(na) .eq. nt) ijkb0 = ijkb0 + nh(nt)
IF (ityp(na) == nt) ijkb0 = ijkb0 + nh(nt)
ENDDO
ENDIF
ENDDO

106
EPW/src/allocate_epwq.f90
View File

@ -1,106 +0,0 @@
!
! Copyright (C) 2010-2016 Samuel Ponce', Roxana Margine, Carla Verdi, Feliciano Giustino
! Copyright (C) 2007-2009 Jesse Noffsinger, Brad Malone, Feliciano Giustino
!
! This file is distributed under the terms of the GNU General Public
! License. See the file `LICENSE' in the root directory of the
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
! Code adapted from PH/allocate_phq - Quantum-ESPRESSO group
! 09/2009 There is a lot of excess in this file.
!
!-----------------------------------------------------------------------
SUBROUTINE allocate_epwq
!-----------------------------------------------------------------------
!!
!! Dynamical allocation of arrays: quantities needed for the linear
!! response problem
!!
!! RM - Nov/Dec - 2014 - Imported the noncolinear case implemented by xlzhang
!! SP - 2016 - Updated for QE 5
!! RM - Jan 2019 - Updated based on QE 6.3
!!
USE ions_base, ONLY : nat, ntyp => nsp
USE pwcom, ONLY : npwx, nbnd, nspin
USE gvect, ONLY : ngm
USE noncollin_module, ONLY : noncolin, npol, nspin_mag
USE spin_orb, ONLY : lspinorb
USE phcom, ONLY : evq, vlocq, dmuxc
USE phus, ONLY : int1, int1_nc, int2, int2_so, &
int4, int4_nc, int5, int5_so, &
alphap
USE lr_symm_base, ONLY : rtau
USE qpoint, ONLY : eigqts
USE lrus, ONLY : becp1
USE elph2, ONLY : elph, el_ph_mat
USE becmod, ONLY : becp, allocate_bec_type
USE uspp_param, ONLY : nhm
USE uspp, ONLY : okvan, nkb
USE modes, ONLY : u, npert, name_rap_mode, num_rap_mode
USE klist, ONLY : nks
USE fft_base, ONLY : dfftp
USE transportcom, ONLY : transp_temp
USE epwcom, ONLY : nstemp
!
IMPLICIT NONE
!
INTEGER :: ik
!! k-point
INTEGER :: ipol
!! Polarization index
!
! ALLOCATE space for the quantities needed in EPW
!
ALLOCATE (evq(npwx*npol, nbnd))
ALLOCATE (transp_temp(nstemp))
!
ALLOCATE (vlocq(ngm, ntyp))
! SP: nrxx is not used in QE 5 ==> tg_nnr is the maximum among nnr
! This should have the same dim as nrxx had.
! ALLOCATE (dmuxc ( nrxx, nspin, nspin))
! SP: Again a new change in QE (03/08/2016)
! ALLOCATE (dmuxc ( dffts%tg_nnr, nspin, nspin))
! SP: Following new FFT restructuration from Aug. 2017 (SdG)
! nnr = local number of FFT grid elements ( ~nr1*nr2*nr3/nproc )
! nnr_tg = local number of grid elements for task group FFT ( ~nr1*nr2*nr3/proc3 )
! --> tg = task group
! ALLOCATE (dmuxc ( dffts%nnr, nspin, nspin))
!
ALLOCATE (dmuxc(dfftp%nnr, nspin_mag, nspin_mag))
ALLOCATE (eigqts(nat))
ALLOCATE (rtau(3, 48, nat))
ALLOCATE (u(3 * nat, 3 * nat))
ALLOCATE (name_rap_mode(3 * nat))
ALLOCATE (num_rap_mode(3 * nat ))
ALLOCATE (npert(3 * nat))
IF (okvan) THEN
ALLOCATE (int1(nhm, nhm, 3, nat, nspin_mag))
ALLOCATE (int2(nhm, nhm, 3, nat, nat))
ALLOCATE (int4(nhm * (nhm + 1)/2, 3, 3, nat, nspin_mag))
ALLOCATE (int5(nhm * (nhm + 1)/2, 3, 3, nat , nat))
IF (noncolin) THEN
ALLOCATE (int1_nc(nhm, nhm, 3, nat, nspin))
ALLOCATE (int4_nc(nhm, nhm, 3, 3, nat, nspin))
IF (lspinorb) THEN
ALLOCATE (int2_so(nhm, nhm, 3, nat, nat, nspin))
ALLOCATE (int5_so(nhm, nhm, 3, 3, nat, nat, nspin))
ENDIF
ENDIF ! noncolin
ENDIF
!
ALLOCATE (becp1(nks))
ALLOCATE (alphap(3,nks))
!
DO ik = 1, nks
CALL allocate_bec_type(nkb, nbnd, becp1(ik))
DO ipol = 1, 3
CALL allocate_bec_type(nkb, nbnd, alphap(ipol,ik))
ENDDO
ENDDO
CALL allocate_bec_type(nkb, nbnd, becp)
!
IF (elph) ALLOCATE (el_ph_mat(nbnd, nbnd, nks, 3*nat))
!
RETURN
!
END SUBROUTINE allocate_epwq

6
EPW/src/bcast_epw_input.f90
View File

@ -27,7 +27,7 @@
conv_thr_racon, conv_thr_iaxis, broyden_ndim, &
broyden_beta, band_plot, a2f, lacon, &
kmaps, kerwrite, kerread, imag_read, &
gap_edge, fsthick, filukq, filukk, filqf, filkf, &
gap_edge, fsthick, filqf, filkf, &
fileig, fila2f, fermi_energy, &
etf_mem, epwwrite, epwread, eptemp, &
eps_acustic, ephwrite, epbread, nsiter, nqstep, &
@ -215,8 +215,6 @@
CALL mp_bcast (prefix , meta_ionode_id, world_comm)
CALL mp_bcast (filkf , meta_ionode_id, world_comm)
CALL mp_bcast (filqf , meta_ionode_id, world_comm)
CALL mp_bcast (filukk , meta_ionode_id, world_comm)
CALL mp_bcast (filukq , meta_ionode_id, world_comm)
CALL mp_bcast (fileig , meta_ionode_id, world_comm)
CALL mp_bcast (dvscf_dir , meta_ionode_id, world_comm)
CALL mp_bcast (fila2f , meta_ionode_id, world_comm)
@ -240,7 +238,7 @@ SUBROUTINE bcast_epw_input1
! integers
!
CALL mp_bcast (nat_todo, meta_ionode_id, world_comm)
IF (nat_todo.gt.0) THEN
IF (nat_todo > 0) THEN
CALL mp_bcast (atomo, meta_ionode_id, world_comm)
ENDIF
#endif

60
EPW/src/bloch2wan.f90
View File

@ -120,7 +120,7 @@
!
et_tmp = zero
et_opt = zero
IF (nexband_tmp .gt. 0) THEN
IF (nexband_tmp > 0) THEN
DO ik = 1, nks
ibnd = 0
DO i = 1, nbnd
@ -215,9 +215,9 @@
! [mind when comparing with wannier code (eV and angstrom units) with
! write_hr=.true.]
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
!
OPEN(unit=iudecayH,file='decay.H')
OPEN(UNIT=iudecayH,FILE='decay.H')
WRITE(iudecayH, '(/3x,a/)') '#Spatial decay of Hamiltonian in Wannier basis'
DO ir = 1, nrr
!
@ -351,7 +351,7 @@
!
dmec_opt = czero
dmec_tmp = czero
IF (nexband_tmp .gt. 0) THEN
IF (nexband_tmp > 0) THEN
DO ik = 1,nks
jbnd = 0
DO j = 1, nbnd
@ -414,8 +414,8 @@
DO ik = 1, nks
DO ipol = 1, 3
!
! dmec_utmp(:,:) = matmul( dmec_opt(ipol,:,:,ik), cu(:,:,ik) )
! cps(ipol,:,:,ik) = matmul( conjg(transpose( cu(:,:,ik))), dmec_utmp(:,:) )
! dmec_utmp(:,:) = MATMUL( dmec_opt(ipol,:,:,ik), cu(:,:,ik) )
! cps(ipol,:,:,ik) = MATMUL( conjg(transpose( cu(:,:,ik))), dmec_utmp(:,:) )
!
CALL zgemm ('n', 'n', nbnd, nbndsub, nbnd, cone, dmec_opt(ipol,:,:,ik), &
nbnd, cu(:,:,ik), nbnd, czero, dmec_utmp(:,:), nbnd)
@ -459,8 +459,8 @@
! Check spatial decay of Dipole in Wannier basis
! the unit in r-space is angstrom
!
IF (mpime.eq.ionode_id) THEN
OPEN(unit=iudecayP,file='decay.P')
IF (mpime == ionode_id) THEN
OPEN(UNIT=iudecayP,FILE='decay.P')
WRITE(iudecayP, '(/3x,a/)') '#Spatial decay of dipole in Wannier basis'
DO ir = 1, nrr
!
@ -599,8 +599,8 @@
! the unit in r-space is angstrom, and I am plotting
! the matrix for the first mode only
!
IF (mpime.eq.ionode_id) THEN
OPEN(unit=iudecaydyn,file='decay.dynmat')
IF (mpime == ionode_id) THEN
OPEN(UNIT=iudecaydyn,FILE='decay.dynmat')
WRITE(iudecaydyn, '(/3x,a/)') '#Spatial decay of Dynamical matrix in Wannier basis'
DO ir = 1, nrr
!
@ -730,7 +730,7 @@
REAL(kind=DP) :: zero_vect(3)
!! temporary zero vector
REAL(kind=DP) :: delta
!! \delta_nm = 1 if n .eq. m and 0 if n .neq. m
!! \delta_nm = 1 if n == m and 0 if n /= m
!
COMPLEX(kind=DP) :: Apos(3,nbndsub,nbndsub,nks)
!! A^W_{mn,\alpha}(k)
@ -764,8 +764,8 @@
! RM - bvec can be writen on file by making a small change in
! W90/hamiltonian.F90/hamilotonian_write_rmn
!
tempfile=trim(prefix)//'.bvec'
OPEN(iubvec, file=tempfile, action='read', iostat=ios)
tempFILE=trim(prefix)//'.bvec'
OPEN(iubvec, FILE=tempfile, action='read', iostat=ios)
IF (ios /= 0) THEN
!
! if it doesn't exist, then we just set the bvec and wb to zero
@ -800,9 +800,9 @@
ALLOCATE ( M_mn(nbnd, nbnd, nnb, nkstot) )
M_mn = czero
!
IF (mpime.eq.ionode_id) THEN
tempfile=trim(prefix)//'.mmn'
OPEN(iummn, file=tempfile, status = 'old', form = 'formatted', iostat=ios)
IF (mpime == ionode_id) THEN
tempFILE=trim(prefix)//'.mmn'
OPEN(iummn, FILE=tempfile, status = 'old', form = 'formatted', iostat=ios)
!
IF (ios /= 0) THEN
! if it doesn't exist, then we just set the mmn to zero
@ -841,7 +841,7 @@
m_mat_tmp(:,:,:,:) = czero
zero_vect(:) = zero
!
IF (nexband_tmp .gt. 0) THEN
IF (nexband_tmp > 0) THEN
DO ik = 1, nks
CALL ktokpmq ( xk(:,ik), zero_vect, +1, ipool, nkk, nkk_abs)
!
@ -921,8 +921,8 @@
b_tmp(:) = alat / (twopi) * bvec(:,ib,nkk_abs)
CALL ktokpmq ( xk(:,ik), b_tmp(:), +1, ipool, nkb, nkb_abs)
!
! M_mn_utmp(:,:) = matmul( m_mat_opt(:,:,ib,ik), cu_big(:,:,nkb_abs) )
! cvs(:,:,ib,ik) = matmul( conjg(transpose(cu(:,:,ik))), M_mn_utmp(:,:) )
! M_mn_utmp(:,:) = MATMUL( m_mat_opt(:,:,ib,ik), cu_big(:,:,nkb_abs) )
! cvs(:,:,ib,ik) = MATMUL( conjg(transpose(cu(:,:,ik))), M_mn_utmp(:,:) )
!
CALL zgemm ('n', 'n', nbnd, nbndsub, nbnd, cone, m_mat_opt(:,:,ib,ik), &
nbnd, cu_big(:,:,nkb_abs), nbnd, czero, M_mn_utmp(:,:), nbnd)
@ -1004,8 +1004,8 @@
! position matrix cvmew and spatial dimensions are in units of bohr
! [mind when comparing with wannier code (angstrom units) with write_rmn=.true.]
!
IF (mpime.eq.ionode_id) then
OPEN(unit=iudecayv,file='decay.v')
IF (mpime == ionode_id) then
OPEN(UNIT=iudecayv,FILE='decay.v')
WRITE(iudecayv, '(/3x,a/)') '#Spatial decay of Velocity matrix element in Wannier basis'
DO ir = 1, nrr
!
@ -1171,8 +1171,8 @@
! the unit in r-space is angstrom, and I am plotting
! the matrix for the first mode only
!
IF (mpime.eq.ionode_id) THEN
OPEN(unit=iuwane,file='decay.epwane')
IF (mpime == ionode_id) THEN
OPEN(UNIT=iuwane,FILE='decay.epwane')
WRITE(iuwane, '(a)') '# Spatial decay of e-p matrix elements in Wannier basis'
DO ir = 1, nrr
!
@ -1291,9 +1291,9 @@
!
! we plot: R_e, R_p, max_{m,n,nu} |g(m,n,nu;R_e,R_p)|
!
IF (mpime.eq.ionode_id) THEN
IF (ir.eq.1) open(unit=iuwanep,file='decay.epmat_wanep',status='unknown')
IF (ir.eq.1) WRITE(iuwanep, '(a)') '# R_e, R_p, max_{m,n,nu} |g(m,n,nu;R_e,R_p)| '
IF (mpime == ionode_id) THEN
IF (ir == 1) open(UNIT=iuwanep,FILE='decay.epmat_wanep',status='unknown')
IF (ir == 1) WRITE(iuwanep, '(a)') '# R_e, R_p, max_{m,n,nu} |g(m,n,nu;R_e,R_p)| '
DO ire = 1, nrr_k
!
rvec1 = dble(irvec_k(1,ire))*at(:,1) + &
@ -1312,7 +1312,7 @@
WRITE(iuwanep, '(5f15.10)') len1 * alat * bohr2ang, &
len2 * alat * bohr2ang, tmp
ENDDO
IF (ir.eq.nrr_g) CLOSE(iuwanep)
IF (ir == nrr_g) CLOSE(iuwanep)
ENDIF
!
ENDDO
@ -1393,7 +1393,7 @@
COMPLEX(KIND=DP), ALLOCATABLE :: epmatwp_mem(:,:,:,:)
!! e-p matrix in Wannier basis
!
ALLOCATE (epmatwp_mem( nbnd, nbnd, nrr_k, nmodes))
ALLOCATE (epmatwp_mem(nbnd, nbnd, nrr_k, nmodes))
!
!----------------------------------------------------------
! Fourier transform to go into Wannier basis
@ -1429,7 +1429,7 @@
! we plot: R_e, R_p, max_{m,n,nu} |g(m,n,nu;R_e,R_p)|
!
IF (mpime == ionode_id) THEN
IF (ir == 1) OPEN(unit=iuwanep, file='decay.epmat_wanep', status='unknown')
IF (ir == 1) OPEN(UNIT=iuwanep, FILE='decay.epmat_wanep', status='unknown')
IF (ir == 1) WRITE(iuwanep, '(a)') '# R_e, R_p, max_{m,n,nu} |g(m,n,nu;R_e,R_p)| '
DO ire = 1, nrr_k
!
@ -1458,7 +1458,7 @@
!
CALL cryst_to_cart (nq, xk, bg, 1)
!
IF ( ALLOCATED (epmatwp_mem) ) DEALLOCATE (epmatwp_mem)
DEALLOCATE (epmatwp_mem)
!
END SUBROUTINE ephbloch2wanp_mem
!

104
EPW/src/broyden.f90
View File

@ -39,7 +39,7 @@
!
! Here the local variables
!
! max number of iterations used in mixing: n_iter must be .le. maxter
! max number of iterations used in mixing: n_iter must be <= maxter
INTEGER, PARAMETER :: maxter = 8
!
INTEGER :: n, i, j, iwork(maxter), info, iter_used, ipos, inext
@ -54,20 +54,20 @@
REAL(DP) wg(maxter), wg0
DATA wg0 / 0.01d0 /, wg / maxter * 1.d0 /
!
IF ( iter .lt. 1 ) CALL errore('mix_broyden','n_iter is smaller than 1',1)
IF ( n_iter .gt. maxter ) CALL errore('mix_broyden','n_iter is too big',1)
IF ( ndim .le. 0 ) CALL errore('mix_broyden','ndim .le. 0',1)
IF ( iter < 1 ) CALL errore('mix_broyden','n_iter is smaller than 1',1)
IF ( n_iter > maxter ) CALL errore('mix_broyden','n_iter is too big',1)
IF ( ndim <= 0 ) CALL errore('mix_broyden','ndim <= 0',1)
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(df) ) ALLOCATE( df(ndim,n_iter) )
IF ( .not. ALLOCATED(dv) ) ALLOCATE( dv(ndim,n_iter) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(df) ) ALLOCATE ( df(ndim,n_iter) )
IF ( .NOT. ALLOCATED(dv) ) ALLOCATE ( dv(ndim,n_iter) )
ENDIF
IF ( conv .OR. iter .eq. nsiter ) THEN
IF ( ALLOCATED(df) ) DEALLOCATE(df)
IF ( ALLOCATED(dv) ) DEALLOCATE(dv)
IF ( conv .OR. iter == nsiter ) THEN
IF ( ALLOCATED(df) ) DEALLOCATE (df)
IF ( ALLOCATED(dv) ) DEALLOCATE (dv)
RETURN
ENDIF
IF ( .not. ALLOCATED(deltainsave) ) ALLOCATE( deltainsave(ndim) )
IF ( .NOT. ALLOCATED(deltainsave) ) ALLOCATE ( deltainsave(ndim) )
deltainsave(:) = deltain(:)
!
! iter_used = iter-1 IF iter <= n_iter
@ -84,7 +84,7 @@
deltaout(n) = deltaout(n) - deltain(n)
ENDDO
!
IF ( iter .gt. 1 ) THEN
IF ( iter > 1 ) THEN
DO n = 1, ndim
df(n,ipos) = deltaout(n) - df(n,ipos)
dv(n,ipos) = deltain(n) - dv(n,ipos)
@ -141,7 +141,7 @@
df(:,inext) = deltaout(:)
dv(:,inext) = deltainsave(:)
!
IF ( ALLOCATED(deltainsave) ) DEALLOCATE(deltainsave)
IF ( ALLOCATED(deltainsave) ) DEALLOCATE (deltainsave)
!
RETURN
!
@ -179,7 +179,7 @@
!
! Here the local variables
!
! max number of iterations used in mixing: n_iter must be .le. maxter
! max number of iterations used in mixing: n_iter must be <= maxter
INTEGER, PARAMETER :: maxter = 8
!
INTEGER :: n, i, j, iwork(maxter), info, iter_used, ipos, inext
@ -194,20 +194,20 @@
REAL(DP) wg(maxter), wg0
DATA wg0 / 0.01d0 /, wg / maxter * 1.d0 /
!
IF ( iter .lt. 1 ) CALL errore('mix_broyden2','n_iter is smaller than 1',1)
IF ( n_iter .gt. maxter ) CALL errore('mix_broyden2','n_iter is too big',1)
IF ( ndim .le. 0 ) CALL errore('mix_broyden2','ndim .le. 0',1)
IF ( iter < 1 ) CALL errore('mix_broyden2','n_iter is smaller than 1',1)
IF ( n_iter > maxter ) CALL errore('mix_broyden2','n_iter is too big',1)
IF ( ndim <= 0 ) CALL errore('mix_broyden2','ndim <= 0',1)
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(df2) ) ALLOCATE( df2(ndim,n_iter) )
IF ( .not. ALLOCATED(dv2) ) ALLOCATE( dv2(ndim,n_iter) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(df2) ) ALLOCATE ( df2(ndim,n_iter) )
IF ( .NOT. ALLOCATED(dv2) ) ALLOCATE ( dv2(ndim,n_iter) )
ENDIF
IF ( conv .OR. iter .eq. nsiter ) THEN
IF ( ALLOCATED(df2) ) DEALLOCATE(df2)
IF ( ALLOCATED(dv2) ) DEALLOCATE(dv2)
IF ( conv .OR. iter == nsiter ) THEN
IF ( ALLOCATED(df2) ) DEALLOCATE (df2)
IF ( ALLOCATED(dv2) ) DEALLOCATE (dv2)
RETURN
ENDIF
IF ( .not. ALLOCATED(deltainsave) ) ALLOCATE( deltainsave(ndim) )
IF ( .NOT. ALLOCATED(deltainsave) ) ALLOCATE ( deltainsave(ndim) )
deltainsave(:) = deltain(:)
!
! iter_used = iter-1 IF iter <= n_iter
@ -224,7 +224,7 @@
deltaout(n) = deltaout(n) - deltain(n)
ENDDO
!
IF ( iter .gt. 1 ) THEN
IF ( iter > 1 ) THEN
DO n = 1, ndim
df2(n,ipos) = deltaout(n) - df2(n,ipos)
dv2(n,ipos) = deltain(n) - dv2(n,ipos)
@ -281,7 +281,7 @@
df2(:,inext) = deltaout(:)
dv2(:,inext) = deltainsave(:)
!
IF ( ALLOCATED(deltainsave) ) DEALLOCATE(deltainsave)
IF ( ALLOCATED(deltainsave) ) DEALLOCATE (deltainsave)
!
RETURN
!
@ -324,7 +324,7 @@
!
! Here the local variables
!
! max number of iterations used in mixing: n_iter must be .le. maxter
! max number of iterations used in mixing: n_iter must be <= maxter
INTEGER, PARAMETER :: maxter = 8
!
INTEGER :: n, i, j, iwork(maxter), info, iter_used, ipos, inext
@ -340,20 +340,20 @@
DATA wg0 / 0.01d0 /, wg / maxter * 1.d0 /
REAL(DP) :: df_(ndim,n_iter), dv_(ndim,n_iter)
!
IF ( iter .lt. 1 ) CALL errore('mix_broyden','n_iter is smaller than 1',1)
IF ( n_iter .gt. maxter ) CALL errore('mix_broyden','n_iter is too big',1)
IF ( ndim .le. 0 ) CALL errore('mix_broyden','ndim .le. 0',1)
IF ( iter < 1 ) CALL errore('mix_broyden','n_iter is smaller than 1',1)
IF ( n_iter > maxter ) CALL errore('mix_broyden','n_iter is too big',1)
IF ( ndim <= 0 ) CALL errore('mix_broyden','ndim <= 0',1)
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(df) ) ALLOCATE( df(nbndfs,nkfs,ndim,n_iter) )
IF ( .not. ALLOCATED(dv) ) ALLOCATE( dv(nbndfs,nkfs,ndim,n_iter) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(df) ) ALLOCATE ( df(nbndfs,nkfs,ndim,n_iter) )
IF ( .NOT. ALLOCATED(dv) ) ALLOCATE ( dv(nbndfs,nkfs,ndim,n_iter) )
ENDIF
IF ( conv .OR. iter .eq. nsiter ) THEN
IF (ALLOCATED(df)) DEALLOCATE(df)
IF (ALLOCATED(dv)) DEALLOCATE(dv)
IF ( conv .OR. iter == nsiter ) THEN
IF (ALLOCATED(df)) DEALLOCATE (df)
IF (ALLOCATED(dv)) DEALLOCATE (dv)
RETURN
ENDIF
IF ( .not. ALLOCATED(deltainsave) ) ALLOCATE( deltainsave(ndim) )
IF ( .NOT. ALLOCATED(deltainsave) ) ALLOCATE ( deltainsave(ndim) )
deltainsave(:) = deltain(:)
!
! iter_used = iter-1 IF iter <= n_iter
@ -370,7 +370,7 @@
deltaout(n) = deltaout(n) - deltain(n)
ENDDO
!
IF ( iter .gt. 1 ) THEN
IF ( iter > 1 ) THEN
DO n = 1, ndim
df(ibnd,ik,n,ipos) = deltaout(n) - df(ibnd,ik,n,ipos)
dv(ibnd,ik,n,ipos) = deltain(n) - dv(ibnd,ik,n,ipos)
@ -429,7 +429,7 @@
df(ibnd,ik,:,inext) = deltaout(:)
dv(ibnd,ik,:,inext) = deltainsave(:)
!
IF ( ALLOCATED(deltainsave) ) DEALLOCATE(deltainsave)
IF ( ALLOCATED(deltainsave) ) DEALLOCATE (deltainsave)
!
RETURN
!
@ -471,7 +471,7 @@
!
! Here the local variables
!
! max number of iterations used in mixing: n_iter must be .le. maxter
! max number of iterations used in mixing: n_iter must be <= maxter
INTEGER, PARAMETER :: maxter = 8
!
INTEGER :: n, i, j, iwork(maxter), info, iter_used, ipos, inext
@ -487,20 +487,20 @@
DATA wg0 / 0.01d0 /, wg / maxter * 1.d0 /
REAL(DP) :: df_(ndim,n_iter), dv_(ndim,n_iter)
!
IF ( iter .lt. 1 ) CALL errore('mix_broyden','n_iter is smaller than 1',1)
IF ( n_iter .gt. maxter ) CALL errore('mix_broyden','n_iter is too big',1)
IF ( ndim .le. 0 ) CALL errore('mix_broyden','ndim .le. 0',1)
IF ( iter < 1 ) CALL errore('mix_broyden','n_iter is smaller than 1',1)
IF ( n_iter > maxter ) CALL errore('mix_broyden','n_iter is too big',1)
IF ( ndim <= 0 ) CALL errore('mix_broyden','ndim <= 0',1)
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(df2) ) ALLOCATE( df2(nbndfs,nkfs,ndim,n_iter) )
IF ( .not. ALLOCATED(dv2) ) ALLOCATE( dv2(nbndfs,nkfs,ndim,n_iter) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(df2) ) ALLOCATE ( df2(nbndfs,nkfs,ndim,n_iter) )
IF ( .NOT. ALLOCATED(dv2) ) ALLOCATE ( dv2(nbndfs,nkfs,ndim,n_iter) )
ENDIF
IF ( conv .OR. iter .eq. nsiter ) THEN
IF (ALLOCATED(df2)) DEALLOCATE(df2)
IF (ALLOCATED(dv2)) DEALLOCATE(dv2)
IF ( conv .OR. iter == nsiter ) THEN
IF (ALLOCATED(df2)) DEALLOCATE (df2)
IF (ALLOCATED(dv2)) DEALLOCATE (dv2)
RETURN
ENDIF
IF ( .not. ALLOCATED(deltainsave) ) ALLOCATE( deltainsave(ndim) )
IF ( .NOT. ALLOCATED(deltainsave) ) ALLOCATE ( deltainsave(ndim) )
deltainsave(:) = deltain(:)
!
! iter_used = iter-1 IF iter <= n_iter
@ -517,7 +517,7 @@
deltaout(n) = deltaout(n) - deltain(n)
ENDDO
!
IF ( iter .gt. 1 ) THEN
IF ( iter > 1 ) THEN
DO n = 1, ndim
df2(ibnd,ik,n,ipos) = deltaout(n) - df2(ibnd,ik,n,ipos)
dv2(ibnd,ik,n,ipos) = deltain(n) - dv2(ibnd,ik,n,ipos)
@ -576,7 +576,7 @@
df2(ibnd,ik,:,inext) = deltaout(:)
dv2(ibnd,ik,:,inext) = deltainsave(:)
!
IF ( ALLOCATED(deltainsave) ) DEALLOCATE(deltainsave)
IF ( ALLOCATED(deltainsave) ) DEALLOCATE (deltainsave)
!
RETURN
!

105
EPW/src/close_epw.f90
View File

@ -45,13 +45,6 @@
INTEGER :: ierr
!! Error status
!
DEALLOCATE (inv_tau_all)
DEALLOCATE (zi_allvb)
IF (mp_mesh_k .AND. iterative_bte .AND. epmatkqread) DEALLOCATE (s_BZtoIBZ_full)
IF (mp_mesh_k .AND. iterative_bte .AND. epmatkqread) DEALLOCATE (ixkqf_tr)
IF (int_mob .AND. carrier) DEALLOCATE (inv_tau_allcb)
IF (int_mob .AND. carrier) DEALLOCATE (zi_allcb)
!
#if defined(__MPI)
IF (etf_mem == 1) then
CALL MPI_FILE_CLOSE(iunepmatwp2,ierr)
@ -104,20 +97,16 @@
!! Imported the noncolinear case implemented by xlzhang
!!
!----------------------------------------------------------------------
USE phcom, ONLY : alphap, dmuxc, drc, dyn, evq, dvpsi, &
int5, vlocq, int2_so, int5_so
USE lrus, ONLY : becp1, int3, int3_nc
USE phus, ONLY : int1, int1_nc, int2, int4, int4_nc
USE lr_symm_base, ONLY : rtau
USE phcom, ONLY : drc, dyn, dvpsi
USE noncollin_module, ONLY : m_loc
USE control_lr, ONLY : nbnd_occ
USE becmod, ONLY : becp, deallocate_bec_type
USE elph2, ONLY : el_ph_mat, epf17, epsi, etf,&
etq, et_all, wf, wkf, wqf, &
xkq, xk_all, zstar, xkf, xqf, epmatwp, eps_rpa
USE elph2, ONLY : epf17, epsi, etf,&
etq, wkf, wqf, &
xkq, zstar, xkf, xqf, epmatwp, eps_rpa
USE klist_epw, ONLY : xk_all, xk_loc, xk_cryst, et_all, et_loc, &
isk_loc, isk_all
USE epwcom, ONLY : epbread, epwread
USE modes, ONLY : npert, u, name_rap_mode, num_rap_mode
USE qpoint, ONLY : eigqts, igkq
USE qpoint, ONLY : igkq
USE klist, ONLY : nks
!
IMPLICIT NONE
@ -127,95 +116,45 @@
INTEGER :: ipol
!! Polarization number
!
IF ( epwread .and. .not. epbread ) THEN
IF ( epwread .and. .NOT. epbread ) THEN
! EPW variables ONLY
!
IF(ALLOCATED(el_ph_mat)) DEALLOCATE (el_ph_mat)
IF(ALLOCATED(epmatwp)) DEALLOCATE (epmatwp)
IF(ALLOCATED(epf17)) DEALLOCATE (epf17)
IF(ALLOCATED(etq)) DEALLOCATE (etq)
IF(ALLOCATED(etf)) DEALLOCATE (etf)
IF(ALLOCATED(wf)) DEALLOCATE (wf)
IF(ALLOCATED(xkq)) DEALLOCATE (xkq)
IF(ALLOCATED(xkf)) DEALLOCATE (xkf)
IF(ALLOCATED(wkf)) DEALLOCATE (wkf)
IF(ALLOCATED(xqf)) DEALLOCATE (xqf)
IF(ALLOCATED(wqf)) DEALLOCATE (wqf)
IF(ALLOCATED(xk_all)) DEALLOCATE (xk_all)
IF(ALLOCATED(et_all)) DEALLOCATE (et_all)
IF(ALLOCATED(eps_rpa)) DEALLOCATE (eps_rpa)
IF(ALLOCATED(eps_rpa)) DEALLOCATE (eps_rpa)
!
ELSE
!
IF(ASSOCIATED(evq)) DEALLOCATE(evq)
IF(ASSOCIATED(igkq)) DEALLOCATE(igkq)
!
IF(ALLOCATED(dvpsi)) DEALLOCATE (dvpsi)
!
IF(ALLOCATED(vlocq)) DEALLOCATE (vlocq)
IF(ALLOCATED(dmuxc)) DEALLOCATE (dmuxc)
!
IF(ALLOCATED(eigqts)) DEALLOCATE (eigqts)
IF(ALLOCATED(rtau)) DEALLOCATE (rtau)
IF(ASSOCIATED(u)) DEALLOCATE (u)
if(allocated(name_rap_mode)) deallocate (name_rap_mode)
if(allocated(num_rap_mode)) deallocate (num_rap_mode)
IF(ALLOCATED(dyn)) DEALLOCATE (dyn)
IF(ALLOCATED(epsi)) DEALLOCATE (epsi)
IF(ALLOCATED(zstar)) DEALLOCATE (zstar)
!
IF(ALLOCATED(npert)) DEALLOCATE (npert)
!
IF(ALLOCATED(int1)) DEALLOCATE (int1)
IF(ALLOCATED(int2)) DEALLOCATE (int2)
IF(ALLOCATED(int3)) DEALLOCATE (int3)
IF(ALLOCATED(int4)) DEALLOCATE (int4)
IF(ALLOCATED(int5)) DEALLOCATE (int5)
IF(ALLOCATED(int1_nc)) DEALLOCATE(int1_nc)
IF(ALLOCATED(int3_nc)) DEALLOCATE(int3_nc)
IF(ALLOCATED(int4_nc)) DEALLOCATE(int4_nc)
IF(ALLOCATED(int2_so)) DEALLOCATE(int2_so)
IF(ALLOCATED(int5_so)) DEALLOCATE(int5_so)
!
IF (allocated(alphap)) THEN
DO ik = 1, nks
DO ipol = 1, 3
CALL deallocate_bec_type( alphap(ipol,ik) )
ENDDO
ENDDO
DEALLOCATE(alphap)
ENDIF
IF (allocated(becp1)) THEN
DO ik = 1, size(becp1)
CALL deallocate_bec_type( becp1(ik) )
ENDDO
DEALLOCATE(becp1)
ENDIF
CALL deallocate_bec_type ( becp )
!
IF(ALLOCATED(nbnd_occ)) DEALLOCATE(nbnd_occ)
IF(ALLOCATED(m_loc)) DEALLOCATE(m_loc)
!
IF(ALLOCATED(drc)) DEALLOCATE(drc)
IF(ASSOCIATED(igkq)) DEALLOCATE (igkq)
IF(ALLOCATED(dyn)) DEALLOCATE (dyn)
IF(ALLOCATED(epsi)) DEALLOCATE (epsi)
IF(ALLOCATED(zstar)) DEALLOCATE (zstar)
IF(ALLOCATED(nbnd_occ)) DEALLOCATE (nbnd_occ)
IF(ALLOCATED(m_loc)) DEALLOCATE (m_loc)
IF(ALLOCATED(drc)) DEALLOCATE (drc)
!
! EPW variables
!
IF(ALLOCATED(el_ph_mat)) DEALLOCATE (el_ph_mat)
IF(ALLOCATED(epmatwp)) DEALLOCATE (epmatwp)
IF(ALLOCATED(epf17)) DEALLOCATE (epf17)
IF(ALLOCATED(etq)) DEALLOCATE (etq)
IF(ALLOCATED(etf)) DEALLOCATE (etf)
IF(ALLOCATED(wf)) DEALLOCATE (wf)
IF(ALLOCATED(xkq)) DEALLOCATE (xkq)
IF(ALLOCATED(xkf)) DEALLOCATE (xkf)
IF(ALLOCATED(wkf)) DEALLOCATE (wkf)
IF(ALLOCATED(xqf)) DEALLOCATE (xqf)
IF(ALLOCATED(wqf)) DEALLOCATE (wqf)
IF(ALLOCATED(xk_all)) DEALLOCATE (xk_all)
IF(ALLOCATED(xk_all)) DEALLOCATE (xk_all)
IF(ALLOCATED(xk_loc)) DEALLOCATE (xk_loc)
IF(ALLOCATED(xk_cryst)) DEALLOCATE (xk_cryst)
IF(ALLOCATED(et_all)) DEALLOCATE (et_all)
IF(ALLOCATED(eps_rpa)) DEALLOCATE (eps_rpa)
ENDIF ! epwread .and. .not. epbread
IF(ALLOCATED(et_loc)) DEALLOCATE (et_loc)
IF(ALLOCATED(isk_loc)) DEALLOCATE (isk_loc)
IF(ALLOCATED(isk_all)) DEALLOCATE (isk_all)
ENDIF ! epwread .and. .NOT. epbread
!
END SUBROUTINE deallocate_epw
! ---------------------------------------------------------------

2
EPW/src/constants_epw.f90
View File

@ -34,6 +34,7 @@
!
REAL(DP), PARAMETER :: ang2cm = 1.0d-8
REAL(DP), PARAMETER :: ang2m = 1.0d-10
REAL(DP), PARAMETER :: cm2m = 1.0d-2
REAL(DP), PARAMETER :: bohr = 0.52917721092d0
REAL(DP), PARAMETER :: ryd2mev = 13605.6981d0
REAL(DP), PARAMETER :: ryd2ev = 13.6056981d0
@ -62,6 +63,7 @@
REAL(DP), PARAMETER :: eps12 = 1.0E-12_DP
REAL(DP), PARAMETER :: eps14 = 1.0E-14_DP
REAL(DP), PARAMETER :: eps16 = 1.0E-16_DP
REAL(DP), PARAMETER :: eps20 = 1.0E-20_DP
REAL(DP), PARAMETER :: eps24 = 1.0E-24_DP
REAL(DP), PARAMETER :: eps32 = 1.0E-32_DP
REAL(DP), PARAMETER :: eps80 = 1.0E-80_DP

163
EPW/src/createkmap.f90
View File

@ -67,14 +67,14 @@
!
LOGICAL :: in_the_list, found
!
IF (.not. ALLOCATED(xkq) ) ALLOCATE( xkq(3,nkstot) )
IF ( .NOT. ALLOCATED(xkq) ) ALLOCATE ( xkq(3,nkstot) )
xkq(:,:) = zero
!
IF (meta_ionode) THEN
!
! the first proc keeps a copy of all kpoints !
!
IF ( .not. ALLOCATED(shift) ) ALLOCATE( shift(nkstot) )
IF ( .NOT. ALLOCATED(shift) ) ALLOCATE ( shift(nkstot) )
shift(:) = 0
!
! Now fold k+q back into the k-grid for wannier interpolation.
@ -89,10 +89,10 @@
xx = xq(1) * nk1
yy = xq(2) * nk2
zz = xq(3) * nk3
in_the_list = abs(xx-nint(xx)) .le. eps5 .AND. &
abs(yy-nint(yy)) .le. eps5 .AND. &
abs(zz-nint(zz)) .le. eps5
IF (.not.in_the_list) CALL errore('createkmap','q-vec not commensurate',1)
in_the_list = abs(xx-nint(xx)) <= eps5 .AND. &
abs(yy-nint(yy)) <= eps5 .AND. &
abs(zz-nint(zz)) <= eps5
IF ( .NOT. in_the_list) CALL errore('createkmap','q-vec not commensurate',1)
!
ng0vec = 0
DO ig1 = -2, 2
@ -117,12 +117,12 @@
xx_c(ik) = xk(1,ik) * nk1
yy_c(ik) = xk(2,ik) * nk2
zz_c(ik) = xk(3,ik) * nk3
in_the_list = abs(xx_c(ik)-nint(xx_c(ik))) .le. eps5 .AND. &
abs(yy_c(ik)-nint(yy_c(ik))) .le. eps5 .AND. &
abs(zz_c(ik)-nint(zz_c(ik))) .le. eps5
IF (.not.in_the_list) CALL errore('createkmap','is this a uniform k-mesh?',1)
in_the_list = abs(xx_c(ik)-nint(xx_c(ik))) <= eps5 .AND. &
abs(yy_c(ik)-nint(yy_c(ik))) <= eps5 .AND. &
abs(zz_c(ik)-nint(zz_c(ik))) <= eps5
IF ( .NOT. in_the_list) CALL errore('createkmap','is this a uniform k-mesh?',1)
!
IF ( (xx_c(ik) .lt. -eps5) .OR. (yy_c(ik) .lt. -eps5) .OR. (zz_c(ik) .lt. -eps5) ) &
IF ( (xx_c(ik) < -eps5) .OR. (yy_c(ik) < -eps5) .OR. (zz_c(ik) < -eps5) ) &
CALL errore('createkmap','coarse k-mesh needs to be strictly positive in 1st BZ',1)
ENDDO
!
@ -135,10 +135,10 @@
xx = xk_q(1) * nk1
yy = xk_q(2) * nk2
zz = xk_q(3) * nk3
in_the_list = abs(xx-nint(xx)) .le. eps5 .AND. &
abs(yy-nint(yy)) .le. eps5 .AND. &
abs(zz-nint(zz)) .le. eps5
IF (.not.in_the_list) CALL errore('createkmap','k+q does not fall on k-grid',1)
in_the_list = abs(xx-nint(xx)) <= eps5 .AND. &
abs(yy-nint(yy)) <= eps5 .AND. &
abs(zz-nint(zz)) <= eps5
IF ( .NOT. in_the_list) CALL errore('createkmap','k+q does not fall on k-grid',1)
!
! find the index of this k+q in the k-grid
!
@ -158,9 +158,9 @@
found = .false.
DO jk = 1, nkstot
!
found = nint(xx_c(jk)) .eq. nint(xx_n) .AND. &
nint(yy_c(jk)) .eq. nint(yy_n) .AND. &
nint(zz_c(jk)) .eq. nint(zz_n)
found = nint(xx_c(jk)) == nint(xx_n) .AND. &
nint(yy_c(jk)) == nint(yy_n) .AND. &
nint(zz_c(jk)) == nint(zz_n)
IF (found) THEN
n = jk
EXIT
@ -172,7 +172,7 @@
! n = nint(xx_n) * nk2 * nk3 + nint(yy_n) * nk3 + nint(zz_n) + 1
! n represents the index of k+q on the coarse k-grid.
!
IF (n .eq. 0) CALL errore('createkmap','problem indexing k+q',1)
IF (n == 0) CALL errore('createkmap','problem indexing k+q',1)
!
kmap(ik) = n
!
@ -186,15 +186,15 @@
!
in_the_list = .false.
ig0 = 0
DO WHILE ( (ig0.le.ng0vec) .AND. (.not.in_the_list) )
DO WHILE ( (ig0 <= ng0vec) .AND. ( .NOT. in_the_list) )
ig0 = ig0 + 1
in_the_list = ( (abs(g0vec(1) - g0vec_all(1,ig0)) .le. eps5) .AND. &
(abs(g0vec(2) - g0vec_all(2,ig0)) .le. eps5) .AND. &
(abs(g0vec(3) - g0vec_all(3,ig0)) .le. eps5))
in_the_list = ( (abs(g0vec(1) - g0vec_all(1,ig0)) <= eps5) .AND. &
(abs(g0vec(2) - g0vec_all(2,ig0)) <= eps5) .AND. &
(abs(g0vec(3) - g0vec_all(3,ig0)) <= eps5))
ENDDO
shift(ik) = ig0
!
IF (.not.in_the_list) CALL errore &
IF ( .NOT. in_the_list) CALL errore &
('createkmap','cannot find the folding vector in the list',1)
!
! obsolete:
@ -279,11 +279,11 @@
xx = xxq(1) * nk1
yy = xxq(2) * nk2
zz = xxq(3) * nk3
in_the_list = abs(xx-nint(xx)) .le. eps5 .AND. &
abs(yy-nint(yy)) .le. eps5 .AND. &
abs(zz-nint(zz)) .le. eps5
IF (.not.in_the_list) CALL errore('createkmap2','q-vec not commensurate',1)
IF (.not. ALLOCATED(xkq) ) ALLOCATE( xkq(3,nkstot) )
in_the_list = abs(xx-nint(xx)) <= eps5 .AND. &
abs(yy-nint(yy)) <= eps5 .AND. &
abs(zz-nint(zz)) <= eps5
IF ( .NOT. in_the_list) CALL errore('createkmap2','q-vec not commensurate',1)
IF ( .NOT. ALLOCATED(xkq) ) ALLOCATE ( xkq(3,nkstot) )
xkq(:,:) = zero
!
! bring all the k-points from cartesian to crystal coordinates
@ -297,12 +297,12 @@
xx_c(ik) = xk(1,ik) * nk1
yy_c(ik) = xk(2,ik) * nk2
zz_c(ik) = xk(3,ik) * nk3
in_the_list = abs(xx_c(ik)-nint(xx_c(ik))) .le. eps5 .AND. &
abs(yy_c(ik)-nint(yy_c(ik))) .le. eps5 .AND. &
abs(zz_c(ik)-nint(zz_c(ik))) .le. eps5
IF (.not.in_the_list) CALL errore('createkmap2','is this a uniform k-mesh?',1)
in_the_list = abs(xx_c(ik)-nint(xx_c(ik))) <= eps5 .AND. &
abs(yy_c(ik)-nint(yy_c(ik))) <= eps5 .AND. &
abs(zz_c(ik)-nint(zz_c(ik))) <= eps5
IF ( .NOT. in_the_list) CALL errore('createkmap2','is this a uniform k-mesh?',1)
!
IF ( (xx_c(ik) .lt. -eps5) .OR. (yy_c(ik) .lt. -eps5) .OR. (zz_c(ik) .lt. -eps5) ) &
IF ( (xx_c(ik) < -eps5) .OR. (yy_c(ik) < -eps5) .OR. (zz_c(ik) < -eps5) ) &
CALL errore('createkmap2','coarse k-mesh needs to be strictly positive in 1st BZ',1)
ENDDO
!
@ -315,10 +315,10 @@
xx = xkq(1,ik) * nk1
yy = xkq(2,ik) * nk2
zz = xkq(3,ik) * nk3
in_the_list = abs(xx-nint(xx)) .le. eps5 .AND. &
abs(yy-nint(yy)) .le. eps5 .AND. &
abs(zz-nint(zz)) .le. eps5
IF (.not.in_the_list) CALL errore('createkmap2','k+q does not fall on k-grid',1)
in_the_list = abs(xx-nint(xx)) <= eps5 .AND. &
abs(yy-nint(yy)) <= eps5 .AND. &
abs(zz-nint(zz)) <= eps5
IF ( .NOT. in_the_list) CALL errore('createkmap2','k+q does not fall on k-grid',1)
!
! find the index of this k+q in the k-grid
!
@ -330,16 +330,16 @@
found = .false.
DO jk = 1, nkstot
!
found = nint(xx_c(jk)) .eq. nint(xx) .and. &
nint(yy_c(jk)) .eq. nint(yy) .and. &
nint(zz_c(jk)) .eq. nint(zz)
found = nint(xx_c(jk)) == nint(xx) .and. &
nint(yy_c(jk)) == nint(yy) .and. &
nint(zz_c(jk)) == nint(zz)
IF (found) THEN
n = jk
EXIT
ENDIF
ENDDO
!
IF (n .eq. 0) CALL errore('createkmap2','problem indexing k+q',1)
IF (n == 0) CALL errore('createkmap2','problem indexing k+q',1)
!
kmap(ik) = n
!
@ -364,7 +364,7 @@
USE cell_base, ONLY : at, bg
USE start_k, ONLY : nk1, nk2, nk3
USE pwcom, ONLY : nkstot
USE epwcom, ONLY : xk_cryst
USE klist_epw, ONLY : xk_cryst
USE io_global, ONLY : stdout, meta_ionode
USE io_files, ONLY : prefix
USE io_epw, ONLY : iukgmap
@ -441,7 +441,7 @@
WRITE(stdout, '(/5x,a)') 'Calculating kgmap'
CALL flush(stdout)
!
OPEN(iukgmap,file = TRIM(prefix)//'.kgmap',form='formatted')
OPEN(iukgmap,file = TRIM(prefix)//'.kgmap',FORM='formatted')
!
! the 5^3 possible G_0 translations
ng0vec = 0
@ -457,7 +457,8 @@
ENDDO
ig0 = nint( dble(ng0vec) / 2 )
!
IF (.not. ALLOCATED(shift)) ALLOCATE( shift(nkstot) )
!IF ( .NOT. ALLOCATED(shift)) ALLOCATE ( shift(nkstot) )
ALLOCATE (shift(nkstot))
!
DO ik = 1, nkstot
!
@ -466,14 +467,15 @@
zz = xk_cryst(3,ik) * nk3
! check that the k-mesh was defined in the positive region of 1st BZ
!
IF ( (xx .lt. -eps5) .OR. (yy .lt. -eps5) .OR. (zz .lt. -eps5) ) &
IF ( (xx < -eps5) .OR. (yy < -eps5) .OR. (zz < -eps5) ) &
CALL errore('createkmap_pw2','coarse k-mesh needs to be strictly positive in 1st BZ',1)
!
shift(ik) = ig0
WRITE(iukgmap,'(3i6)') ik, shift(ik)
!
ENDDO
IF (ALLOCATED(shift)) DEALLOCATE(shift)
!IF (ALLOCATED(shift)) DEALLOCATE (shift)
DEALLOCATE (shift)
!
g0vec_all_r = dble(g0vec_all)
! bring G_0 vectors from crystal to cartesian coordinates
@ -502,16 +504,16 @@
!
! and computes all the g vectors inside a sphere
!
ALLOCATE( mill_unsorted(3,ngm_save) )
ALLOCATE( igsrt(ngm_max) )
ALLOCATE( g2l(ngm_max) )
ALLOCATE( g2sort_g(ngm_max) )
ALLOCATE( ig_l2g(ngm_max) )
ALLOCATE( mill(3,ngm_max) )
ALLOCATE( jtoi(ngm_max) )
ALLOCATE( itoj(ngm_max) )
ALLOCATE( g(3,ngm_max) )
ALLOCATE( gg(ngm_max) )
ALLOCATE (mill_unsorted(3, ngm_save))
ALLOCATE (igsrt(ngm_max))
ALLOCATE (g2l(ngm_max))
ALLOCATE (g2sort_g(ngm_max))
ALLOCATE (ig_l2g(ngm_max))
ALLOCATE (mill(3, ngm_max))
ALLOCATE (jtoi(ngm_max))
ALLOCATE (itoj(ngm_max))
ALLOCATE (g(3, ngm_max))
ALLOCATE (gg(ngm_max))
!
! Set the total number of FFT mesh points and and initial value of gg.
! The choice of gcutm is due to the fact that we have to order the
@ -523,7 +525,7 @@
!
! allocate temporal array
!
ALLOCATE( tt(dfftp%nr3) )
ALLOCATE (tt(dfftp%nr3))
!
! max miller indices (same convention as in module stick_set)
!
@ -585,7 +587,7 @@
!
igsrt(1) = 0
CALL hpsort_eps( ngm_g, g2sort_g, igsrt, eps8 )
DEALLOCATE( g2sort_g, tt )
DEALLOCATE ( g2sort_g, tt )
!
ngm = 0
!
@ -605,19 +607,19 @@
gg(ngm) = sum(g(1:3,ngm)**2)
ENDIF
ENDDO !ngloop
DEALLOCATE( g2l )
DEALLOCATE ( g2l )
!
IF (ngm /= ngm_save) &
CALL errore('createkmap_pw2', 'g-vectors (ngm) missing !', abs(ngm - ngm_save))
!
CALL fft_set_nl( dfftp, at, g, mill )
!
DO i = 1, ngm_g
jtoi(i) = igsrt(i)
DO i=1, ngm_g
jtoi(i) = igsrt(i)
ENDDO !
!
DO i = 1, ngm_g
itoj(jtoi(i)) = i
DO i=1, ngm_g
itoj(jtoi(i)) = i
ENDDO
!
CALL refold( ngm_g, mill, itoj, jtoi )
@ -625,7 +627,14 @@
CALL mp_barrier(inter_pool_comm)
CALL mp_barrier(inter_image_comm)
!
DEALLOCATE( ig_l2g, mill, mill_unsorted, igsrt, jtoi, itoj, g, gg )
DEALLOCATE (ig_l2g)
DEALLOCATE (mill)
DEALLOCATE (mill_unsorted)
DEALLOCATE (igsrt)
DEALLOCATE (jtoi)
DEALLOCATE (itoj)
DEALLOCATE (g)
DEALLOCATE (gg)
!
RETURN
!
@ -633,7 +642,7 @@
!-------------------------------------------------------------------------
!
!-----------------------------------------------------------------------
SUBROUTINE refold( ngm_g, mill_g, itoj, jtoi )
SUBROUTINE refold (ngm_g, mill_g, itoj, jtoi)
!----------------------------------------------------------------------
!
! Map the indices of G+G_0 into those of G
@ -682,15 +691,15 @@
!
LOGICAL :: tfound
!
ALLOCATE( gmap(ngm_g,ng0vec) )
gmap(:,:) = 0
ALLOCATE (gmap(ngm_g, ng0vec))
gmap(:, :) = 0
guess_skip = 0
!
! Loop on the inequivalent G_0 vectors
!
DO ig0 = 1, ng0vec
!
IF (ig0 .eq. 1) THEN
IF (ig0 == 1) THEN
WRITE(stdout,'(/5x,"Progress kgmap: ")',advance='no')
indold = 0
ENDIF
@ -722,11 +731,11 @@
!
ig2_guess = jtoi(ig1_use) + guess_skip
!
IF ((ig2_guess .gt. 0) .AND. (ig2_guess .lt. ngm_g+1)) THEN
IF ((ig2_guess > 0) .AND. (ig2_guess < ngm_g+1)) THEN
!
ig2_guess = itoj(ig2_guess)
!
IF ((i .eq. mill_g(1,ig2_guess)) .AND. (j .eq. mill_g(2,ig2_guess)) .AND. (k .eq. mill_g(3,ig2_guess))) THEN
IF ((i == mill_g(1,ig2_guess)) .AND. (j == mill_g(2,ig2_guess)) .AND. (k == mill_g(3,ig2_guess))) THEN
!
ig2_use = ig2_guess
tfound = .true.
@ -735,21 +744,21 @@
!
ENDIF
!
DO WHILE ((.not. tfound) .AND. (ig2 .lt. ngm_g))
DO WHILE (( .NOT. tfound) .AND. (ig2 < ngm_g))
!
ig2 = ig2 + 1
ig2_use = itoj(ig2)
tfound = (i .eq. mill_g(1,ig2_use)) .AND. &
(j .eq. mill_g(2,ig2_use)) .AND. &
(k .eq. mill_g(3,ig2_use))
tfound = (i == mill_g(1,ig2_use)) .AND. &
(j == mill_g(2,ig2_use)) .AND. &
(k == mill_g(3,ig2_use))
!
ENDDO
!
IF (tfound) THEN
gmap(ig1_use,ig0) = ig2_use
gmap(ig1_use, ig0) = ig2_use
guess_skip = jtoi(ig2_use) - jtoi(ig1_use)
ELSE
gmap(ig1_use,ig0) = 0
gmap(ig1_use, ig0) = 0
notfound = notfound + 1
ENDIF
!

98
EPW/src/dvanqq2.f90
View File

@ -94,7 +94,7 @@
!! e^{-i q * \tau} * conjg(e^{-i q * \tau})
COMPLEX(kind=DP) :: fact1
!! -i * omega
COMPLEX(kind=DP), EXTERNAL :: zdotc
COMPLEX(kind=DP), EXTERNAL :: ZDOTC
!! the scalar product function
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:), aux2(:), &
aux3(:), aux5(:), sk(:)
@ -105,7 +105,7 @@
COMPLEX(kind=DP), POINTER :: qgmq(:)
!! the augmentation function at q+G
!
IF (.not.okvan) RETURN
IF (.NOT. okvan) RETURN
!
CALL start_clock('dvanqq2')
!
@ -113,29 +113,45 @@
int2(:,:,:,:,:) = czero
int4(:,:,:,:,:) = czero
int5(:,:,:,:,:) = czero
ALLOCATE( sk(ngm) )
ALLOCATE( aux1(ngm) )
ALLOCATE( aux2(ngm) )
ALLOCATE( aux3(ngm) )
ALLOCATE( aux5(ngm) )
ALLOCATE( qmodg(ngm) )
ALLOCATE( qmod(ngm) )
ALLOCATE( qgmq(ngm) )
ALLOCATE( qgm(ngm))
ALLOCATE( ylmk0(ngm, lmaxq * lmaxq) )
ALLOCATE( ylmkq(ngm, lmaxq * lmaxq) )
!
ALLOCATE ( sk(ngm) )
ALLOCATE ( aux1(ngm) )
ALLOCATE ( aux2(ngm) )
ALLOCATE ( aux3(ngm) )
ALLOCATE ( aux5(ngm) )
ALLOCATE ( qmodg(ngm) )
ALLOCATE ( qmod(ngm) )
ALLOCATE ( qgmq(ngm) )
ALLOCATE ( qgm(ngm))
ALLOCATE ( ylmk0(ngm, lmaxq * lmaxq) )
ALLOCATE ( ylmkq(ngm, lmaxq * lmaxq) )
sk(:) = czero
aux1(:) = czero
aux2(:) = czero
aux3(:) = czero
aux5(:) = czero
qmodg(:) = zero
qmod(:) = zero
qgmq(:) = czero
qgm(:) = czero
ylmk0(:,:) = zero
ylmkq(:,:) = zero
!
! compute spherical harmonics
!
CALL ylmr2( lmaxq * lmaxq, ngm, g, gg, ylmk0 )
!
DO ig = 1, ngm
qmodg(ig) = sqrt( gg(ig) )
ENDDO
!
ALLOCATE( qpg(3, ngm) )
ALLOCATE ( qpg(3, ngm) )
qpg(:,:) = zero
!
CALL setqmod( ngm, xq, g, qmod, qpg )
CALL ylmr2(lmaxq * lmaxq, ngm, qpg, qmod, ylmkq)
DEALLOCATE(qpg)
!
DEALLOCATE (qpg)
DO ig = 1, ngm
qmod(ig) = sqrt( qmod(ig) )
ENDDO
@ -143,8 +159,10 @@
! we start by computing the FT of the effective potential
!
ALLOCATE (veff(dfftp%nnr,nspin_mag))
veff(:,:) = czero
!
DO is = 1, nspin_mag
IF (nspin_mag.ne.4 .or. is==1) THEN
IF (nspin_mag /= 4 .OR. is == 1) THEN
DO ir = 1, dfftp%nnr
veff(ir,is) = CMPLX(vltot(ir) + v%of_r(ir,is), zero, kind=DP)
ENDDO
@ -200,7 +218,7 @@
aux5(ig) = sk(ig) * ( g(ipol,ig) + xq(ipol) )
ENDDO
int2(ih,jh,ipol,na,nb) = fact * fact1 * &
zdotc(ngm, aux1, 1, aux5, 1)
ZDOTC(ngm, aux1, 1, aux5, 1)
!
DO jpol = 1, 3
IF (jpol >= ipol) THEN
@ -210,7 +228,7 @@
ENDDO
int5(ijh,ipol,jpol,na,nb) = &
conjg(fact) * tpiba2 * omega * &
zdotc(ngm, aux3, 1, aux1, 1)
ZDOTC(ngm, aux3, 1, aux1, 1)
ELSE
int5(ijh,ipol,jpol,na,nb) = &
int5(ijh,jpol,ipol,na,nb)
@ -232,14 +250,14 @@
aux2(ig) = veff(dfftp%nl(ig),is) * g(ipol,ig)
ENDDO
int1(ih,jh,ipol,nb,is) = - fact1 * &
zdotc(ngm, aux1, 1, aux2, 1)
ZDOTC(ngm, aux1, 1, aux2, 1)
DO jpol = 1, 3
IF (jpol >= ipol) THEN
DO ig = 1, ngm
aux3(ig) = aux2(ig) * g(jpol,ig)
ENDDO
int4(ijh,ipol,jpol,nb,is) = - tpiba2 * &
omega * zdotc(ngm, aux3, 1, aux1, 1)
omega * ZDOTC(ngm, aux3, 1, aux1, 1)
ELSE
int4(ijh,ipol,jpol,nb,is) = &
int4(ijh,jpol,ipol,nb,is)
@ -304,28 +322,28 @@
ENDIF
!
!DBRM
!write(*,'(a,e20.12)') 'int1 = ', &
!SUM((REAL(REAL(int1(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int1(:,:,:,:,:))))**2)
!write(*,'(a,e20.12)') 'int2 = ', &
!SUM((REAL(REAL(int2(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int2(:,:,:,:,:))))**2)
!write(*,'(a,e20.12)') 'int4 = ', &
!SUM((REAL(REAL(int4(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int4(:,:,:,:,:))))**2)
!write(*,'(a,e20.12)') 'int5 = ', &
!SUM((REAL(REAL(int5(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int5(:,:,:,:,:))))**2)
! write(*,'(a,e20.12)') 'int1 = ', &
! SUM((REAL(REAL(int1(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int1(:,:,:,:,:))))**2)
! write(*,'(a,e20.12)') 'int2 = ', &
! SUM((REAL(REAL(int2(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int2(:,:,:,:,:))))**2)
! write(*,'(a,e20.12)') 'int4 = ', &
! SUM((REAL(REAL(int4(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int4(:,:,:,:,:))))**2)
! write(*,'(a,e20.12)') 'int5 = ', &
! SUM((REAL(REAL(int5(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int5(:,:,:,:,:))))**2)
!END
!
DEALLOCATE(sk)
DEALLOCATE(aux1)
DEALLOCATE(aux2)
DEALLOCATE(aux3)
DEALLOCATE(aux5)
DEALLOCATE(qmodg)
DEALLOCATE(qmod)
DEALLOCATE(qgmq)
DEALLOCATE(qgm)
DEALLOCATE(ylmk0)
DEALLOCATE(ylmkq)
DEALLOCATE(veff)
DEALLOCATE (sk)
DEALLOCATE (aux1)
DEALLOCATE (aux2)
DEALLOCATE (aux3)
DEALLOCATE (aux5)
DEALLOCATE (qmodg)
DEALLOCATE (qmod)
DEALLOCATE (qgmq)
DEALLOCATE (qgm)
DEALLOCATE (ylmk0)
DEALLOCATE (ylmkq)
DEALLOCATE (veff)
!
CALL stop_clock ('dvanqq2')
RETURN

56
EPW/src/dvqpsi_us3.f90
View File

@ -10,7 +10,7 @@
! adapted from PH/dvqpsi_us (QE)
!
!----------------------------------------------------------------------
SUBROUTINE dvqpsi_us3( ik, uact, addnlcc, xxkq, xq0 )
SUBROUTINE dvqpsi_us3( ik, uact, addnlcc, xxkq, xq0, igk, igkq, npw, npwq )
!----------------------------------------------------------------------
!!
!! This routine calculates dV_bare/dtau * psi for one perturbation
@ -33,7 +33,7 @@
USE fft_interfaces, ONLY : fwfft, invfft
USE gvect, ONLY : eigts1, eigts2, eigts3, mill, g, ngm
USE gvecs, ONLY : ngms, doublegrid
USE lsda_mod, ONLY : lsda, isk
USE lsda_mod, ONLY : lsda
USE scf, ONLY : rho, rho_core
USE noncollin_module, ONLY : nspin_lsda, nspin_gga, npol
use uspp_param, ONLY : upf
@ -42,11 +42,12 @@
USE nlcc_ph, ONLY : drc
USE uspp, ONLY : nlcc_any
USE eqv, ONLY : dvpsi, dmuxc, vlocq
USE qpoint, ONLY : eigqts, npwq
USE qpoint, ONLY : eigqts
USE klist, ONLY : ngk
USE klist_epw, ONLY : isk_loc
USE gc_lr, ONLY : grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s
USE funct, ONLY : dft_is_gradient, dft_is_nonlocc
USE elph2, ONLY : igkq, igk, lower_band, upper_band
USE elph2, ONLY : lower_band, upper_band
USE constants_epw, ONLY : czero, eps12
!
IMPLICIT NONE
@ -56,6 +57,14 @@
!
INTEGER, INTENT(in) :: ik
!! Counter on k-point
INTEGER, INTENT(in) :: npw
!! Number of k+G-vectors inside 'ecut sphere'
INTEGER, INTENT(in) :: npwq
!! Number of k+G-vectors inside 'ecut sphere'
INTEGER, INTENT(in) :: igk(npw)
!! k+G mapping
INTEGER, INTENT(in) :: igkq(npwq)
!! k+G+q mapping
!
REAL(kind=DP), INTENT (in) :: xq0(3)
!! Current coarse q-point coordinate
@ -83,8 +92,6 @@
!! counter on spin
INTEGER :: ip
!! counter on polarizations
INTEGER :: npw
!! Number of k+G-vectors inside 'ecut sphere'
!
REAL(kind=DP) :: fac
!! spin degeneracy factor
@ -107,15 +114,13 @@
!
CALL start_clock('dvqpsi_us3')
!
npw = ngk(ik)
!
IF (nlcc_any .AND. addnlcc) THEN
ALLOCATE( drhoc(dfftp%nnr) )
ALLOCATE( aux (dfftp%nnr) )
ALLOCATE( auxs(dffts%nnr) )
ALLOCATE (drhoc(dfftp%nnr))
ALLOCATE (aux(dfftp%nnr))
ALLOCATE (auxs(dffts%nnr))
ENDIF
ALLOCATE( aux1(dffts%nnr) )
ALLOCATE( aux2(dffts%nnr) )
ALLOCATE (aux1(dffts%nnr))
ALLOCATE (aux2(dffts%nnr))
!
! We start by computing the contribution of the local potential.
! The computation of the derivative of the local potential is done in
@ -130,7 +135,7 @@
u1 = uact(mu+1)
u2 = uact(mu+2)
u3 = uact(mu+3)
IF (abs(u1) + abs(u2) + abs(u3) .gt. eps12) THEN
IF (abs(u1) + abs(u2) + abs(u3) > eps12) THEN
nt = ityp(na)
gu0 = xq0(1) * u1 + xq0(2) * u2 + xq0(3) * u3
DO ig = 1, ngms
@ -153,7 +158,7 @@
u1 = uact(mu+1)
u2 = uact(mu+2)
u3 = uact(mu+3)
IF (abs(u1) + abs(u2) + abs(u3) .gt. eps12) THEN
IF (abs(u1) + abs(u2) + abs(u3) > eps12) THEN
nt = ityp(na)
gu0 = xq0(1) * u1 + xq0(2) * u2 + xq0(3) * u3
IF (upf(nt)%nlcc) THEN
@ -170,18 +175,19 @@
!
CALL invfft('Rho', drhoc, dfftp)
!
IF (.not.lsda) THEN
aux(:) = czero
IF (.NOT. lsda) THEN
DO ir = 1, dfftp%nnr
aux(ir) = drhoc(ir) * dmuxc(ir,1,1)
ENDDO
ELSE
is = isk(ik)
is = isk_loc(ik)
DO ir = 1, dfftp%nnr
aux(ir) = drhoc(ir) * 0.5d0 * ( dmuxc(ir,is,1) + dmuxc(ir,is,2) )
aux(ir) = drhoc(ir) * 0.5d0 * (dmuxc(ir, is, 1) + dmuxc(ir, is, 2))
ENDDO
ENDIF
!
fac = 1.d0 / dble(nspin_lsda)
fac = 1.d0 / DBLE(nspin_lsda)
DO is = 1, nspin_lsda
rho%of_r(:,is) = rho%of_r(:,is) + fac * rho_core
ENDDO
@ -249,18 +255,18 @@
ENDDO
!
IF (nlcc_any .AND. addnlcc) THEN
DEALLOCATE(drhoc)
DEALLOCATE(aux)
DEALLOCATE(auxs)
DEALLOCATE (drhoc)
DEALLOCATE (aux)
DEALLOCATE (auxs)
ENDIF
DEALLOCATE(aux1)
DEALLOCATE(aux2)
DEALLOCATE (aux1)
DEALLOCATE (aux2)
!
! We add the contribution of the nonlocal potential in the US form
! First a term similar to the KB case.
! Then a term due to the change of the D coefficients in the perturbat
!
CALL dvqpsi_us_only3( ik, uact, xxkq )
CALL dvqpsi_us_only3(ik, uact, xxkq, igkq, npwq)
!
CALL stop_clock('dvqpsi_us3')
!

170
EPW/src/dvqpsi_us_only3.f90
View File

@ -10,7 +10,7 @@
! adapted from PH/dvqpsi_us_only (QE)
!
!----------------------------------------------------------------------
subroutine dvqpsi_us_only3( ik, uact, xxkq )
SUBROUTINE dvqpsi_us_only3 (ik, uact, xxkq, igkq, npwq)
!----------------------------------------------------------------------
!!
!! This routine calculates dV_bare/dtau * psi for one perturbation
@ -25,23 +25,27 @@
USE cell_base, ONLY : tpiba
USE gvect, ONLY : g
USE ions_base, ONLY : nat, ityp, ntyp => nsp
USE lsda_mod, ONLY : lsda, current_spin, isk, nspin
USE lsda_mod, ONLY : lsda, current_spin, nspin
USE spin_orb, ONLY : lspinorb
USE wvfct, ONLY : npwx, et
USE uspp, ONLY : okvan, nkb, vkb
USE uspp_param, ONLY : nh, nhm
USE qpoint, ONLY : npwq
USE phus, ONLY : int1, int1_nc, int2, int2_so, alphap
USE lrus, ONLY : becp1
USE eqv, ONLY : dvpsi
USE elph2, ONLY : igkq, lower_band, upper_band
USE elph2, ONLY : lower_band, upper_band
USE noncollin_module, ONLY : noncolin, npol
USE constants_epw, ONLY : czero, cone, eps12
USE constants_epw, ONLY : czero, zero, cone, eps12
USE klist_epw, ONLY : isk_loc
!
IMPLICIT NONE
!
INTEGER, INTENT(in) :: ik
!! the k point
INTEGER, INTENT(in) :: npwq
!! Number of k+G-vectors inside 'ecut sphere'
INTEGER, INTENT(in) :: igkq(npwq)
!! k+G+q mapping
REAL(kind=DP), INTENT(in) :: xxkq(3)
!! the k+q point (cartesian coordinates)
COMPLEX(kind=DP), INTENT(in) :: uact(3 * nat)
@ -93,26 +97,26 @@
!
CALL start_clock('dvqpsi_us_on')
IF (noncolin) THEN
ALLOCATE( ps1_nc(nkb, npol, lower_band:upper_band) )
ALLOCATE( ps2_nc(nkb, npol, lower_band:upper_band, 3) )
ALLOCATE( deff_nc(nhm, nhm, nat, nspin) )
ELSE
ALLOCATE( ps1(nkb, lower_band:upper_band) )
ALLOCATE( ps2(nkb, lower_band:upper_band, 3) )
ALLOCATE( deff(nhm, nhm, nat) )
ENDIF
ALLOCATE( aux(npwx) )
IF (lsda) current_spin = isk(ik)
!
! we first compute the coefficients of the vectors
!
IF (noncolin) THEN
ALLOCATE ( ps1_nc(nkb, npol, lower_band:upper_band) )
ALLOCATE ( ps2_nc(nkb, npol, lower_band:upper_band, 3) )
ALLOCATE ( deff_nc(nhm, nhm, nat, nspin) )
ps1_nc(:,:,:) = czero
ps2_nc(:,:,:,:) = czero
deff_nc(:,:,:,:) = czero
ELSE
ALLOCATE ( ps1(nkb, lower_band:upper_band) )
ALLOCATE ( ps2(nkb, lower_band:upper_band, 3) )
ALLOCATE ( deff(nhm, nhm, nat) )
ps1(:,:) = czero
ps2(:,:,:) = czero
deff(:,:,:) = zero
ENDIF
ALLOCATE ( aux(npwx) )
aux(:) = czero
!
IF (lsda) current_spin = isk_loc(ik)
!
! we first compute the coefficients of the vectors
!
DO ibnd = lower_band, upper_band
IF (noncolin) THEN
@ -124,7 +128,7 @@
ijkb0 = 0
DO nt = 1, ntyp
DO na = 1, nat
IF (ityp(na) .eq. nt) THEN
IF (ityp(na) == nt) THEN
mu = 3 * (na - 1)
DO ih = 1, nh(nt)
ikb = ijkb0 + ih
@ -138,7 +142,7 @@
DO js = 1, npol
ijs = ijs + 1
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
deff_nc(ih,jh,na,ijs) * &
deff_nc(ih,jh,na,ijs) * &
alphap(ipol,ik)%nc(jkb,js,ibnd) * uact(mu+ipol)
ps2_nc(ikb,is,ibnd,ipol) = ps2_nc(ikb,is,ibnd,ipol) + &
deff_nc(ih,jh,na,ijs) * becp1(ik)%nc(jkb,js,ibnd) * &
@ -153,52 +157,52 @@
deff(ih,jh,na) * becp1(ik)%k(jkb,ibnd) * &
(0.d0,-1.d0) * uact(mu+ipol) * tpiba
ENDIF
! IF (okvan) THEN
! IF (noncolin) THEN
! ijs = 0
! DO is = 1, npol
! DO js = 1, npol
! ijs = ijs + 1
! ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
! int1_nc(ih,jh,ipol,na,ijs) * &
! becp1(ik)%nc(jkb,js,ibnd) * uact(mu+ipol)
! ENDDO
! ENDDO
! ELSE
! ps1(ikb,ibnd) = ps1(ikb, ibnd) + &
! int1(ih,jh,ipol,na,current_spin) * &
! becp1(ik)%k(jkb,ibnd) * uact(mu+ipol)
! ENDIF
! ENDIF ! okvan
IF (okvan) THEN
IF (noncolin) THEN
ijs = 0
DO is = 1, npol
DO js = 1, npol
ijs = ijs + 1
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
int1_nc(ih,jh,ipol,na,ijs) * &
becp1(ik)%nc(jkb,js,ibnd) * uact(mu+ipol)
ENDDO
ENDDO
ELSE
ps1(ikb,ibnd) = ps1(ikb, ibnd) + &
int1(ih,jh,ipol,na,current_spin) * &
becp1(ik)%k(jkb,ibnd) * uact(mu+ipol)
ENDIF
ENDIF ! okvan
ENDIF ! uact>0
! IF (okvan) THEN
! DO nb = 1, nat
! nu = 3 * (nb - 1)
! IF (noncolin) THEN
! IF (lspinorb) THEN
! ijs = 0
! DO is = 1, npol
! DO js = 1, npol
! ijs = ijs + 1
! ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
! int2_so(ih,jh,ipol,nb,na,ijs) * &
! becp1(ik)%nc(jkb,js,ibnd) * uact(nu+ipol)
! ENDDO
! ENDDO
! ELSE
! DO is = 1, npol
! ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
! int2(ih,jh,ipol,nb,na) * &
! becp1(ik)%nc(jkb,is,ibnd) * uact(nu+ipol)
! ENDDO
! ENDIF
! ELSE
! ps1(ikb,ibnd) = ps1(ikb,ibnd) + &
! int2(ih,jh,ipol,nb,na) * &
! becp1(ik)%k(jkb,ibnd) * uact(nu+ipol)
! ENDIF
! ENDDO
! ENDIF ! okvan
IF (okvan) THEN
DO nb = 1, nat
nu = 3 * (nb - 1)
IF (noncolin) THEN
IF (lspinorb) THEN
ijs = 0
DO is = 1, npol
DO js = 1, npol
ijs = ijs + 1
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
int2_so(ih,jh,ipol,nb,na,ijs) * &
becp1(ik)%nc(jkb,js,ibnd) * uact(nu+ipol)
ENDDO
ENDDO
ELSE
DO is = 1, npol
ps1_nc(ikb,is,ibnd) = ps1_nc(ikb,is,ibnd) + &
int2(ih,jh,ipol,nb,na) * &
becp1(ik)%nc(jkb,is,ibnd) * uact(nu+ipol)
ENDDO
ENDIF
ELSE
ps1(ikb,ibnd) = ps1(ikb,ibnd) + &
int2(ih,jh,ipol,nb,na) * &
becp1(ik)%k(jkb,ibnd) * uact(nu+ipol)
ENDIF
ENDDO
ENDIF ! okvan
ENDDO ! ipol
ENDDO ! jh
ENDDO ! ih
@ -210,12 +214,12 @@
!
! This term is proportional to beta(k+q+G)
!
IF (nkb.gt.0) THEN
IF (nkb > 0) THEN
IF (noncolin) THEN
CALL zgemm( 'n', 'n', npwq, (upper_band-lower_band+1)*npol, nkb, &
CALL ZGEMM( 'n', 'n', npwq, (upper_band-lower_band+1)*npol, nkb, &
cone, vkb, npwx, ps1_nc, nkb, cone, dvpsi, npwx )
ELSE
CALL zgemm( 'n', 'n', npwq, (upper_band-lower_band+1), nkb, &
CALL ZGEMM( 'n', 'n', npwq, (upper_band-lower_band+1), nkb, &
cone, vkb, npwx, ps1, nkb, cone, dvpsi, npwx )
ENDIF
ENDIF
@ -224,15 +228,15 @@
!
DO ikb = 1, nkb
DO ipol = 1, 3
ok = .false.
ok = .FALSE.
IF (noncolin) THEN
DO ibnd = lower_band, upper_band
ok = ok .OR. ( abs( ps2_nc(ikb,1,ibnd,ipol) ) .gt. eps12 ) .OR. &
( abs( ps2_nc(ikb,2,ibnd,ipol) ) .gt. eps12 )
ok = ok .OR. ( ABS(ps2_nc(ikb,1,ibnd,ipol) ) > eps12 ) .OR. &
( ABS(ps2_nc(ikb,2,ibnd,ipol) ) > eps12 )
ENDDO
ELSE
DO ibnd = lower_band, upper_band
ok = ok .OR. ( abs( ps2(ikb,ibnd,ipol) ) .gt. eps12 )
ok = ok .OR. ( ABS(ps2(ikb,ibnd,ipol) ) > eps12)
ENDDO
ENDIF
IF (ok) THEN
@ -243,25 +247,25 @@
ENDDO
DO ibnd = lower_band, upper_band
IF (noncolin) THEN
CALL zaxpy( npwq, ps2_nc(ikb,1,ibnd,ipol), aux, 1, dvpsi(1,ibnd), 1 )
CALL zaxpy( npwq, ps2_nc(ikb,2,ibnd,ipol), aux, 1, dvpsi(1+npwx,ibnd), 1 )
CALL ZAXPY( npwq, ps2_nc(ikb,1,ibnd,ipol), aux, 1, dvpsi(1,ibnd), 1 )
CALL ZAXPY( npwq, ps2_nc(ikb,2,ibnd,ipol), aux, 1, dvpsi(1+npwx,ibnd), 1 )
ELSE
CALL zaxpy( npwq, ps2(ikb,ibnd,ipol), aux, 1, dvpsi(1,ibnd), 1 )
CALL ZAXPY( npwq, ps2(ikb,ibnd,ipol), aux, 1, dvpsi(1,ibnd), 1 )
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO
!
DEALLOCATE(aux)
DEALLOCATE (aux)
IF (noncolin) THEN
DEALLOCATE(ps2_nc)
DEALLOCATE(ps1_nc)
DEALLOCATE(deff_nc)
DEALLOCATE (ps1_nc)
DEALLOCATE (ps2_nc)
DEALLOCATE (deff_nc)
ELSE
DEALLOCATE(ps2)
DEALLOCATE(ps1)
DEALLOCATE(deff)
DEALLOCATE (ps1)
DEALLOCATE (ps2)
DEALLOCATE (deff)
ENDIF
!
CALL stop_clock('dvqpsi_us_on')

6
EPW/src/eliashberg.f90
View File

@ -43,7 +43,7 @@
ENDIF
!
CALL estimate_tc_gap
IF ( gap_edge .gt. 0.d0 ) THEN
IF ( gap_edge > 0.d0 ) THEN
gap0 = gap_edge
ENDIF
IF ( lreal ) CALL eliashberg_iso_raxis
@ -62,13 +62,13 @@
CALL eliashberg_init
CALL evaluate_a2f_lambda
CALL estimate_tc_gap
IF ( gap_edge .gt. 0.d0 ) THEN
IF ( gap_edge > 0.d0 ) THEN
gap0 = gap_edge
ENDIF
IF ( limag ) CALL eliashberg_aniso_iaxis
ENDIF
!
IF ( .not. liso .AND. .not. laniso ) THEN
IF ( .NOT. liso .AND. .NOT. laniso ) THEN
WRITE(stdout,'(/5x,a)') REPEAT('=',67)
WRITE(stdout,'(5x,"Calculate Eliashberg spectral function")')
WRITE(stdout,'(5x,a/)') REPEAT('=',67)

7
EPW/src/elph2.f90
View File

@ -37,10 +37,8 @@
eps_rpa(:) ! screening
REAL(KIND=DP), ALLOCATABLE ::&
a_all(:,:), &! electronic spectral function du to electron-phonon interaction
xk_all(:,:), &! full k point grid, coarse (3, nkstot)
et_all(:,:), &! full eigenvalue list, coarse (nbnd, nkstot)
a_all_ph(:,:), &! phononic spectral function du to electron-phonon interaction
et_ks(:,:), &! lda eigenvalues
et_mb(:,:), &! gw eigenvalues
xkq(:,:), &! local k+q grid, coarse (3, nks)
etq(:,:), &! eigenvalues of k+q wavefunctions
xkf(:,:), &! fine k point grid (3, nkqf)
@ -77,6 +75,7 @@
ifc(:,:,:,:,:,:,:), &! Interatomic force constant in real space
omegap(:), &! Photon energy for phonon-assisted absorption
epsilon2_abs(:,:,:), &! Imaginary part of dielectric function for phonon-assisted absorption, vs omega, vs broadening
wscache(:,:,:,:,:), &! Use as cache when doing IFC when lifc = .true.
epsilon2_abs_lorenz(:,:,:) ! Imaginary part of dielectric function for phonon-assisted absorption, vs omega, vs broadening
REAL(KIND=DP) :: &!
efnew, &! Fermi level on the fine grid. Added globaly for efficiency reason
@ -99,7 +98,7 @@
ngk_all(:), &! Global number of plane wave for each global k-point
map_rebal(:), &! Map between the k-point and their load rebalanced one
map_rebal_inv(:) ! Map between the k-point and their load rebalanced one
INTEGER, allocatable :: &!
INTEGER, ALLOCATABLE :: &!
shift (:), &! for every k+q, index of the G0 which folds k+q into k+q+G0 of the first BZ
gmap(:) ! the map G -> G-G_0 in the large (density) G vectors set, for every G_0
LOGICAL, allocatable :: &!

550
EPW/src/elphel2_shuffle.f90
View File

@ -64,20 +64,22 @@
USE wavefunctions, ONLY : evc
USE io_files, ONLY : diropn, seqopn
USE wvfct, ONLY : npwx
USE pwcom, ONLY : current_spin, isk, lsda, nbnd, xk, nks
USE pwcom, ONLY : current_spin, lsda, nbnd, nks
USE klist_epw, ONLY : xk_loc, xk_all, isk_loc, et_all
USE cell_base, ONLY : tpiba
USE gvect, ONLY : ngm, g
USE uspp, ONLY : vkb
USE symm_base, ONLY : s
USE modes, ONLY : u
USE qpoint, ONLY : xq, npwq
USE eqv, ONLY : dvpsi, evq
USE eqv, ONLY : dvpsi
USE phcom, ONLY : evq
USE units_lr, ONLY : lrwfc, iuwfc
USE phus, ONLY : alphap
USE lrus, ONLY : becp1
USE becmod, ONLY : calbec
USE elph2, ONLY : shift, gmap, el_ph_mat, umat, umatq, igk_k_all, &
umat_all, xk_all, et_all, xkq, etq, igkq, igk, &
USE elph2, ONLY : shift, gmap, el_ph_mat, igk_k_all, &
umat_all, xkq, etq, &
ngk_all, lower_band, upper_band
USE fft_base, ONLY : dffts
USE constants_epw, ONLY : czero, cone, ci, zero
@ -152,6 +154,10 @@
!! Index of k+q-point in the pool
INTEGER :: nkq_abs
!! Absolute index of k+q-point
INTEGER, ALLOCATABLE :: igk(:)
!! Index for k+G
INTEGER, ALLOCATABLE :: igkq(:)
!! Index for k+q+G
!
! Local variables for rotating the wavefunctions (in order to use q in the irr wedge)
REAL(kind=DP) :: xkqtmp(3)
@ -163,8 +169,19 @@
REAL(kind=DP) :: zero_vect(3)
!! Temporary zero vector
!
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:,:), aux2(:,:), aux3(:,:)
COMPLEX(kind=DP), ALLOCATABLE :: eptmp(:,:), elphmat(:,:,:)
COMPLEX(kind=DP) :: umat(nbnd, nbnd, nks)
!! the rotation matrix for the unique setting of the wfs gauge -- on the local pool
COMPLEX(kind=DP) :: umatq(nbnd, nbnd, nks)
!! the rotation matrix for the unique setting of the wfs gauge -- on the local pool
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:, :)
!! Auxillary wavefunction
COMPLEX(kind=DP), ALLOCATABLE :: aux2(:, :)
!! Auxillary wavefunction
COMPLEX(kind=DP), ALLOCATABLE :: aux3(:, :)
!! Auxillary wavefunction
COMPLEX(kind=DP), ALLOCATABLE :: eptmp(:, :)
!! Temporary array
COMPLEX(kind=DP), ALLOCATABLE :: elphmat(:, :, :)
!! arrays for e-ph matrix elements
!
!DBSP - NAG complains ...
@ -173,18 +190,18 @@
! REAL(kind=DP) :: b, c, d
!END
!
IF ( .not. ALLOCATED(elphmat) ) ALLOCATE( elphmat(nbnd, nbnd, npe) )
IF ( .not. ALLOCATED(eptmp) ) ALLOCATE( eptmp(nbnd, nbnd) )
IF ( .not. ALLOCATED(aux1) ) ALLOCATE( aux1(dffts%nnr, npol) )
IF ( .not. ALLOCATED(aux2) ) ALLOCATE( aux2(npwx*npol, nbnd) )
ALLOCATE (elphmat(nbnd, nbnd, npe))
ALLOCATE (eptmp(nbnd, nbnd))
ALLOCATE (aux1(dffts%nnr, npol))
ALLOCATE (aux2(npwx * npol, nbnd))
elphmat(:,:,:) = czero
eptmp(:,:) = czero
aux1(:,:) = czero
aux2(:,:) = czero
zero_vect = zero
!
IF (ALLOCATED(xkq) ) DEALLOCATE(xkq)
IF (.not. ALLOCATED(xkq) ) ALLOCATE( xkq(3,nkstot) )
IF (ALLOCATED(xkq) ) DEALLOCATE (xkq)
IF ( .NOT. ALLOCATED(xkq) ) ALLOCATE ( xkq(3,nkstot) )
xkq(:,:) = zero
!
IF ( nproc_pool>1 ) CALL errore &
@ -196,17 +213,21 @@
! SP: Bound for band parallelism
CALL fkbounds_bnd( nbnd, lower_band, upper_band )
!
IF ( .not. ALLOCATED(aux3) ) ALLOCATE( aux3(npwx*npol, lower_band:upper_band) )
IF ( .not. ALLOCATED(dvpsi) ) ALLOCATE( dvpsi(npwx*npol, lower_band:upper_band) )
ALLOCATE (aux3(npwx * npol, lower_band:upper_band))
ALLOCATE (dvpsi(npwx * npol, lower_band:upper_band))
aux3(:,:) = czero
dvpsi(:,:) = czero
!
! setup for k+q folding
!
CALL kpointdivision( ik0 )
CALL readgmap( nkstot, ngxx, ng0vec, g0vec_all_r, lower_bnd )
CALL kpointdivision(ik0)
!
ALLOCATE (shift(nkstot))
shift(:) = 0
! gmap gets allocated inside readgmap
CALL readgmap(nkstot, ngxx, ng0vec, g0vec_all_r, lower_bnd)
!
IF (imode0.eq.0 .AND. iverbosity.eq.1) WRITE(stdout,5) ngxx
IF (imode0 == 0 .AND. iverbosity == 1) WRITE(stdout,5) ngxx
5 FORMAT (5x,'Estimated size of gmap: ngxx =',i5)
!
! close all sequential files in order to re-open them as direct access
@ -216,229 +237,225 @@
! never remove this barrier
CALL mp_barrier(inter_pool_comm)
!
DO ik = 1, nks
!
IF (lsda) current_spin = isk(ik)
elphmat(:,:,:) = czero
DO ik=1, nks
!
IF (lsda) current_spin = isk_loc(ik)
elphmat(:,:,:) = czero
!DBSP
! b = zero
! c = zero
! d = zero
! b = zero
! c = zero
! d = zero
!END
!
! find index, and possibly pool, of k+q
! the index nkq (nkq_abs) takes into account the even/odd ordering
! of the nscf calc
! we also redefine the ikq points and the corresponding energies
! (we need to make sure that xk(:,ikq) is really k+q for the KB projectors
! below and also that the eigenvalues are taken correctly in ephwann)
!
CALL ktokpmq( xk(:,ik), xq, +1, ipool, nkq, nkq_abs )
!
! we define xkq(:,ik) and etq(:,ik) for the current xq
!
IF (ALLOCATED(etq)) DEALLOCATE(etq)
IF (.not. ALLOCATED(etq) ) ALLOCATE( etq(nbnd,nks) )
etq(:,:) = zero
!
xkq(:,ik) = xk_all(:,nkq_abs)
etq(:,ik) = et_all(:,nkq_abs)
!
ipooltmp = my_pool_id + 1
!
! in serial execution ipool is not used in the called subroutines,
! in parallel ipooltmp is for k and ipool is for k+q
!
! read unperturbed wavefunctions psi(k) and psi(k+q)
!
CALL readwfc( ipooltmp, ik, evc )
CALL readwfc( ipool, nkq, evq )
!
! Now we define the igk and igkq from the global igk_k_all
!
npw = ngk_all(ik+lower_bnd-1)
npwq = ngk_all(nkq_abs)
!
IF (ALLOCATED(igk)) DEALLOCATE(igk)
IF (ALLOCATED(igkq)) DEALLOCATE(igkq)
ALLOCATE( igk(npw) )
ALLOCATE( igkq(npwq) )
!
igk = igk_k_all(1:npw,ik+lower_bnd-1)
igkq = igk_k_all(1:npwq,nkq_abs)
!
IF ( nks.gt.1 .AND. maxval(igkq(1:npwq)).gt.ngxx ) &
CALL errore('elphel2_shuffle', 'ngxx too small', 1 )
!
! ----------------------------------------------------------------
! Set the gauge for the eigenstates: unitary transform and phases
! ----------------------------------------------------------------
!
! With this option, different compilers and different machines
! should always give the same wavefunctions.
!
CALL ktokpmq( xk(:,ik), zero_vect, +1, ipool, nkk, nkk_abs )
CALL ktokpmq( xkq(:,ik), zero_vect, +1, ipool, nkk, nkq_abs )
!
IF ( .not. ALLOCATED(umat) ) ALLOCATE( umat(nbnd,nbnd,nks) )
IF ( .not. ALLOCATED(umatq) ) ALLOCATE( umatq(nbnd,nbnd,nks) )
umat(:,:,ik) = umat_all(:,:,nkk_abs)
umatq(:,:,ik) = umat_all(:,:,nkq_abs)
!
! the k-vector needed for the KB projectors
xkqtmp = xkq(:,ik)
!
! --------------------------------------------------
! Fourier translation of the G-sphere igkq
! --------------------------------------------------
!
! Translate by G_0 the G-sphere where evq is defined,
! none of the G-points are lost.
!
DO ig = 1, npwq
imap = ng0vec * ( igkq(ig) - 1 ) + shift(ik+ik0)
igkq_tmp(ig) = gmap(imap)
! the old matrix version...
! igkq_tmp(ig) = gmap( igkq(ig), shift(ik+ik0) )
ENDDO
igkq = igkq_tmp
!
! find k+q from k+q+G_0
! (this is needed in the calculation of the KB terms
! for nonlocal pseudos)
!
xkqtmp = xkq(:,ik) - g0vec_all_r(:,shift(ik+ik0))
!
! ---------------------------------------------------------------------
! phase factor arising from fractional traslations
! ---------------------------------------------------------------------
!
! u_{k+q+G_0} carries an additional factor e^{i G_0 v}
!
CALL fractrasl( npw, igk, evc, eigv(:,isym), cone )
CALL fractrasl( npwq, igkq, evq, eigv(:,isym), cone )
!
! ---------------------------------------------------------------------
! wave function rotation to generate matrix elements for the star of q
! ---------------------------------------------------------------------
!
! ps. don't use npwx instead of npw, npwq since the unused elements
! may be large and blow up gmapsym (personal experience)
!
igk (1:npw ) = gmapsym( igk (1:npw ), isym )
igkq(1:npwq) = gmapsym( igkq(1:npwq), isym )
!
! In dvqpsi_us_only3 we need becp1 and alphap for the rotated wfs.
! The other quantities (deeq and qq) do not depend on the wfs, in
! particular in the KB case (not ultrasoft), the deeq's are the
! unscreened coefficients, and the qq's are zero.
!
! For the KB part, remember dV_NL[q_0] ~ |S^-1(k)+q_0> <S^-1(k)|
! the total momentum transfer must be q_0 and the rotation
! tranforms k+Sq_0 into S^-1(k)+q_0, k into S^-1(k)
! [see Eqs. (A9),(A14) Baroni et al. RMP]
!
! Since in QE a normal rotation s is defined as S^-1 we have here
! sxk = S(k).
!
CALL rotate_cart( xk(:,ik), s(:,:,isym), sxk )
!
! here we generate vkb on the igk() set and for k ...
CALL init_us_2( npw, igk, sxk, vkb )
!
! ... and we recompute the becp terms with the wfs (rotated through igk)
!
CALL calbec( npw, vkb, evc, becp1(ik) )
!
! we also recompute the derivative of the becp terms with the (rotated) wfs
!
DO ipol = 1, 3
aux2 = czero
DO ibnd = 1, nbnd
DO ig = 1, npw
aux2(ig,ibnd) = evc(ig,ibnd) * tpiba * ci * &
( sxk(ipol) + g(ipol,igk(ig)) )
END DO
IF (noncolin) THEN
DO ig = 1, npw
aux2(ig+npwx,ibnd) = evc(ig+npwx,ibnd) * tpiba * ci * &
( sxk(ipol) + g(ipol,igk(ig)) )
ENDDO
ENDIF
ENDDO
CALL calbec( npw, vkb, aux2, alphap(ipol,ik) )
ENDDO
!
! now we generate vkb on the igkq() set because dvpsi is needed on that set
! we need S(k)+q_0 in the KB projector: total momentum transfer must be q_0
!
xkqtmp = sxk + xq0
CALL init_us_2( npwq, igkq, xkqtmp, vkb )
!
! --------------------------------------------------
! Calculation of the matrix element
! --------------------------------------------------
!
DO ipert = 1, npe
!
! recalculate dvbare_q*psi_k
! the call to dvqpsi_us3 differs from the old one to dvqpsi_us
! only the xkqtmp passed.
!
! we have to use the first q in the star in the dvqpsi_us3 call below (xq0)
!
mode = imode0 + ipert
IF (timerev) THEN
CALL dvqpsi_us3( ik, conjg(u(:,mode)), .false., xkqtmp, xq0 )
ELSE
CALL dvqpsi_us3( ik, u(:,mode), .false., xkqtmp, xq0 )
!
! find index, and possibly pool, of k+q
! the index nkq (nkq_abs) takes into account the even/odd ordering
! of the nscf calc
! we also redefine the ikq points and the corresponding energies
! (we need to make sure that xk(:,ikq) is really k+q for the KB projectors
! below and also that the eigenvalues are taken correctly in ephwann)
!
CALL ktokpmq( xk_loc(:,ik), xq, +1, ipool, nkq, nkq_abs )
!
! we define xkq(:,ik) and etq(:,ik) for the current xq
!
IF (ALLOCATED(etq)) DEALLOCATE (etq)
IF (.NOT. ALLOCATED(etq)) ALLOCATE (etq(nbnd, nks))
etq(:,:) = zero
!
xkq(:,ik) = xk_all(:,nkq_abs)
etq(:,ik) = et_all(:,nkq_abs)
!
ipooltmp = my_pool_id + 1
!
! in serial execution ipool is not used in the called subroutines,
! in parallel ipooltmp is for k and ipool is for k+q
!
! read unperturbed wavefunctions psi(k) and psi(k+q)
!
CALL readwfc( ipooltmp, ik, evc )
CALL readwfc( ipool, nkq, evq )
!
! Now we define the igk and igkq from the global igk_k_all
!
npw = ngk_all(ik + lower_bnd - 1)
npwq = ngk_all(nkq_abs)
!
ALLOCATE (igk(npw))
ALLOCATE (igkq(npwq))
!
igk = igk_k_all(1:npw, ik + lower_bnd - 1)
igkq = igk_k_all(1:npwq, nkq_abs)
!
IF ( nks > 1 .AND. MAXVAL(igkq(1:npwq)) > ngxx ) &
CALL errore('elphel2_shuffle', 'ngxx too small', 1 )
!
! ----------------------------------------------------------------
! Set the gauge for the eigenstates: unitary transform and phases
! ----------------------------------------------------------------
!
! With this option, different compilers and different machines
! should always give the same wavefunctions.
!
CALL ktokpmq(xk_loc(:,ik), zero_vect, +1, ipool, nkk, nkk_abs)
CALL ktokpmq(xkq(:,ik), zero_vect, +1, ipool, nkk, nkq_abs)
!
umat(:, :, ik) = umat_all(:, :, nkk_abs)
umatq(:, :, ik) = umat_all(:, :, nkq_abs)
!
! the k-vector needed for the KB projectors
xkqtmp = xkq(:,ik)
!
! --------------------------------------------------
! Fourier translation of the G-sphere igkq
! --------------------------------------------------
!
! Translate by G_0 the G-sphere where evq is defined,
! none of the G-points are lost.
!
DO ig = 1, npwq
imap = ng0vec * ( igkq(ig) - 1 ) + shift(ik+ik0)
igkq_tmp(ig) = gmap(imap)
! the old matrix version...
! igkq_tmp(ig) = gmap( igkq(ig), shift(ik+ik0) )
ENDDO
igkq = igkq_tmp
!
! find k+q from k+q+G_0
! (this is needed in the calculation of the KB terms
! for nonlocal pseudos)
!
xkqtmp = xkq(:,ik) - g0vec_all_r(:,shift(ik+ik0))
!
! ---------------------------------------------------------------------
! phase factor arising from fractional traslations
! ---------------------------------------------------------------------
!
! u_{k+q+G_0} carries an additional factor e^{i G_0 v}
!
CALL fractrasl( npw, igk, evc, eigv(:,isym), cone )
CALL fractrasl( npwq, igkq, evq, eigv(:,isym), cone )
!
! ---------------------------------------------------------------------
! wave function rotation to generate matrix elements for the star of q
! ---------------------------------------------------------------------
!
! ps. don't use npwx instead of npw, npwq since the unused elements
! may be large and blow up gmapsym (personal experience)
!
igk(1:npw ) = gmapsym( igk (1:npw ), isym )
igkq(1:npwq) = gmapsym( igkq(1:npwq), isym )
!
! In dvqpsi_us_only3 we need becp1 and alphap for the rotated wfs.
! The other quantities (deeq and qq) do not depend on the wfs, in
! particular in the KB case (not ultrasoft), the deeq's are the
! unscreened coefficients, and the qq's are zero.
!
! For the KB part, remember dV_NL[q_0] ~ |S^-1(k)+q_0> <S^-1(k)|
! the total momentum transfer must be q_0 and the rotation
! tranforms k+Sq_0 into S^-1(k)+q_0, k into S^-1(k)
! [see Eqs. (A9),(A14) Baroni et al. RMP]
!
! Since in QE a normal rotation s is defined as S^-1 we have here
! sxk = S(k).
!
CALL rotate_cart( xk_loc(:,ik), s(:,:,isym), sxk )
!
! here we generate vkb on the igk() set and for k ...
CALL init_us_2( npw, igk, sxk, vkb )
!
! ... and we recompute the becp terms with the wfs (rotated through igk)
!
CALL calbec( npw, vkb, evc, becp1(ik) )
!
! we also recompute the derivative of the becp terms with the (rotated) wfs
!
DO ipol=1, 3
aux2 = czero
DO ibnd=1, nbnd
DO ig=1, npw
aux2(ig,ibnd) = evc(ig,ibnd) * tpiba * ci * &
( sxk(ipol) + g(ipol,igk(ig)) )
END DO
IF (noncolin) THEN
DO ig=1, npw
aux2(ig+npwx,ibnd) = evc(ig+npwx,ibnd) * tpiba * ci * &
( sxk(ipol) + g(ipol,igk(ig)) )
ENDDO
ENDIF
ENDDO
CALL calbec( npw, vkb, aux2, alphap(ipol,ik) )
ENDDO
!
! now we generate vkb on the igkq() set because dvpsi is needed on that set
! we need S(k)+q_0 in the KB projector: total momentum transfer must be q_0
!
xkqtmp = sxk + xq0
CALL init_us_2( npwq, igkq, xkqtmp, vkb )
!
! --------------------------------------------------
! Calculation of the matrix element
! --------------------------------------------------
!
DO ipert=1, npe
!
! recalculate dvbare_q*psi_k
! the call to dvqpsi_us3 differs from the old one to dvqpsi_us
! only the xkqtmp passed.
!
! we have to use the first q in the star in the dvqpsi_us3 call below (xq0)
!
mode = imode0 + ipert
IF (timerev) THEN
CALL dvqpsi_us3(ik, CONJG(u(:, mode)), .false., xkqtmp, xq0, igk, igkq, npw, npwq)
ELSE
CALL dvqpsi_us3(ik, u(:, mode), .false., xkqtmp, xq0, igk, igkq, npw, npwq)
ENDIF
!DBSP
! b = b+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
! b = b+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
!END
!
! calculate dvscf_q*psi_k
!
CALL start_clock('dvscf_q*psi_k')
!
aux3 = czero
DO ibnd = lower_band, upper_band
CALL invfft_wave(npw, igk, evc(:,ibnd), aux1)
IF (timerev) THEN
CALL apply_dpot(dffts%nnr, aux1, conjg(dvscfins(:,:,ipert)), current_spin)
ELSE
CALL apply_dpot(dffts%nnr, aux1, dvscfins(:,:,ipert), current_spin)
ENDIF
CALL fwfft_wave(npwq, igkq, aux3(:,ibnd), aux1)
ENDDO
dvpsi = dvpsi + aux3
!
!
! calculate dvscf_q*psi_k
!
CALL start_clock('dvscf_q*psi_k')
!
aux3 = czero
DO ibnd = lower_band, upper_band
CALL invfft_wave(npw, igk, evc(:,ibnd), aux1)
IF (timerev) THEN
CALL apply_dpot(dffts%nnr, aux1, conjg(dvscfins(:,:,ipert)), current_spin)
ELSE
CALL apply_dpot(dffts%nnr, aux1, dvscfins(:,:,ipert), current_spin)
ENDIF
CALL fwfft_wave(npwq, igkq, aux3(:,ibnd), aux1)
ENDDO
dvpsi = dvpsi + aux3
!
!DBSP
! c = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
! c = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
!END
!
CALL adddvscf2( ipert, ik )
!
CALL adddvscf2( ipert, ik )
!DBRM
! d = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
! d = c+SUM((REAL(REAL(dvpsi(:,:))))**2)+SUM((REAL(AIMAG(dvpsi(:,:))))**2)
!END
!
! calculate elphmat(j,i)=<psi_{k+q,j}|dvscf_q*psi_{k,i}> for this pertur
!
!
DO ibnd =lower_band, upper_band
DO jbnd = 1, nbnd
elphmat(jbnd,ibnd,ipert) = &
zdotc( npwq, evq(1,jbnd), 1, dvpsi(1,ibnd), 1 )
IF (noncolin) &
elphmat(jbnd,ibnd,ipert) = elphmat(jbnd,ibnd,ipert) + &
zdotc( npwq, evq(npwx+1,jbnd), 1, dvpsi(npwx+1,ibnd), 1 )
ENDDO
!
! calculate elphmat(j,i)=<psi_{k+q,j}|dvscf_q*psi_{k,i}> for this pertur
!
!
DO ibnd =lower_band, upper_band
DO jbnd = 1, nbnd
elphmat(jbnd,ibnd,ipert) = &
zdotc( npwq, evq(1,jbnd), 1, dvpsi(1,ibnd), 1 )
IF (noncolin) &
elphmat(jbnd,ibnd,ipert) = elphmat(jbnd,ibnd,ipert) + &
zdotc( npwq, evq(npwx+1,jbnd), 1, dvpsi(npwx+1,ibnd), 1 )
ENDDO
ENDDO
!
CALL mp_sum(elphmat, intra_pool_comm)
CALL mp_sum(elphmat, inter_image_comm)
!
ENDDO
ENDDO
!
CALL mp_sum(elphmat, intra_pool_comm)
CALL mp_sum(elphmat, inter_image_comm)
!
!DBSP
! IF (ik==2) THEN
! write(*,*)'SUM dvpsi b ', b
@ -447,33 +464,36 @@
! write(*,*)'elphmat(:,:,:)**2', SUM((REAL(REAL(elphmat(:,:,:))))**2)+SUM((REAL(AIMAG(elphmat(:,:,:))))**2)
! ENDIF
!END
!
! Rotate elphmat with the gauge matrices (this should be equivalent
! to calculate elphmat with the truely rotated eigenstates)
!
DO ipert = 1, npe
!
! the two zgemm call perform the following ops:
! elphmat = umat(k+q)^\dagger * [ elphmat * umat(k) ]
!
CALL zgemm( 'n', 'n', nbnd, nbnd, nbnd, cone, elphmat(:,:,ipert), &
nbnd, umat(:,:,ik), nbnd, czero, eptmp, nbnd )
CALL zgemm( 'c', 'n', nbnd, nbnd, nbnd, cone, umatq(:,:,ik), &
nbnd, eptmp, nbnd, czero, elphmat(:,:,ipert), nbnd )
!
ENDDO
!
! save eph matrix elements into el_ph_mat
!
DO ipert = 1, npe
DO jbnd = 1, nbnd
DO ibnd = 1, nbnd
el_ph_mat(ibnd,jbnd,ik,ipert+imode0) = elphmat(ibnd,jbnd,ipert)
ENDDO
!
! Rotate elphmat with the gauge matrices (this should be equivalent
! to calculate elphmat with the truely rotated eigenstates)
!
DO ipert=1, npe
!
! the two zgemm call perform the following ops:
! elphmat = umat(k+q)^\dagger * [ elphmat * umat(k) ]
!
CALL zgemm( 'n', 'n', nbnd, nbnd, nbnd, cone, elphmat(:,:,ipert), &
nbnd, umat(:,:,ik), nbnd, czero, eptmp, nbnd )
CALL zgemm( 'c', 'n', nbnd, nbnd, nbnd, cone, umatq(:,:,ik), &
nbnd, eptmp, nbnd, czero, elphmat(:,:,ipert), nbnd )
!
ENDDO
!
! save eph matrix elements into el_ph_mat
!
DO ipert=1, npe
DO jbnd=1, nbnd
DO ibnd=1, nbnd
el_ph_mat(ibnd,jbnd,ik,ipert+imode0) = elphmat(ibnd,jbnd,ipert)
ENDDO
ENDDO
!
ENDDO
ENDDO
ENDDO
!
DEALLOCATE (igk)
DEALLOCATE (igkq)
!
ENDDO ! ik
!
! restore original configuration of files
!
@ -481,13 +501,14 @@
! never remove this barrier - > insures that wfcs are restored to each pool before moving on
CALL mp_barrier(world_comm)
!
DEALLOCATE(elphmat)
DEALLOCATE(eptmp)
DEALLOCATE(aux1)
DEALLOCATE(aux2)
DEALLOCATE(aux3)
DEALLOCATE(gmap)
DEALLOCATE(shift)
DEALLOCATE (elphmat)
DEALLOCATE (eptmp)
DEALLOCATE (aux1)
DEALLOCATE (aux2)
DEALLOCATE (aux3)
DEALLOCATE (dvpsi)
DEALLOCATE (gmap)
DEALLOCATE (shift)
!
END SUBROUTINE elphel2_shuffle
!
@ -502,7 +523,8 @@
!
IMPLICIT NONE
!
INTEGER, INTENT(in) :: npw, igk(npwx)
INTEGER, INTENT(in) :: npw
INTEGER, INTENT(in) :: igk(npw)
COMPLEX(kind=DP), INTENT(inout) :: evc(npwx*npol, nbnd)
COMPLEX(kind=DP), INTENT(in) :: eigv1(ngm), eig0v
!

21
EPW/src/elphon_shuffle.f90
View File

@ -85,19 +85,21 @@
!
! read Delta Vscf and calculate electron-phonon coefficients
!
ALLOCATE (el_ph_mat(nbnd, nbnd, nks, 3 * nat))
!
imode0 = 0
DO irr = 1, nirr
npe = npert(irr)
ALLOCATE( dvscfin(dfftp%nnr, nspin_mag, npe) )
ALLOCATE ( dvscfin(dfftp%nnr, nspin_mag, npe) )
IF (okvan) THEN
ALLOCATE( int3(nhm, nhm, nat, nspin_mag, npe) )
IF (noncolin) ALLOCATE( int3_nc(nhm, nhm, nat, nspin, npe) )
ALLOCATE ( int3(nhm, nhm, nat, nspin_mag, npe) )
IF (noncolin) ALLOCATE ( int3_nc(nhm, nhm, nat, nspin, npe) )
ENDIF
!
! read the <prefix>.dvscf_q[iq] files
!
dvscfin = czero
IF ( my_pool_id.eq.0 ) THEN
IF ( my_pool_id == 0 ) THEN
DO ipert = 1, npe
CALL readdvscf( dvscfin(1,1,ipert), imode0 + ipert, iq_irr, nqc_irr )
ENDDO
@ -105,7 +107,7 @@
CALL mp_sum(dvscfin,inter_pool_comm)
!
IF (doublegrid) THEN
ALLOCATE( dvscfins(dffts%nnr, nspin_mag, npe) )
ALLOCATE ( dvscfins(dffts%nnr, nspin_mag, npe) )
DO is = 1, nspin_mag
DO ipert = 1, npe
CALL fft_interpolate(dfftp, dvscfin(:,is,ipert), dffts, dvscfins(:,is,ipert))
@ -119,11 +121,11 @@
CALL elphel2_shuffle( npe, imode0, dvscfins, gmapsym, eigv, isym, xq0, timerev )
!
imode0 = imode0 + npe
IF (doublegrid) DEALLOCATE(dvscfins)
DEALLOCATE(dvscfin)
IF (doublegrid) DEALLOCATE (dvscfins)
DEALLOCATE (dvscfin)
IF (okvan) THEN
DEALLOCATE(int3)
IF (noncolin) DEALLOCATE(int3_nc)
DEALLOCATE (int3)
IF (noncolin) DEALLOCATE (int3_nc)
ENDIF
ENDDO
!
@ -153,6 +155,7 @@
ENDDO
ENDDO
ENDDO
DEALLOCATE (el_ph_mat)
!DBSP
!write(*,*)'epmatq(:,:,215,:,iq)**2',SUM((REAL(REAL(epmatq(:,:,215,:,iq))))**2)+&
! SUM((REAL(AIMAG(epmatq(:,:,215,:,iq))))**2)

278
EPW/src/elphon_shuffle_wrap.f90
View File

@ -21,7 +21,7 @@
!
USE kinds, ONLY : DP
USE mp_global, ONLY : my_pool_id, inter_pool_comm, &
npool, inter_image_comm, world_comm
npool, inter_image_comm, world_comm
USE mp_images, ONLY : my_image_id, nimage
USE mp_world, ONLY : mpime
USE mp, ONLY : mp_barrier, mp_bcast
@ -32,31 +32,41 @@
USE uspp_param, ONLY : lmaxq, nbetam
USE io_files, ONLY : prefix, tmp_dir
USE wavefunctions, ONLY : evc
USE wvfct, ONLY : npwx
USE eqv, ONLY : vlocq, dmuxc
USE ions_base, ONLY : nat, nsp, tau, ityp
USE control_flags, ONLY : iverbosity
USE io_epw, ONLY : iuepb, iuqpeig
USE pwcom, ONLY : et, xk, nks, nbnd, nkstot
USE pwcom, ONLY : nks, nbnd, nkstot
USE cell_base, ONLY : at, bg
USE symm_base, ONLY : irt, s, nsym, ftau, sname, invs, s_axis_to_cart, &
USE symm_base, ONLY : irt, s, nsym, ft, sname, invs, s_axis_to_cart, &
sr, nrot, copy_sym, set_sym_bl, find_sym, &
inverse_s, remove_sym, allfrac
USE start_k, ONLY : nk1, nk2, nk3
USE phcom, ONLY : dpsi, dvpsi, evq, nq1, nq3, nq2
USE qpoint, ONLY : igkq, xq
USE modes, ONLY : nmodes
USE qpoint, ONLY : igkq, xq, eigqts
USE modes, ONLY : nmodes, u, npert
USE lr_symm_base, ONLY : minus_q, rtau, gi, gimq, irotmq, nsymq, invsymq
USE epwcom, ONLY : epbread, epbwrite, epwread, lifc, etf_mem, vme, &
nbndsub, iswitch, kmaps, eig_read, dvscf_dir, lpolar
USE elph2, ONLY : epmatq, dynq, sumr, et_all, xk_all, et_mb, et_ks, &
USE elph2, ONLY : epmatq, dynq, sumr, et_ks, &
zstar, epsi, cu, cuq, lwin, lwinq, bmat, igk_k_all, &
ngk_all, exband
ngk_all, exband, wscache, umat, umat_all
USE klist_epw, ONLY : xk_all, et_loc, et_all
USE constants_epw, ONLY : ryd2ev, zero, czero
USE fft_base, ONLY : dfftp
USE control_ph, ONLY : u_from_file
USE noncollin_module, ONLY : m_loc
USE noncollin_module, ONLY : m_loc, npol, noncolin
USE iotk_module, ONLY : iotk_open_read, iotk_scan_dat, iotk_free_unit, &
iotk_close_read
USE division, ONLY : fkbounds
USE uspp, ONLY : okvan
USE spin_orb, ONLY : lspinorb
USE lrus, ONLY : becp1
USE becmod, ONLY : becp, deallocate_bec_type
USE phus, ONLY : int1, int1_nc, int2, int2_so, &
int4, int4_nc, int5, int5_so, alphap
#if defined(__NAG)
USE f90_unix_io, ONLY : flush
#endif
@ -76,7 +86,7 @@
INTEGER :: maxvalue
!! Temporary integer for max value
INTEGER :: nqxq_tmp
!! Maximum G+q length ?
!! Maximum G+q length
INTEGER :: ibnd
!! Band index
INTEGER :: ik
@ -136,7 +146,7 @@
!! The corresponding weigths
REAL(kind=DP) :: sxq(3, 48)
!! List of vectors in the star of q
REAL(kind=DP) :: et_tmp(nbnd,nkstot)
REAL(kind=DP) :: et_tmp(nbnd, nkstot)
!! Temporary array containing the eigenvalues (KS or GW) when read from files
REAL(kind=DP) :: xq0(3)
!! Current coarse q-point coords.
@ -196,11 +206,12 @@
!
IF (meta_ionode) READ(5,*) nqc_irr
CALL mp_bcast(nqc_irr, meta_ionode_id, world_comm)
ALLOCATE( xqc_irr(3,nqc_irr) )
ALLOCATE( xqc(3,nq1*nq2*nq3), wqlist(nq1*nq2*nq3) )
xqc_irr(:,:) = zero
xqc(:,:) = zero
wqlist(:) = zero
ALLOCATE (xqc_irr(3, nqc_irr))
ALLOCATE (xqc(3, nq1 * nq2 * nq3))
ALLOCATE (wqlist(nq1 * nq2 * nq3))
xqc_irr(:, :) = zero
xqc(:, :) = zero
wqlist(:) = zero
!
IF (meta_ionode) THEN
DO iq_irr = 1, nqc_irr
@ -215,39 +226,41 @@
!
maxvalue = nqxq
DO iq_irr = 1, nqc_irr
qnorm_tmp = sqrt( xqc_irr(1,iq_irr)**2 + xqc_irr(2,iq_irr)**2 + &
xqc_irr(3,iq_irr)**2)
nqxq_tmp = INT( ( (sqrt(gcutm) + qnorm_tmp) / dq + 4) * cell_factor )
IF (nqxq_tmp .gt. maxvalue) maxvalue = nqxq_tmp
qnorm_tmp = SQRT(xqc_irr(1, iq_irr)**2 + xqc_irr(2, iq_irr)**2 + &
xqc_irr(3, iq_irr)**2)
nqxq_tmp = INT(((SQRT(gcutm) + qnorm_tmp) / dq + 4) * cell_factor)
IF (nqxq_tmp > maxvalue) maxvalue = nqxq_tmp
ENDDO
IF (maxvalue .gt. nqxq) THEN
IF (ALLOCATED(qrad)) DEALLOCATE(qrad)
ALLOCATE( qrad(maxvalue, nbetam*(nbetam+1)/2, lmaxq, nsp) )
!
IF (maxvalue > nqxq) THEN
IF (ALLOCATED(qrad)) DEALLOCATE (qrad)
ALLOCATE (qrad(maxvalue, nbetam * (nbetam + 1) / 2, lmaxq, nsp))
qrad(:,:,:,:) = zero
! RM - need to call init_us_1 to re-calculate qrad
CALL init_us_1
ENDIF
!
! do not perform the check if restart
IF ( epwread .and. .not. epbread ) THEN
IF (epwread .AND. .NOT. epbread) THEN
CONTINUE
ELSE
IF (nkstot .ne. nk1*nk2*nk3 ) &
IF (nkstot /= nk1 * nk2 * nk3) &
CALL errore('elphon_shuffle_wrap','nscf run inconsistent with epw input',1)
ENDIF
!
! Read in external electronic eigenvalues. e.g. GW
!
IF ( .not. ALLOCATED(et_ks) ) ALLOCATE(et_ks(nbnd,nks))
IF ( .not. ALLOCATED(et_mb) ) ALLOCATE(et_mb(nbnd,nks))
et_ks(:,:) = zero
et_mb(:,:) = zero
ALLOCATE (et_ks(nbnd, nks))
et_ks(:, :) = zero
IF (eig_read) THEN
IF (meta_ionode) THEN
WRITE (stdout,'(5x,a,i5,a,i5,a)') "Reading external electronic eigenvalues (", &
nbnd, ",", nkstot,")"
tempfile = trim(prefix)//'.eig'
OPEN(iuqpeig, file=tempfile, form='formatted', action='read', iostat=ios)
OPEN(iuqpeig, FILE=tempfile, FORM='formatted', action='read', iostat=ios)
IF (ios /= 0) CALL errore('elphon_shuffle_wrap','error opening' // tempfile, 1)
READ(iuqpeig,'(a)') line
DO ik = 1, nkstot
DO ik=1, nkstot
! We do not save the k-point for the moment ==> should be read and
! tested against the current one
READ(iuqpeig,'(a)') line
@ -260,28 +273,26 @@
CALL mp_bcast(et_tmp, meta_ionode_id, world_comm)
!
CALL fkbounds(nkstot, ik_start, ik_stop)
et_ks(:,:) = et(:,1:nks)
et(:,1:nks) = et_tmp(:,ik_start:ik_stop)
et_mb(:,:) = et(:,1:nks)
et_ks(:,:) = et_loc(:,:)
et_loc(:,:) = et_tmp(:,ik_start:ik_stop)
ENDIF
!
! Do not recompute dipole matrix elements
IF ( epwread .and. .not. epbread ) THEN
IF ( epwread .AND. .NOT. epbread ) THEN
CONTINUE
ELSE
! compute coarse grid dipole matrix elements. Very fast
IF (.not. vme) CALL compute_pmn_para
IF (.NOT. vme) CALL compute_pmn_para
ENDIF
!
! gather electronic eigenvalues for subsequent shuffle
!
ALLOCATE( xk_all(3,nkstot), et_all(nbnd,nkstot) )
xk_all(:,:) = zero
et_all(:,:) = zero
CALL poolgather( 3, nkstot, nks, xk(:,1:nks), xk_all)
CALL poolgather(nbnd, nkstot, nks, et(1:nbnd,1:nks), et_all)
IF (eig_read) THEN
et_all(:,:) = zero
CALL poolgather(nbnd, nkstot, nks, et_loc(1:nbnd,1:nks), et_all)
ENDIF
!
IF (.not.kmaps) THEN
IF (.NOT. kmaps) THEN
CALL start_clock('kmaps')
CALL createkmap_pw2
CALL stop_clock('kmaps')
@ -295,30 +306,31 @@
WRITE(stdout,'(/5x,a)') 'Using kmap and kgmap from disk'
ENDIF
!
CALL mp_barrier(inter_pool_comm)
CALL mp_barrier(inter_image_comm)
!
! Do not do symmetry stuff
IF ( epwread .AND. .not. epbread ) THEN
IF (epwread .AND. .NOT. epbread) THEN
CONTINUE
ELSE
!
! allocate dynamical matrix and ep matrix for all q's
!
ALLOCATE( dynq(nmodes, nmodes, nq1*nq2*nq3), &
epmatq(nbnd, nbnd, nks, nmodes, nq1*nq2*nq3), &
epsi(3,3), zstar(3,3,nat), &
bmat(nbnd, nbnd, nks, nq1*nq2*nq3), &
cu(nbnd, nbndsub, nks), cuq(nbnd, nbndsub, nks), &
lwin(nbnd, nks), lwinq(nbnd, nks), exband(nbnd) )
ALLOCATE (dynq(nmodes, nmodes, nq1 * nq2 * nq3))
ALLOCATE (epmatq(nbnd, nbnd, nks, nmodes, nq1 * nq2 * nq3))
ALLOCATE (epsi(3, 3))
ALLOCATE (zstar(3, 3, nat))
ALLOCATE (bmat(nbnd, nbnd, nks, nq1 * nq2 * nq3))
ALLOCATE (cu(nbnd, nbndsub, nks))
ALLOCATE (cuq(nbnd, nbndsub, nks))
ALLOCATE (lwin(nbnd, nks))
ALLOCATE (lwinq(nbnd, nks))
ALLOCATE (exband(nbnd))
!
dynq(:,:,:) = czero
epmatq(:,:,:,:,:) = czero
bmat(:,:,:,:) = czero
cu(:,:,:) = czero
cuq(:,:,:) = czero
epsi(:,:) = zero
zstar(:,:,:) = zero
dynq(:, :, :) = czero
epmatq(:, :, :, :, :) = czero
epsi(:, :) = zero
zstar(:, :, :) = zero
bmat(:, :, :, :) = czero
cu(:, :, :) = czero
cuq(:, :, :) = czero
!
! read interatomic force constat matrix from q2r
IF (lifc) CALL read_ifc
@ -334,13 +346,13 @@
!
! ~~~~~~~~ setup crystal symmetry ~~~~~~~~
CALL find_sym(nat, tau, ityp, .false., m_loc)
IF ( .not. allfrac ) CALL remove_sym( dfftp%nr1, dfftp%nr2, dfftp%nr3 )
IF ( .NOT. allfrac ) CALL remove_sym( dfftp%nr1, dfftp%nr2, dfftp%nr3 )
WRITE(stdout,'(5x,a,i3)') "Symmetries of crystal: ", nsym
!
! The following loop is required to propertly set up the symmetry matrix s.
! We here copy the calls made in PHonon/PH/init_representations.f90 to have the same s as in QE 5.
DO iq_irr = 1, nqc_irr
xq = xqc_irr(:,iq_irr)
DO iq_irr=1, nqc_irr
xq = xqc_irr(:, iq_irr)
! search for the small group of q
CALL set_small_group_of_q(nsymq, invsymq, minus_q)
! calculate rtau with the new symmetry order
@ -349,11 +361,17 @@
! if minus_q is true calculate also irotmq and the G associated to Sq=-g+G
CALL set_giq(xq, s, nsymq, nsym, irotmq, minus_q, gi, gimq)
ENDDO
ENDIF ! epwread .and. .not. epbread
ENDIF ! epwread .and. .NOT. epbread
!
! CV: if we read the .fmt files we don't need to read the .epb anymore
!
IF (.not. epbread .AND. .not. epwread) THEN
IF (.NOT. epbread .AND. .NOT. epwread) THEN
!
ALLOCATE (evq(npwx * npol, nbnd))
IF (lifc) THEN
ALLOCATE (wscache(-2*nq3:2*nq3, -2*nq2:2*nq2, -2*nq1:2*nq1, nat, nat))
wscache(:,:,:,:,:) = zero
ENDIF
!
! In the loop over irr q-point, we need to read the pattern that
! corresponds to the dvscf file computed with QE 5.
@ -374,7 +392,7 @@
filename = TRIM(dirname) // '/patterns.' // &
TRIM(int_to_char(iq_irr)) // '.xml'
INQUIRE(FILE=TRIM(filename), EXIST=exst )
IF (.not.exst) CALL errore('elphon_shuffle_wrap', &
IF ( .NOT. exst) CALL errore('elphon_shuffle_wrap', &
'cannot open file for reading or writing', ierr)
CALL iotk_open_read(iunpun, file = TRIM(filename), &
binary = .FALSE., ierr = ierr)
@ -398,7 +416,7 @@
minus_q = .true.
sym = .false.
sym(1:nsym) = .true.
CALL smallg_q(xq, 0, at, bg, nsym, s, ftau, sym, minus_q) ! s is intent(in)
CALL smallg_q(xq, 0, at, bg, nsym, s, sym, minus_q) ! s is intent(in)
!
! SP: Notice that the function copy_sym reshuffles the s matrix for each irr_q.
! This is why we then need to call gmap_sym for each irr_q [see below].
@ -429,7 +447,7 @@
! reshuffles the s matrix for each irr_q [putting the sym of the small group of q first].
!
! [I checked that gmapsym(gmapsym(ig,isym),invs(isym)) = ig]
CALL gmap_sym(nsym, s, ftau, gmapsym, eigv, invs)
CALL gmap_sym(nsym, s, ft, gmapsym, eigv, invs)
!
! Re-set the variables needed for the pattern representation
! and the symmetries of the small group of irr-q
@ -441,7 +459,7 @@
!
CALL sgam_lr(at, bg, nsym, s, irt, tau, rtau, nat)
!
IF ( .not. ALLOCATED(sumr) ) ALLOCATE( sumr(2,3,nat,3) )
IF ( .NOT. ALLOCATED(sumr) ) ALLOCATE ( sumr(2,3,nat,3) )
IF (meta_ionode) THEN
CALL readmat_shuffle2(iq_irr, nqc_irr, nq, iq_first, sxq, imq, isq, &
invs, s, irt, rtau)
@ -453,14 +471,14 @@
!
! now dynq is the cartesian dyn mat (not divided by the masses)
!
minus_q = (iswitch .gt. -3)
minus_q = (iswitch > -3)
!
! loop over the q points of the star
!
DO iq = 1, nq
! SP: First the vlocq needs to be initialized properly with the first
! q in the star
xq = xq0
xq = xq0
CALL epw_init(.false.)
!
! retrieve the q in the star
@ -470,14 +488,14 @@
nqc = nqc + 1
xqc(:,nqc) = xq
!
IF (iq .eq. 1) WRITE(stdout,*)
IF (iq == 1) WRITE(stdout,*)
WRITE(stdout,5) nqc, xq
!
! prepare the gmap for the refolding
!
CALL createkmap( xq )
!
IF (iverbosity.eq.1) THEN
IF (iverbosity == 1) THEN
!
! description of symmetries
!
@ -485,20 +503,17 @@
CALL s_axis_to_cart() ! give sr(:,:, isym)
DO isym = 1, nsym
WRITE( stdout, '(/6x,"isym = ",i2,5x,a45/)') isym, sname(isym)
IF (ftau(1,isym).ne.0 .OR. ftau(2,isym).ne.0 .OR. ftau(3,isym).ne.0) THEN
ft1 = at(1,1)*ftau(1,isym)/dfftp%nr1 + at(1,2)*ftau(2,isym)/dfftp%nr2 + &
at(1,3)*ftau(3,isym)/dfftp%nr3
ft2 = at(2,1)*ftau(1,isym)/dfftp%nr1 + at(2,2)*ftau(2,isym)/dfftp%nr2 + &
at(2,3)*ftau(3,isym)/dfftp%nr3
ft3 = at(3,1)*ftau(1,isym)/dfftp%nr1 + at(3,2)*ftau(2,isym)/dfftp%nr2 + &
at(3,3)*ftau(3,isym)/dfftp%nr3
IF ( ft(1,isym)**2 + ft(2,isym)**2 + ft(3,isym)**2 > 1.0d-8 ) THEN
ft1 = at(1,1)*ft(1,isym) + at(1,2)*ft(2,isym) + at(1,3)*ft(3,isym)
ft2 = at(2,1)*ft(1,isym) + at(2,2)*ft(2,isym) + at(2,3)*ft(3,isym)
ft3 = at(3,1)*ft(1,isym) + at(3,2)*ft(2,isym) + at(3,3)*ft(3,isym)
WRITE(stdout, '(1x,"cryst.",3x,"s(",i2,") = (",3(i6,5x), &
& " ) f =( ",f10.7," )")') &
isym, (s(1,ipol,isym),ipol=1,3), dble(ftau(1,isym))/dble(dfftp%nr1)
isym, (s(1,ipol,isym),ipol=1,3), ft(1,isym)
WRITE(stdout, '(17x," (",3(i6,5x), " ) ( ",f10.7," )")') &
(s(2,ipol,isym),ipol=1,3), dble(ftau(2,isym))/dble(dfftp%nr2)
(s(2,ipol,isym),ipol=1,3), ft(2,isym)
WRITE(stdout, '(17x," (",3(i6,5x), " ) ( ",f10.7," )"/)') &
(s(3,ipol,isym),ipol=1,3), dble(ftau(3,isym))/dble(dfftp%nr3)
(s(3,ipol,isym),ipol=1,3), ft(3,isym)
WRITE(stdout, '(1x,"cart. ",3x,"s(",i2,") = (",3f11.7, &
& " ) f =( ",f10.7," )")') &
isym, (sr(1,ipol,isym),ipol=1,3), ft1
@ -533,14 +548,14 @@
nsq = 0 ! nsq is the degeneracy of the small group for this iq in the star
!
DO jsym = 1, nsym
IF ( isq(jsym) .eq. iq ) THEN
IF ( isq(jsym) == iq ) THEN
nsq = nsq + 1
sym_sgq(nsq) = jsym
ENDIF
ENDDO
IF ( nsq*nq .ne. nsym ) CALL errore('elphon_shuffle_wrap', 'wrong degeneracy', iq)
!
IF (iverbosity.eq.1) THEN
IF (iverbosity == 1) THEN
!
WRITE(stdout,*) 'iq, i, isym, nog, symmo'
DO i = 1, nsq
@ -563,7 +578,7 @@
!
! check whether the symmetry belongs to a symmorphic group
!
symmo = (ftau(1,isym).eq.0 .AND. ftau(2,isym).eq.0 .AND. ftau(3,isym).eq.0)
symmo = ( ft(1,isym)**2 + ft(2,isym)**2 + ft(3,isym)**2 > 1.0d-8 )
!
WRITE(stdout,'(3i5,L3,L3)') iq, i, isym, nog, symmo
!
@ -624,14 +639,14 @@
!
CALL rotate_epmat( cz1, cz2, xq, nqc, lwin, lwinq, exband )
!DBSP
! write(*,*)'epmatq(:,:,2,:,nqc)',SUM(epmatq(:,:,2,:,nqc))
! write(*,*)'epmatq(:,:,2,:,nqc)**2',SUM((REAL(REAL(epmatq(:,:,2,:,nqc))))**2)+&
! SUM((REAL(AIMAG(epmatq(:,:,2,:,nqc))))**2)
! print*,'dynq ', SUM(dynq(:,:,nqc))
! print*,'et ', et(:,2)
!write(*,*)'epmatq(:,:,2,:,nqc)',SUM(epmatq(:,:,2,:,nqc))
!write(*,*)'epmatq(:,:,2,:,nqc)**2',SUM((REAL(REAL(epmatq(:,:,2,:,nqc))))**2)+&
! SUM((REAL(AIMAG(epmatq(:,:,2,:,nqc))))**2)
!print*,'dynq ', SUM(dynq(:,:,nqc))
!print*,'et ', et_loc(:,2)
!END
! SP: Now we treat separately the case imq == 0
IF (imq .eq. 0) THEN
IF (imq == 0) THEN
!
! SP: First the vlocq need to be initialized propertly with the first
! q in the star
@ -645,7 +660,7 @@
nqc = nqc + 1
xqc(:,nqc) = xq
!
IF (iq .eq. 1) write(stdout,*)
IF (iq == 1) write(stdout,*)
WRITE(stdout,5) nqc, xq
!
! prepare the gmap for the refolding
@ -673,7 +688,7 @@
ENDDO
!
iq_first = iq_first + nq
if (imq .eq. 0) iq_first = iq_first + nq
if (imq == 0) iq_first = iq_first + nq
!
ENDDO ! irr-q loop
!
@ -681,7 +696,41 @@
CALL errore('elphon_shuffle_wrap','nqc .ne. nq1*nq2*nq3',nqc)
wqlist = dble(1) / dble(nqc)
!
ENDIF
IF (lifc) DEALLOCATE (wscache)
DEALLOCATE (evc)
DEALLOCATE (evq)
DEALLOCATE (vlocq)
DEALLOCATE (dmuxc)
DEALLOCATE (eigqts)
DEALLOCATE (rtau)
DEALLOCATE (u)
DEALLOCATE (npert)
IF (okvan) THEN
DEALLOCATE (int1)
DEALLOCATE (int2)
DEALLOCATE (int4)
DEALLOCATE (int5)
IF (noncolin) THEN
DEALLOCATE (int1_nc)
DEALLOCATE (int4_nc)
IF (lspinorb) THEN
DEALLOCATE (int2_so)
DEALLOCATE (int5_so)
ENDIF
ENDIF
ENDIF
DO ik = 1, nks
DO ipol = 1, 3
CALL deallocate_bec_type( alphap(ipol,ik) )
ENDDO
ENDDO
DEALLOCATE (alphap)
DO ik = 1, size(becp1)
CALL deallocate_bec_type( becp1(ik) )
ENDDO
DEALLOCATE (becp1)
CALL deallocate_bec_type ( becp )
ENDIF ! IF (.NOT. epbread .AND. .NOT. epwread) THEN
!
IF (my_image_id == 0 ) THEN
IF ( epbread .OR. epbwrite ) THEN
@ -695,10 +744,10 @@
!
IF (epbread) THEN
inquire(file = tempfile, exist=exst)
IF (.not. exst) CALL errore( 'elphon_shuffle_wrap', 'epb files not found ', 1)
IF ( .NOT. exst) CALL errore( 'elphon_shuffle_wrap', 'epb files not found ', 1)
OPEN(iuepb, file = tempfile, form = 'unformatted')
WRITE(stdout,'(/5x,"Reading epmatq from .epb files"/)')
READ(iuepb) nqc, xqc, et, dynq, epmatq, zstar, epsi
READ(iuepb) nqc, xqc, et_loc, dynq, epmatq, zstar, epsi
CLOSE(iuepb)
WRITE(stdout,'(/5x,"The .epb files have been correctly read"/)')
ENDIF
@ -706,7 +755,7 @@
IF (epbwrite) THEN
OPEN(iuepb, file = tempfile, form = 'unformatted')
WRITE(stdout,'(/5x,"Writing epmatq on .epb files"/)')
WRITE(iuepb) nqc, xqc, et, dynq, epmatq, zstar, epsi
WRITE(iuepb) nqc, xqc, et_loc, dynq, epmatq, zstar, epsi
CLOSE(iuepb)
WRITE(stdout,'(/5x,"The .epb files have been correctly written"/)')
ENDIF
@ -721,7 +770,7 @@
CALL stop_epw
ENDIF
!
IF ( .not.epbread .AND. epwread ) THEN
IF ( .NOT. epbread .AND. epwread ) THEN
! CV: need dummy nqc, xqc for the ephwann_shuffle call
nqc = 1
xqc = zero
@ -737,8 +786,15 @@
!
! free up some memory
!
IF ( ASSOCIATED (evq) ) NULLIFY (evq)
IF ( ALLOCATED (evc) ) DEALLOCATE (evc)
DEALLOCATE (umat_all)
DEALLOCATE (umat)
DEALLOCATE (xqc_irr)
DEALLOCATE (wqlist)
!
IF (maxvalue > nqxq) THEN
DEALLOCATE (qrad)
ENDIF
!
IF ( ASSOCIATED (igkq) ) NULLIFY (igkq)
IF ( ALLOCATED (dvpsi)) DEALLOCATE (dvpsi)
IF ( ALLOCATED (dpsi) ) DEALLOCATE (dpsi)
@ -775,6 +831,7 @@
CALL ephwann_shuffle( nqc, xqc )
#endif
ENDIF
DEALLOCATE (xqc)
!
5 FORMAT (8x,"q(",i5," ) = (",3f12.7," )")
!
@ -828,9 +885,9 @@
!! acceptance parameter
PARAMETER (accep = 1.0d-5)
!
eqvect_strict = abs( x(1)-y(1) ) .lt. accep .AND. &
abs( x(2)-y(2) ) .lt. accep .AND. &
abs( x(3)-y(3) ) .lt. accep
eqvect_strict = abs( x(1)-y(1) ) < accep .AND. &
abs( x(2)-y(2) ) < accep .AND. &
abs( x(3)-y(3) ) < accep
!
END FUNCTION eqvect_strict
!---------------------------------------------------------------------------
@ -839,7 +896,7 @@
!!
!! This routine reads the displacement patterns.
!!
USE modes, ONLY : nirr, npert, u, name_rap_mode, num_rap_mode
USE modes, ONLY : nirr, npert, u
USE lr_symm_base, ONLY : minus_q, nsymq
USE iotk_module, ONLY : iotk_index, iotk_scan_dat, iotk_scan_begin, &
iotk_scan_end
@ -890,9 +947,6 @@
imode = imode0 + ipert
CALL iotk_scan_begin(iunpun, "PERTURBATION"// &
TRIM( iotk_index(ipert) ))
CALL iotk_scan_dat(iunpun, "SYMMETRY_TYPE_CODE", &
num_rap_mode(imode))
CALL iotk_scan_dat(iunpun, "SYMMETRY_TYPE", name_rap_mode(imode))
CALL iotk_scan_dat(iunpun, "DISPLACEMENT_PATTERN", u(:,imode))
CALL iotk_scan_end(iunpun, "PERTURBATION"// &
TRIM( iotk_index(ipert) ))
@ -906,13 +960,11 @@
!
ENDIF
!
CALL mp_bcast(nirr , meta_ionode_id, world_comm)
CALL mp_bcast(npert , meta_ionode_id, world_comm)
CALL mp_bcast(nsymq , meta_ionode_id, world_comm)
CALL mp_bcast(minus_q , meta_ionode_id, world_comm)
CALL mp_bcast(u , meta_ionode_id, world_comm)
CALL mp_bcast(name_rap_mode, meta_ionode_id, world_comm)
CALL mp_bcast(num_rap_mode , meta_ionode_id, world_comm)
CALL mp_bcast(nirr , meta_ionode_id, world_comm)
CALL mp_bcast(npert , meta_ionode_id, world_comm)
CALL mp_bcast(nsymq , meta_ionode_id, world_comm)
CALL mp_bcast(minus_q, meta_ionode_id, world_comm)
CALL mp_bcast(u , meta_ionode_id, world_comm)
!
RETURN
!

2167
EPW/src/ephwann_shuffle.f90
View File

File diff suppressed because it is too large Load Diff

1981
EPW/src/ephwann_shuffle_mem.f90
View File

File diff suppressed because it is too large Load Diff

97
EPW/src/epw.f90
View File

@ -17,9 +17,6 @@
!! This is the main EPW driver which sets the phases on the wavefunctions,
!! calls [[wann_run]] and [[elphon_shuffle_wrap]]
!!
!! @Note
!! 8/14/08 lnscf is unnecessary, as is nqs, iq_start
!!
USE io_global, ONLY : stdout, ionode
USE mp, ONLY : mp_bcast, mp_barrier
USE mp_world, ONLY : mpime
@ -31,65 +28,61 @@
USE environment, ONLY : environment_start
USE elph2, ONLY : elph
USE close_epw, ONLY : close_final, deallocate_epw
! Flag to perform an electron-phonon calculation. If .true.
! the code will enter in [[elphon_shuffle_wrap]]
!
IMPLICIT NONE
!
CHARACTER (LEN=12) :: code = 'EPW'
CHARACTER(LEN=12) :: code = 'EPW'
!! Name of the program
!
version_number = '5.1.0'
!
CALL init_clocks( .TRUE. )
CALL init_clocks(.TRUE.)
!
CALL start_clock( 'EPW' )
CALL start_clock('EPW')
!
gamma_only = .FALSE.
!
CALL mp_startup(start_images=.true.)
CALL mp_startup(start_images = .TRUE.)
!
! Display the logo
IF (mpime.eq.ionode_id) then
WRITE(stdout,'(a)') " "
WRITE(stdout,'(a)') " ``:oss/ "
WRITE(stdout,'(a)') " `.+s+. .+ys--yh+ `./ss+. "
WRITE(stdout,'(a)') " -sh//yy+` +yy +yy -+h+-oyy "
WRITE(stdout,'(a)') " -yh- .oyy/.-sh. .syo-.:sy- /yh "
WRITE(stdout,'(a)') " `.-.` `yh+ -oyyyo. `/syys: oys `.` "
WRITE(stdout,'(a)') " `/+ssys+-` `sh+ ` oys` .:osyo` "
WRITE(stdout,'(a)') " -yh- ./syyooyo` .sys+/oyo--yh/ "
WRITE(stdout,'(a)') " `yy+ .-:-. `-/+/:` -sh- "
WRITE(stdout,'(a)') " /yh. oys "
WRITE(stdout,'(a)') " ``..---hho---------` .---------..` `.-----.` -hd+---. "
WRITE(stdout,'(a)') " `./osmNMMMMMMMMMMMMMMMs. +NNMMMMMMMMNNmh+. yNMMMMMNm- oNMMMMMNmo++:` "
WRITE(stdout,'(a)') " +sy--/sdMMMhyyyyyyyNMMh- .oyNMMmyyyyyhNMMm+` -yMMMdyyo:` .oyyNMMNhs+syy` "
WRITE(stdout,'(a)') " -yy/ /MMM+.`-+/``mMMy- `mMMh:`````.dMMN:` `MMMy-`-dhhy```mMMy:``+hs "
WRITE(stdout,'(a)') " -yy+` /MMMo:-mMM+`-oo/. mMMh: `dMMN/` dMMm:`dMMMMy..MMMo-.+yo` "
WRITE(stdout,'(a)') " .sys`/MMMMNNMMMs- mMMmyooooymMMNo: oMMM/sMMMMMM++MMN//oh: "
WRITE(stdout,'(a)') " `sh+/MMMhyyMMMs- `-` mMMMMMMMMMNmy+-` -MMMhMMMsmMMmdMMd/yy+ "
WRITE(stdout,'(a)') " `-/+++oyy-/MMM+.`/hh/.`mNm:` mMMd+/////:-.` NMMMMMd/:NMMMMMy:/yyo/:.` "
WRITE(stdout,'(a)') " +os+//:-..-oMMMo:--:::-/MMMo. .-mMMd+---` hMMMMN+. oMMMMMo. `-+osyso:` "
WRITE(stdout,'(a)') " syo `mNMMMMMNNNNNNNNMMMo.oNNMMMMMNNNN:` +MMMMs:` dMMMN/` ``:syo "
WRITE(stdout,'(a)') " /yh` :syyyyyyyyyyyyyyyy+.`+syyyyyyyyo:` .oyys:` .oyys:` +yh "
WRITE(stdout,'(a)') " -yh- ```````````````` ````````` `` `` oys "
WRITE(stdout,'(a)') " -+h/------------------------::::::::://////++++++++++++++++++++++///////::::/yd: "
WRITE(stdout,'(a)') " shdddddddddddddddddddddddddddddhhhhhhhhyyyyyssssssssssssssssyyyyyyyhhhhhhhddddh` "
WRITE(stdout,'(a)') " "
WRITE(stdout,'(a)') " S. Ponce, E. R. Margine, C. Verdi, and F. Giustino, "
WRITE(stdout,'(a)') " Comput. Phys. Commun. 209, 116 (2016) "
WRITE(stdout,'(a)') " "
IF (mpime == ionode_id) then
WRITE(stdout, '(a)') " "
WRITE(stdout, '(a)') " ``:oss/ "
WRITE(stdout, '(a)') " `.+s+. .+ys--yh+ `./ss+. "
WRITE(stdout, '(a)') " -sh//yy+` +yy +yy -+h+-oyy "
WRITE(stdout, '(a)') " -yh- .oyy/.-sh. .syo-.:sy- /yh "
WRITE(stdout, '(a)') " `.-.` `yh+ -oyyyo. `/syys: oys `.` "
WRITE(stdout, '(a)') " `/+ssys+-` `sh+ ` oys` .:osyo` "
WRITE(stdout, '(a)') " -yh- ./syyooyo` .sys+/oyo--yh/ "
WRITE(stdout, '(a)') " `yy+ .-:-. `-/+/:` -sh- "
WRITE(stdout, '(a)') " /yh. oys "
WRITE(stdout, '(a)') " ``..---hho---------` .---------..` `.-----.` -hd+---. "
WRITE(stdout, '(a)') " `./osmNMMMMMMMMMMMMMMMs. +NNMMMMMMMMNNmh+. yNMMMMMNm- oNMMMMMNmo++:` "
WRITE(stdout, '(a)') " +sy--/sdMMMhyyyyyyyNMMh- .oyNMMmyyyyyhNMMm+` -yMMMdyyo:` .oyyNMMNhs+syy` "
WRITE(stdout, '(a)') " -yy/ /MMM+.`-+/``mMMy- `mMMh:`````.dMMN:` `MMMy-`-dhhy```mMMy:``+hs "
WRITE(stdout, '(a)') " -yy+` /MMMo:-mMM+`-oo/. mMMh: `dMMN/` dMMm:`dMMMMy..MMMo-.+yo` "
WRITE(stdout, '(a)') " .sys`/MMMMNNMMMs- mMMmyooooymMMNo: oMMM/sMMMMMM++MMN//oh: "
WRITE(stdout, '(a)') " `sh+/MMMhyyMMMs- `-` mMMMMMMMMMNmy+-` -MMMhMMMsmMMmdMMd/yy+ "
WRITE(stdout, '(a)') " `-/+++oyy-/MMM+.`/hh/.`mNm:` mMMd+/////:-.` NMMMMMd/:NMMMMMy:/yyo/:.` "
WRITE(stdout, '(a)') " +os+//:-..-oMMMo:--:::-/MMMo. .-mMMd+---` hMMMMN+. oMMMMMo. `-+osyso:` "
WRITE(stdout, '(a)') " syo `mNMMMMMNNNNNNNNMMMo.oNNMMMMMNNNN:` +MMMMs:` dMMMN/` ``:syo "
WRITE(stdout, '(a)') " /yh` :syyyyyyyyyyyyyyyy+.`+syyyyyyyyo:` .oyys:` .oyys:` +yh "
WRITE(stdout, '(a)') " -yh- ```````````````` ````````` `` `` oys "
WRITE(stdout, '(a)') " -+h/------------------------::::::::://////++++++++++++++++++++++///////::::/yd: "
WRITE(stdout, '(a)') " shdddddddddddddddddddddddddddddhhhhhhhhyyyyyssssssssssssssssyyyyyyyhhhhhhhddddh` "
WRITE(stdout, '(a)') " "
WRITE(stdout, '(a)') " S. Ponce, E. R. Margine, C. Verdi, and F. Giustino, "
WRITE(stdout, '(a)') " Comput. Phys. Commun. 209, 116 (2016) "
WRITE(stdout, '(a)') " "
ENDIF
!
CALL environment_start ( code )
CALL environment_start(code)
!
! Read in the input file
!
CALL epw_readin
!
CALL allocate_epwq
!
IF ( epwread .AND. .NOT. epbread ) THEN
IF (epwread .AND. .NOT. epbread) THEN
WRITE(stdout,'(a)') " "
WRITE(stdout,'(a)') " ------------------------------------------------------------------------ "
WRITE(stdout,'(a)') " RESTART - RESTART - RESTART - RESTART "
@ -106,24 +99,24 @@
!
CALL epw_summary
!
IF ( ep_coupling ) THEN
IF (ep_coupling) THEN
!
! In case of restart with arbitrary number of cores.
IF ( epwread .AND. .NOT. epbread ) THEN
IF (epwread .AND. .NOT. epbread) THEN
CONTINUE
ELSE
CALL openfilepw
ENDIF
!
CALL print_clock( 'EPW' )
CALL print_clock('EPW' )
!
IF ( epwread .AND. .NOT. epbread ) THEN
IF (epwread .AND. .NOT. epbread) THEN
CONTINUE
ELSE
CALL epw_init(.true.)
CALL epw_init(.TRUE.)
ENDIF
!
CALL print_clock( 'EPW' )
CALL print_clock('EPW')
!
! Generates the perturbation matrix which fixes the gauge of
! the calculated wavefunctions
@ -143,7 +136,7 @@
trim(filukk) , ' from disk', repeat('-',67)
ENDIF
!
IF ( elph ) THEN
IF (elph) THEN
!
! CALL dvanqq2()
!
@ -153,7 +146,7 @@
!
! ... cleanup of the variables
!
CALL clean_pw( .FALSE. )
CALL clean_pw(.FALSE.)
CALL deallocate_epw
!
! ... Close the files
@ -162,11 +155,11 @@
!
ENDIF
!
IF ( cumulant .and. ionode ) THEN
IF (cumulant .AND. ionode) THEN
CALL spectral_cumulant()
ENDIF
!
IF ( eliashberg ) THEN
IF (eliashberg) THEN
CALL eliashberg_eqs()
ENDIF
!

120
EPW/src/epw_init.f90
View File

@ -18,32 +18,35 @@
!! Roxana Margine - Dec 2018: Updated based on QE 6.3
!!
!
USE kinds, ONLY : DP
USE ions_base, ONLY : nat, ntyp => nsp, ityp, tau
USE becmod, ONLY : calbec
USE phus, ONLY : alphap
USE lrus, ONLY : becp1
USE uspp, ONLY : vkb
USE pwcom, ONLY : npwx, nbnd, nks, lsda, current_spin, &
isk, xk
USE constants, ONLY : tpi
USE constants_epw, ONLY : zero, czero, cone
USE cell_base, ONLY : tpiba2, tpiba, bg, omega
USE klist, ONLY : ngk, igk_k, nkstot
USE gvect, ONLY : g, ngm
USE atom, ONLY : msh, rgrid
USE wavefunctions, ONLY : evc
USE noncollin_module, ONLY : noncolin, npol
USE uspp_param, ONLY : upf
USE m_gth, ONLY : setlocq_gth
USE units_lr, ONLY : lrwfc, iuwfc
USE phcom, ONLY : vlocq
USE qpoint, ONLY : xq, eigqts
USE nlcc_ph, ONLY : drc
USE uspp, ONLY : nlcc_any
USE elph2, ONLY : igk_k_all, ngk_all
USE mp, ONLY : mp_barrier
USE mp_global, ONLY : inter_pool_comm
USE kinds, ONLY : DP
USE ions_base, ONLY : nat, ntyp => nsp, tau
USE becmod, ONLY : calbec, becp, allocate_bec_type
USE lrus, ONLY : becp1
USE uspp, ONLY : vkb, nlcc_any, okvan, nkb
USE pwcom, ONLY : npwx, nbnd, nks
USE klist_epw, ONLY : xk_loc, isk_loc
USE constants, ONLY : tpi
USE constants_epw, ONLY : zero, czero, cone
USE cell_base, ONLY : tpiba2, tpiba, omega
USE klist, ONLY : ngk, igk_k, nkstot
USE gvect, ONLY : g, ngm
USE atom, ONLY : msh, rgrid
USE wavefunctions, ONLY : evc
USE noncollin_module, ONLY : noncolin, npol, nspin_mag
USE uspp_param, ONLY : upf, nhm
USE m_gth, ONLY : setlocq_gth
USE units_lr, ONLY : lrwfc, iuwfc
USE phcom, ONLY : vlocq
USE qpoint, ONLY : xq, eigqts
USE nlcc_ph, ONLY : drc
USE elph2, ONLY : igk_k_all, ngk_all
USE mp, ONLY : mp_barrier
USE mp_global, ONLY : inter_pool_comm, my_pool_id
USE spin_orb, ONLY : lspinorb
USE lsda_mod, ONLY : nspin, lsda, current_spin
USE phus, ONLY : int1, int1_nc, int2, int2_so, &
int4, int4_nc, int5, int5_so, &
alphap
!
IMPLICIT NONE
!
@ -72,13 +75,43 @@
!
!
CALL start_clock( 'epw_init' )
!
!
IF (first_run) THEN
ALLOCATE (vlocq(ngm, ntyp))
ALLOCATE (eigqts(nat))
IF (okvan) THEN
ALLOCATE (int1(nhm, nhm, 3, nat, nspin_mag))
ALLOCATE (int2(nhm, nhm, 3, nat, nat))
ALLOCATE (int4(nhm * (nhm + 1)/2, 3, 3, nat, nspin_mag))
ALLOCATE (int5(nhm * (nhm + 1)/2, 3, 3, nat , nat))
IF (noncolin) THEN
ALLOCATE (int1_nc(nhm, nhm, 3, nat, nspin))
ALLOCATE (int4_nc(nhm, nhm, 3, 3, nat, nspin))
IF (lspinorb) THEN
ALLOCATE (int2_so(nhm, nhm, 3, nat, nat, nspin))
ALLOCATE (int5_so(nhm, nhm, 3, 3, nat, nat, nspin))
ENDIF
ENDIF ! noncolin
ENDIF ! okvan
!
ALLOCATE (becp1(nks))
ALLOCATE (alphap(3, nks))
!
DO ik = 1, nks
CALL allocate_bec_type(nkb, nbnd, becp1(ik))
DO ipol = 1, 3
CALL allocate_bec_type(nkb, nbnd, alphap(ipol,ik))
ENDDO
ENDDO
CALL allocate_bec_type(nkb, nbnd, becp)
ENDIF
!
DO na = 1, nat
!
! xq here is the first q of the star
arg = ( xq(1) * tau(1,na) + &
xq(2) * tau(2,na) + &
xq(3) * tau(3,na) ) * tpi
arg = (xq(1) * tau(1, na) + &
xq(2) * tau(2, na) + &
xq(3) * tau(3, na)) * tpi
!
eigqts(na) = CMPLX( COS( arg ), - SIN( arg ), kind=DP )
!
@ -104,20 +137,22 @@
!
END DO
!
ALLOCATE( aux1( npwx*npol, nbnd ) )
!
ALLOCATE (aux1(npwx*npol, nbnd))
!ALLOCATE (evc(npwx*npol, nbnd))
!
DO ik = 1, nks
!
!
IF ( lsda ) current_spin = isk( ik )
IF (lsda) current_spin = isk_loc(ik)
!
! ... d) The functions vkb(k+G)
!
CALL init_us_2( ngk(ik), igk_k(1,ik), xk(1,ik), vkb )
CALL init_us_2( ngk(ik), igk_k(1,ik), xk_loc(1,ik), vkb )
!
! ... read the wavefunctions at k
!
CALL davcio( evc, lrwfc, iuwfc, ik, -1 )
CALL readwfc(my_pool_id + 1, ik, evc)
!CALL davcio( evc, lrwfc, iuwfc, ik, -1 )
!
! ... e) we compute the becp terms which are used in the rest of
! ... the code
@ -132,25 +167,24 @@
DO ibnd = 1, nbnd
DO ig = 1, ngk(ik)
aux1(ig,ibnd) = evc(ig,ibnd) * tpiba * cone * &
( xk(ipol,ik) + g(ipol,igk_k(ig,ik)) )
( xk_loc(ipol,ik) + g(ipol,igk_k(ig,ik)) )
ENDDO
IF (noncolin) THEN
DO ig = 1, ngk(ik)
aux1(ig+npwx,ibnd) = evc(ig+npwx,ibnd) * tpiba *cone *&
( xk(ipol,ik) + g(ipol,igk_k(ig,ik)) )
( xk_loc(ipol,ik) + g(ipol,igk_k(ig,ik)) )
ENDDO
ENDIF
ENDDO
CALL calbec( ngk(ik), vkb, aux1, alphap(ipol,ik) )
CALL calbec( ngk(ik), vkb, aux1, alphap(ipol,ik) )
ENDDO
!
!
ENDDO
!
DEALLOCATE( aux1 )
DEALLOCATE (aux1)
!
IF(.not. ALLOCATED(igk_k_all)) ALLOCATE(igk_k_all(npwx,nkstot))
IF(.not. ALLOCATED(ngk_all)) ALLOCATE(ngk_all(nkstot))
IF( .NOT. ALLOCATED(igk_k_all) ) ALLOCATE (igk_k_all(npwx,nkstot))
IF( .NOT. ALLOCATED(ngk_all) ) ALLOCATE (ngk_all(nkstot))
!
#if defined(__MPI)
!
@ -165,7 +199,7 @@
!
#endif
!
IF (.not.first_run) CALL dvanqq2()
IF ( .NOT. first_run ) CALL dvanqq2()
!
CALL stop_clock( 'epw_init' )
!

162
EPW/src/epw_readin.f90
View File

@ -20,10 +20,11 @@
!! SP: Image parallelization added
!!
USE ions_base, ONLY : nat, ntyp => nsp
USE cell_base, ONLY : at
USE mp, ONLY : mp_bcast
USE wvfct, ONLY : nbnd
USE klist, ONLY : nks
USE lsda_mod, ONLY : lsda
USE wvfct, ONLY : nbnd, et
USE klist, ONLY : nks, xk, nkstot
USE lsda_mod, ONLY : lsda, isk
USE fixed_occ, ONLY : tfixed_occ
USE qpoint, ONLY : xq
USE disp, ONLY : nq1, nq2, nq3
@ -33,7 +34,7 @@
num_iter, dis_froz_max, fsthick, dis_froz_min, &
vme, degaussw, epexst, eig_read, kmaps, &
epwwrite, epbread, phonselfen, elecselfen, &
a2f, plselfen, specfun_pl, nest_fn, &
a2f, plselfen, specfun_pl, nest_fn, filukk, &
rand_nk, rand_k, rand_nq, rand_q, &
nkf1, nkf2, nkf3, nqf1, nqf2, nqf3, &
eps_acustic, nw, wmax, wmin, &
@ -50,7 +51,7 @@
cumulant, bnd_cum, proj, write_wfn, iswitch, ntempxx, &
liso, lacon, lpade, etf_mem, epbwrite, &
nsiter, conv_thr_racon, specfun_el, specfun_ph, &
pwc, nswc, nswfc, nswi, filukq, filukk, &
pwc, nswc, nswfc, nswi, nc, &
nbndsub, nbndskip, system_2d, delta_approx, &
title, int_mob, scissor, iterative_bte, scattering, &
ncarrier, carrier, scattering_serta, restart, restart_freq, &
@ -58,18 +59,21 @@
restart_filq, prtgkk, nel, meff, epsiHEG, lphase, &
omegamin, omegamax, omegastep, n_r, lindabs, &
mob_maxiter, use_ws, epmatkqread, selecqread
USE klist_epw, ONLY : xk_all, xk_loc, xk_cryst, isk_all, isk_loc, et_all, et_loc
USE elph2, ONLY : elph
USE start_k, ONLY : nk1, nk2, nk3
USE constants_epw, ONLY : ryd2mev, ryd2ev, ev2cmm1, kelvin2eV, zero
USE io_files, ONLY : tmp_dir, prefix
USE control_flags, ONLY : iverbosity, modenum, gamma_only
USE ions_base, ONLY : amass
USE mp_world, ONLY : world_comm
USE mp_world, ONLY : world_comm, mpime
USE partial, ONLY : atomo, nat_todo
USE constants, ONLY : AMU_RY
USE mp_global, ONLY : my_pool_id, me_pool
USE io_global, ONLY : meta_ionode, meta_ionode_id
USE io_global, ONLY : meta_ionode, meta_ionode_id, ionode_id
USE io_epw, ONLY : iunkf, iunqf
USE noncollin_module, ONLY : npol
USE wvfct, ONLY : npwx
#if defined(__NAG)
USE F90_UNIX_ENV, ONLY : iargc, getarg
#endif
@ -89,6 +93,8 @@
!! auxilary variable for saving the modenum
INTEGER :: i
!! Counter for loops
INTEGER :: ik
!! Counter on k-points
INTEGER :: nk1tmp
!! temp vars for saving kgrid info
INTEGER :: nk2tmp
@ -100,14 +106,14 @@
namelist / inputepw / &
amass, outdir, prefix, iverbosity, fildvscf, &
elph, nq1, nq2, nq3, nk1, nk2, nk3, nbndskip, nbndsub, &
filukk, filukq, epbread, epbwrite, epwread, epwwrite, etf_mem, kmaps, &
epbread, epbwrite, epwread, epwwrite, etf_mem, kmaps, &
eig_read, wepexst, epexst, vme, &
degaussw, fsthick, eptemp, nsmear, delta_smear, &
dvscf_dir, ngaussw, epmatkqread, selecqread, &
wannierize, dis_win_max, dis_win_min, dis_froz_min, dis_froz_max, &
num_iter, proj, bands_skipped, wdata, iprint, write_wfn, &
wmin, wmax, nw, eps_acustic, a2f, nest_fn, plselfen, &
elecselfen, phonselfen, use_ws, &
elecselfen, phonselfen, use_ws, nc, &
rand_q, rand_nq, rand_k, rand_nk, specfun_pl, &
nqf1, nqf2, nqf3, nkf1, nkf2, nkf3, &
mp_mesh_k, mp_mesh_q, filqf, filkf, ephwrite, &
@ -142,7 +148,6 @@
! filqf : file with fine q kmesh for interpolation
! filkf : file with fine kmesh for interpolation
! filukk : file with rotation matrix U(k) for interpolation
! filukq : file with rotation matrix U(k+q) for interpolation
! tphases : if true set absolute unitary gauge for eigenvectors
! epstrict : if true use strict selection rule for phonon linewidht calculation
! fsthick : the thickness of the Fermi shell for averaging the e-ph matrix elements (units of eV)
@ -185,13 +190,13 @@
!
! added by @ RM
!
! ephwrite : if true write el-phonon matrix elements on the fine mesh to file
! ephwrite : if true write el-phonon matrix elements on the fine mesh to file
! eps_acustic : min phonon frequency for e-p and a2f calculations (units of cm-1)
! band_plot : if true write files to plot band structure and phonon dispersion
! degaussq : smearing for sum over q in e-ph coupling (units of meV)
! delta_qsmear : change in energy for each additional smearing in the a2f (units of meV)
! nqsmear : number of smearings used to calculate a2f
! nqstep : number of bins for frequency used to calculate a2f
! band_plot : if true write files to plot band structure and phonon dispersion
! degaussq : smearing for sum over q in e-ph coupling (units of meV)
! delta_qsmear: change in energy for each additional smearing in the a2f (units of meV)
! nqsmear : number of smearings used to calculate a2f
! nqstep : number of bins for frequency used to calculate a2f
! nswfc : nr. of grid points between (0,wsfc) in Eliashberg equations
! nswc : nr. of grid points between (wsfc,wscut)
! pwc : power used to define nswc for non-uniform grid real-axis calculations
@ -285,6 +290,7 @@
! use_ws : If .true., use the Wannier-center to create the Wigner-Seitz cell.
! epmatkqread : If .true., restart an IBTE calculation from scattering written to files.
! selecqread : If .true., restart from the selecq.fmt file
! nc : Number of carrier for the Ziman resistivity formula (can be fractional)
!
! Added by Manos Kioupakis
! omegamin : Photon energy minimum
@ -292,6 +298,7 @@
! omegastep : Photon energy step in evaluating phonon-assisted absorption spectra (in eV)
! n_r : constant refractive index
! lindabs : do phonon-assisted absorption
!
nk1tmp = 0
nk2tmp = 0
nk3tmp = 0
@ -307,13 +314,13 @@
!
ENDIF
!
CALL mp_bcast(ios, meta_ionode_id, world_comm )
CALL errore( 'epw_readin', 'reading title ', ABS( ios ) )
CALL mp_bcast(title, meta_ionode_id, world_comm )
CALL mp_bcast(ios, meta_ionode_id, world_comm)
CALL errore('epw_readin', 'reading title ', ABS( ios ))
CALL mp_bcast(title, meta_ionode_id, world_comm)
!
! Rewind the input if the title is actually the beginning of inputph namelist
!
IF( imatches("&inputepw", title) ) THEN
IF(imatches("&inputepw", title)) THEN
WRITE(*, '(6x,a)') "Title line not specified: using 'default'."
title='default'
IF (meta_ionode) REWIND(5, iostat=ios)
@ -376,7 +383,6 @@
filkf = ' '
fildrho = ' '
fildvscf = ' '
filukk = ' '
rand_q = .false.
delta_approx = .false.
rand_nq = 1
@ -483,6 +489,7 @@
use_ws = .false.
epmatkqread = .false.
selecqread = .false.
nc = 4.0d0
!
! reading the namelist inputepw
!
@ -502,20 +509,23 @@
!
! Check all namelist variables
!
IF (filukk.eq.' ') filukk=trim(prefix)//'.ukk'
IF (nsmear .lt. 1) CALL errore ('epw_readin', &
! file with rotation matrix U(k) for interpolation
filukk=TRIM(prefix)//'.ukk'
IF (nsmear < 1) CALL errore ('epw_readin', &
& 'Wrong number of nsmears',1)
IF (iverbosity.ne.0 .and. iverbosity.ne.1 .and. iverbosity.ne.2 .and. iverbosity.ne.3) &
CALL errore ('epw_readin', ' Wrong iverbosity ', 1)
! IF (tphases .and. fildvscf0.eq.' ') CALL errore ('epw_readin', &
! IF (tphases .and. fildvscf0 == ' ') CALL errore ('epw_readin', &
! &' tphases requires fildvscf0', 1)
IF (epbread .and. epbwrite) CALL errore ('epw_readin', &
&' epbread cannot be used with epbwrite', 1)
IF (epbread .and. epwread) CALL errore ('epw_readin', &
&' epbread cannot be used with epwread', 1)
IF (degaussw*4.d0 > fsthick) CALL errore ('epw_readin', &
&' degaussw too close to fsthick', 1)
IF ( nbndskip .lt. 0) CALL errore('epw_readin', &
IF ( nbndskip < 0) CALL errore('epw_readin', &
&' nbndskip must not be less than 0', 1)
IF ((nw.lt.1) .or. (nw.gt.1000)) CALL errore ('epw_readin', &
IF ((nw < 1) .or. (nw > 1000)) CALL errore ('epw_readin', &
&' unreasonable nw', 1)
IF (elecselfen .and. plselfen) CALL errore('epw_readin', &
&'Electron-plasmon self-energy cannot be computed with electron-phonon',1)
@ -533,33 +543,33 @@
&'Electron-plasmon spectral function cannot be computed with el-ph spectral function',1)
IF (specfun_ph .and. specfun_pl) CALL errore('epw_readin', &
&'Electron-plasmon spectral function cannot be computed with el-ph spectral function',1)
IF (a2f .AND. .not.phonselfen) CALL errore('epw_readin', &
IF (a2f .AND. .NOT. phonselfen) CALL errore('epw_readin', &
&'a2f requires phonoselfen',1)
IF (elph .AND. .not.ep_coupling ) CALL errore('epw_readin', &
IF (elph .AND. .NOT. ep_coupling ) CALL errore('epw_readin', &
&'elph requires ep_coupling=.true.',1)
IF ( (elph .AND. wannierize) .AND. (epwread) ) CALL errore('epw_readin', &
& 'must use same w90 rotation matrix for entire run', 1)
IF (wannierize .AND. .not.ep_coupling ) CALL errore('epw_readin', &
IF (wannierize .AND. .NOT. ep_coupling ) CALL errore('epw_readin', &
&'wannierize requires ep_coupling=.true.',1)
IF ((wmin > wmax)) &
CALL errore ('epw_readin', ' check wmin, wmax ', 1)
IF ((wmin_specfun.gt.wmax_specfun)) &
IF ((wmin_specfun > wmax_specfun)) &
CALL errore ('epw_readin', ' check wmin_specfun, wmax_specfun ', 1)
IF ((nw_specfun.lt.2)) CALL errore ('epw_readin', &
IF ((nw_specfun < 2)) CALL errore ('epw_readin', &
&' nw_specfun must be at least 2', 1)
IF ((nqstep.lt.2)) CALL errore ('epw_readin', &
IF ((nqstep < 2)) CALL errore ('epw_readin', &
&' nqstep must be at least 2', 1)
IF ((nbndsub > 200)) CALL errore ('epw_readin', &
' too many wannier functions increase size of projx', 1)
IF (( phonselfen .OR. elecselfen .or. specfun_el .or. specfun_ph ) .and. ( mp_mesh_k .or. mp_mesh_q )) &
CALL errore('epw_readin', 'can only work with full uniform mesh',1)
IF (ephwrite .AND. .NOT. ep_coupling .and. .not.elph ) CALL errore('epw_readin', &
IF (ephwrite .AND. .NOT. ep_coupling .and. .NOT. elph ) CALL errore('epw_readin', &
&'ephwrite requires ep_coupling=.true., elph=.true.',1)
IF (ephwrite .AND. (rand_k .OR. rand_q ) ) &
CALL errore('epw_readin', 'ephwrite requires a uniform grid',1)
IF (ephwrite .AND. (mod(nkf1,nqf1) .ne. 0 .OR. mod(nkf2,nqf2) .ne. 0 .OR. mod(nkf3,nqf3) .ne. 0 ) ) &
CALL errore('epw_readin', 'ephwrite requires nkf1,nkf2,nkf3 to be multiple of nqf1,nqf2,nqf3',1)
IF (band_plot .AND. filkf .eq. ' ' .and. filqf .eq. ' ') CALL errore('epw_readin', &
IF (band_plot .AND. filkf == ' ' .and. filqf == ' ') CALL errore('epw_readin', &
&'plot band structure and phonon dispersion requires k- and q-points read from filkf and filqf files',1)
IF (band_plot .AND. filkf .ne. ' ' .and. (nkf1 > 0 .or. nkf2 > 0 .or. nkf3 > 0) ) CALL errore('epw_readin', &
&'You should define either filkf or nkf when band_plot = .true.',1)
@ -573,23 +583,17 @@
CALL errore('epw_readin', 'define either (tempsmin and tempsmax) or temps(:)',1)
IF ( scattering .AND. tempsmax < tempsmin ) &
CALL errore('epw_readin', 'tempsmax should be greater than tempsmin',1)
! IF ( int_mob .AND. efermi_read) CALL errore('epw_init', &
! 'Fermi level can not be set (efermi_read) when computing intrinsic mobilities',1)
! IF ( int_mob .AND. (ABS(ncarrier) > 1E+5) ) CALL errore('epw_init', &
! 'You cannot compute intrinsic mobilities and doped mobilities at the same time',1)
IF ( (ABS(ncarrier) > 1E+5) .AND. .NOT. carrier ) CALL errore('epw_readin', &
'carrier must be .true. if you specify ncarrier.',1)
IF ( carrier .AND. (ABS(ncarrier) < 1E+5) ) CALL errore('epw_readin', &
'The absolute value of the doping carrier concentration must be larger than 1E5 cm^-3',1)
! IF ( (iterative_bte .AND. scattering_serta) .OR. (iterative_bte .AND.scattering_0rta) ) CALL errore('epw_init', &
! 'You should first do a run in the SRTA to get the initial scattering_rate files.',1)
IF ( (longrange .OR. shortrange) .AND. (.NOT. lpolar)) CALL errore('epw_readin',&
&'Error: longrange or shortrange can only be true if lpolar is true as well.',1)
IF ( longrange .AND. shortrange) CALL errore('epw_init',&
IF ( longrange .AND. shortrange) CALL errore('epw_readin',&
&'Error: longrange and shortrange cannot be both true.',1)
IF ( epwread .AND. .NOT. kmaps .AND. .NOT. epbread) CALL errore('epw_readin',&
&'Error: kmaps has to be true for a restart run. ',1)
IF ( .not. epwread .AND. .NOT. epwwrite) CALL errore('epw_readin',&
IF ( .NOT. epwread .AND. .NOT. epwwrite) CALL errore('epw_readin',&
&'Error: Either epwread or epwwrite needs to be true. ',1)
IF ( lscreen .AND. etf_mem == 2) CALL errore('epw_readin',&
&'Error: lscreen not implemented with etf_mem=2 ',1)
@ -604,15 +608,11 @@
101 CALL errore('epw_readin','opening file '//filqf,abs(ios))
CLOSE(iunqf)
ENDIF
!#ifndef __MPI
! IF ( etf_mem == 2 ) CALL errore('epw_init','Error: etf_mem == 2 only works with MPI.',1)
!#endif
!
! thickness and smearing width of the Fermi surface
! from eV to Ryd
fsthick = fsthick / ryd2ev
degaussw = degaussw / ryd2ev
fsthick = fsthick / ryd2ev
degaussw = degaussw / ryd2ev
delta_smear = delta_smear / ryd2ev
!
! smearing of phonon in a2f
@ -631,7 +631,7 @@
! Out-of bound issue with GCC compiler. Multiple Fermi temp is not used anyway.
eptemp = eptemp * kelvin2eV / ryd2ev
!DO i = 1, ntempxx
! IF (eptemp(i) .gt. 0.d0) THEN
! IF (eptemp(i) > 0.d0) THEN
! ! 1 K in eV = 8.6173423e-5
! ! from K to Ryd
! eptemp(i) = eptemp(i) * kelvin2eV / ryd2ev
@ -661,7 +661,7 @@
IF ( scattering ) THEN
DO i = 1, ntempxx
IF (temps(i) .gt. 0.d0) THEN
IF (temps(i) > 0.d0) THEN
nstemp = i
ENDIF
ENDDO
@ -686,18 +686,66 @@
!
modenum_aux = modenum
!
! SP: This initialized nspin and nspin_mag
IF ( epwread .and. .not. epbread ) THEN
! SP: This initialized xk, nspin and nspin_mag
IF (epwread .AND. .NOT. epbread) THEN
CONTINUE
ELSE
CALL read_file
! In read_file, the call to allocate_wfc allocate evc with dimension ALLOCATE (evc(npwx*npol, nbnd))
CALL read_file()
!
!IF (mpime /= ionode_id) THEN
! ALLOCATE (evc(npwx*npol, nbnd))
!ENDIF
!CALL mp_bcast(evc, ionode_id, world_comm)
!
! We define the global list of coarse grid k-points (cart and cryst)
ALLOCATE (xk_all(3, nkstot))
ALLOCATE (et_all(nbnd, nkstot))
ALLOCATE (isk_all(nkstot))
ALLOCATE (xk_cryst(3, nkstot))
xk_all(:,:) = zero
et_all(:,:) = zero
isk_all(:) = 0
xk_cryst(:,:) = zero
DO ik=1, nkstot
xk_all(:, ik) = xk(:, ik)
isk_all(ik) = isk(ik)
et_all(:, ik) = et(:, ik)
xk_cryst(:, ik) = xk(:, ik)
ENDDO
! bring k-points from cartesian to crystal coordinates
CALL cryst_to_cart(nkstot, xk_cryst, at, -1)
! Only master has the correct full list of kpt. Therefore bcast to all cores
CALL mp_bcast(xk_all, ionode_id, world_comm)
CALL mp_bcast(et_all, ionode_id, world_comm)
CALL mp_bcast(isk_all, ionode_id, world_comm)
CALL mp_bcast(xk_cryst, ionode_id, world_comm)
!
! We define the local list of kpt
ALLOCATE (xk_loc(3, nks))
ALLOCATE (et_loc(nbnd, nks))
ALLOCATE (isk_loc(nks))
xk_loc(:,:) = zero
et_loc(:,:) = zero
isk_loc(:) = 0
DO ik=1, nks
xk_loc(:, ik) = xk(:, ik)
et_loc(:, ik) = et(:, ik)
isk_loc(ik) = isk(ik)
ENDDO
!
! 04-2019 - SP
! isk_loc and isk_all are spin index (LSDA only) on the local or all k-points.
! Those variable are introduced here for potential use but are not currently used further in EPW
! One would need to interpolate isk on the fine grids in ephwann_shuffle.
!
ENDIF
!
! nbnd comes out of readfile
IF (nbndsub.eq.0) nbndsub = nbnd
IF (nbndsub == 0) nbndsub = nbnd
!
#if defined(__MPI)
IF (.not.(me_pool /=0 .or. my_pool_id /=0)) THEN
IF (.NOT. (me_pool /=0 .OR. my_pool_id /=0)) THEN
nk1 = nk1tmp
nk2 = nk2tmp
nk3 = nk3tmp
@ -711,10 +759,10 @@
IF (gamma_only) CALL errore('epw_readin',&
'cannot start from pw.x data file using Gamma-point tricks',1)
!
IF (modenum_aux .ne. -1) THEN
IF (modenum_aux /= -1) THEN
modenum = modenum_aux
iswitch = -4
ELSEIF (modenum .eq. 0) THEN
ELSEIF (modenum == 0) THEN
iswitch = -2
ELSE
iswitch = -4

90
EPW/src/epw_setup.f90
View File

@ -20,36 +20,34 @@
USE kinds, ONLY : DP
USE ions_base, ONLY : tau, nat, ntyp => nsp, ityp
USE cell_base, ONLY : at, bg
USE io_global, ONLY : stdout, ionode, ionode_id
USE io_files, ONLY : tmp_dir
USE klist, ONLY : xk, nks, nkstot
USE io_global, ONLY : ionode_id
USE klist, ONLY : nkstot
USE lsda_mod, ONLY : nspin, starting_magnetization
USE scf, ONLY : v, vrs, vltot, rho, kedtau
USE scf, ONLY : v, vrs, vltot, kedtau
USE gvect, ONLY : ngm
USE symm_base, ONLY : nsym, s, irt, t_rev, time_reversal, invs, sr, &
USE symm_base, ONLY : nsym, s, irt, t_rev, time_reversal, sr, &
inverse_s
USE eqv, ONLY : dmuxc
USE uspp_param, ONLY : upf
USE spin_orb, ONLY : domag
USE constants_epw, ONLY : zero, eps5
USE noncollin_module, ONLY : noncolin, m_loc, angle1, angle2, ux
USE constants_epw, ONLY : zero, eps5, czero
USE nlcc_ph, ONLY : drc
USE uspp, ONLY : nlcc_any
USE control_ph, ONLY : search_sym, u_from_file
USE control_lr, ONLY : alpha_pv, nbnd_occ
USE modes, ONLY : u, npertx, npert, nirr, nmodes, num_rap_mode
USE modes, ONLY : npertx, npert, nirr, nmodes, num_rap_mode, u, name_rap_mode
USE lr_symm_base, ONLY : gi, gimq, irotmq, minus_q, nsymq, invsymq, rtau
USE qpoint, ONLY : xq
USE control_flags, ONLY : modenum, noinv
USE funct, ONLY : dft_is_gradient
USE mp_global, ONLY : world_comm
USE mp, ONLY : mp_bcast
USE mp_pools, ONLY : inter_pool_comm
USE epwcom, ONLY : xk_cryst, scattering, nstemp, tempsmin, tempsmax, &
temps
USE epwcom, ONLY : scattering, nstemp, tempsmin, tempsmax, temps
USE klist_epw, ONLY : xk_cryst
USE fft_base, ONLY : dfftp
USE gvecs, ONLY : doublegrid
USE start_k, ONLY : nk1, nk2, nk3
USE transportcom, ONLY : transp_temp
USE noncollin_module, ONLY : noncolin, m_loc, angle1, angle2, ux, nspin_mag
!
IMPLICIT NONE
!
@ -70,15 +68,6 @@
!
CALL start_clock('epw_setup')
!
! 0) Set up list of kpoints in crystal coordinates
!
DO jk = 1, nkstot
xk_cryst(:,jk) = xk(:,jk)
ENDDO
! bring k-points from cartesian to crystal coordinates
CALL cryst_to_cart(nkstot, xk_cryst, at, -1)
CALL mp_bcast(xk_cryst,ionode_id,world_comm)
!
! loosy tolerance: not important
DO jk = 1, nkstot
xx_c = xk_cryst(1,jk) * nk1
@ -87,7 +76,7 @@
!
! check that the k-mesh was defined in the positive region of 1st BZ
!
IF ( xx_c .lt. -eps5 .or. yy_c .lt. -eps5 .or. zz_c .lt. -eps5 ) &
IF ( xx_c < -eps5 .or. yy_c < -eps5 .or. zz_c < -eps5 ) &
CALL errore('epw_setup','coarse k-mesh needs to be strictly positive in 1st BZ',1)
!
ENDDO
@ -99,28 +88,30 @@
! Set non linear core correction stuff
!
nlcc_any = ANY( upf(1:ntyp)%nlcc )
IF (nlcc_any) ALLOCATE(drc(ngm, ntyp))
IF (nlcc_any) ALLOCATE (drc(ngm, ntyp))
!
! 2) If necessary calculate the local magnetization. This information is
! needed in sgama
!
IF (.not.ALLOCATED(m_loc)) ALLOCATE(m_loc(3, nat))
IF (noncolin .AND. domag) THEN
DO na = 1, nat
ALLOCATE (m_loc(3, nat))
DO na=1, nat
!
m_loc(1,na) = starting_magnetization(ityp(na)) * &
SIN( angle1(ityp(na)) ) * COS( angle2(ityp(na)) )
m_loc(2,na) = starting_magnetization(ityp(na)) * &
SIN( angle1(ityp(na)) ) * SIN( angle2(ityp(na)) )
m_loc(3,na) = starting_magnetization(ityp(na)) * &
COS( angle1(ityp(na)) )
m_loc(1, na) = starting_magnetization(ityp(na)) * &
SIN(angle1(ityp(na))) * COS(angle2(ityp(na)))
m_loc(2, na) = starting_magnetization(ityp(na)) * &
SIN(angle1(ityp(na))) * SIN(angle2(ityp(na)))
m_loc(3, na) = starting_magnetization(ityp(na)) * &
COS(angle1(ityp(na)))
ENDDO
ux = zero
IF (dft_is_gradient()) CALL compute_ux(m_loc,ux,nat)
DEALLOCATE (m_loc)
ENDIF
!
! 3) Computes the derivative of the xc potential
!
ALLOCATE (dmuxc(dfftp%nnr, nspin_mag, nspin_mag))
CALL setup_dmuxc()
!
! 3.1) Setup all gradient correction stuff
@ -161,6 +152,8 @@
! allocate and calculate rtau, the Bravais lattice vector associated
! to a rotation
!
ALLOCATE (rtau(3, 48, nat))
ALLOCATE (npert(3 * nat))
CALL sgam_lr(at, bg, nsym, s, irt, tau, rtau, nat)
!
! and calculate the vectors G associated to the symmetry Sq = q + G
@ -170,35 +163,42 @@
!
search_sym = search_sym .AND. symmorphic_or_nzb()
!
ALLOCATE (num_rap_mode(3 * nat))
num_rap_mode = -1
IF (search_sym) CALL prepare_sym_analysis(nsymq, sr, t_rev, magnetic_sym)
!
ALLOCATE (name_rap_mode(3 * nat))
ALLOCATE (u(3 * nat, 3 * nat))
u(:, :) = czero
IF (.NOT. u_from_file) THEN
! SP: These calls set the u
CALL find_irrep()
ENDIF
CALL find_irrep_sym()
!
DEALLOCATE (num_rap_mode)
DEALLOCATE (name_rap_mode)
!
! 8) set max perturbation
!
npertx = 0
DO irr = 1, nirr
npertx = max(npertx, npert(irr))
DO irr=1, nirr
npertx = MAX(npertx, npert(irr))
ENDDO
!
IF (.NOT. ALLOCATED(transp_temp)) ALLOCATE( transp_temp(nstemp) )
ALLOCATE (transp_temp(nstemp))
!
transp_temp(:) = zero
! In case of scattering calculation
IF ( scattering ) THEN
IF (scattering) THEN
!
IF ( maxval(temps(:)) > zero ) THEN
IF (MAXVAL(temps(:)) > zero ) THEN
transp_temp(:) = temps(:)
ELSE
IF ( nstemp .eq. 1 ) THEN
IF (nstemp == 1) THEN
transp_temp(1) = tempsmin
ELSE
DO itemp = 1, nstemp
DO itemp=1, nstemp
transp_temp(itemp) = tempsmin + dble(itemp-1) * &
( tempsmax - tempsmin ) / dble(nstemp-1)
ENDDO
@ -235,21 +235,21 @@
!
CALL start_clock ('epw_setup')
!
IF (.NOT. ALLOCATED(transp_temp)) ALLOCATE( transp_temp(nstemp) )
ALLOCATE (transp_temp(nstemp))
!
transp_temp(:) = zero
! In case of scattering calculation
IF ( scattering ) THEN
IF (scattering) THEN
!
IF ( maxval(temps(:)) > zero ) THEN
IF (MAXVAL(temps(:)) > zero) THEN
transp_temp(:) = temps(:)
ELSE
IF ( nstemp .eq. 1 ) THEN
IF (nstemp == 1) THEN
transp_temp(1) = tempsmin
ELSE
DO itemp = 1, nstemp
transp_temp(itemp) = tempsmin + dble(itemp-1) * &
( tempsmax - tempsmin ) / dble(nstemp-1)
DO itemp=1, nstemp
transp_temp(itemp) = tempsmin + DBLE(itemp - 1) * &
(tempsmax - tempsmin) / DBLE(nstemp - 1)
ENDDO
ENDIF
ENDIF

39
EPW/src/epw_summary.f90
View File

@ -22,11 +22,12 @@
USE ions_base, ONLY : nat, ityp, atm, tau, ntyp => nsp, amass
USE io_global, ONLY : stdout
USE cell_base, ONLY : at, bg, ibrav, alat, omega, celldm
USE klist, ONLY : lgauss, degauss, ngauss, nkstot, xk, wk
USE klist, ONLY : lgauss, degauss, ngauss, nkstot, wk
USE klist_epw, ONLY : xk_all
USE gvect, ONLY : gcutm, ngm
USE gvecs, ONLY : dual, doublegrid, gcutms, ngms
USE gvecw, ONLY : ecutwfc
USE symm_base, ONLY : s, sname, ftau, s_axis_to_cart, sr, t_rev
USE symm_base, ONLY : s, sname, ft, s_axis_to_cart, sr, t_rev
USE noncollin_module, ONLY : noncolin
USE spin_orb, ONLY : lspinorb, domag
USE funct, ONLY : write_dft_name
@ -122,7 +123,7 @@
! description of symmetries
!
WRITE(stdout, * )
IF (nsymq.le.1 .and. .not.minus_q) THEN
IF (nsymq <= 1 .and. .NOT. minus_q) THEN
WRITE(stdout, '(5x,"No symmetry!")')
ELSE
IF (minus_q) THEN
@ -133,7 +134,7 @@
ENDIF
ENDIF
IF (iverbosity.eq.1) THEN
IF (iverbosity == 1) THEN
WRITE( stdout, '(36x,"s",24x,"frac. trans.")')
IF (minus_q) THEN
nsymtot = nsymq + 1
@ -141,7 +142,7 @@
nsymtot = nsymq
ENDIF
DO isymq = 1, nsymtot
IF (isymq.gt.nsymq) THEN
IF (isymq > nsymq) THEN
isym = irotmq
WRITE(stdout, '(/,5x,"This transformation sends q -> -q+G")')
ELSE
@ -151,25 +152,19 @@
IF (noncolin.and.domag) &
WRITE(stdout,'(1x, "Time Reversal",i3)') t_rev(isym)
!
IF (ftau(1,isym).ne.0 .OR. ftau(2,isym).ne.0 .OR. ftau(3,isym).ne.0) THEN
ft1 = at(1,1) * ftau(1,isym) / dfftp%nr1 &
+ at(1,2) * ftau(2,isym) / dfftp%nr2 &
+ at(1,3) * ftau(3,isym) / dfftp%nr3
ft2 = at(2,1) * ftau(1,isym) / dfftp%nr1 &
+ at(2,2) * ftau(2,isym) / dfftp%nr2 &
+ at(2,3) * ftau(3,isym) / dfftp%nr3
ft3 = at(3,1) * ftau(1,isym) / dfftp%nr1 &
+ at(3,2) * ftau(2,isym) / dfftp%nr2 &
+ at(3,3) * ftau(3,isym) / dfftp%nr3
IF ( ft(1,isym)**2 + ft(2,isym)**2 + ft(3,isym)**2 > 1.0d-8 ) THEN
ft1 = at(1,1)*ft(1,isym) + at(1,2)*ft(2,isym) + at(1,3)*ft(3,isym)
ft2 = at(2,1)*ft(1,isym) + at(2,2)*ft(2,isym) + at(2,3)*ft(3,isym)
ft3 = at(3,1)*ft(1,isym) + at(3,2)*ft(2,isym) + at(3,3)*ft(3,isym)
WRITE(stdout, '(1x,"cryst.",3x,"s(",i2,") = (",3i6, &
& " ) f =( ",f10.7," )")') isymq, &
& (s(1,ipol,isym), ipol = 1, 3), DBLE(ftau(1,isym))/DBLE(dfftp%nr1)
& (s(1,ipol,isym), ipol = 1, 3), ft(1,isym)
WRITE(stdout, '(17x," (",3(i6,5x), &
& " ) ( ",f10.7," )")') &
& (s(2,ipol,isym), ipol = 1, 3), DBLE(ftau(2,isym))/DBLE(dfftp%nr2)
& (s(2,ipol,isym), ipol = 1, 3), ft(2,isym)
WRITE(stdout, '(17x," (",3(i6,5x), &
& " ) ( ",f10.7," )"/)') &
& (s(3,ipol,isym), ipol = 1, 3), DBLE(ftau(3,isym))/DBLE(dfftp%nr3)
& (s(3,ipol,isym), ipol = 1, 3), ft(3,isym)
WRITE(stdout, '(1x,"cart.",3x,"s(",i2,") = (",3f11.7, &
& " ) f =( ",f10.7," )")') isymq, &
& (sr(1,ipol,isym), ipol = 1, 3), ft1
@ -212,15 +207,15 @@
WRITE(stdout, '(23x,"cart. coord. in units 2pi/a_0")')
DO ik = 1, nkstot
WRITE(stdout, '(8x,"k(",i5,") = (",3f12.7,"), wk =",f12.7)') ik, &
(xk(ipol,ik) , ipol = 1, 3), wk(ik)
(xk_all(ipol,ik) , ipol = 1, 3), wk(ik)
ENDDO
ENDIF
IF (iverbosity.eq.1) THEN
IF (iverbosity == 1) THEN
WRITE(stdout, '(/23x,"cryst. coord.")')
DO ik = 1, nkstot
DO ipol = 1, 3
xkg(ipol) = at(1,ipol) * xk(1,ik) + at(2,ipol) * xk(2,ik) &
+ at(3,ipol) * xk(3,ik)
xkg(ipol) = at(1,ipol) * xk_all(1,ik) + at(2,ipol) * xk_all(2,ik) &
+ at(3,ipol) * xk_all(3,ik)
! xkg are the components of xk in the reciprocal lattice basis
ENDDO
WRITE(stdout, '(8x,"k(",i5,") = (",3f12.7,"), wk =",f12.7)') &

28
EPW/src/epwcom.f90
View File

@ -148,6 +148,8 @@
!! Value of the scissor shift in eV.
REAL (KIND=DP) :: ncarrier
!! Amount of carrier concentration in cm^-3 when doping a semiconductors
REAL (KIND=DP) :: nc
!! Number of carrier per unit cell that participate to the conduction in the Ziman resistivity formula
!
! Plasmon
REAL (KIND=DP) :: nel
@ -322,13 +324,29 @@ MODULE klist_epw
!!
!! The variable for the k-points
!!
USE kinds, ONLY: DP
USE parameters, ONLY :npk
USE kinds, ONLY : DP
USE parameters, ONLY : npk
!
SAVE
!
INTEGER :: kmap(npk) ! map of k+q grid into k grid
REAL(DP) :: xk_cryst(3,npk) ! List of all kpoints in crystal coordinates
INTEGER :: kmap(npk)
!! map of k+q grid into k grid
INTEGER, ALLOCATABLE :: isk_all(:)
!! Spin index of each k-point (used in LSDA calculations only)
INTEGER, ALLOCATABLE :: isk_loc(:)
!! Spin index of local k-point (used in LSDA calculations only)
INTEGER, ALLOCATABLE :: isk_dummy(:)
!! Spin index on the fine grid - dummy at the moment
REAL(kind=DP), ALLOCATABLE :: xk_loc(:, :)
!! List of local (each cores) kpoints in cartesian coordinates
REAL(kind=DP), ALLOCATABLE :: xk_all(:, :)
!! List of all kpoints in cartesian coordinates
REAL(kind=DP), ALLOCATABLE :: xk_cryst(:, :)
!! List of all kpoints in crystal coordinates
REAL(kind=DP), ALLOCATABLE :: et_all(:, :)
!! Eigenenergies on the full coarse k-grid
REAL(kind=DP), ALLOCATABLE :: et_loc(:, :)
!! Eigenenergies on the local (each core) coarse k-grid
!
END MODULE klist_epw
!
@ -345,8 +363,6 @@ MODULE output_epw
!! input file for the fine k mesh
CHARACTER (LEN=80) :: filukk
!! input file for the rotation matrix U(k)
CHARACTER (LEN=80) :: filukq
!! input file for the rotation matrix U(k+q)
CHARACTER (LEN=80) :: fildvscf0
!! output file for the deltavscf used as a fake perturbation to set phases
CHARACTER (LEN=80) :: fila2f

2
EPW/src/fermiwindow.f90
View File

@ -48,7 +48,7 @@
DO ibnd = 1, nbndsub
ebnd = etf (ibnd, ik)
!
IF ( abs(ebnd - ef) .lt. fsthick ) THEN
IF ( abs(ebnd - ef) < fsthick ) THEN
ibndmin = min(ibnd,ibndmin)
ibndmax = max(ibnd,ibndmax)
ebndmin = min(ebnd,ebndmin)

24
EPW/src/gmap_sym.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE gmap_sym( nsym, s, ftau, gmapsym, eigv, invs )
SUBROUTINE gmap_sym( nsym, s, ft, gmapsym, eigv, invs )
!-----------------------------------------------------------------------
!!
!! For every G vector, find S(G) for all the symmetry operations
@ -23,7 +23,6 @@
!----------------------------------------------------------------------
USE kinds, ONLY : DP
USE constants_epw, ONLY : twopi, ci, cone
USE fft_base, ONLY : dfftp
USE gvect, ONLY : mill, ngm
!
IMPLICIT NONE
@ -32,8 +31,8 @@
!! the number of symmetries of the crystal
INTEGER, INTENT(in) :: s(3,3,48)
!! the symmetry matrices
INTEGER, INTENT(in) :: ftau(3,48)
!! the fractional traslations
REAL(dp), INTENT(in) :: ft(3,48)
!! the fractional traslations in crystal axis
INTEGER, INTENT(in) :: invs(48)
!! inverse symmetry matrix
INTEGER, INTENT(out) :: gmapsym(ngm,48)
@ -85,9 +84,9 @@
!
jg = 0
tfound = .false.
DO WHILE ( (.not.tfound) .AND. (jg < ngm) )
DO WHILE ( ( .NOT. tfound) .AND. (jg < ngm) )
jg = jg + 1
tfound = (i.eq.mill(1,jg)) .AND. (j.eq.mill(2,jg)) .AND. (k.eq.mill(3,jg))
tfound = (i == mill(1,jg)) .AND. (j == mill(2,jg)) .AND. (k == mill(3,jg))
ENDDO
!
IF (tfound) THEN
@ -99,14 +98,11 @@
!
! now the phase factors e^{iGv}
!
IF ( ftau(1,isym) .ne. 0 .OR. ftau(2,isym) .ne. 0 .OR. ftau(3,isym) .ne. 0 ) THEN
IF ( ft(1,isym)**2 + ft(2,isym)**2 + ft(3,isym)**2 > 1.0d-8 ) THEN
!
! fractional traslation in crystal coord is ftau/nr*
! for cart/crys transform of the G-vecctors have a look at the bottom
!
rdotk = dble( mill(1,ig) * ftau(1,isym) ) / dble(dfftp%nr1) &
+ dble( mill(2,ig) * ftau(2,isym) ) / dble(dfftp%nr2) &
+ dble( mill(3,ig) * ftau(3,isym) ) / dble(dfftp%nr3)
rdotk = dble( mill(1,ig) ) * ft(1,isym) &
+ dble( mill(2,ig) ) * ft(2,isym) &
+ dble( mill(3,ig) ) * ft(3,isym)
!
! the actual translation is -v (have a look at ruota_ijk.f90)
!
@ -118,7 +114,7 @@
!
ENDDO
!
IF (notfound.gt.0) &
IF (notfound > 0) &
CALL errore('gmap_sym','incomplete mapping of G vectors: notfound = ',notfound)
!
ENDDO

18
EPW/src/indabs.f90
View File

@ -178,14 +178,14 @@
WRITE(stdout,'(5x,"Phonon-assisted absorption")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick .lt. 1.d3 ) &
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Temperature T = ',eptemp * ryd2ev, ' eV'
!
IF ( .not. ALLOCATED (omegap) ) ALLOCATE(omegap(nomega))
IF ( .not. ALLOCATED (epsilon2_abs) ) ALLOCATE(epsilon2_abs(3,nomega,neta))
IF ( .not. ALLOCATED (epsilon2_abs_lorenz) ) ALLOCATE(epsilon2_abs_lorenz(3,nomega,neta))
IF ( .NOT. ALLOCATED (omegap) ) ALLOCATE (omegap(nomega))
IF ( .NOT. ALLOCATED (epsilon2_abs) ) ALLOCATE (epsilon2_abs(3,nomega,neta))
IF ( .NOT. ALLOCATED (epsilon2_abs_lorenz) ) ALLOCATE (epsilon2_abs_lorenz(3,nomega,neta))
!
epsilon2_abs = 0.d0
epsilon2_abs_lorenz = 0.d0
@ -217,7 +217,7 @@
wq(imode) = wf (imode, iq)
!
epf(:,:,imode) = epf17(:, :, imode,ik)
IF ( wq(imode) .gt. eps_acustic ) THEN
IF ( wq(imode) > eps_acustic ) THEN
nqv(imode) = wgauss( -wq(imode)/(eptemp), -99)
nqv(imode) = nqv(imode) / ( one - two * nqv(imode) )
ENDIF
@ -246,7 +246,7 @@
! the energy of the electron at k (relative to Ef)
ekk = etf (ibndmin-1+ibnd, ikk) - ef0
!
IF ( abs(ekk) .lt. fsthick ) THEN
IF ( abs(ekk) < fsthick ) THEN
!
wgkk = wgauss( -ekk*inv_eptemp0, -99)
!
@ -337,7 +337,7 @@
!
! The k points are distributed among pools: here we collect them
!
IF ( iq .eq. nqtotf ) THEN
IF ( iq == nqtotf ) THEN
!
#if defined(__MPI)
!
@ -374,7 +374,7 @@
WRITE(c,"(i0)") neta+1
format_string = "("//TRIM(c) // "E22.14)"
OPEN(unit=iuindabs,file=nameF)
OPEN(UNIT=iuindabs,FILE=nameF)
WRITE(iuindabs,'(a)') '# Phonon-assisted absorption versus energy'
WRITE(iuindabs,'(a)') '# Photon energy (eV), Directionally-averaged imaginary dielectric function along x,y,z'
DO iw = 1, nomega
@ -382,7 +382,7 @@
ENDDO
CLOSE(iuindabs)
!
OPEN(unit=iuindabs,file='epsilon2_indabs_lorenz.dat')
OPEN(UNIT=iuindabs,FILE='epsilon2_indabs_lorenz.dat')
WRITE(iuindabs,'(a)') '# Phonon-assisted absorption versus energy'
WRITE(iuindabs,'(a)') '# Photon energy (eV), Directionally-averaged imaginary dielectric function along x,y,z'
DO iw = 1, nomega

445
EPW/src/io_eliashberg.f90
View File

File diff suppressed because it is too large Load Diff

3
EPW/src/io_epw.f90
View File

@ -29,7 +29,7 @@
iufilfreq, iufilegnv, iufileph, iufilkqmap, &
iufilikmap, iueig, iunepmatwp, iunepmatwe, iunkf, iunqf, &
iufileig, iukmap, crystal, iunifc, iunimem, iunepmatwp2
PUBLIC :: iuwinfil, iun_plot, iuukk, iuprojfil, iudecayH, iudecayP, &
PUBLIC :: iuwinfil, iun_plot, iuprojfil, iudecayH, iudecayP, &
iudecaydyn, iudecayv, iummn, iubvec
PUBLIC :: iufilsigma, iufilseebeck, iufilkappael, iufilkappa, iufilscatt_rate,&
iufilFi_all, iufilsigma_all, iufiltau_all, iuindabs
@ -130,7 +130,6 @@
! states <u_nmk|u_nk+b>
INTEGER :: iun_plot = 203 ! UNK file (needed by Wannier90 for plotting the
! real space Wannier functions)
INTEGER :: iuukk = 204 ! Final ukk rotation matrix (the big U!)
INTEGER :: iuprojfil = 205 ! Unit for projector [.projw90]
INTEGER :: iudecayH = 206 ! Hamiltonian decay in real space
INTEGER :: iudecayP = 207 ! Dipole decay in real space

124
EPW/src/io_scattering.f90
View File

@ -1,4 +1,4 @@
!
!
! Copyright (C) 2010-2016 Samuel Ponce', Roxana Margine, Carla Verdi, Feliciano Giustino
!
! This file is distributed under the terms of the GNU General Public
@ -19,6 +19,9 @@
!----------------------------------------------------------------------------
SUBROUTINE Fin_write(iter, F_in, av_mob_old, elec)
!----------------------------------------------------------------------------
!!
!! Writes the F without magnetic field for restart
!!
USE kinds, ONLY : DP
USE io_epw, ONLY : iufilFi_all
USE io_files, ONLY : diropn
@ -27,7 +30,6 @@
USE mp_world, ONLY : mpime
USE io_global, ONLY : ionode_id
USE elph2, ONLY : ibndmax, ibndmin, nkqtotf
USE transportcom, ONLY : lower_bnd, upper_bnd
USE constants_epw, ONLY : zero
!
IMPLICIT NONE
@ -35,10 +37,8 @@
INTEGER, INTENT(IN) :: iter
!! Iteration number
REAL(kind=DP), INTENT(IN) :: F_in(3, ibndmax-ibndmin+1, nkqtotf/2, nstemp)
!REAL(kind=DP), INTENT(IN) :: F_in(:,:,:,:)
!! In solution for iteration i
REAL(kind=DP), INTENT(IN) :: av_mob_old(nstemp)
!REAL(kind=DP), INTENT(IN) :: av_mob_old(:)
!! Error in the hole mobility
LOGICAL, INTENT(IN) :: elec
!! IF true we do electron mobility, if false the hole one.
@ -117,11 +117,9 @@
USE constants_epw, ONLY : zero
USE io_files, ONLY : prefix, tmp_dir, diropn
USE mp, ONLY : mp_barrier, mp_bcast
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm, root_pool
USE mp_world, ONLY : mpime
USE mp_world, ONLY : mpime, world_comm
USE io_global, ONLY : ionode_id
USE elph2, ONLY : ibndmax, ibndmin, nkqtotf
USE transportcom, ONLY : lower_bnd, upper_bnd
!
IMPLICIT NONE
!
@ -133,7 +131,6 @@
!! Error in the hole mobility
LOGICAL, INTENT(IN) :: elec
!! IF true we do electron mobility, if false the hole one.
!
! Local variable
LOGICAL :: exst
@ -148,8 +145,6 @@
!! band index
INTEGER :: idir
!! Direction index
INTEGER :: nqtotf_read
!! Total number of q-point read
INTEGER :: itemp
!! Temperature index
!
@ -158,7 +153,7 @@
REAL(KIND=DP) :: aux ( 3 * (ibndmax-ibndmin+1) * (nkqtotf/2) * nstemp + nstemp + 1 )
!! Vector to store the array
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
! First inquire if the file exists
IF (elec) THEN
@ -215,14 +210,14 @@
! First element is the iteration number
iter = INT( aux(1) )
!
i = 2
i = 1
DO itemp=1, nstemp
i = i + 1
! Last value of hole mobility
av_mob_old(itemp) = aux(i)
ENDDO
!
i = 2 + nstemp
i = 1 + nstemp
DO itemp=1, nstemp
DO ik=1, nkqtotf/2
DO ibnd=1, (ibndmax-ibndmin+1)
@ -238,16 +233,12 @@
ENDIF
ENDIF ! mpime
!
CALL mp_bcast (exst, ionode_id, inter_pool_comm)
CALL mp_bcast (exst, root_pool, intra_pool_comm)
CALL mp_bcast (exst, ionode_id, world_comm)
!
IF (exst) THEN
CALL mp_bcast (iter, ionode_id, inter_pool_comm)
CALL mp_bcast (iter, root_pool, intra_pool_comm)
CALL mp_bcast (F_in, ionode_id, inter_pool_comm)
CALL mp_bcast (F_in, root_pool, intra_pool_comm)
CALL mp_bcast (av_mob_old, ionode_id, inter_pool_comm)
CALL mp_bcast (av_mob_old, root_pool, intra_pool_comm)
CALL mp_bcast (iter, ionode_id, world_comm)
CALL mp_bcast (F_in, ionode_id, world_comm)
CALL mp_bcast (av_mob_old, ionode_id, world_comm)
!
WRITE(stdout, '(a,i10)' ) ' Restart from iter: ',iter
ENDIF ! exists
@ -264,9 +255,9 @@
!
USE kinds, ONLY : DP
USE io_files, ONLY : tmp_dir, prefix
USE io_epw, ONLY : iufilibtev_sup, iunepmat, iunsparseq, iunsparsek, &
USE io_epw, ONLY : iunepmat, iunsparseq, iunsparsek, &
iunsparsei, iunsparsej, iunsparset, iunsparseqcb, &
iunsparsekcb, iunrestart, iunsparseicb, iunsparsejcb,&
iunsparsekcb, iunsparseicb, iunsparsejcb,&
iunsparsetcb, iunepmatcb
USE mp_world, ONLY : world_comm
#if defined(__MPI)
@ -408,18 +399,18 @@
!
WRITE(stdout,'(/5x,"Writing scattering rate to file"/)')
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
! Write to file
temp = etemp * ryd2ev / kelvin2eV
IF ( temp .lt. 10.d0 - eps4 ) THEN
IF ( temp < 10.d0 - eps4 ) THEN
WRITE(name1,'(a18,f4.2)') 'scattering_rate_00', temp
ELSEIF ( temp .ge. 10.d0 - eps4 .AND. temp .lt. 100.d0 -eps4 ) THEN
ELSEIF ( temp >= 10.d0 - eps4 .AND. temp < 100.d0 -eps4 ) THEN
WRITE(name1,'(a17,f5.2)') 'scattering_rate_0', temp
ELSEIF ( temp .ge. 100.d0 -eps4 ) THEN
ELSEIF ( temp >= 100.d0 -eps4 ) THEN
WRITE(name1,'(a16,f6.2)') 'scattering_rate_', temp
ENDIF
OPEN(iufilscatt_rate,file=name1, form='formatted')
OPEN(iufilscatt_rate,FILE=name1, FORM='formatted')
WRITE(iufilscatt_rate,'(a)') '# Inverse scattering time (ps)'
WRITE(iufilscatt_rate,'(a)') '# ik ibnd E(ibnd) scattering rate(1/ps)'
!
@ -462,8 +453,7 @@
USE constants_epw, ONLY : ryd2mev, kelvin2eV, ryd2ev, &
meV2invps, eps4
USE mp, ONLY : mp_barrier, mp_bcast
USE mp_global, ONLY : inter_pool_comm, root_pool, intra_pool_comm
USE mp_world, ONLY : mpime
USE mp_world, ONLY : mpime, world_comm
USE io_global, ONLY : ionode_id
!
IMPLICIT NONE
@ -498,17 +488,17 @@
!
WRITE(stdout,'(/5x,"Reading scattering rate from file"/)')
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
! Write to file
temp = etemp * ryd2ev / kelvin2eV
IF ( temp .lt. 10.d0 - eps4 ) THEN
IF ( temp < 10.d0 - eps4 ) THEN
WRITE(name1,'(a18,f4.2)') 'scattering_rate_00', temp
ELSEIF ( temp .ge. 10.d0 - eps4 .AND. temp .lt. 100.d0 -eps4 ) THEN
ELSEIF ( temp >= 10.d0 - eps4 .AND. temp < 100.d0 -eps4 ) THEN
WRITE(name1,'(a17,f5.2)') 'scattering_rate_0', temp
ELSEIF ( temp .ge. 100.d0 -eps4 ) THEN
ELSEIF ( temp >= 100.d0 -eps4 ) THEN
WRITE(name1,'(a16,f6.2)') 'scattering_rate_', temp
ENDIF
OPEN(iufilscatt_rate,file=name1, status='old',iostat=ios)
OPEN(iufilscatt_rate,FILE=name1, status='old',iostat=ios)
WRITE(stdout,'(a16,a22)') ' Open file: ',name1
! There are two comment line at the beginning of the file
READ(iufilscatt_rate,*) dummy1
@ -542,13 +532,8 @@
CLOSE(iufilscatt_rate)
!
ENDIF
CALL mp_bcast (etf_all, ionode_id, inter_pool_comm)
CALL mp_bcast (etf_all, root_pool, intra_pool_comm)
CALL mp_bcast (inv_tau_all, ionode_id, inter_pool_comm)
CALL mp_bcast (inv_tau_all, root_pool, intra_pool_comm)
CALL mp_barrier(inter_pool_comm)
CALL mp_bcast (etf_all, ionode_id, world_comm)
CALL mp_bcast (inv_tau_all, ionode_id, world_comm)
!
WRITE(stdout,'(/5x,"Scattering rate read from file"/)')
!
@ -600,7 +585,7 @@
REAL(KIND=DP) :: aux ( 3 * (ibndmax-ibndmin+1) * nktotf + 2 )
!! Vector to store the array
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
lsigma_all = 3 * (ibndmax-ibndmin+1) * nktotf +2
! First element is the current q-point
@ -661,8 +646,7 @@
USE constants_epw, ONLY : zero
USE transportcom, ONLY : lower_bnd, upper_bnd
USE mp, ONLY : mp_barrier, mp_bcast
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm, root_pool
USE mp_world, ONLY : mpime
USE mp_world, ONLY : mpime, world_comm
USE io_global, ONLY : ionode_id
!
IMPLICIT NONE
@ -699,7 +683,7 @@
!
CHARACTER (len=256) :: name1
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
! First inquire if the file exists
#if defined(__MPI)
@ -747,18 +731,13 @@
ENDIF
ENDIF
!
CALL mp_bcast (exst, ionode_id, inter_pool_comm)
CALL mp_bcast (exst, root_pool, intra_pool_comm)
CALL mp_bcast (exst, ionode_id, world_comm)
!
IF (exst) THEN
CALL mp_bcast (iqq, ionode_id, inter_pool_comm)
CALL mp_bcast (iqq, root_pool, intra_pool_comm)
CALL mp_bcast (sigmar_all, ionode_id, inter_pool_comm)
CALL mp_bcast (sigmar_all, root_pool, intra_pool_comm)
CALL mp_bcast (sigmai_all, ionode_id, inter_pool_comm)
CALL mp_bcast (sigmai_all, root_pool, intra_pool_comm)
CALL mp_bcast (zi_all, ionode_id, inter_pool_comm)
CALL mp_bcast (zi_all, root_pool, intra_pool_comm)
CALL mp_bcast (iqq, ionode_id, world_comm)
CALL mp_bcast (sigmar_all, ionode_id, world_comm)
CALL mp_bcast (sigmai_all, ionode_id, world_comm)
CALL mp_bcast (zi_all, ionode_id, world_comm)
!
! Make everythin 0 except the range of k-points we are working on
IF (lower_bnd > 1 ) THEN
@ -821,7 +800,7 @@
REAL(KIND=DP) :: aux ( 2 * nstemp * (ibndmax-ibndmin+1) * nktotf +2 )
!! Vector to store the array inv_tau_all and zi_all
!
IF (mpime .eq. meta_ionode_id) THEN
IF (mpime == meta_ionode_id) THEN
!
ltau_all = 2 * nstemp * (ibndmax-ibndmin+1) * nktotf +2
! First element is the iteration number
@ -900,7 +879,7 @@
END SUBROUTINE tau_write
!----------------------------------------------------------------------------
!----------------------------------------------------------------------------
SUBROUTINE tau_read(iqq,totq,nktotf,second)
SUBROUTINE tau_read (iqq, totq, nktotf, second)
!----------------------------------------------------------------------------
!
USE kinds, ONLY : DP
@ -942,12 +921,12 @@
!! Length of the vector
INTEGER :: nqtotf_read
!! Total number of q-point read
REAL(KIND=DP) :: aux ( 2 * nstemp * (ibndmax-ibndmin+1) * nktotf + 2 )
REAL(KIND=DP) :: aux(2 * nstemp * (ibndmax - ibndmin + 1) * nktotf + 2)
!! Vector to store the array
!
CHARACTER (len=256) :: name1
!
IF (mpime .eq. meta_ionode_id) THEN
IF (mpime == meta_ionode_id) THEN
!
! First inquire if the file exists
#if defined(__MPI)
@ -1074,12 +1053,6 @@
SUBROUTINE merge_read(nktotf, nqtotf_new, inv_tau_all_new)
!----------------------------------------------------------------------------
!
#if defined(__SX6)
# define DIRECT_IO_FACTOR 1
#else
# define DIRECT_IO_FACTOR 8
#endif
!
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE elph2, ONLY : ibndmax, ibndmin
@ -1087,8 +1060,7 @@
USE io_files, ONLY : tmp_dir, diropn
USE epwcom, ONLY : nstemp, restart_filq
USE mp, ONLY : mp_barrier, mp_bcast
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm, root_pool
USE mp_world, ONLY : mpime
USE mp_world, ONLY : mpime, world_comm
USE io_global, ONLY : ionode_id
!
IMPLICIT NONE
@ -1116,12 +1088,12 @@
!! Length of the vector
INTEGER(kind=8) :: unf_recl
!!
REAL(KIND=DP) :: aux ( nstemp * (ibndmax-ibndmin+1) * nktotf + 2 )
REAL(KIND=DP) :: aux ( nstemp * (ibndmax-ibndmin+1) * nktotf + 2 ), dummy
!! Vector to store the array
CHARACTER (len=256) :: name1
!
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
! First inquire if the file exists
name1 = trim(tmp_dir) // trim(restart_filq)
@ -1132,7 +1104,8 @@
ltau_all = nstemp * (ibndmax-ibndmin+1) * nktotf +2
!CALL diropn (iufiltau_all, 'tau_restart', ltau_all, exst)
!
unf_recl = DIRECT_IO_FACTOR * int(ltau_all, kind=kind(unf_recl))
INQUIRE (IOLENGTH = unf_recl) dummy
unf_recl = unf_recl * int(ltau_all, kind=kind(unf_recl))
open (unit = iufiltau_all, file = restart_filq, iostat = ios, form ='unformatted', &
status = 'unknown', access = 'direct', recl = unf_recl)
!
@ -1156,14 +1129,11 @@
ENDIF
ENDIF
!
CALL mp_bcast (exst, ionode_id, inter_pool_comm)
CALL mp_bcast (exst, root_pool, intra_pool_comm)
CALL mp_bcast (exst, ionode_id, world_comm)
!
IF (exst) THEN
CALL mp_bcast (nqtotf_new, ionode_id, inter_pool_comm)
CALL mp_bcast (nqtotf_new, root_pool, intra_pool_comm)
CALL mp_bcast (inv_tau_all_new, ionode_id, inter_pool_comm)
CALL mp_bcast (inv_tau_all_new, root_pool, intra_pool_comm)
CALL mp_bcast (nqtotf_new, ionode_id, world_comm)
CALL mp_bcast (inv_tau_all_new, ionode_id, world_comm)
!
WRITE(stdout, '(a,a)' ) ' Correctly read file ',restart_filq
ENDIF

2
EPW/src/kpoint_grid_epw.f90
View File

@ -184,7 +184,7 @@ DO nk=1,nks
wk(nk) = wk(nk)/fact
ENDDO
DEALLOCATE(xkg,wkk)
DEALLOCATE (xkg,wkk)
RETURN
END SUBROUTINE kpoint_grid_epw

56
EPW/src/ktokpmq.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!--------------------------------------------------------
subroutine ktokpmq ( xk, xq, sign, ipool, nkq, nkq_abs)
subroutine ktokpmq(xk, xq, sign, ipool, nkq, nkq_abs)
!--------------------------------------------------------
!!
!! For a given k point in cart coord, find the index
@ -23,7 +23,7 @@
use pwcom, ONLY : nkstot
USE cell_base, ONLY : at
USE start_k, ONLY : nk1, nk2, nk3
use epwcom, ONLY : xk_cryst
use klist_epw, ONLY : xk_cryst
USE mp_global, ONLY : nproc_pool, npool
USE mp_images, ONLY : nproc_image
USE mp, ONLY : mp_barrier, mp_bcast
@ -78,12 +78,12 @@
xx = xxk(1) * nk1
yy = xxk(2) * nk2
zz = xxk(3) * nk3
in_the_list = abs(xx-nint(xx)) .le. eps5 .AND. &
abs(yy-nint(yy)) .le. eps5 .AND. &
abs(zz-nint(zz)) .le. eps5
IF (.not.in_the_list) CALL errore('ktokpmq','is this a uniform k-mesh?',1)
in_the_list = abs(xx-nint(xx)) <= eps5 .AND. &
abs(yy-nint(yy)) <= eps5 .AND. &
abs(zz-nint(zz)) <= eps5
IF ( .NOT. in_the_list) CALL errore('ktokpmq','is this a uniform k-mesh?',1)
!
IF ( xx .lt. -eps5 .or. yy .lt. -eps5 .or. zz .lt. -eps5 ) &
IF ( xx < -eps5 .or. yy < -eps5 .or. zz < -eps5 ) &
CALL errore('ktokpmq','coarse k-mesh needs to be strictly positive in 1st BZ',1)
!
! now add the phonon wavevector and check that k+q falls again on the k grid
@ -93,10 +93,10 @@
xx = xxk(1) * nk1
yy = xxk(2) * nk2
zz = xxk(3) * nk3
in_the_list = abs(xx-nint(xx)) .le. eps5 .AND. &
abs(yy-nint(yy)) .le. eps5 .AND. &
abs(zz-nint(zz)) .le. eps5
IF (.not.in_the_list) CALL errore('ktokpmq','k+q does not fall on k-grid',1)
in_the_list = abs(xx-nint(xx)) <= eps5 .AND. &
abs(yy-nint(yy)) <= eps5 .AND. &
abs(zz-nint(zz)) <= eps5
IF ( .NOT. in_the_list) CALL errore('ktokpmq','k+q does not fall on k-grid',1)
!
! find the index of this k+q in the k-grid
!
@ -107,18 +107,18 @@
n = 0
found = .false.
DO ik = 1, nkstot
xx_c = xk_cryst(1,ik) * nk1
yy_c = xk_cryst(2,ik) * nk2
zz_c = xk_cryst(3,ik) * nk3
xx_c = xk_cryst(1, ik) * nk1
yy_c = xk_cryst(2, ik) * nk2
zz_c = xk_cryst(3, ik) * nk3
!
! check that the k-mesh was defined in the positive region of 1st BZ
!
IF ( xx_c .lt. -eps5 .or. yy_c .lt. -eps5 .or. zz_c .lt. -eps5 ) &
IF ( xx_c < -eps5 .or. yy_c < -eps5 .or. zz_c < -eps5 ) &
CALL errore('ktokpmq','coarse k-mesh needs to be strictly positive in 1st BZ',1)
!
found = nint(xx_c) .eq. nint(xx) .AND. &
nint(yy_c) .eq. nint(yy) .AND. &
nint(zz_c) .eq. nint(zz)
found = nint(xx_c) == nint(xx) .AND. &
nint(yy_c) == nint(yy) .AND. &
nint(zz_c) == nint(zz)
IF (found) THEN
n = ik
EXIT
@ -129,7 +129,7 @@
! since coarse k- and q- meshes are commensurate, one can easily find n
! n = nint(xx) * nk2 * nk3 + nint(yy) * nk3 + nint(zz) + 1
!
IF (n .eq. 0) call errore('ktokpmq','problem indexing k+q',1)
IF (n == 0) call errore('ktokpmq','problem indexing k+q',1)
!
! Now n represents the index of k+sign*q in the original k grid.
! In the parallel case we have to find the corresponding pool
@ -154,7 +154,7 @@
iks = nkl * jpool + 1
IF ( jpool >= nkr ) iks = iks + nkr * kunit
!
IF (n .ge. iks) THEN
IF (n >= iks) THEN
ipool = jpool + 1
nkq = n - iks + 1
ENDIF
@ -198,8 +198,8 @@
!
INTEGER :: rest, nrst
!
IF (total .le. npool) THEN
IF (my_pool_id .lt. total) THEN
IF (total <= npool) THEN
IF (my_pool_id < total) THEN
lower = my_pool_id + 1
upper = lower
ELSE
@ -247,14 +247,14 @@
! is far from cubic
!
DO ib = -2,0
IF (nint(xx) .lt. ib*n1) xx = xx + (-ib+1)*n1
IF (nint(yy) .lt. ib*n2) yy = yy + (-ib+1)*n2
IF (nint(zz) .lt. ib*n3) zz = zz + (-ib+1)*n3
IF (nint(xx) < ib*n1) xx = xx + (-ib+1)*n1
IF (nint(yy) < ib*n2) yy = yy + (-ib+1)*n2
IF (nint(zz) < ib*n3) zz = zz + (-ib+1)*n3
ENDDO
DO ib = 2,1,-1
IF (nint(xx) .ge. ib*n1) xx = xx - ib*n1
IF (nint(yy) .ge. ib*n2) yy = yy - ib*n2
IF (nint(zz) .ge. ib*n3) zz = zz - ib*n3
IF (nint(xx) >= ib*n1) xx = xx - ib*n1
IF (nint(yy) >= ib*n2) yy = yy - ib*n2
IF (nint(zz) >= ib*n3) zz = zz - ib*n3
ENDDO
!
!-------------------------------------------

4
EPW/src/load_rebal.f90
View File

@ -69,8 +69,8 @@
etf_all = etf
#endif
!
ALLOCATE(map_rebal(nkqtotf/2))
ALLOCATE(map_rebal_inv(nkqtotf/2))
ALLOCATE (map_rebal(nkqtotf/2))
ALLOCATE (map_rebal_inv(nkqtotf/2))
!
kpt_in(:) = 0
kpt_out(:) = 0

36
EPW/src/loadkmesh.f90
View File

@ -53,7 +53,7 @@ SUBROUTINE loadkmesh_para
REAL(kind=DP), ALLOCATABLE :: wkf_(:), wkf_tmp(:)
!! weights k-points
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
IF (filkf .ne. '') THEN ! load from file (crystal coordinates)
!
WRITE(stdout, *) ' Using k-mesh file: ', trim(filkf)
@ -120,7 +120,7 @@ SUBROUTINE loadkmesh_para
wkf_(ikk) = 2.d0 * wkf_tmp(ik)
wkf_(ikq) = 0.d0
ENDDO
DEALLOCATE(xkf_tmp, wkf_tmp)
DEALLOCATE (xkf_tmp, wkf_tmp)
!
! bring the k point to crystal coordinates
CALL cryst_to_cart(2*nkqtotf, xkfval, at, -1)
@ -141,7 +141,7 @@ SUBROUTINE loadkmesh_para
!
nkqtotf = 2 * nkqtotf
!
DEALLOCATE(xkfval)
DEALLOCATE (xkfval)
!
ELSE ! mp_mesh_k
!
@ -224,8 +224,8 @@ SUBROUTINE loadkmesh_para
ENDIF
!
nkf = nkqf / 2
IF (.not.ALLOCATED(xkf_)) ALLOCATE (xkf_(3,nkqtotf))
IF (.not.ALLOCATED(wkf_)) ALLOCATE (wkf_( nkqtotf))
IF ( .NOT. ALLOCATED(xkf_)) ALLOCATE (xkf_(3,nkqtotf))
IF ( .NOT. ALLOCATED(wkf_)) ALLOCATE (wkf_( nkqtotf))
CALL mp_bcast(xkf_, ionode_id, inter_pool_comm)
CALL mp_bcast(wkf_, ionode_id, inter_pool_comm)
!
@ -242,13 +242,13 @@ SUBROUTINE loadkmesh_para
!
! Assign the weights and vectors to the correct bounds
!
ALLOCATE(xkf(3,nkqf))
ALLOCATE(wkf( nkqf))
ALLOCATE (xkf(3,nkqf))
ALLOCATE (wkf( nkqf))
xkf(:,:) = xkf_ (:, lower_bnd:upper_bnd)
!
! KMB: set coordinates of displaced vectors for indabs
IF (vme .AND. eig_read) THEN
ALLOCATE( xkfd(3,nkqf,6))
ALLOCATE ( xkfd(3,nkqf,6))
deltaq = 0.001d0
DO ik = 1, nkqf
!--bring the k point to cartesian coordinates
@ -272,14 +272,14 @@ SUBROUTINE loadkmesh_para
wkf( :) = wkf_ ( lower_bnd:upper_bnd)
ENDIF
!
IF (abs(sum (wkf_ (:)) - 2.d0) .gt. 1.d-4 ) &
IF (abs(sum (wkf_ (:)) - 2.d0) > 1.d-4 ) &
WRITE(stdout,'(5x,"WARNING: k-point weigths do not add up to 1 [loadkmesh_para]")')
!
WRITE( stdout, '(5x,"Size of k point mesh for interpolation: ",i10)' ) nkqtotf
WRITE( stdout, '(5x,"Max number of k points per pool:",7x,i10)' ) nkqf
!
IF (ALLOCATED(xkf_)) DEALLOCATE(xkf_)
IF (ALLOCATED(wkf_)) DEALLOCATE(wkf_)
IF (ALLOCATED(xkf_)) DEALLOCATE (xkf_)
IF (ALLOCATED(wkf_)) DEALLOCATE (wkf_)
!
END SUBROUTINE loadkmesh_para
!-----------------------------------------------------------------------
@ -321,7 +321,7 @@ SUBROUTINE loadkmesh_serial
REAL(kind=DP), ALLOCATABLE :: wkf_tmp(:)
!! weights k-points
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
IF (filkf .ne. '') THEN ! load from file (crystal coordinates)
!
! Each pool gets its own copy from the action=read statement
@ -467,14 +467,14 @@ SUBROUTINE loadkmesh_serial
CALL mp_bcast (nkf, ionode_id, inter_pool_comm)
CALL mp_bcast (nkqf, ionode_id, inter_pool_comm)
CALL mp_bcast (nkqtotf, ionode_id, inter_pool_comm)
IF (.not.ALLOCATED(xkf)) ALLOCATE (xkf(3,nkqtotf))
IF (.not.ALLOCATED(wkf)) ALLOCATE (wkf( nkqtotf))
IF ( .NOT. ALLOCATED(xkf)) ALLOCATE (xkf(3,nkqtotf))
IF ( .NOT. ALLOCATED(wkf)) ALLOCATE (wkf( nkqtotf))
CALL mp_bcast(xkf, ionode_id, inter_pool_comm)
CALL mp_bcast(wkf, ionode_id, inter_pool_comm)
!
! KMB: set coordinates of displaced vectors - indabs
IF (vme .AND. eig_read) THEN
ALLOCATE( xkfd(3,nkqf,6))
ALLOCATE ( xkfd(3,nkqf,6))
deltaq = 0.001d0
DO ik = 1, nkqf
! Bring the k point to cartesian coordinates
@ -492,7 +492,7 @@ SUBROUTINE loadkmesh_serial
END DO
ENDDO
ENDIF
IF (abs(sum (wkf) - 2.d0) .gt. 1.d-4 ) &
IF (abs(sum (wkf) - 2.d0) > 1.d-4 ) &
WRITE(stdout,'(5x,"WARNING: k-point weigths do not add up to 1 [loadkmesh_serial]")')
!
WRITE( stdout, '(5x,"Size of k point mesh for interpolation: ",i10)' ) nkqtotf
@ -507,14 +507,14 @@ SUBROUTINE init_random_seed()
INTEGER, DIMENSION(:), ALLOCATABLE :: seed
!
CALL RANDOM_SEED(size = n)
ALLOCATE(seed(n))
ALLOCATE (seed(n))
!
CALL SYSTEM_CLOCK(COUNT=clock)
!
seed = clock + 37 * (/ (i - 1, i = 1, n) /)
CALL RANDOM_SEED(PUT = seed)
!
DEALLOCATE(seed)
DEALLOCATE (seed)
!
END SUBROUTINE init_random_seed
!-----------------------------------------------------------------------

24
EPW/src/loadqmesh.f90
View File

@ -36,7 +36,7 @@ SUBROUTINE loadqmesh_para
!
integer :: rest
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
IF (filqf .ne. '') THEN ! load from file (crystal coordinates)
!
WRITE(stdout, *) ' Using q-mesh file: ', trim(filqf)
@ -143,8 +143,8 @@ SUBROUTINE loadqmesh_para
upper_bnd = lower_bnd + nqf - 1
ENDIF
!
IF (.not.ALLOCATED(xqf_)) ALLOCATE (xqf_(3,nqtotf))
IF (.not.ALLOCATED(wqf_)) ALLOCATE (wqf_( nqtotf))
IF ( .NOT. ALLOCATED(xqf_)) ALLOCATE (xqf_(3,nqtotf))
IF ( .NOT. ALLOCATED(wqf_)) ALLOCATE (wqf_( nqtotf))
CALL mp_bcast(xqf_, ionode_id, inter_pool_comm)
CALL mp_bcast(wqf_, ionode_id, inter_pool_comm)
!
@ -160,8 +160,8 @@ SUBROUTINE loadqmesh_para
!
! Assign the weights and vectors to the correct bounds
!
ALLOCATE(xqf(3,nqf))
ALLOCATE(wqf( nqf))
ALLOCATE (xqf(3,nqf))
ALLOCATE (wqf( nqf))
xqf(:,:) = xqf_ (:, lower_bnd:upper_bnd)
IF (noncolin) THEN
wqf( :) = wqf_ ( lower_bnd:upper_bnd)/2.d0
@ -169,14 +169,14 @@ SUBROUTINE loadqmesh_para
wqf( :) = wqf_ ( lower_bnd:upper_bnd)
ENDIF
!
IF (abs(sum (wqf_ (:)) - 1.d0) .gt. 1.d-4 ) &
IF (abs(sum (wqf_ (:)) - 1.d0) > 1.d-4 ) &
WRITE(stdout,'(5x,"WARNING: q-point weigths do not add up to 1 [loadqmesh_para]")')
!
WRITE( stdout, '(5x,"Size of q point mesh for interpolation: ",i10)' ) nqtotf
WRITE( stdout, '(5x,"Max number of q points per pool:",7x,i10)' ) nqf
!
IF (ALLOCATED(xqf_)) DEALLOCATE(xqf_)
IF (ALLOCATED(wqf_)) DEALLOCATE(wqf_)
IF (ALLOCATED(xqf_)) DEALLOCATE (xqf_)
IF (ALLOCATED(wqf_)) DEALLOCATE (wqf_)
!
END SUBROUTINE loadqmesh_para
!-----------------------------------------------------------------------
@ -205,7 +205,7 @@ SUBROUTINE loadqmesh_serial
!
integer :: iq, i, j, k, ios
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
IF (filqf .ne. '') THEN ! load from file (crystal coordinates)
!
! Each pool gets its own copy from the action=read statement
@ -311,12 +311,12 @@ SUBROUTINE loadqmesh_serial
!
CALL mp_bcast (nqf, ionode_id, inter_pool_comm)
CALL mp_bcast (nqtotf, ionode_id, inter_pool_comm)
IF (.not.ALLOCATED(xqf)) ALLOCATE (xqf(3,nqtotf))
IF (.not.ALLOCATED(wqf)) ALLOCATE (wqf( nqtotf))
IF ( .NOT. ALLOCATED(xqf)) ALLOCATE (xqf(3,nqtotf))
IF ( .NOT. ALLOCATED(wqf)) ALLOCATE (wqf( nqtotf))
CALL mp_bcast(xqf, ionode_id, inter_pool_comm)
CALL mp_bcast(wqf, ionode_id, inter_pool_comm)
!
IF (abs(sum (wqf) - 1.d0) .gt. 1.d-4 ) &
IF (abs(sum (wqf) - 1.d0) > 1.d-4 ) &
WRITE(stdout,'(5x,"WARNING: q-point weigths do not add up to 1 [loadqmesh_serial]")')
!
WRITE( stdout, '(5x,"Size of q point mesh for interpolation: ",i10)' ) nqtotf

2
EPW/src/loadumat.f90
View File

@ -91,7 +91,7 @@
!
! first proc read rotation matrix (coarse mesh) from file
!
OPEN(iunukk, file=filukk, status='old', form='formatted', iostat=ios)
OPEN(iunukk, FILE=filukk, status='old', FORM='formatted', iostat=ios)
IF (ios /=0) CALL errore('loadumat', 'error opening ukk file', iunukk)
!
DO ik = 1, nkstot

42
EPW/src/make.depend
View File

@ -17,18 +17,7 @@ adddvscf2.o : ../../Modules/uspp.o
adddvscf2.o : ../../PW/src/pwcom.o
adddvscf2.o : constants_epw.o
adddvscf2.o : elph2.o
allocate_epwq.o : ../../LR_Modules/lrcom.o
allocate_epwq.o : ../../Modules/becmod.o
allocate_epwq.o : ../../Modules/fft_base.o
allocate_epwq.o : ../../Modules/ions_base.o
allocate_epwq.o : ../../Modules/noncol.o
allocate_epwq.o : ../../Modules/recvec.o
allocate_epwq.o : ../../Modules/uspp.o
allocate_epwq.o : ../../PHonon/PH/phcom.o
allocate_epwq.o : ../../PW/src/pwcom.o
allocate_epwq.o : elph2.o
allocate_epwq.o : epwcom.o
allocate_epwq.o : transportcom.o
adddvscf2.o : epwcom.o
bcast_epw_input.o : ../../LR_Modules/lrcom.o
bcast_epw_input.o : ../../Modules/control_flags.o
bcast_epw_input.o : ../../Modules/io_files.o
@ -57,7 +46,6 @@ broyden.o : ../../Modules/kind.o
broyden.o : eliashbergcom.o
broyden.o : epwcom.o
close_epw.o : ../../LR_Modules/lrcom.o
close_epw.o : ../../Modules/becmod.o
close_epw.o : ../../Modules/io_files.o
close_epw.o : ../../Modules/kind.o
close_epw.o : ../../Modules/mp_global.o
@ -124,6 +112,7 @@ dvqpsi_us3.o : ../../PW/src/pwcom.o
dvqpsi_us3.o : ../../PW/src/scf_mod.o
dvqpsi_us3.o : constants_epw.o
dvqpsi_us3.o : elph2.o
dvqpsi_us3.o : epwcom.o
dvqpsi_us_only3.o : ../../LR_Modules/lrcom.o
dvqpsi_us_only3.o : ../../Modules/cell_base.o
dvqpsi_us_only3.o : ../../Modules/ions_base.o
@ -135,6 +124,7 @@ dvqpsi_us_only3.o : ../../PHonon/PH/phcom.o
dvqpsi_us_only3.o : ../../PW/src/pwcom.o
dvqpsi_us_only3.o : constants_epw.o
dvqpsi_us_only3.o : elph2.o
dvqpsi_us_only3.o : epwcom.o
eliashberg.o : ../../Modules/io_global.o
eliashberg.o : eliashbergcom.o
eliashberg.o : epwcom.o
@ -164,6 +154,7 @@ elphel2_shuffle.o : ../../UtilXlib/mp.o
elphel2_shuffle.o : constants_epw.o
elphel2_shuffle.o : division.o
elphel2_shuffle.o : elph2.o
elphel2_shuffle.o : epwcom.o
elphon_shuffle.o : ../../FFTXlib/fft_interfaces.o
elphon_shuffle.o : ../../LR_Modules/lrcom.o
elphon_shuffle.o : ../../Modules/fft_base.o
@ -179,6 +170,7 @@ elphon_shuffle.o : ../../UtilXlib/mp.o
elphon_shuffle.o : constants_epw.o
elphon_shuffle.o : elph2.o
elphon_shuffle_wrap.o : ../../LR_Modules/lrcom.o
elphon_shuffle_wrap.o : ../../Modules/becmod.o
elphon_shuffle_wrap.o : ../../Modules/cell_base.o
elphon_shuffle_wrap.o : ../../Modules/control_flags.o
elphon_shuffle_wrap.o : ../../Modules/fft_base.o
@ -205,6 +197,7 @@ elphon_shuffle_wrap.o : elph2.o
elphon_shuffle_wrap.o : epwcom.o
elphon_shuffle_wrap.o : io_epw.o
ephwann_shuffle.o : ../../Modules/cell_base.o
ephwann_shuffle.o : ../../Modules/control_flags.o
ephwann_shuffle.o : ../../Modules/io_files.o
ephwann_shuffle.o : ../../Modules/io_global.o
ephwann_shuffle.o : ../../Modules/ions_base.o
@ -233,6 +226,7 @@ ephwann_shuffle.o : transportcom.o
ephwann_shuffle.o : wan2bloch.o
ephwann_shuffle.o : wigner.o
ephwann_shuffle_mem.o : ../../Modules/cell_base.o
ephwann_shuffle_mem.o : ../../Modules/control_flags.o
ephwann_shuffle_mem.o : ../../Modules/io_files.o
ephwann_shuffle_mem.o : ../../Modules/io_global.o
ephwann_shuffle_mem.o : ../../Modules/ions_base.o
@ -288,7 +282,9 @@ epw_init.o : ../../PW/src/pwcom.o
epw_init.o : ../../UtilXlib/mp.o
epw_init.o : constants_epw.o
epw_init.o : elph2.o
epw_init.o : epwcom.o
epw_readin.o : ../../LR_Modules/lrcom.o
epw_readin.o : ../../Modules/cell_base.o
epw_readin.o : ../../Modules/constants.o
epw_readin.o : ../../Modules/control_flags.o
epw_readin.o : ../../Modules/io_files.o
@ -296,6 +292,8 @@ epw_readin.o : ../../Modules/io_global.o
epw_readin.o : ../../Modules/ions_base.o
epw_readin.o : ../../Modules/mp_global.o
epw_readin.o : ../../Modules/mp_world.o
epw_readin.o : ../../Modules/noncol.o
epw_readin.o : ../../Modules/wavefunctions.o
epw_readin.o : ../../PHonon/PH/phcom.o
epw_readin.o : ../../PW/src/pwcom.o
epw_readin.o : ../../PW/src/start_k.o
@ -309,12 +307,10 @@ epw_setup.o : ../../Modules/cell_base.o
epw_setup.o : ../../Modules/control_flags.o
epw_setup.o : ../../Modules/fft_base.o
epw_setup.o : ../../Modules/funct.o
epw_setup.o : ../../Modules/io_files.o
epw_setup.o : ../../Modules/io_global.o
epw_setup.o : ../../Modules/ions_base.o
epw_setup.o : ../../Modules/kind.o
epw_setup.o : ../../Modules/mp_global.o
epw_setup.o : ../../Modules/mp_pools.o
epw_setup.o : ../../Modules/noncol.o
epw_setup.o : ../../Modules/recvec.o
epw_setup.o : ../../Modules/uspp.o
@ -351,7 +347,6 @@ fermiwindow.o : ../../PW/src/pwcom.o
fermiwindow.o : ../../UtilXlib/mp.o
fermiwindow.o : elph2.o
fermiwindow.o : epwcom.o
gmap_sym.o : ../../Modules/fft_base.o
gmap_sym.o : ../../Modules/kind.o
gmap_sym.o : ../../Modules/recvec.o
gmap_sym.o : constants_epw.o
@ -646,20 +641,6 @@ selfen_pl.o : division.o
selfen_pl.o : elph2.o
selfen_pl.o : epwcom.o
selfen_pl.o : io_epw.o
setphases.o : ../../FFTXlib/fft_interfaces.o
setphases.o : ../../LR_Modules/lrcom.o
setphases.o : ../../Modules/cell_base.o
setphases.o : ../../Modules/control_flags.o
setphases.o : ../../Modules/fft_base.o
setphases.o : ../../Modules/io_global.o
setphases.o : ../../Modules/kind.o
setphases.o : ../../Modules/mp_global.o
setphases.o : ../../Modules/recvec.o
setphases.o : ../../Modules/wavefunctions.o
setphases.o : ../../PHonon/PH/phcom.o
setphases.o : ../../PW/src/pwcom.o
setphases.o : ../../UtilXlib/mp.o
setphases.o : constants_epw.o
setphases_wrap.o : ../../Modules/io_global.o
setphases_wrap.o : ../../Modules/kind.o
setphases_wrap.o : ../../Modules/mp_global.o
@ -816,7 +797,6 @@ wan2bloch.o : io_epw.o
wannierEPW.o : ../../Modules/kind.o
wannierize.o : ../../Modules/io_files.o
wannierize.o : ../../Modules/io_global.o
wannierize.o : ../../Modules/ions_base.o
wannierize.o : ../../Modules/kind.o
wannierize.o : ../../Modules/mp_global.o
wannierize.o : ../../Modules/mp_world.o

13
EPW/src/nesting_fn.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
subroutine nesting_fn_q ( iqq, iq )
subroutine nesting_fn_q(iqq, iq)
!-----------------------------------------------------------------------
!!
!! compute the imaginary part of the phonon self energy due to electron-
@ -24,7 +24,8 @@
USE epwcom, ONLY : nbndsub, fsthick, &
eptemp, ngaussw, degaussw, &
nsmear, delta_smear, efermi_read, fermi_energy
USE pwcom, ONLY : nelec, ef, isk
USE pwcom, ONLY : nelec, ef
USE klist_epw, ONLY : isk_dummy
USE elph2, ONLY : ibndmax, ibndmin, etf, &
wkf, xqf, wqf, nkqf, &
nkf, nkqtotf, xqf
@ -78,7 +79,7 @@
WRITE(stdout,'(5x,"Nesting Function in the double delta approx")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick.lt.1.d3 ) &
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
@ -100,7 +101,7 @@
IF ( efermi_read ) THEN
ef0 = fermi_energy
ELSE
ef0 = efermig(etf, nbndsub, nkqf, nelec, wkf, degaussw0, ngaussw, 0, isk)
ef0 = efermig(etf, nbndsub, nkqf, nelec, wkf, degaussw0, ngaussw, 0, isk_dummy)
ENDIF
!
dosef = dos_ef (ngaussw, degaussw0, ef0, etf, wkf, nkqf, nbndsub)
@ -123,8 +124,8 @@
ikq = ikk + 1
!
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .and. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) then
IF ( ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) .and. &
( minval ( abs(etf (:, ikq) - ef) ) < fsthick ) ) then
!
fermicount = fermicount + 1
!

47
EPW/src/newdq2.f90
View File

@ -33,7 +33,7 @@
USE mp, ONLY : mp_sum
USE lrus, ONLY : int3
USE qpoint, ONLY : eigqts
USE constants_epw, ONLY : czero
USE constants_epw, ONLY : czero, zero
!
IMPLICIT NONE
!
@ -72,32 +72,40 @@
REAL(kind=DP), ALLOCATABLE :: ylmk0(:,:)
!! the spherical harmonics at q+G
!
COMPLEX(kind=DP), EXTERNAL :: zdotc
COMPLEX(kind=DP), EXTERNAL :: ZDOTC
!! the scalar product function
COMPLEX(kind=DP), ALLOCATABLE :: aux1(:), aux2(:,:)
COMPLEX(kind=DP), ALLOCATABLE :: qgm(:)
!! the augmentation function at G
!! the augmentation function at q+G
COMPLEX(kind=DP), ALLOCATABLE :: veff(:)
!! effective potential
!
IF (.not.okvan) RETURN
IF (.NOT. okvan) RETURN
!
CALL start_clock('newdq2')
!
int3(:,:,:,:,:) = czero
!
ALLOCATE( aux1(ngm) )
ALLOCATE( aux2(ngm,nspin_mag) )
ALLOCATE( veff(dfftp%nnr) )
ALLOCATE( ylmk0(ngm, lmaxq * lmaxq) )
ALLOCATE( qgm(ngm) )
ALLOCATE( qmod(ngm) )
ALLOCATE( qg(3,ngm) )
ALLOCATE ( aux1(ngm) )
ALLOCATE ( aux2(ngm,nspin_mag) )
ALLOCATE ( veff(dfftp%nnr) )
ALLOCATE ( ylmk0(ngm, lmaxq * lmaxq) )
ALLOCATE ( qgm(ngm) )
ALLOCATE ( qmod(ngm) )
ALLOCATE ( qg(3,ngm) )
aux1(:) = czero
aux2(:,:) = czero
veff(:) = czero
ylmk0(:,:) = zero
qgm(:) = czero
qmod(:) = zero
qg(:,:) = zero
!
! first compute the spherical harmonics
!
CALL setqmod( ngm, xq0, g, qmod, qg )
CALL ylmr2( lmaxq * lmaxq, ngm, qg, qmod, ylmk0 )
!
DO ig = 1, ngm
qmod(ig) = sqrt( qmod(ig) )
ENDDO
@ -127,6 +135,7 @@
!
DO ih = 1, nh(nt)
DO jh = ih, nh(nt)
!
CALL qvan2( ngm, ih, jh, nt, qmod, qgm, ylmk0 )
!
DO na = 1, nat
@ -139,7 +148,7 @@
ENDDO
DO is = 1, nspin_mag
int3(ih,jh,na,is,ipert) = omega * &
zdotc(ngm,aux1,1,aux2(1,is),1)
ZDOTC(ngm,aux1,1,aux2(1,is),1)
ENDDO
ENDIF
ENDDO
@ -177,13 +186,13 @@
!SUM((REAL(REAL(int3(:,:,:,:,:))))**2)+SUM((REAL(AIMAG(int3(:,:,:,:,:))))**2)
!END
!
DEALLOCATE(aux1)
DEALLOCATE(aux2)
DEALLOCATE(veff)
DEALLOCATE(ylmk0)
DEALLOCATE(qgm)
DEALLOCATE(qmod)
DEALLOCATE(qg)
DEALLOCATE (aux1)
DEALLOCATE (aux2)
DEALLOCATE (veff)
DEALLOCATE (ylmk0)
DEALLOCATE (qgm)
DEALLOCATE (qmod)
DEALLOCATE (qg)
!
CALL stop_clock('newdq2')
!

2
EPW/src/openfilepw.f90
View File

@ -38,7 +38,7 @@
iuwfc = 20
lrwfc = 2 * nbnd * npwx * npol
CALL diropn(iuwfc, 'wfc', lrwfc, exst)
IF (.not. exst) CALL errore ('openfilepw','file '//TRIM( prefix )//'.wfc'//' not found',1)
IF ( .NOT. exst) CALL errore ('openfilepw','file '//TRIM( prefix )//'.wfc'//' not found',1)
!
! file for setting unitary gauges of eigenstates
!

12
EPW/src/plot_band.f90
View File

@ -57,7 +57,7 @@
!
IF (filqf /= ' ') THEN
!
IF ( my_pool_id .eq. ionode_id ) THEN
IF ( my_pool_id == ionode_id ) THEN
!
OPEN(iufilfreq, file = "phband.freq", form = 'formatted')
WRITE(iufilfreq, '(" &plot nbnd=",i4,", nks=",i6," /")') nmodes, nqtotf
@ -102,8 +102,8 @@
!
ENDDO
!
IF ( .not. ALLOCATED(xkf_all) ) ALLOCATE ( xkf_all( 3, nkqtotf))
IF ( .not. ALLOCATED(etf_all) ) ALLOCATE (etf_all( nbndsub, nkqtotf))
IF ( .NOT. ALLOCATED(xkf_all) ) ALLOCATE ( xkf_all( 3, nkqtotf))
IF ( .NOT. ALLOCATED(etf_all) ) ALLOCATE (etf_all( nbndsub, nkqtotf))
!
#if defined(__MPI)
CALL poolgather2( 3, nkqtotf, nkqf, xkf, xkf_all )
@ -115,7 +115,7 @@
etf_all = etf
#endif
!
IF ( my_pool_id .eq. ionode_id ) THEN
IF ( my_pool_id == ionode_id ) THEN
!
OPEN(iufileig, file = "band.eig", form = 'formatted')
WRITE(iufileig, '(" &plot nbnd=",i4,", nks=",i6," /")') nbndsub, nksqtotf
@ -153,8 +153,8 @@
ENDIF
CALL mp_barrier(inter_pool_comm)
!
IF ( ALLOCATED(xkf_all)) DEALLOCATE( xkf_all )
IF ( ALLOCATED(etf_all)) DEALLOCATE( etf_all )
IF ( ALLOCATED(xkf_all)) DEALLOCATE ( xkf_all )
IF ( ALLOCATED(etf_all)) DEALLOCATE ( etf_all )
!
ENDIF ! filkf
!

168
EPW/src/print_ibte.f90
View File

@ -23,8 +23,8 @@
restart, restart_freq, restart_filq, vme, ncarrier
USE pwcom, ONLY : ef
USE elph2, ONLY : ibndmax, ibndmin, etf, nkqf, nkf, dmef, vmef, wf, wqf, &
epf17, nkqtotf, inv_tau_all, inv_tau_allcb, &
xqf, zi_allvb, zi_allcb, xkf, wkf, dmef, vmef, nqf
epf17, nkqtotf, &
xqf, xkf, wkf, dmef, vmef, nqf
USE transportcom, ONLY : transp_temp, lower_bnd
USE constants_epw, ONLY : zero, one, two, pi, ryd2mev, kelvin2eV, ryd2ev, &
eps6, eps10, bohr2ang, ang2cm, eps4, eps8
@ -173,8 +173,6 @@
!! Temporary array to store the scattering rates
REAL(kind=DP) :: zi_tmp(ibndmax-ibndmin+1)
!! Temporary array to store the zi
REAL(KIND=DP), ALLOCATABLE :: inv_tau_all_new (:,:,:)
!! New scattering rates to be merged
REAL(KIND=DP) :: xkf_all(3,nkqtotf/2)
!! k-points coordinate from all cores
REAL(KIND=DP) :: wkf_all(nkqtotf/2)
@ -186,8 +184,6 @@
!! Eigen-energies on the fine grid collected from all pools in parallel case
REAL(KIND=DP), EXTERNAL :: DDOT
!! Dot product function
REAL(KIND=DP), EXTERNAL :: efermig
!! Function that returns the Fermi energy
REAL(KIND=DP), EXTERNAL :: wgauss
!! Compute the approximate theta function. Here computes Fermi-Dirac
REAL(KIND=DP), EXTERNAL :: w0gauss
@ -264,8 +260,8 @@
!
! We are not consistent with ef from ephwann_shuffle but it should not
! matter if fstick is large enough.
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
IF ( ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) < fsthick ) ) THEN
xkf_all(:, ik+lower_bnd - 1 ) = xkf(:,ikk)
wkf_all(ik+lower_bnd - 1 ) = wkf(ikk)
@ -294,7 +290,7 @@
!
! SP : Avoid if statement in inner loops
! the coupling from Gamma acoustic phonons is negligible
IF ( wq .gt. eps_acustic ) THEN
IF ( wq > eps_acustic ) THEN
g2_tmp = 1.0
wgq = wgauss( -wq*inv_etemp, -99)
wgq = wgq / ( one - two * wgq )
@ -395,7 +391,7 @@
!
! SP : Avoid if statement in inner loops
! the coupling from Gamma acoustic phonons is negligible
IF ( wq .gt. eps_acustic ) THEN
IF ( wq > eps_acustic ) THEN
g2_tmp = 1.0
wgq = wgauss( -wq*inv_etemp, -99)
wgq = wgq / ( one - two * wgq )
@ -476,51 +472,47 @@
! WRITE(stdout,'(a,i9,E22.8)') ' Total number of element written ',ind_tot
!
! Size of what we write
lsize = INT( ind(my_pool_id+1), kind = MPI_OFFSET_KIND )
lsize = INT(ind(my_pool_id + 1), kind = MPI_OFFSET_KIND)
! Offset where we need to start writing (we increment for each q-points)
lrepmatw = lrepmatw2 + &
INT( SUM( ind(1:my_pool_id+1)) - ind(my_pool_id+1), kind = MPI_OFFSET_KIND ) * 8_MPI_OFFSET_KIND
INT(SUM(ind(1:my_pool_id + 1)) - ind(my_pool_id + 1), kind = MPI_OFFSET_KIND) * 8_MPI_OFFSET_KIND
lrepmatw3 = lrepmatw4 + &
INT( SUM( ind(1:my_pool_id+1)) - ind(my_pool_id+1), kind = MPI_OFFSET_KIND ) * 4_MPI_OFFSET_KIND
INT(SUM(ind(1:my_pool_id + 1)) - ind(my_pool_id + 1), kind = MPI_OFFSET_KIND) * 4_MPI_OFFSET_KIND
!
CALL MPI_FILE_SEEK(iunepmat, lrepmatw,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunepmat, trans_prob, lsize, MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!CALL MPI_FILE_SEEK(iunepmat, lrepmatw,MPI_SEEK_SET,ierr)
!IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
!CALL MPI_FILE_WRITE(iunepmat, trans_prob, lsize, MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,ierr)
!IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
CALL MPI_FILE_WRITE_AT(iunepmat, lrepmatw, trans_prob, lsize, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_SEEK (iunsparseq, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparseq, sparse_q, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!CALL MPI_FILE_SEEK (iunsparseq, lrepmatw3,MPI_SEEK_SET,ierr)
!IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
!CALL MPI_FILE_WRITE(iunsparseq, sparse_q, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
!IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
CALL MPI_FILE_WRITE_AT(iunsparseq, lrepmatw3, sparse_q, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_SEEK (iunsparsek, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparsek, sparse_k, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
CALL MPI_FILE_WRITE_AT(iunsparsek, lrepmatw3, sparse_k, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_SEEK (iunsparsei, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparsei, sparse_i, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
CALL MPI_FILE_WRITE_AT(iunsparsei, lrepmatw3, sparse_i, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_SEEK (iunsparsej, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparsej, sparse_j, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
CALL MPI_FILE_WRITE_AT(iunsparsej, lrepmatw3, sparse_j, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_SEEK (iunsparset, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparset, sparse_t, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
CALL MPI_FILE_WRITE_AT(iunsparset, lrepmatw3, sparse_t, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
! Offset for the next q iteration
lrepmatw2 = lrepmatw2 + INT( SUM( ind(:) ), kind = MPI_OFFSET_KIND ) * 8_MPI_OFFSET_KIND
lrepmatw4 = lrepmatw4 + INT( SUM( ind(:) ), kind = MPI_OFFSET_KIND ) * 4_MPI_OFFSET_KIND
lrepmatw2 = lrepmatw2 + INT(SUM(ind(:)), kind = MPI_OFFSET_KIND ) * 8_MPI_OFFSET_KIND
lrepmatw4 = lrepmatw4 + INT(SUM(ind(:)), kind = MPI_OFFSET_KIND ) * 4_MPI_OFFSET_KIND
!
! now write in the support file
CALL mp_sum(xkf_all, world_comm)
CALL mp_sum(wkf_all, world_comm)
CALL MP_SUM(xkf_all, world_comm)
CALL MP_SUM(wkf_all, world_comm)
!
ENDIF
IF ( sum(indcb) > 0 ) THEN
@ -531,54 +523,44 @@
! WRITE(stdout,'(a,i9,E22.8)') ' Total number of element written in electron ',ind_totcb
!
! Size of what we write
lsize = INT( indcb(my_pool_id+1), kind = MPI_OFFSET_KIND )
lsize = INT(indcb(my_pool_id + 1), kind = MPI_OFFSET_KIND)
! Offset where we need to start writing (we increment for each q-points)
lrepmatw = lrepmatw5 + &
INT( SUM( indcb(1:my_pool_id+1)) - indcb(my_pool_id+1), kind = MPI_OFFSET_KIND ) * 8_MPI_OFFSET_KIND
INT(SUM(indcb(1:my_pool_id + 1)) - indcb(my_pool_id + 1), kind = MPI_OFFSET_KIND) * 8_MPI_OFFSET_KIND
lrepmatw3 = lrepmatw6 + &
INT( SUM( indcb(1:my_pool_id+1)) - indcb(my_pool_id+1), kind = MPI_OFFSET_KIND ) * 4_MPI_OFFSET_KIND
INT(SUM(indcb(1:my_pool_id + 1)) - indcb(my_pool_id + 1), kind = MPI_OFFSET_KIND) * 4_MPI_OFFSET_KIND
!
CALL MPI_FILE_SEEK(iunepmatcb, lrepmatw,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunepmatcb, trans_probcb, lsize, MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!
CALL MPI_FILE_SEEK (iunsparseqcb, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparseqcb, sparsecb_q, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!
CALL MPI_FILE_SEEK (iunsparsekcb, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparsekcb, sparsecb_k, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!
CALL MPI_FILE_SEEK (iunsparseicb, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparseicb, sparsecb_i, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!
CALL MPI_FILE_SEEK (iunsparsejcb, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparsejcb, sparsecb_j, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
!
CALL MPI_FILE_SEEK (iunsparsetcb, lrepmatw3,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_WRITE(iunsparsetcb, sparsecb_t, lsize, MPI_INTEGER4,MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'print_ibte', 'error in MPI_FILE_WRITE',1 )
! SEEK+WRITE = AT + collective (ALL)
!CALL MPI_FILE_WRITE_AT_ALL(iunepmatcb, lrepmatw, trans_probcb, lsize, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE, ierr)
CALL MPI_FILE_WRITE_AT(iunepmatcb, lrepmatw, trans_probcb, lsize, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_WRITE_AT(iunsparseqcb, lrepmatw3, sparsecb_q, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_WRITE_AT(iunsparsekcb, lrepmatw3, sparsecb_k, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_WRITE_AT(iunsparseicb, lrepmatw3, sparsecb_i, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_WRITE_AT(iunsparsejcb, lrepmatw3, sparsecb_j, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
CALL MPI_FILE_WRITE_AT(iunsparsetcb, lrepmatw3, sparsecb_t, lsize, MPI_INTEGER4, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('print_ibte', 'error in MPI_FILE_WRITE_AT',1)
!
! Offset for the next q iteration
lrepmatw5 = lrepmatw5 + INT( SUM( indcb(:) ), kind = MPI_OFFSET_KIND ) * 8_MPI_OFFSET_KIND
lrepmatw6 = lrepmatw6 + INT( SUM( indcb(:) ), kind = MPI_OFFSET_KIND ) * 4_MPI_OFFSET_KIND
lrepmatw5 = lrepmatw5 + INT(SUM(indcb(:)), kind = MPI_OFFSET_KIND) * 8_MPI_OFFSET_KIND
lrepmatw6 = lrepmatw6 + INT(SUM(indcb(:)), kind = MPI_OFFSET_KIND) * 4_MPI_OFFSET_KIND
!
ENDIF ! indcb
#endif
!
! Save to file restart information in formatted way for possible restart
IF (my_pool_id == 0) THEN
OPEN(unit=iunrestart,file='restart_ibte.fmt')
OPEN(UNIT=iunrestart,FILE='restart_ibte.fmt')
WRITE (iunrestart,*) iqq
WRITE (iunrestart,*) ind_tot
WRITE (iunrestart,*) ind_totcb
@ -609,15 +591,15 @@
etf_all(ibnd, ik+lower_bnd-1) = etf(ibndmin-1+ibnd, ikk)
ENDDO
ENDDO
CALL mp_sum ( vkk_all, world_comm )
CALL mp_sum ( etf_all, world_comm )
CALL mp_sum ( wkf_all, world_comm )
CALL mp_sum(vkk_all, world_comm)
CALL mp_sum(etf_all, world_comm)
CALL mp_sum(wkf_all, world_comm)
!
IF ( my_pool_id == 0 ) THEN
! Now write total number of q-point inside and k-velocity
!
OPEN(iufilibtev_sup,file='IBTEvel_sup.fmt', form='formatted')
OPEN(iufilibtev_sup,FILE='IBTEvel_sup.fmt', FORM='formatted')
WRITE(iufilibtev_sup,'(a)') '# Number of elements in hole and electrons '
WRITE(iufilibtev_sup,'(2i16)') ind_tot, ind_totcb
WRITE(iufilibtev_sup,'(a)') '# itemp ef0 efcb'
@ -625,9 +607,9 @@
WRITE(iufilibtev_sup,'(i8,2E22.12)') itemp, ef0(itemp), efcb(itemp)
ENDDO
WRITE(iufilibtev_sup,'(a)') '# ik ibnd velocity (x,y,z) eig weight '
DO ik = 1, nkqtotf/2
DO ibnd = 1, ibndmax-ibndmin+1
WRITE(iufilibtev_sup,'(i8,i6,5E22.12)') ik, ibnd, vkk_all(:,ibnd,ik), etf_all(ibnd, ik), wkf_all(ik)
DO ik=1, nkqtotf / 2
DO ibnd=1, ibndmax - ibndmin + 1
WRITE(iufilibtev_sup,'(i8,i6,5E22.12)') ik, ibnd, vkk_all(:, ibnd, ik), etf_all(ibnd, ik), wkf_all(ik)
ENDDO
ENDDO
CLOSE(iufilibtev_sup)
@ -640,36 +622,36 @@
carrier_density = 0.0
!
IF ( ncarrier < 0.0 ) THEN ! VB
DO ik = 1, nkf
DO ibnd = 1, ibndmax-ibndmin+1
DO ik=1, nkf
DO ibnd=1, ibndmax - ibndmin + 1
! This selects only valence bands for hole conduction
IF (etf_all (ibnd, ik+lower_bnd-1 ) < ef0(itemp) ) THEN
IF (etf_all(ibnd, ik + lower_bnd - 1 ) < ef0(itemp)) THEN
! energy at k (relative to Ef)
ekk = etf_all (ibnd, ik+lower_bnd-1 ) - ef0(itemp)
fnk = wgauss( -ekk / etemp, -99)
! The wkf(ikk) already include a factor 2
carrier_density = carrier_density + wkf_all(ik+lower_bnd-1 ) * (1.0d0 - fnk )
carrier_density = carrier_density + wkf_all(ik + lower_bnd - 1) * (1.0d0 - fnk)
ENDIF
ENDDO
ENDDO
CALL mp_sum( carrier_density, world_comm )
CALL MP_SUM(carrier_density, world_comm)
carrier_density = carrier_density * inv_cell * ( bohr2ang * ang2cm)**(-3)
WRITE(stdout,'(5x, 1f8.3, 1f12.4, 1E19.6)') etemp *ryd2ev/kelvin2eV, &
ef0(itemp)*ryd2ev, carrier_density
ELSE ! CB
DO ik = 1, nkf
DO ibnd = 1, ibndmax-ibndmin+1
DO ik=1, nkf
DO ibnd=1, ibndmax - ibndmin + 1
! This selects only valence bands for hole conduction
IF (etf_all (ibnd, ik+lower_bnd-1 ) > efcb(itemp) ) THEN
! energy at k (relative to Ef)
ekk = etf_all (ibnd, ik+lower_bnd-1 ) - efcb(itemp)
ekk = etf_all(ibnd, ik+lower_bnd-1) - efcb(itemp)
fnk = wgauss( -ekk / etemp, -99)
! The wkf(ikk) already include a factor 2
carrier_density = carrier_density + wkf_all(ik+lower_bnd-1 ) * fnk
carrier_density = carrier_density + wkf_all(ik + lower_bnd - 1) * fnk
ENDIF
ENDDO
ENDDO
CALL mp_sum( carrier_density, world_comm )
CALL MP_SUM(carrier_density, world_comm)
carrier_density = carrier_density * inv_cell * ( bohr2ang * ang2cm)**(-3)
WRITE(stdout,'(5x, 1f8.3, 1f12.4, 1E19.6)') etemp *ryd2ev/kelvin2eV, &
efcb(itemp)*ryd2ev, carrier_density

71
EPW/src/printing.f90
View File

@ -90,10 +90,10 @@
!! Temporary g-vertex for each pool
!
! find the bounds of k-dependent arrays in the parallel case in each pool
CALL fkbounds( nkqtotf/2, lower_bnd, upper_bnd )
CALL fkbounds(nkqtotf/2, lower_bnd, upper_bnd)
!
ALLOCATE ( epc (ibndmax-ibndmin+1, ibndmax-ibndmin+1, nmodes, nkqtotf/2) )
ALLOCATE ( epc_sym (ibndmax-ibndmin+1, ibndmax-ibndmin+1, nmodes) )
ALLOCATE (epc(ibndmax-ibndmin+1, ibndmax-ibndmin+1, nmodes, nkqtotf/2))
ALLOCATE (epc_sym(ibndmax-ibndmin+1, ibndmax-ibndmin+1, nmodes))
!
epc(:,:,:,:) = zero
epc_sym(:,:,:) = zero
@ -155,11 +155,11 @@
w_2 = etf (ibndmin-1+pbnd, ikk)
IF ( abs(w_2-w_1) < eps8 ) THEN
n = n + 1
g2 = g2 + epc(pbnd,jbnd,nu,ik+lower_bnd-1)*epc(pbnd,jbnd,nu,ik+lower_bnd-1)
g2 = g2 + epc(jbnd,pbnd,nu,ik+lower_bnd-1)*epc(jbnd,pbnd,nu,ik+lower_bnd-1)
ENDIF
ENDDO
g2 = g2 / float(n)
epc_sym (ibnd, jbnd, nu) = sqrt (g2)
epc_sym (jbnd, ibnd, nu) = sqrt (g2)
ENDDO
ENDDO
ENDDO
@ -176,11 +176,11 @@
w_2 = etf(ibndmin-1+pbnd, ikq)
IF ( abs(w_2-w_1) < eps8 ) then
n = n + 1
g2 = g2 + epc(ibnd,pbnd,nu,ik+lower_bnd-1)*epc(ibnd,pbnd,nu,ik+lower_bnd-1)
g2 = g2 + epc(pbnd,ibnd,nu,ik+lower_bnd-1)*epc(pbnd,ibnd,nu,ik+lower_bnd-1)
ENDIF
ENDDO
g2 = g2 / float(n)
epc_sym (ibnd, jbnd, nu) = sqrt (g2)
epc_sym (jbnd, ibnd, nu) = sqrt (g2)
ENDDO
ENDDO
ENDDO
@ -209,12 +209,12 @@
#endif
!
! Only master writes
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
WRITE(stdout, '(5x,a)') ' Electron-phonon vertex |g| (meV)'
!
WRITE(stdout, '(/5x,"iq = ",i7," coord.: ", 3f12.7)') iq, xqf (:, iq)
DO ik = 1, nkqtotf/2
DO ik=1, nkqtotf/2
!
ikk = 2 * ik - 1
ikq = ikk + 1
@ -223,25 +223,24 @@
WRITE(stdout, '(5x,a)') ' ibnd jbnd imode enk[eV] enk+q[eV] omega(q)[meV] |g|[meV]'
WRITE(stdout,'(5x,a)') repeat('-',78)
!
DO ibnd = 1, ibndmax-ibndmin+1
DO ibnd=1, ibndmax-ibndmin+1
ekk = etf_all (ibndmin-1+ibnd, ikk)
DO jbnd = 1, ibndmax-ibndmin+1
DO jbnd=1, ibndmax-ibndmin+1
ekq = etf_all (ibndmin-1+jbnd, ikq)
DO nu = 1, nmodes
DO nu=1, nmodes
WRITE(stdout,'(3i9,3f12.4,1e20.10)') ibndmin-1+ibnd, ibndmin-1+jbnd, nu, ryd2ev * ekk, ryd2ev * ekq, &
ryd2mev * wf(nu,iq), ryd2mev * epc(ibnd,jbnd,nu,ik)
ENDDO
ENDDO
!
!
ENDDO
WRITE(stdout,'(5x,a/)') repeat('-',78)
!
ENDDO
ENDIF ! master node
!
DEALLOCATE ( epc )
DEALLOCATE ( epc_sym )
DEALLOCATE (epc)
DEALLOCATE (epc_sym)
!
END SUBROUTINE print_gkk
!
@ -324,8 +323,6 @@
!! Symmetry matrix in cartesian coordinate
REAL(KIND=DP) :: ekk
!! Energy relative to Fermi level: $$\varepsilon_{n\mathbf{k}}-\varepsilon_F$$
REAL(KIND=DP) :: dfnk
!! Derivative Fermi distribution $$-df_{nk}/dE_{nk}$$
REAL(KIND=DP) :: carrier_density
!! Carrier density [nb of carrier per unit cell]
REAL(KIND=DP) :: fnk
@ -649,8 +646,6 @@
!! Electrical conductivity
REAL(KIND=DP) :: ekk
!! Energy relative to Fermi level: $$\varepsilon_{n\mathbf{k}}-\varepsilon_F$$
REAL(KIND=DP) :: dfnk
!! Derivative Fermi distribution $$-df_{nk}/dE_{nk}$$
REAL(KIND=DP) :: carrier_density
!! Carrier density [nb of carrier per unit cell]
REAL(KIND=DP) :: fnk
@ -805,13 +800,6 @@
ENDDO
Fi_check(:,itemp) = Fi_check(:,itemp) + F_SERTA(:, ibnd, ik, itemp) * sfac / (nkf1*nkf2*nkf3)
!
! energy at k (relative to Ef)
!ekk = etf_all (ibnd, ik) - ef0(itemp)
!
! derivative Fermi distribution
! (-df_nk/dE_nk) = (f_nk)*(1-f_nk)/ (k_B T)
!dfnk = w0gauss( ekk / etemp, -99 ) / etemp
!
! electrical conductivity
Sigma(:,itemp) = Sigma(:,itemp) + tdf_sigma(:)
!
@ -957,8 +945,6 @@
!! Symmetry matrix in cartesian coordinate
REAL(KIND=DP) :: ekk
!! Energy relative to Fermi level: $$\varepsilon_{n\mathbf{k}}-\varepsilon_F$$
REAL(KIND=DP) :: dfnk
!! Derivative Fermi distribution $$-df_{nk}/dE_{nk}$$
REAL(KIND=DP) :: carrier_density
!! Carrier density [nb of carrier per unit cell]
REAL(KIND=DP) :: fnk
@ -1044,13 +1030,6 @@
ENDIF ! BZ
ENDDO ! ikb
!
! energy at k (relative to Ef)
!ekk = etf_all (ibnd, ik) - ef0(itemp)
!
! derivative Fermi distribution
! (-df_nk/dE_nk) = (f_nk)*(1-f_nk)/ (k_B T)
!dfnk = w0gauss( ekk / etemp, -99 ) / etemp
!
! electrical conductivity
Sigma(:,itemp) = Sigma(:,itemp) + tdf_sigma(:)
!
@ -1156,13 +1135,6 @@
ENDIF ! BZ
ENDDO ! ikb
!
! energy at k (relative to Ef)
!ekk = etf_all (ibnd, ik) - ef0(itemp)
!
! derivative Fermi distribution
! (-df_nk/dE_nk) = (f_nk)*(1-f_nk)/ (k_B T)
!dfnk = w0gauss( ekk / etemp, -99 ) / etemp
!
! electrical conductivity
Sigma(:,itemp) = Sigma(:,itemp) + tdf_sigma(:)
!
@ -1234,11 +1206,11 @@
!-----------------------------------------------------------------------
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE cell_base, ONLY : at, omega, bg
USE epwcom, ONLY : int_mob, ncarrier, nstemp, &
USE cell_base, ONLY : omega
USE epwcom, ONLY : ncarrier, nstemp, &
nkf1, nkf2, nkf3
USE elph2, ONLY : nkf, ibndmax, ibndmin, nkqtotf
USE transportcom, ONLY : lower_bnd, transp_temp
USE transportcom, ONLY : transp_temp
USE constants_epw, ONLY : zero, two, pi, kelvin2eV, ryd2ev, eps10, &
electron_SI, bohr2ang, ang2cm, hbarJ
USE noncollin_module, ONLY : noncolin
@ -1282,8 +1254,6 @@
!! Electrical conductivity
REAL(KIND=DP) :: ekk
!! Energy relative to Fermi level: $$\varepsilon_{n\mathbf{k}}-\varepsilon_F$$
REAL(KIND=DP) :: dfnk
!! Derivative Fermi distribution $$-df_{nk}/dE_{nk}$$
REAL(KIND=DP) :: carrier_density
!! Carrier density [nb of carrier per unit cell]
REAL(KIND=DP) :: fnk
@ -1346,13 +1316,6 @@
ENDDO
Fi_check(:,itemp) = Fi_check(:,itemp) + F_out(:, ibnd, ik, itemp) * sfac / (nkf1*nkf2*nkf3)
!
! energy at k (relative to Ef)
!ekk = etf_all (ibnd, ik) - ef0(itemp)
!
! derivative Fermi distribution
! (-df_nk/dE_nk) = (f_nk)*(1-f_nk)/ (k_B T)
!dfnk = w0gauss( ekk / etemp, -99 ) / etemp
!
! electrical conductivity
!Sigma(:,itemp) = Sigma(:,itemp) + dfnk * tdf_sigma(:)
Sigma(:,itemp) = Sigma(:,itemp) + tdf_sigma(:)

417
EPW/src/pw2wan90epw.f90
View File

@ -99,16 +99,37 @@
!-----------------------------------------------------------------------
!! Routine to de-allocate Wannier related matrices.
!
USE wannierEPW
USE wannierEPW, ONLY : atcart, atsym, kpb, g_kpb, center_w, alpha_w, &
l_w, mr_w, r_w, zaxis, xaxis, excluded_band, &
m_mat, u_mat, u_mat_opt, a_mat, eigval, &
lwindow, gf, ig_, zerophase, wann_centers, &
wann_spreads
!
IMPLICIT NONE
!
IF (ALLOCATED(m_mat) ) DEALLOCATE(m_mat)
IF (ALLOCATED(u_mat) ) DEALLOCATE(u_mat)
IF (ALLOCATED(u_mat_opt) ) DEALLOCATE(u_mat_opt)
IF (ALLOCATED(a_mat) ) DEALLOCATE(a_mat)
IF (ALLOCATED(eigval) ) DEALLOCATE(eigval)
IF (ALLOCATED(lwindow) ) DEALLOCATE(lwindow)
DEALLOCATE (atcart)
DEALLOCATE (atsym)
DEALLOCATE (kpb)
DEALLOCATE (g_kpb)
DEALLOCATE (center_w)
DEALLOCATE (alpha_w)
DEALLOCATE (l_w)
DEALLOCATE (mr_w)
DEALLOCATE (r_w)
DEALLOCATE (zaxis)
DEALLOCATE (xaxis)
DEALLOCATE (excluded_band)
DEALLOCATE (m_mat)
DEALLOCATE (u_mat)
DEALLOCATE (u_mat_opt)
DEALLOCATE (a_mat)
DEALLOCATE (eigval)
DEALLOCATE (lwindow)
DEALLOCATE (gf)
DEALLOCATE (ig_)
DEALLOCATE (zerophase)
DEALLOCATE (wann_centers)
DEALLOCATE (wann_spreads)
!
END SUBROUTINE lib_dealloc
!
@ -176,7 +197,7 @@
!! Counter on polarizations
INTEGER :: idum
!! Dummy index for reading nnkp file
INTEGER, ALLOCATABLE :: ig_check(:,:)
INTEGER, ALLOCATABLE :: ig_check(:, :)
!! Temporary index on G_k+b vectors
REAL(DP) :: xnorm
!! Norm of xaxis
@ -266,21 +287,28 @@
! exclude_bands exclude_bands
! atcart atoms_cart
! atsym atom_symbols
ALLOCATE( atcart(3,nat), atsym(nat) )
ALLOCATE( kpb(iknum,num_nnmax), g_kpb(3,iknum,num_nnmax) )
ALLOCATE( center_w(3,nbnd), alpha_w(nbnd), l_w(nbnd), &
mr_w(nbnd), r_w(nbnd), zaxis(3,nbnd), xaxis(3,nbnd) )
ALLOCATE( excluded_band(nbnd) )
!
ALLOCATE (atcart(3, nat))
ALLOCATE (atsym(nat))
ALLOCATE (kpb(iknum, num_nnmax))
ALLOCATE (g_kpb(3, iknum, num_nnmax))
ALLOCATE (center_w(3, nbnd))
ALLOCATE (alpha_w(nbnd))
ALLOCATE (l_w(nbnd))
ALLOCATE (mr_w(nbnd))
ALLOCATE (r_w(nbnd))
ALLOCATE (zaxis(3, nbnd))
ALLOCATE (xaxis(3, nbnd))
ALLOCATE (excluded_band(nbnd))
!
! real lattice (Cartesians, Angstrom)
rlatt(:,:) = transpose(at(:,:)) * alat * bohr
rlatt(:, :) = TRANSPOSE(at(:, :)) * alat * bohr
! reciprocal lattice (Cartesians, Angstrom)
glatt(:,:) = transpose(bg(:,:)) * tpi / ( alat * bohr )
glatt(:, :) = TRANSPOSE(bg(:, :)) * tpi / ( alat * bohr )
! atom coordinates in Cartesian coords and Angstrom units
atcart(:,:) = tau(:,:) * bohr * alat
atcart(:, :) = tau(:, :) * bohr * alat
! atom symbols
DO ia = 1, nat
DO ia=1, nat
type = ityp(ia)
atsym(ia) = atm(type)
ENDDO
@ -335,7 +363,7 @@
indexb = exclude_bands(ibnd)
IF (indexb>nbnd .OR. indexb<0) THEN
CALL errore('setup_nnkp',' wrong excluded band index ', 1)
ELSEIF (indexb.eq.0) THEN
ELSEIF (indexb == 0) THEN
EXIT band_loop
ELSE
nexband = nexband + 1
@ -347,9 +375,9 @@
WRITE(stdout,'(" - Number of total bands is (",i3,")")') nbnd
WRITE(stdout,'(" - Number of excluded bands is (",i3,")")') nexband
WRITE(stdout,'(" - Number of wannier functions is (",i3,")")') n_wannier
IF ((nexband .gt. 0) .AND. (nbndskip .ne. nexband)) THEN
IF ((nexband > 0) .AND. (nbndskip .ne. nexband)) THEN
WRITE(stdout,'(/5x,"Warning: check if nbndskip = ", i3 " makes sense since ", i3, &
" bands are excluded from wannier projection")') nbndskip, nexband
&" bands are excluded from wannier projection")') nbndskip, nexband
ENDIF
!
IF ( (nbnd-nexband) .ne. num_bands ) &
@ -358,29 +386,29 @@
! Now we read the .nnkp file
!
IF (meta_ionode) THEN ! Read nnkp file on ionode only
INQUIRE(file=trim(seedname2)//".nnkp",exist=have_nnkp)
IF (.not. have_nnkp) THEN
INQUIRE(FILE=trim(seedname2)//".nnkp",exist=have_nnkp)
IF ( .NOT. have_nnkp) THEN
CALL errore( 'pw2wannier90', 'Could not find the file '&
&//trim(seedname2)//'.nnkp', 1 )
ENDIF
iun_nnkp = find_free_unit()
OPEN(unit=iun_nnkp, file=trim(seedname2)//".nnkp",form='formatted')
OPEN(UNIT=iun_nnkp, FILE=trim(seedname2)//".nnkp",FORM='formatted')
ENDIF
!
IF (meta_ionode) THEN ! read from ionode only
IF (noncolin) THEN
CALL scan_file_to(iun_nnkp,'spinor_projections',found)
IF (.not. found) THEN
IF ( .NOT. found) THEN
!try old style projections
CALL scan_file_to(iun_nnkp,'projections',found)
IF (.not. found) THEN
IF ( .NOT. found) THEN
CALL errore( 'pw2wannier90', 'Could not find projections block in '&
&//trim(seedname2)//'.nnkp', 1 )
ENDIF
ENDIF
ELSE
CALL scan_file_to(iun_nnkp,'projections',found)
IF (.not. found) THEN
IF ( .NOT. found) THEN
CALL errore( 'pw2wannier90', 'Could not find projections block in '&
&//trim(seedname2)//'.nnkp', 1 )
ENDIF
@ -389,11 +417,13 @@
ENDIF
CALL mp_bcast(n_proj, meta_ionode_id, world_comm)
!
ALLOCATE( gf(npwx,n_proj), csph(16,n_proj) )
IF (noncolin) ALLOCATE( spin_eig(n_proj), spin_qaxis(3,n_proj) )
ALLOCATE (gf(npwx, n_proj))
ALLOCATE (csph(16, n_proj))
IF (noncolin) ALLOCATE (spin_eig(n_proj))
IF (noncolin) ALLOCATE (spin_qaxis(3, n_proj))
!
IF (meta_ionode) THEN ! read from ionode only
DO iw = 1, n_proj
DO iw=1, n_proj
READ(iun_nnkp,*) (center_w(i,iw), i=1,3), l_w(iw), mr_w(iw), r_w(iw)
READ(iun_nnkp,*) (zaxis(i,iw), i=1,3), (xaxis(i,iw), i=1,3), alpha_w(iw)
xnorm = sqrt( xaxis(1,iw)*xaxis(1,iw) + xaxis(2,iw)*xaxis(2,iw) + &
@ -438,7 +468,7 @@
!
IF (meta_ionode) THEN ! read from ionode only
CALL scan_file_to(iun_nnkp,'nnkpts',found)
IF (.not.found) THEN
IF ( .NOT. found) THEN
CALL errore( 'pw2wannier90epw', 'Could not find nnkpts block in '&
&//trim(seedname2)//'.nnkp', 1 )
ENDIF
@ -451,8 +481,9 @@
!
nnbx = 0
nnbx = max( nnbx, nnb )
ALLOCATE( ig_(iknum,nnbx), ig_check(iknum,nnbx) )
ALLOCATE( zerophase(iknum,nnb) )
ALLOCATE (ig_(iknum, nnbx))
ALLOCATE (ig_check(iknum, nnbx))
ALLOCATE (zerophase(iknum, nnb))
zerophase = .false.
!
! Read data about neighbours
@ -473,9 +504,9 @@
!
DO ik =1, iknum
DO ib = 1, nnb
IF ( (g_kpb(1,ik,ib).eq.0) .AND. &
(g_kpb(2,ik,ib).eq.0) .AND. &
(g_kpb(3,ik,ib).eq.0) ) zerophase(ik,ib) = .true.
IF ( (g_kpb(1,ik,ib) == 0) .AND. &
(g_kpb(2,ik,ib) == 0) .AND. &
(g_kpb(3,ik,ib) == 0) ) zerophase(ik,ib) = .true.
g_(:) = REAL( g_kpb(:,ik,ib) )
CALL cryst_to_cart (1, g_, bg, 1)
gg_ = g_(1)*g_(1) + g_(2)*g_(2) + g_(3)*g_(3)
@ -499,14 +530,14 @@
' g_kpb vector is not in the list of Gs', 100*ik+ib )
ENDDO
ENDDO
DEALLOCATE(ig_check)
DEALLOCATE (ig_check)
!
WRITE(stdout,*) ' - All neighbours are found '
WRITE(stdout,*)
!
IF (meta_ionode) THEN
CALL scan_file_to(iun_nnkp,'exclude_bands',found)
IF (.not.found) THEN
IF ( .NOT. found) THEN
CALL errore( 'pw2wannier90epw', 'Could not find exclude_bands block in '&
&//trim(seedname2)//'.nnkp', 1 )
ENDIF
@ -601,11 +632,11 @@
CHARACTER (len=80) :: line
!! Temporary character
!
ALLOCATE(u_mat(n_wannier,n_wannier,iknum))
ALLOCATE(u_mat_opt(num_bands,n_wannier,iknum))
ALLOCATE(lwindow(num_bands,iknum))
ALLOCATE(wann_centers(3,n_wannier))
ALLOCATE(wann_spreads(n_wannier))
ALLOCATE (u_mat(n_wannier, n_wannier, iknum))
ALLOCATE (u_mat_opt(num_bands, n_wannier, iknum))
ALLOCATE (lwindow(num_bands, iknum))
ALLOCATE (wann_centers(3, n_wannier))
ALLOCATE (wann_spreads(n_wannier))
!
u_mat = czero
u_mat_opt = czero
@ -615,8 +646,8 @@
IF (eig_read) THEN
WRITE (stdout,'(5x,a,i5,a,i5,a)') "Reading external electronic eigenvalues (", &
nbnd, ",", nkstot,")"
tempfile=trim(prefix)//'.eig'
OPEN(iuqpeig, file=tempfile, form='formatted', action='read', iostat=ios)
tempFILE=trim(prefix)//'.eig'
OPEN(iuqpeig, FILE=tempfile, FORM='formatted', action='read', iostat=ios)
IF (ios /= 0) CALL errore('run_wannier','error opening' // tempfile, 1)
READ(iuqpeig,'(a)') line
DO ik = 1, nkstot
@ -629,8 +660,8 @@
ENDIF
! SP : This file is not used for now. Only required to build the UNK file
! tempfile=trim(prefix)//'.mmn'
! OPEN(iummn, file=tempfile, iostat=ios, form='unformatted')
! tempFILE=trim(prefix)//'.mmn'
! OPEN(iummn, FILE=tempfile, iostat=ios, FORM='unformatted')
! WRITE(iummn) m_mat
! CLOSE(iummn)
@ -679,7 +710,8 @@
!!
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE klist, ONLY : xk, nks, igk_k
USE klist, ONLY : nks, igk_k
USE klist_epw, ONLY : xk_loc
USE wvfct, ONLY : nbnd, npw, npwx, g2kin
USE wavefunctions, ONLY : evc
USE gvect, ONLY : g, ngm
@ -752,10 +784,10 @@
! IF (any_uspp .and. noncolin) CALL errore('pw2wan90epw',&
! 'noncolin calculation not implemented with USP',1)
!
ALLOCATE( a_mat(num_bands,n_wannier,iknum) )
ALLOCATE( sgf(npwx,n_proj) )
ALLOCATE( gf_spinor(2*npwx,n_proj) )
ALLOCATE( sgf_spinor(2*npwx,n_proj) )
ALLOCATE ( a_mat(num_bands,n_wannier,iknum) )
ALLOCATE ( sgf(npwx,n_proj) )
ALLOCATE ( gf_spinor(2*npwx,n_proj) )
ALLOCATE ( sgf_spinor(2*npwx,n_proj) )
!
! initialize
a_mat = czero
@ -775,19 +807,19 @@
WRITE(stdout,'(6x,a,i5,a,i4,a)') 'k points = ',iknum, ' in ', npool, ' pools'
#endif
!
DO ik = 1, nks
DO ik=1, nks
!
! returns in-pool index nkq and absolute index nkq_abs of xk
CALL ktokpmq( xk(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
CALL ktokpmq(xk_loc(:,ik), zero_vect, +1, ipool, nkq, nkq_abs)
ik_g = nkq_abs
!
WRITE(stdout,'(5x,i8, " of ", i4,a)') ik , nks, ' on ionode'
CALL flush(stdout)
CALL FLUSH(stdout)
! SP: Replaced by our wrapper to deal with parallel
CALL readwfc( my_pool_id+1, ik, evc )
!
! sorts k+G vectors in order of increasing magnitude, up to ecut
CALL gk_sort( xk(1,ik), ngm, g, gcutw, npw, igk_k(1,ik), g2kin )
CALL gk_sort( xk_loc(1,ik), ngm, g, gcutw, npw, igk_k(1,ik), g2kin )
!
CALL generate_guiding_functions( ik ) ! they are called gf(npw,n_proj)
@ -801,7 +833,7 @@
! USPP
!
IF (any_uspp) THEN
CALL init_us_2( npw, igk_k(1,ik), xk(1,ik), vkb )
CALL init_us_2( npw, igk_k(1,ik), xk_loc(1,ik), vkb )
! below we compute the product of beta functions with trial func.
IF (noncolin) THEN
CALL calbec( npw, vkb, gf_spinor, becp, n_proj )
@ -912,10 +944,10 @@
ENDIF
ENDDO ! k-points
!
DEALLOCATE(sgf)
DEALLOCATE(csph)
DEALLOCATE(gf_spinor)
DEALLOCATE(sgf_spinor)
DEALLOCATE (sgf)
DEALLOCATE (csph)
DEALLOCATE (gf_spinor)
DEALLOCATE (sgf_spinor)
!
IF (any_uspp) CALL deallocate_bec_type( becp )
!
@ -1013,7 +1045,8 @@
USE units_lr, ONLY : lrwfc, iuwfc
USE fft_base, ONLY : dffts
USE fft_interfaces, ONLY : fwfft, invfft
USE klist, ONLY : nkstot, xk, nks, igk_k
USE klist, ONLY : nkstot, nks, igk_k
USE klist_epw, ONLY : xk_all, xk_loc
USE gvect, ONLY : g, ngm, gstart
USE gvecw, ONLY : gcutw
USE cell_base, ONLY : omega, tpiba, bg
@ -1090,8 +1123,6 @@
!! Square of dxk
REAL(DP), ALLOCATABLE :: ylm(:,:)
!!
REAL(DP) :: xktot(3,nkstot)
!! Coordinates of k-points
REAL(DP) :: zero_vect(3)
!! Temporary zero vector
REAL(DP) :: arg
@ -1132,17 +1163,17 @@
! IF (any_uspp .and. noncolin) CALL errore('pw2wan90epw',&
! 'noncolin calculation not implimented with USP',1)
!
ALLOCATE( phase(dffts%nnr) )
ALLOCATE( igkq(npwx) )
ALLOCATE( evcq(npol*npwx,nbnd) )
ALLOCATE ( phase(dffts%nnr) )
ALLOCATE ( igkq(npwx) )
ALLOCATE ( evcq(npol*npwx,nbnd) )
!
IF (noncolin) THEN
ALLOCATE( aux_nc(npwx,npol) )
ALLOCATE ( aux_nc(npwx,npol) )
ELSE
ALLOCATE( aux(npwx) )
ALLOCATE ( aux(npwx) )
ENDIF
!
ALLOCATE( m_mat(num_bands,num_bands,nnb,iknum) )
ALLOCATE ( m_mat(num_bands,num_bands,nnb,iknum) )
!
! close all the wfc files to allow access for each pool to all wfs
CLOSE(unit = iuwfc, status = 'keep')
@ -1150,16 +1181,6 @@
WRITE(stdout,*)
WRITE(stdout,'(5x,a)') 'MMN'
!
! Get all the k-vector coords to each pool via xktot
!
xktot = zero
IF (meta_ionode) THEN
DO ik = 1, nkstot
xktot(:,ik) = xk(:,ik)
ENDDO
ENDIF
CALL mp_sum(xktot, inter_pool_comm)
!
zero_vect = zero
m_mat = czero
!
@ -1169,17 +1190,17 @@
CALL init_us_1
CALL allocate_bec_type( nkb, nbnd, becp )
IF (noncolin) THEN
ALLOCATE( becp2_nc(nkb,2,nbnd) )
ALLOCATE ( becp2_nc(nkb,2,nbnd) )
ELSE
ALLOCATE( becp2(nkb,nbnd) )
ALLOCATE ( becp2(nkb,nbnd) )
ENDIF
!
! qb is FT of Q(r)
!
nbt = nnb * iknum
!
ALLOCATE( qg(nbt) )
ALLOCATE( dxk(3,nbt) )
ALLOCATE ( qg(nbt) )
ALLOCATE ( dxk(3,nbt) )
!
ind = 0
DO ik = 1, iknum ! loop over k-points
@ -1190,16 +1211,16 @@
g_(:) = REAL( g_kpb(:,ik,ib) )
! bring g_ to cartesian
CALL cryst_to_cart( 1, g_, bg, 1 )
dxk(:,ind) = xktot(:,ikp) + g_(:) - xktot(:,ik)
dxk(:,ind) = xk_all(:,ikp) + g_(:) - xk_all(:,ik)
qg(ind) = dxk(1,ind) * dxk(1,ind) + &
dxk(2,ind) * dxk(2,ind) + &
dxk(3,ind) * dxk(3,ind)
ENDDO
ENDDO
!
ALLOCATE( ylm(nbt,lmaxq*lmaxq), qgm(nbt) )
ALLOCATE( qb(nkb, nkb, ntyp, nbt) )
ALLOCATE( qq_so(nhm, nhm, 4, ntyp) )
ALLOCATE ( ylm(nbt,lmaxq*lmaxq), qgm(nbt) )
ALLOCATE ( qb(nkb, nkb, ntyp, nbt) )
ALLOCATE ( qq_so(nhm, nhm, 4, ntyp) )
!
CALL ylmr2(lmaxq*lmaxq, nbt, dxk, qg, ylm)
qg(:) = sqrt(qg(:)) * tpiba
@ -1215,25 +1236,25 @@
ENDIF
ENDDO
!
DEALLOCATE( qg, qgm, ylm )
DEALLOCATE ( qg, qgm, ylm )
!
ENDIF
!
ALLOCATE( Mkb(nbnd,nbnd) )
ALLOCATE ( Mkb(nbnd,nbnd) )
!
#if defined(__MPI)
WRITE(stdout,'(6x,a,i5,a,i4,a)') 'k points = ',iknum, ' in ', npool, ' pools'
#endif
!
! returns in-pool index nkq and absolute index nkq_abs of first k-point in this pool
CALL ktokpmq( xk(:,1), zero_vect, +1, ipool, nkq, nkq_abs )
CALL ktokpmq( xk_loc(:,1), zero_vect, +1, ipool, nkq, nkq_abs )
ind0 = (nkq_abs - 1) * nnb
!
ind = ind0
DO ik = 1, nks
!
! returns in-pool index nkq and absolute index nkq_abs of xk
CALL ktokpmq( xk(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
CALL ktokpmq( xk_loc(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
ik_g = nkq_abs
!
WRITE(stdout,'(5x,i8, " of ", i4,a)') ik , nks, ' on ionode'
@ -1243,12 +1264,12 @@
CALL readwfc( my_pool_id+1, ik, evc )
!
! sorts k+G vectors in order of increasing magnitude, up to ecut
CALL gk_sort( xk(1,ik), ngm, g, gcutw, npw, igk_k(1,ik), g2kin )
CALL gk_sort( xk_loc(1,ik), ngm, g, gcutw, npw, igk_k(1,ik), g2kin )
!
! USPP
!
IF (any_uspp) THEN
CALL init_us_2( npw, igk_k(1,ik), xk(1,ik), vkb )
CALL init_us_2( npw, igk_k(1,ik), xk_loc(1,ik), vkb )
! below we compute the product of beta functions with |psi>
CALL calbec( npw, vkb, evc, becp )
ENDIF
@ -1259,15 +1280,15 @@
!
ikp = kpb(ik_g,ib)
!
CALL ktokpmq( xktot(:,ikp), zero_vect, +1, ipool, nkq, nkq_abs )
CALL ktokpmq( xk_all(:,ikp), zero_vect, +1, ipool, nkq, nkq_abs )
!
! read wfc at k+b
CALL readwfc( ipool, nkq, evcq )
!
CALL gk_sort( xktot(1,ikp), ngm, g, gcutw, npwq, igkq, g2kin )
CALL gk_sort( xk_all(1,ikp), ngm, g, gcutw, npwq, igkq, g2kin )
!
! compute the phase
IF (.not.zerophase(ik_g,ib)) THEN
IF (.NOT. zerophase(ik_g,ib)) THEN
phase(:) = czero
IF ( ig_(ik_g,ib)>0 ) phase( dffts%nl(ig_(ik_g,ib)) ) = cone
CALL invfft('Wave', phase, dffts)
@ -1276,7 +1297,7 @@
! USPP
!
IF (any_uspp) THEN
CALL init_us_2( npwq, igkq, xktot(1,ikp), vkb )
CALL init_us_2( npwq, igkq, xk_all(1,ikp), vkb )
! below we compute the product of beta functions with |psi>
IF (noncolin) THEN
CALL calbec( npwq, vkb, evcq, becp2_nc )
@ -1356,7 +1377,7 @@
istart = (ipol - 1) * npwx + 1
iend = istart + npw - 1
psic_nc( dffts%nl(igk_k(1:npw,ik)), ipol ) = evc(istart:iend,m)
IF (.not.zerophase(ik_g,ib)) THEN
IF (.NOT. zerophase(ik_g,ib)) THEN
CALL invfft('Wave', psic_nc(:,ipol), dffts)
psic_nc( 1:dffts%nnr, ipol) = psic_nc( 1:dffts%nnr, ipol ) * &
phase(1:dffts%nnr)
@ -1367,7 +1388,7 @@
ELSE
psic(:) = czero
psic( dffts%nl(igk_k(1:npw,ik)) ) = evc(1:npw,m)
IF (.not.zerophase(ik_g,ib)) THEN
IF ( .NOT. zerophase(ik_g,ib)) THEN
CALL invfft('Wave', psic, dffts)
psic(1:dffts%nnr) = psic(1:dffts%nnr) * phase(1:dffts%nnr)
CALL fwfft('Wave', psic, dffts)
@ -1457,32 +1478,32 @@
ENDDO
!
CLOSE(iummn)
DEALLOCATE( m_mat_tmp )
DEALLOCATE ( m_mat_tmp )
ENDIF
ENDIF
!
DEALLOCATE( Mkb, phase, evcq, igkq )
DEALLOCATE ( Mkb, phase, evcq, igkq )
IF (noncolin) THEN
DEALLOCATE(aux_nc)
DEALLOCATE (aux_nc)
ELSE
DEALLOCATE(aux)
DEALLOCATE (aux)
ENDIF
!
IF (any_uspp) THEN
DEALLOCATE(dxk)
DEALLOCATE(qb)
DEALLOCATE(qq_so)
DEALLOCATE (dxk)
DEALLOCATE (qb)
DEALLOCATE (qq_so)
CALL deallocate_bec_type( becp )
IF (noncolin) THEN
DEALLOCATE(becp2_nc)
DEALLOCATE (becp2_nc)
ELSE
DEALLOCATE(becp2)
DEALLOCATE (becp2)
ENDIF
ENDIF
!
WRITE(stdout,'(5x,a)') 'MMN calculated'
!
! reopen wfc here, leaving unit=20 in the same state
! reopen wfc here, leaving UNIT=20 in the same state
iuwfc = 20
CALL diropn(iuwfc,'wfc',lrwfc,exst)
!
@ -1507,7 +1528,9 @@
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE mp, ONLY : mp_sum
USE klist, ONLY : xk, nks, igk_k
USE mp_global, ONLY : my_pool_id
USE klist, ONLY : nks, igk_k
USE klist_epw, ONLY : xk_loc
USE wvfct, ONLY : nbnd, npw, npwx, g2kin
USE gvecw, ONLY : gcutw
USE wavefunctions, ONLY : evc
@ -1544,10 +1567,10 @@
!
any_uspp = ANY( upf(:)%tvanp )
!
IF (any_uspp .and. noncolin) CALL errore('pw2wan90epw',&
'noncolin calculation not implimented with USP',1)
IF ( any_uspp ) CALL errore('pw2wan90epw',&
'dipole matrix calculation not implimented with USP - set vme=.true.',1)
!
ALLOCATE( dmec(3,nbnd,nbnd,nks) )
ALLOCATE (dmec(3, nbnd, nbnd, nks))
!
! initialize
dmec = czero
@ -1566,16 +1589,17 @@
DO ik = 1, nks
!
! read wfc for the given kpt
CALL davcio( evc, lrwfc, iuwfc, ik, -1 )
CALL readwfc(my_pool_id + 1, ik, evc)
!CALL davcio( evc, lrwfc, iuwfc, ik, -1 )
!
! setup k+G grids for each kpt
CALL gk_sort( xk(:,ik), ngm, g, gcutw, npw, igk_k(:,ik), g2kin )
CALL gk_sort( xk_loc(:,ik), ngm, g, gcutw, npw, igk_k(:,ik), g2kin )
!
dipole_aux = czero
DO jbnd = 1, nbnd
DO ibnd = 1, nbnd
!
IF ( ibnd .eq. jbnd ) CYCLE
IF ( ibnd == jbnd ) CYCLE
!
! taken from PP/epsilon.f90 subroutine dipole_calc
DO ig = 1, npw
@ -1611,12 +1635,12 @@
ENDIF
!
dipole_aux(:,ibnd,ibnd) = dipole_aux(:,ibnd,ibnd) + &
( g(:,igk_k(ig,ik)) + xk(:,ik) ) * caux
( g(:,igk_k(ig,ik)) + xk_loc(:,ik) ) * caux
!
ENDDO
ENDDO
! need to divide by 2pi/a to fix the units
dmec(:,:,:,ik) = dipole_aux(:,:,:) * tpiba
dmec(:, :, :, ik) = dipole_aux(:, :, :) * tpiba
!
ENDDO ! k-points
!
@ -1645,7 +1669,7 @@
! 07/2010 Fixed the rotation for ndimwin when lower bands are not included
!
USE kinds, ONLY : DP
USE io_epw, ONLY : iuukk
USE io_epw, ONLY : iunukk
USE wvfct, ONLY : nbnd
USE wannierEPW, ONLY : n_wannier, iknum, u_mat, u_mat_opt, lwindow, &
excluded_band, num_bands, wann_centers
@ -1698,20 +1722,20 @@
! get the final rotation matrix, which is the product of the optimal
! subspace and the rotation among the n_wannier wavefunctions
!
ALLOCATE( u_kc_tmp(num_bands, n_wannier, iknum) )
ALLOCATE ( u_kc_tmp(num_bands, n_wannier, iknum) )
u_kc_tmp(:,:,:) = czero
!
DO ik = 1, iknum
DO ik=1, iknum
!
u_kc_tmp(1:ndimwin(ik),1:n_wannier,ik) = &
matmul( u_mat_opt(1:ndimwin(ik),:,ik), u_mat(:,1:n_wannier,ik) )
MATMUL( u_mat_opt(1:ndimwin(ik),:,ik), u_mat(:,1:n_wannier,ik) )
!
ENDDO
!
ALLOCATE( u_kc(nbnd, n_wannier, iknum) )
u_kc(:,:,:) = czero
ALLOCATE(u_kc(nbnd, n_wannier, iknum))
u_kc(:, :, :) = czero
!
OPEN(unit = iuukk, file = filukk, form = 'formatted')
OPEN(unit=iunukk, file=filukk, form='formatted')
! u_kc(1:num_bands,:,:) = u_kc_tmp(1:num_bands,:,:)
! u_kc(num_bands+1:nbnd,:,:) = czero
DO ik = 1, iknum
@ -1726,13 +1750,13 @@
!
DO ibnd = 1, nbnd
DO iw = 1, n_wannier
WRITE(iuukk,*) u_kc(ibnd,iw,ik)
WRITE(iunukk,*) u_kc(ibnd,iw,ik)
ENDDO
ENDDO
ENDDO
!
! needs also lwindow when disentanglement is used
ALLOCATE( lwindow_tmp(nbnd, iknum) )
ALLOCATE ( lwindow_tmp(nbnd, iknum) )
lwindow_tmp(:,:) = .false.
!
DO ik = 1, iknum
@ -1744,26 +1768,26 @@
ENDDO
!
DO ibnd = 1, nbnd
WRITE(iuukk,*) lwindow_tmp(ibnd,ik)
WRITE(iunukk,*) lwindow_tmp(ibnd,ik)
ENDDO
ENDDO
!
DO ibnd = 1, nbnd
WRITE(iuukk,*) excluded_band(ibnd)
WRITE(iunukk,*) excluded_band(ibnd)
ENDDO
!
! Now write the Wannier centers to files
DO iw = 1, n_wannier
! SP : Need more precision other WS are not determined properly.
!WRITE (iuukk,'(3f12.8)') wann_centers(:,iw)/alat/bohr
WRITE (iuukk,'(3E22.12)') wann_centers(:,iw)/alat/bohr
WRITE (iunukk,'(3E22.12)') wann_centers(:,iw)/alat/bohr
ENDDO
!
CLOSE(iuukk)
CLOSE(iunukk)
!
DEALLOCATE(u_kc_tmp)
DEALLOCATE(u_kc)
DEALLOCATE(lwindow_tmp)
DEALLOCATE (u_kc_tmp)
DEALLOCATE (u_kc)
DEALLOCATE (lwindow_tmp)
!
ENDIF
!
@ -1784,7 +1808,8 @@
USE mp, ONLY : mp_sum
USE kinds, ONLY : DP
USE io_global, ONLY : meta_ionode
USE klist, ONLY : nkstot, xk, nks
USE klist, ONLY : nkstot, nks
USE klist_epw, ONLY : xk_loc
USE wvfct, ONLY : nbnd
USE wannierEPW, ONLY : a_mat, m_mat, num_bands, n_wannier, n_proj, &
nnb, kpb, iknum, excluded_band
@ -1834,12 +1859,12 @@
! m_mat(num_bands,n_wannier,nnb,nkstot) in compute_mmn_para
! umat(nbnd,nbnd,nks) and umat_mat(nbnd,nbnd,nkstot) in setphases_wrap
!
ALLOCATE(a_mat_tmp(nbnd,n_wannier,iknum))
ALLOCATE(a_mat_tmp1(nbnd,n_wannier,iknum))
ALLOCATE(m_mat_tmp(nbnd,nbnd,nnb,iknum))
ALLOCATE(m_mn_tmp1(nbnd,nbnd))
ALLOCATE(m_mn_tmp2(nbnd,nbnd))
ALLOCATE(m_mn_tmp3(nbnd,nbnd,nnb,iknum))
ALLOCATE (a_mat_tmp(nbnd,n_wannier,iknum))
ALLOCATE (a_mat_tmp1(nbnd,n_wannier,iknum))
ALLOCATE (m_mat_tmp(nbnd,nbnd,nnb,iknum))
ALLOCATE (m_mn_tmp1(nbnd,nbnd))
ALLOCATE (m_mn_tmp2(nbnd,nbnd))
ALLOCATE (m_mn_tmp3(nbnd,nbnd,nnb,iknum))
!
! zero all temporary/work quantities
!
@ -1881,7 +1906,7 @@
DO ik = 1, nks
!
! returns in-pool index nkq and absolute index nkq_abs of xk
CALL ktokpmq( xk(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
CALL ktokpmq( xk_loc(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
ik_g = nkq_abs
!
! GF_n are the guiding functions which are our initial guesses
@ -1908,8 +1933,8 @@
CALL zgemm( 'n', 'n', nbnd, nbnd, nbnd, cone, m_mn_tmp1(:,:), &
nbnd, umat_all(:,:,ikb), nbnd, czero, m_mn_tmp2(:,:), nbnd )
!
! m_mn_tmp1 = matmul( conjg( transpose (umat(:,:,ik) )), m_mat(:,:,ib,ik_g ) )
! m_mn_tmp2 = matmul( m_mn_tmp1, umat_g(:,:,ikb) )
! m_mn_tmp1 = MATMUL( conjg( transpose (umat(:,:,ik) )), m_mat(:,:,ib,ik_g ) )
! m_mn_tmp2 = MATMUL( m_mn_tmp1, umat_g(:,:,ikb) )
!
m_mn_tmp3(:,:,ib,ik_g) = m_mn_tmp2(:,:)
ENDDO
@ -1947,12 +1972,12 @@
ENDDO
ENDDO
!
DEALLOCATE(a_mat_tmp)
DEALLOCATE(a_mat_tmp1)
DEALLOCATE(m_mat_tmp)
DEALLOCATE(m_mn_tmp1)
DEALLOCATE(m_mn_tmp2)
DEALLOCATE(m_mn_tmp3)
DEALLOCATE (a_mat_tmp)
DEALLOCATE (a_mat_tmp1)
DEALLOCATE (m_mat_tmp)
DEALLOCATE (m_mn_tmp1)
DEALLOCATE (m_mn_tmp2)
DEALLOCATE (m_mn_tmp3)
!
RETURN
!
@ -1976,7 +2001,8 @@
USE gvect, ONLY : g
USE cell_base, ONLY : tpiba
USE wannierEPW, ONLY : n_proj, gf, center_w, csph, alpha_w, r_w
USE klist, ONLY : xk, igk_k
USE klist, ONLY : igk_k
USE klist_epw, ONLY : xk_loc
USE constants_epw, ONLY : czero
IMPLICIT NONE
@ -1989,12 +2015,12 @@
REAL(DP), ALLOCATABLE :: gk(:,:), qg(:), ylm(:,:), radial(:,:)
COMPLEX(DP), ALLOCATABLE :: sk(:)
!
ALLOCATE( gk(3,npw), qg(npw), ylm(npw,lmax2), sk(npw), radial(npw,0:lmax) )
ALLOCATE ( gk(3,npw), qg(npw), ylm(npw,lmax2), sk(npw), radial(npw,0:lmax) )
!
DO ig = 1, npw
gk(1,ig) = xk(1,ik) + g(1,igk_k(ig,ik) )
gk(2,ig) = xk(2,ik) + g(2,igk_k(ig,ik) )
gk(3,ig) = xk(3,ik) + g(3,igk_k(ig,ik) )
gk(1,ig) = xk_loc(1,ik) + g(1,igk_k(ig,ik) )
gk(2,ig) = xk_loc(2,ik) + g(2,igk_k(ig,ik) )
gk(3,ig) = xk_loc(3,ik) + g(3,igk_k(ig,ik) )
qg(ig) = gk(1,ig)**2 + gk(2,ig)**2 + gk(3,ig)**2
ENDDO
!
@ -2034,7 +2060,7 @@
gf(:,iw) = gf(:,iw) / dsqrt(anorm)
ENDDO
!
DEALLOCATE( gk, qg, ylm, sk, radial )
DEALLOCATE ( gk, qg, ylm, sk, radial )
!
RETURN
!
@ -2060,7 +2086,7 @@
INTEGER :: ibnd1
!! Band index
!
ALLOCATE(eigval(num_bands,iknum))
ALLOCATE (eigval(num_bands,iknum))
!
DO ik = ikstart, ikstop
ikevc = ik - ikstart + 1
@ -2095,7 +2121,8 @@
USE wavefunctions, ONLY : evc, psic, psic_nc
USE wannierEPW, ONLY : reduce_unk, wvfn_formatted, ispinw, nexband, &
excluded_band
USE klist, ONLY : xk, nks, igk_k
USE klist, ONLY : nks, igk_k
USE klist_epw, ONLY : xk_loc
USE gvect, ONLY : g, ngm
USE fft_base, ONLY : dffts
USE fft_interfaces, ONLY : invfft
@ -2138,10 +2165,10 @@
INTEGER nxxs
COMPLEX(DP), ALLOCATABLE :: psic_all(:), psic_nc_all(:,:)
nxxs = dffts%nr1x * dffts%nr2x * dffts%nr3x
IF (.not. noncolin) THEN
ALLOCATE( psic_all(nxxs) )
IF ( .NOT. noncolin) THEN
ALLOCATE ( psic_all(nxxs) )
ELSE
ALLOCATE( psic_nc_all(nxxs,npol) )
ALLOCATE ( psic_nc_all(nxxs,npol) )
ENDIF
#endif
!
@ -2156,11 +2183,11 @@
n2by2 = (dffts%nr2 + 1) / 2
n3by2 = (dffts%nr3 + 1) / 2
WRITE(stdout,'(3(a,i5))') 'n1by2=',n1by2,'n2by2=',n2by2,'n3by2=',n3by2
IF (.not. noncolin) THEN
ALLOCATE( psic_small(n1by2*n2by2*n3by2) )
IF ( .NOT. noncolin) THEN
ALLOCATE ( psic_small(n1by2*n2by2*n3by2) )
psic_small = czero
ELSE
ALLOCATE( psic_nc_small(n1by2*n2by2*n3by2,npol) )
ALLOCATE ( psic_nc_small(n1by2*n2by2*n3by2,npol) )
psic_nc_small = czero
ENDIF
ENDIF
@ -2168,12 +2195,12 @@
DO ik = 1, nks
!
! returns in-pool index nkq and absolute index nkq_abs of xk
CALL ktokpmq ( xk(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
CALL ktokpmq ( xk_loc(:,ik), zero_vect, +1, ipool, nkq, nkq_abs )
ik_g = nkq_abs
!
spin = ispinw
IF (ispinw.eq.0) spin = 1
IF (.not. noncolin) THEN
IF (ispinw == 0) spin = 1
IF ( .NOT. noncolin) THEN
WRITE(wfnname,200) ik_g, spin
ELSE
WRITE(wfnname,201) ik_g
@ -2183,14 +2210,14 @@
!
IF (meta_ionode) THEN
IF (wvfn_formatted) THEN
OPEN(unit=iun_plot, file=wfnname,form='formatted')
OPEN(UNIT=iun_plot, FILE=wfnname,FORM='formatted')
IF (reduce_unk) THEN
WRITE(iun_plot,*) n1by2, n2by2, n3by2, ik_g, nbnd-nexband
ELSE
WRITE(iun_plot,*) dffts%nr1, dffts%nr2, dffts%nr3, ik_g, nbnd-nexband
ENDIF
ELSE
OPEN(unit=iun_plot, file=wfnname,form='unformatted')
OPEN(UNIT=iun_plot, FILE=wfnname,FORM='unformatted')
IF (reduce_unk) THEN
WRITE(iun_plot) n1by2, n2by2, n3by2, ik_g, nbnd-nexband
ELSE
@ -2200,13 +2227,13 @@
ENDIF
!
CALL readwfc( my_pool_id+1, ik, evc )
CALL gk_sort( xk(1,ik), ngm, g, gcutw, npw, igk_k(1,ik), g2kin )
CALL gk_sort( xk_loc(1,ik), ngm, g, gcutw, npw, igk_k(1,ik), g2kin )
!
ibnd1 = 0
DO ibnd = 1, nbnd
IF (excluded_band(ibnd)) CYCLE
ibnd1 = ibnd1 + 1
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
psic(:) = czero
psic( dffts%nl(igk_k(1:npw,ik)) ) = evc(1:npw,ibnd)
CALL invfft('Wave', psic, dffts)
@ -2219,7 +2246,7 @@
ENDIF
IF (reduce_unk) pos = 0
#if defined(__MPI)
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
CALL gather_grid( dffts, psic, psic_all )
ELSE
DO ipol = 1, npol
@ -2233,7 +2260,7 @@
DO i = 1, dffts%nr1, 2
idx = (k-1) * dffts%nr3 * dffts%nr2 + (j-1) * dffts%nr2 + i
pos = pos + 1
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
psic_small(pos) = psic_all(idx)
ELSE
DO ipol = 1, npol
@ -2248,7 +2275,7 @@
IF (meta_ionode) THEN
IF (wvfn_formatted) THEN
IF (reduce_unk) THEN
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
WRITE(iun_plot,'(2ES20.10)') (psic_small(j), j = 1, n1by2*n2by2*n3by2)
ELSE
DO ipol = 1, npol
@ -2256,7 +2283,7 @@
ENDDO
ENDIF
ELSE
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
WRITE(iun_plot,'(2ES20.10)') (psic_all(j), j = 1, dffts%nr1*dffts%nr2*dffts%nr3)
ELSE
DO ipol = 1, npol
@ -2266,7 +2293,7 @@
ENDIF
ELSE
IF (reduce_unk) THEN
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
WRITE(iun_plot) (psic_small(j), j = 1, n1by2*n2by2*n3by2)
ELSE
DO ipol = 1, npol
@ -2274,7 +2301,7 @@
ENDDO
ENDIF
ELSE
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
WRITE(iun_plot) (psic_all(j), j = 1, dffts%nr1*dffts%nr2*dffts%nr3)
ELSE
DO ipol = 1, npol
@ -2291,7 +2318,7 @@
DO i = 1, dffts%nr1, 2
idx = (k-1) * dffts%nr3 * dffts%nr2 + (j-1) * dffts%nr2 + i
pos = pos + 1
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
psic_small(pos) = psic(idx)
ELSE
DO ipol = 1, npol
@ -2305,7 +2332,7 @@
!
IF (meta_ionode) THEN
IF (wvfn_formatted) THEN
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
IF (reduce_unk) THEN
WRITE(iun_plot,'(2ES20.10)') (psic_small(j), j = 1, n1by2*n2by2*n3by2)
ELSE
@ -2321,7 +2348,7 @@
ENDDO
ENDIF
ELSE
IF (.not. noncolin) THEN
IF ( .NOT. noncolin) THEN
IF (reduce_unk) THEN
WRITE(iun_plot) (psic_small(j), j = 1, n1by2*n2by2*n3by2)
ELSE
@ -2346,18 +2373,18 @@
ENDDO !ik
!
IF (reduce_unk) THEN
IF (.not. noncolin) THEN
DEALLOCATE(psic_small)
IF ( .NOT. noncolin) THEN
DEALLOCATE (psic_small)
ELSE
DEALLOCATE(psic_nc_small)
DEALLOCATE (psic_nc_small)
ENDIF
ENDIF
!
#if defined(__MPI)
IF (.not. noncolin) THEN
DEALLOCATE(psic_all)
IF ( .NOT. noncolin) THEN
DEALLOCATE (psic_all)
ELSE
DEALLOCATE(psic_nc_all)
DEALLOCATE (psic_nc_all)
ENDIF
#endif
!
@ -2385,8 +2412,8 @@
REAL(DP), ALLOCATABLE :: r(:,:), rr(:), rp(:,:), ylm_w(:), ylm(:,:), mly(:,:)
REAL(DP) :: u(3,3)
!
ALLOCATE( r(3,lmax2), rp(3,lmax2), rr(lmax2), ylm_w(lmax2) )
ALLOCATE( ylm(lmax2,lmax2), mly(lmax2,lmax2) )
ALLOCATE ( r(3,lmax2), rp(3,lmax2), rr(lmax2), ylm_w(lmax2) )
ALLOCATE ( ylm(lmax2,lmax2), mly(lmax2,lmax2) )
! generate a set of nr=lmax2 random vectors
DO ir = 1, lmax2
@ -2407,11 +2434,11 @@
!- define the u matrix that rotate the reference frame
CALL set_u_matrix( xaxis(:,iw), zaxis(:,iw), u )
!- find rotated r-vectors
rp(:,:) = matmul( u(:,:) , r(:,:) )
rp(:,:) = MATMUL( u(:,:) , r(:,:) )
!- set ylm funtion according to wannier90 (l,mr) indexing in the rotaterd points
CALL ylm_wannier( ylm_w, l_w(iw), mr_w(iw), rp, lmax2 )
!
csph(:,iw) = matmul( mly(:,:), ylm_w(:) )
csph(:,iw) = MATMUL( mly(:,:), ylm_w(:) )
!
! WRITE (stdout,*)
! WRITE (stdout,'(2i4,2(2x,3f6.3))') l_w(iw), mr_w(iw), xaxis(:,iw), zaxis(:,iw)
@ -2419,7 +2446,7 @@
! WRITE (stdout,'(16f6.3)') (csph(lm,iw), lm=1,lmax2)
!
ENDDO
DEALLOCATE( r, rp, rr, ylm_w, ylm, mly )
DEALLOCATE ( r, rp, rr, ylm_w, ylm, mly )
!
RETURN
!
@ -2440,8 +2467,8 @@
REAL(DP) :: capel
INTEGER :: lm
!
ALLOCATE( uno(lmax2,lmax2) )
uno = matmul(mly, ylm)
ALLOCATE ( uno(lmax2,lmax2) )
uno = MATMUL(mly, ylm)
capel = 0.d0
DO lm = 1, lmax2
uno(lm,lm) = uno(lm,lm) - 1.d0

14
EPW/src/readdvscf.f90
View File

@ -19,12 +19,6 @@
!! Imported the noncolinear case implemented by xlzhang
!!
!-------------------------------------------------------------
#if defined(__ALPHA)
# define DIRECT_IO_FACTOR 2
#else
# define DIRECT_IO_FACTOR 8
#endif
!
USE kinds, ONLY : DP
USE io_files, ONLY : prefix
USE units_ph, ONLY : lrdrho
@ -49,6 +43,7 @@
! Local variables
!
INTEGER :: unf_recl, ios
REAL(DP) :: dummy
CHARACTER(len=256) :: tempfile
CHARACTER(len=3) :: filelab
!! file number
@ -61,7 +56,8 @@
!
CALL set_ndnmbr(0, iq, 1, nqc, filelab)
tempfile = trim(dvscf_dir) // trim(prefix) // '.dvscf_q' // filelab
unf_recl = DIRECT_IO_FACTOR * lrdrho
INQUIRE (IOLENGTH=unf_recl) dummy
unf_recl = unf_recl * lrdrho
!unf_recl = iofactor * lrdrho
!DBSP
!print*,'iofactor ',iofactor
@ -76,8 +72,8 @@
IF(ios /= 0) CALL errore('readdvscf','error opening ' // tempfile, iudvscf)
!
! check that the binary file is long enough
INQUIRE(file=tempfile, size=file_size)
IF (mult_unit .gt. file_size) CALL errore('readdvscf', &
INQUIRE(FILE=tempfile, size=file_size)
IF (mult_unit > file_size) CALL errore('readdvscf', &
trim(tempfile)//' too short, check ecut', iudvscf)
!
READ(iudvscf, rec = recn) dvscf

16
EPW/src/readgmap.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!--------------------------------------------------------------
SUBROUTINE readgmap( nkstot, ngxx, ng0vec, g0vec_all_r, lower_bnd )
SUBROUTINE readgmap (nkstot, ngxx, ng0vec, g0vec_all_r, lower_bnd)
!--------------------------------------------------------------
!!
!! read map of G vectors G -> G-G_0 for a given q point
@ -57,8 +57,6 @@
!
REAL(DP) :: tmp
!
ALLOCATE( shift(nkstot) )
!
! OBSOLETE: now we read directly the igkq to get the proper ngxx
!
! read only a piece of the map to save time
@ -91,7 +89,7 @@
!
IF (meta_ionode) THEN
!
OPEN(iukgmap, file=trim(prefix)//'.kgmap', form='formatted', status='old', iostat=ios)
OPEN(iukgmap, FILE=trim(prefix)//'.kgmap', FORM='formatted', status='old', iostat=ios)
IF (ios /=0) CALL errore('readgmap', 'error opening kgmap file', iukgmap)
!
DO ik = 1, nkstot
@ -111,7 +109,7 @@
! 'fake' reading is because the gmap appears *after* the
! wrong kmap.
!
OPEN(iukmap, file=trim(prefix)//'.kmap', form='formatted', status='old', iostat=ios)
OPEN(iukmap, FILE=trim(prefix)//'.kmap', FORM='formatted', status='old', iostat=ios)
IF (ios /= 0) CALL errore ('readgmap', 'error opening kmap file', iukmap)
DO ik = 1, nkstot
READ(iukmap,*) ik1, itmp, shift(ik1)
@ -124,7 +122,7 @@
!
CALL mp_bcast( ng0vec, meta_ionode_id, world_comm )
!
ALLOCATE( gmap(ngxx * ng0vec) )
ALLOCATE (gmap(ngxx * ng0vec))
!
IF (meta_ionode) THEN
!
@ -144,8 +142,8 @@
!
! first node broadcasts everything to all nodes
!
CALL mp_bcast( g0vec_all_r, meta_ionode_id, world_comm )
CALL mp_bcast( shift, meta_ionode_id, world_comm )
CALL mp_bcast( gmap, meta_ionode_id, world_comm )
CALL mp_bcast(g0vec_all_r, meta_ionode_id, world_comm)
CALL mp_bcast(shift, meta_ionode_id, world_comm)
CALL mp_bcast(gmap, meta_ionode_id, world_comm)
!
END SUBROUTINE readgmap

343
EPW/src/readmat_shuffle2.f90
View File

@ -11,7 +11,7 @@
invs, s, irt, rtau)
!-----------------------------------------------------------------------
!!
!! read dynamical matrix for the q points
!! read dynamical matrix for the q points, either in plain text or xml.
!! iq_first, iq_first+1, ... iq_first+nq-1
!!
!-----------------------------------------------------------------------
@ -25,7 +25,7 @@
USE modes, ONLY : nmodes
USE control_flags, ONLY : iverbosity
USE phcom, ONLY : nq1, nq2, nq3
USE noncollin_module, ONLY : noncolin, nspin_mag
USE noncollin_module, ONLY : nspin_mag
USE io_dyn_mat2, ONLY : read_dyn_mat_param, read_dyn_mat_header,&
read_dyn_mat
USE io_global, ONLY : ionode, stdout
@ -89,7 +89,7 @@
CHARACTER(len=3) :: atm, filelab
CHARACTER(len=80) :: line
CHARACTER(len=256) :: tempfile
LOGICAL :: found, lrigid, lraman, nog
LOGICAL :: found, lrigid, lraman, nog, is_xml_file
INTEGER :: ntyp_, nat_, ibrav_, ityp_, ios, iq, jq, &
nt, na, nb, naa, nbb, nu, mu, i, j, ipol,jpol
INTEGER, parameter :: ntypx = 10
@ -117,9 +117,21 @@
!
!DBSP
! SP: If noncolin, the dynamical matrix are printed in xml format by QE
IF (noncolin) THEN
CALL set_ndnmbr ( 0, iq_irr, 1, nqc_irr, filelab)
tempfile = trim(dvscf_dir) // trim(prefix) // '.dyn_q' // filelab
! FG: Not anymore (since v6.4?) xml files are produced only if user asks for
! it. Thus one cannot assume anymore files are xml based on noncolin.
! the call to set_ndnmbr is just a trick to get quickly
! a file label by exploiting an existing subroutine
! (if you look at the sub you will find that the original
! purpose was for pools and nodes)
!
CALL set_ndnmbr ( 0, iq_irr, 1, nqc_irr, filelab)
tempfile = trim(dvscf_dir) // trim(prefix) // '.dyn_q' // trim(filelab)
! the following function will check either or not the file is formatted in
! xml. If no file is found, an error is raised
call check_is_xml_file(tempfile, is_xml_file)
IF (is_xml_file) THEN
CALL read_dyn_mat_param(tempfile,ntyp,nat)
ALLOCATE (m_loc(3,nat))
ALLOCATE (dchi_dtau(3,3,3,nat) )
@ -153,7 +165,7 @@
!
! If time-reversal is not included in the star of q, then double the nq to
! search from.
IF (imq.eq.0) then
IF (imq == 0) then
mq = 2*nq
ELSE
mq = nq
@ -179,17 +191,17 @@
! Impose the acoustic sum rule (q=0 needs to be the first q point in the coarse grid)
! [Gonze and Lee, PRB 55, 10361 (1998), Eq. (45) and (81)]
!
IF ( abs(q(1,iq)).lt.eps .and. abs(q(2,iq)).lt.eps .and. abs(q(3,iq)).lt.eps ) THEN
IF ( abs(q(1,iq)) < eps .and. abs(q(2,iq)) < eps .and. abs(q(3,iq)) < eps ) THEN
WRITE(stdout,'(5x,a)') 'Imposing acoustic sum rule on the dynamical matrix'
IF (lpolar .and. .not. lrigid) CALL errore('readmat_shuffle2', &
IF (lpolar .and. .NOT. lrigid) CALL errore('readmat_shuffle2', &
&'You set lpolar = .true. but did not put epsil = true in the PH calculation at Gamma. ',1)
ENDIF
DO na = 1,nat
DO ipol = 1,3
DO jpol = ipol,3
!
IF ( abs(q(1,iq)).lt.eps .and. abs(q(2,iq)).lt.eps .and. abs(q(3,iq)).lt.eps ) then
IF ( .not. allocated(sumr) ) allocate ( sumr(2,3,nat,3) )
IF ( abs(q(1,iq)) < eps .and. abs(q(2,iq)) < eps .and. abs(q(3,iq)) < eps ) then
IF ( .NOT. allocated(sumr) ) allocate ( sumr(2,3,nat,3) )
sumr(1,ipol,na,jpol) = sum ( dynr (1,ipol,na,jpol,:) )
sumr(2,ipol,na,jpol) = sum ( dynr (2,ipol,na,jpol,:) )
ENDIF
@ -223,17 +235,8 @@
!
ENDDO ! iq = 1, mq
!
ELSE ! noncolin
ELSE ! not a xml file
!END
!
! the call to set_ndnmbr is just a trick to get quickly
! a file label by exploiting an existing subroutine
! (if you look at the sub you will find that the original
! purpose was for pools and nodes)
!
CALL set_ndnmbr ( 0, iq_irr, 1, nqc_irr, filelab)
tempfile = trim(dvscf_dir) // trim(prefix) // '.dyn_q' // filelab
!
open (unit = iudyn, file = tempfile, status = 'old', iostat = ios)
IF (ios /=0) call errore ('readmat_shuffle2', 'opening file'//tempfile, abs (ios) )
!
@ -245,21 +248,21 @@
!
! We stop testing celldm as it can be different between scf and nscf
!IF (ntyp.ne.ntyp_.or.nat.ne.nat_.or.ibrav_.ne.ibrav.or.abs ( &
! celldm_ (1) - celldm (1) ) .gt.1.0d-5) call errore ('readmat_shuffle2', &
! celldm_ (1) - celldm (1) ) > 1.0d-5) call errore ('readmat_shuffle2', &
! 'inconsistent data', 1)
IF (ntyp.ne.ntyp_.or.nat.ne.nat_.or.ibrav_.ne.ibrav ) call errore ('readmat_shuffle2', &
'inconsistent data', 1)
!
! skip reading of cell parameters here
!
IF (ibrav_ .eq. 0) then
IF (ibrav_ == 0) then
DO i = 1,4
read (iudyn, * ) line
ENDDO
ENDIF
DO nt = 1, ntyp
read (iudyn, * ) i, atm, amass_
IF (nt.ne.i.or.abs (amass_ - amass (nt) ) .gt.1.0d-2) then
IF (nt.ne.i.or.abs (amass_ - amass (nt) ) > 1.0d-2) then
write (stdout,*) amass_, amass(nt)
call errore ('readmat_shuffle2', 'inconsistent data', 1)
endif
@ -275,7 +278,7 @@
!
! If time-reversal is not included in the star of q, then double the nq to
! search from.
IF (imq.eq.0) then
IF (imq == 0) then
mq = 2*nq
ELSE
mq = nq
@ -306,15 +309,15 @@
! impose the acoustic sum rule (q=0 needs to be the first q point in the coarse grid)
! [Gonze and Lee, PRB 55, 10361 (1998), Eq. (45) and (81)]
!
IF ( abs(q(1,iq)).lt.eps .and. abs(q(2,iq)).lt.eps .and. abs(q(3,iq)).lt.eps ) then
IF ( abs(q(1,iq)) < eps .and. abs(q(2,iq)) < eps .and. abs(q(3,iq)) < eps ) then
WRITE(stdout,'(5x,a)') 'Imposing acoustic sum rule on the dynamical matrix'
ENDIF
DO na = 1,nat
DO ipol = 1,3
DO jpol = ipol,3
!
IF ( abs(q(1,iq)).lt.eps .and. abs(q(2,iq)).lt.eps .and. abs(q(3,iq)).lt.eps ) then
IF ( .not. allocated(sumr) ) allocate ( sumr(2,3,nat,3) )
IF ( abs(q(1,iq)) < eps .and. abs(q(2,iq)) < eps .and. abs(q(3,iq)) < eps ) then
IF ( .NOT. allocated(sumr) ) allocate ( sumr(2,3,nat,3) )
sumr(1,ipol,na,jpol) = sum ( dynr (1,ipol,na,jpol,:) )
sumr(2,ipol,na,jpol) = sum ( dynr (2,ipol,na,jpol,:) )
ENDIF
@ -348,7 +351,7 @@
!
ENDDO
!
IF ( abs(q(1,1)).lt.eps .and. abs(q(2,1)).lt.eps .and. abs(q(3,1)).lt.eps ) THEN
IF ( abs(q(1,1)) < eps .and. abs(q(2,1)) < eps .and. abs(q(3,1)) < eps ) THEN
! read dielectric tensor and effective charges if present
! SP: Warning zstar is not properly bcast at the moment
read (iudyn,'(a)') line
@ -408,9 +411,9 @@
DO m1=-2,2
DO m2=-2,2
DO m3=-2,2
IF ((abs(q(1,jq)-(sxq(1,iq)+m1)).lt.eps .and. &
abs(q(2,jq)-(sxq(2,iq)+m2)).lt.eps .and. &
abs(q(3,jq)-(sxq(3,iq)+m3)).lt.eps )) THEN
IF ((abs(q(1,jq)-(sxq(1,iq)+m1)) < eps .and. &
abs(q(2,jq)-(sxq(2,iq)+m2)) < eps .and. &
abs(q(3,jq)-(sxq(3,iq)+m3)) < eps )) THEN
found = .true.
exit ! exit loop
ENDIF
@ -433,17 +436,17 @@
! We still call the above just to make the checks. The content of dynq
! will be re-written just below and NOT read from the dyn from the /save folder
IF (lifc) THEN
!
! build the WS cell corresponding to the force constant grid
atws(:,1) = at(:,1)*DBLE(nq1)
atws(:,2) = at(:,2)*DBLE(nq2)
atws(:,3) = at(:,3)*DBLE(nq3)
! initialize WS r-vectors
CALL wsinit(rws,nrwsx,nrws,atws)
CALL dynifc2blochc (nmodes, rws, nrws, q(:,1), dynq_tmp)
dynq(:,:,iq_first)=dynq_tmp
WRITE (stdout,'(5x,a)') "Dyn mat calculated from ifcs"
!
!
! build the WS cell corresponding to the force constant grid
atws(:, 1) = at(:, 1) * DBLE(nq1)
atws(:, 2) = at(:, 2) * DBLE(nq2)
atws(:, 3) = at(:, 3) * DBLE(nq3)
! initialize WS r-vectors
CALL wsinit(rws,nrwsx,nrws,atws)
CALL dynifc2blochc (nmodes, rws, nrws, q(:,1), dynq_tmp)
dynq(:,:,iq_first)=dynq_tmp
WRITE (stdout,'(5x,a)') "Dyn mat calculated from ifcs"
!
ENDIF
!
! Now construct the other dyn matrix for the q in the star using sym.
@ -459,7 +462,7 @@
!
sym_sgq(:) = 0
DO jsym = 1, nsym
IF ( isq(jsym) .eq. iq ) then
IF ( isq(jsym) == iq ) then
nsq = nsq + 1
sym_sgq(nsq) = jsym
ENDIF
@ -536,7 +539,7 @@
!
DO nu = 1, nmodes
DO mu = 1, nmodes
IF ( mu.ne.nu .and. abs(dynq(mu,nu,current_iq)).gt.eps ) call errore &
IF ( mu.ne.nu .and. abs(dynq(mu,nu,current_iq)) > eps ) call errore &
('rotate_eigenm','problem with rotated eigenmodes',0)
ENDDO
ENDDO
@ -544,7 +547,7 @@
! DBSP-----------------------------------------------
! a simple check on the frequencies
!
IF (iverbosity.eq.1) THEN
IF (iverbosity == 1) THEN
DO na = 1, nat
DO nb = 1, nat
massfac = 1.d0 / sqrt ( amass(ityp(na)) * amass(ityp(nb)) )
@ -566,7 +569,7 @@
DO nu = 1, nmodes
IF ( w1 (nu) .gt. 0.d0 ) then
IF ( w1 (nu) > 0.d0 ) then
wtmp(nu) = sqrt(abs( w1 (nu) ))
ELSE
wtmp(nu) = -sqrt(abs( w1 (nu) ))
@ -579,7 +582,7 @@
current_iq = current_iq + 1
!
! SP Repeat the same but for minus_q one
IF (imq.eq.0) then
IF (imq == 0) then
!
xq = -sxq(:,iq)
!saq = xq
@ -610,7 +613,7 @@
!
DO nu = 1, nmodes
DO mu = 1, nmodes
IF ( mu.ne.nu .and. abs(dynq(mu,nu,current_iq)).gt.eps ) call errore &
IF ( mu.ne.nu .and. abs(dynq(mu,nu,current_iq)) > eps ) call errore &
('rotate_eigenm','problem with rotated eigenmodes',0)
ENDDO
ENDDO
@ -638,20 +641,20 @@
USE phcom, ONLY : nq1, nq2, nq3
USE io_global, ONLY : stdout
USE io_epw, ONLY : iunifc
USE noncollin_module, ONLY : noncolin, nspin_mag
USE noncollin_module, ONLY : nspin_mag
USE io_dyn_mat2, ONLY : read_dyn_mat_param, read_dyn_mat_header,&
read_dyn_mat, read_ifc_xml, read_ifc_param
USE io_global, ONLY : ionode_id
USE mp, ONLY : mp_barrier, mp_bcast
USE mp_global, ONLY : intra_pool_comm, inter_pool_comm, root_pool
USE mp_world, ONLY : mpime
USE mp_world, ONLY : mpime, world_comm
#if defined(__NAG)
USE f90_unix_io, ONLY : flush
#endif
!
implicit none
!
LOGICAL :: lpolar_, has_zstar
LOGICAL :: lpolar_, has_zstar, is_plain_text_file, is_xml_file
CHARACTER (len=80) :: line
CHARACTER(len=256) :: tempfile
INTEGER :: ios, i, j, m1,m2,m3, na,nb, &
@ -666,101 +669,103 @@
CALL flush(stdout)
!
! This is important in restart mode as zstar etc has not been allocated
IF (.NOT. ALLOCATED (zstar) ) ALLOCATE( zstar(3,3,nat) )
IF (.NOT. ALLOCATED (epsi) ) ALLOCATE( epsi(3,3) )
IF (.not. ALLOCATED (ifc)) ALLOCATE ( ifc ( nq1, nq2, nq3, 3, 3, nat, nat ) )
IF (.NOT. ALLOCATED (zstar) ) ALLOCATE ( zstar(3,3,nat) )
IF (.NOT. ALLOCATED (epsi) ) ALLOCATE ( epsi(3,3) )
IF ( .NOT. ALLOCATED (ifc)) ALLOCATE ( ifc ( nq1, nq2, nq3, 3, 3, nat, nat ) )
zstar=0.d0
epsi=0.d0
IF (mpime.eq.ionode_id) THEN
IF (noncolin) THEN
!
tempfile = trim(dvscf_dir) // 'ifc.q2r'
! generic name for the ifc.q2r file. If it is xml, the file will be named
! ifc.q2r.xml instead
tempfile = TRIM(dvscf_dir) // 'ifc.q2r'
! The following function will check if the file exists in xml format
CALL check_is_xml_file(tempfile, is_xml_file)
IF (mpime == ionode_id) THEN
IF (is_xml_file) THEN
! pass the 'tempfile' as the '.xml' extension is added in the next routine
CALL read_dyn_mat_param(tempfile,ntyp_,nat_)
ALLOCATE (m_loc(3,nat_))
ALLOCATE (m_loc(3, nat_))
ALLOCATE (atm(ntyp_))
CALL read_dyn_mat_header(ntyp_, nat_, ibrav, nspin_mag, &
celldm, at, bg, omega, atm, amass2, &
tau_, ityp_, m_loc, nqs, has_zstar, epsi, zstar )
! alat=celldm(1)
call volume(alat,at(1,1),at(1,2),at(1,3),omega)
CALL read_ifc_param(nq1,nq2,nq3)
CALL read_ifc_xml(nq1,nq2,nq3,nat_,ifc)
call volume(alat, at(1, 1), at(1, 2), at(1, 3), omega)
CALL read_ifc_param(nq1, nq2, nq3)
CALL read_ifc_xml(nq1, nq2, nq3, nat_, ifc)
DEALLOCATE (m_loc)
DEALLOCATE (atm)
!
ELSE
!
tempfile = trim(dvscf_dir) // 'ifc.q2r'
OPEN(unit=iunifc,file=tempfile,status='old',iostat=ios)
OPEN(UNIT=iunifc,FILE=tempfile,status='old',iostat=ios)
IF (ios /= 0) call errore ('read_ifc', 'error opening ifc.q2r',iunifc)
!
! read real-space interatomic force constants
!
READ(iunifc,'(3i4)') ntyp_ , nat_ , ibrav_
IF (ibrav_ .eq. 0) then
DO i = 1,3
read (iunifc, * ) line
ENDDO
IF (ibrav_ == 0) then
DO i = 1,3
read (iunifc, * ) line
ENDDO
ENDIF
DO i=1,ntyp_
READ(iunifc,'(a)') line
READ(iunifc,'(a)') line
ENDDO
DO na=1,nat
READ(iunifc,*) idum, idum, (tau_(j,na),j=1,3)
ENDDO
READ(iunifc,*) idum, idum, (tau_(j,na),j=1,3)
ENDDO
READ(iunifc,*) lpolar_
!
IF (lpolar_) THEN
READ (iunifc,*) ((epsi(i,j), j=1,3), i=1,3)
DO na = 1, nat
READ (iunifc,*) idum
READ (iunifc,*) ((zstar(i,j,na), j=1,3), i=1,3)
ENDDO
WRITE (stdout,'(5x,a)') "Read Z* and epsilon"
READ (iunifc,*) ((epsi(i,j), j=1,3), i=1,3)
DO na=1, nat
READ (iunifc,*) idum
READ (iunifc,*) ((zstar(i,j,na), j=1,3), i=1,3)
ENDDO
WRITE (stdout,'(5x,a)') "Read Z* and epsilon"
ENDIF
!
READ (iunifc,*) idum
!
ifc = 0.d0
DO i=1,3
DO j=1,3
DO na=1,nat
DO nb=1,nat
READ (iunifc,*) ibid, jbid, nabid, nbbid
IF(i .NE.ibid .OR. j .NE.jbid .OR. &
na.NE.nabid .OR. nb.NE.nbbid) &
CALL errore ('read_epw','error in reading ifc',1)
READ (iunifc,*) (((m1bid, m2bid, m3bid, &
ifc(m1,m2,m3,i,j,na,nb), &
m1=1,nq1),m2=1,nq2),m3=1,nq3)
ENDDO
DO i=1, 3
DO j=1, 3
DO na=1, nat
DO nb=1, nat
READ (iunifc,*) ibid, jbid, nabid, nbbid
IF(i .NE.ibid .OR. j .NE.jbid .OR. &
na.NE.nabid .OR. nb.NE.nbbid) &
CALL errore ('read_epw','error in reading ifc',1)
READ (iunifc,*) (((m1bid, m2bid, m3bid, &
ifc(m1,m2,m3,i,j,na,nb), &
m1=1,nq1),m2=1,nq2),m3=1,nq3)
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
!
ENDIF ! noncol
ENDIF
!
! It has to be casted like this because mpi cannot cast 7 indices
DO i=1,3
DO j=1,3
DO na=1,nat
DO nb=1,nat
CALL mp_bcast (ifc(:,:,:,i,j,na,nb), ionode_id, inter_pool_comm)
CALL mp_bcast (ifc(:,:,:,i,j,na,nb), root_pool, intra_pool_comm)
ENDDO
DO i=1, 3
DO j=1, 3
DO na=1, nat
DO nb=1, nat
CALL mp_bcast (ifc(:,:,:,i,j,na,nb), ionode_id, inter_pool_comm)
CALL mp_bcast (ifc(:,:,:,i,j,na,nb), root_pool, intra_pool_comm)
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
!
CALL mp_bcast (zstar, ionode_id, inter_pool_comm)
CALL mp_bcast (zstar, root_pool, intra_pool_comm)
CALL mp_bcast (epsi, ionode_id, inter_pool_comm)
CALL mp_bcast (epsi, root_pool, intra_pool_comm)
CALL mp_bcast (tau_, ionode_id, inter_pool_comm)
CALL mp_bcast (tau_, root_pool, intra_pool_comm)
CALL mp_bcast (ibrav_, ionode_id, inter_pool_comm)
CALL mp_bcast (ibrav_, root_pool, intra_pool_comm)
CALL mp_bcast (zstar, ionode_id, world_comm)
CALL mp_bcast (epsi, ionode_id, world_comm)
CALL mp_bcast (tau_, ionode_id, world_comm)
CALL mp_bcast (ibrav_, ionode_id, world_comm)
!
WRITE(stdout,'(5x,"IFC last ", 1f12.7)') ifc(nq1,nq2,nq3,3,3,nat,nat)
!
@ -768,7 +773,7 @@
nat, ibrav_, tau_)
!
CALL mp_barrier(inter_pool_comm)
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
CLOSE(iunifc)
ENDIF
!
@ -842,7 +847,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
call errore('set_asr','invalid Acoustic Sum Rule:' // asr, 1)
endif
!
if(asr.eq.'simple') then
if(asr == 'simple') then
!
! Simple Acoustic Sum Rule on effective charges
!
@ -884,16 +889,16 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
!
end if
if(asr.eq.'crystal') n=3
if(asr.eq.'one-dim') then
if(asr == 'crystal') n=3
if(asr == 'one-dim') then
! the direction of periodicity is the rotation axis
! It will work only if the crystal axis considered is one of
! the cartesian axis (typically, ibrav=1, 6 or 8, or 4 along the
! z-direction)
if (nr1*nr2*nr3.eq.1) axis=3
if ((nr1.ne.1).and.(nr2*nr3.eq.1)) axis=1
if ((nr2.ne.1).and.(nr1*nr3.eq.1)) axis=2
if ((nr3.ne.1).and.(nr1*nr2.eq.1)) axis=3
if (nr1*nr2*nr3 == 1) axis=3
if ((nr1.ne.1).and.(nr2*nr3 == 1)) axis=1
if ((nr2.ne.1).and.(nr1*nr3 == 1)) axis=2
if ((nr3.ne.1).and.(nr1*nr2 == 1)) axis=3
if (((nr1.ne.1).and.(nr2.ne.1)).or.((nr2.ne.1).and. &
(nr3.ne.1)).or.((nr1.ne.1).and.(nr3.ne.1))) then
call errore('set_asr','too many directions of &
@ -906,7 +911,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
write(stdout,'("asr rotation axis in 1D system= ",I4)') axis
n=4
endif
if(asr.eq.'zero-dim') n=6
if(asr == 'zero-dim') n=6
!
! Acoustic Sum Rule on effective charges
!
@ -933,7 +938,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
enddo
enddo
!
if (n.eq.4) then
if (n == 4) then
do i=1,3
! These are the 3 vectors associated with the
! single rotational sum rule (1D system)
@ -946,7 +951,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
enddo
endif
!
if (n.eq.6) then
if (n == 6) then
do i=1,3
do j=1,3
! These are the 3*3 vectors associated with the
@ -970,7 +975,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
do q=1,k-1
r=1
do izeu_less=1,nzeu_less
if (zeu_less(izeu_less).eq.q) r=0
if (zeu_less(izeu_less) == q) r=0
enddo
if (r.ne.0) then
call sp_zeu(zeu_x,zeu_u(q,:,:,:),nat,scal)
@ -978,7 +983,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
endif
enddo
call sp_zeu(zeu_w,zeu_w,nat,norm2)
if (norm2.gt.1.0d-16) then
if (norm2 > 1.0d-16) then
zeu_u(k,:,:,:) = zeu_w(:,:,:) / DSQRT(norm2)
else
nzeu_less=nzeu_less+1
@ -993,7 +998,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
do k=1,p
r=1
do izeu_less=1,nzeu_less
if (zeu_less(izeu_less).eq.k) r=0
if (zeu_less(izeu_less) == k) r=0
enddo
if (r.ne.0) then
zeu_x(:,:,:)=zeu_u(k,:,:,:)
@ -1015,7 +1020,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
!do k=1,p
! zeu_x(:,:,:)=zeu_u(k,:,:,:)
! call sp_zeu(zeu_x,zeu_new,nat,scal)
! if (DABS(scal).gt.1d-10) write(6,'("k= ",I8," zeu_new|zeu_u(k)= ",F15.10)')
! if (DABS(scal) > 1d-10) write(6,'("k= ",I8," zeu_new|zeu_u(k)= ",F15.10)')
! k,scal
!enddo
!
@ -1067,7 +1072,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
enddo
enddo
!
if (n.eq.4) then
if (n == 4) then
do i=1,3
do na=1,nat
! These are the 3*nat vectors associated with the
@ -1082,7 +1087,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
enddo
endif
!
if (n.eq.6) then
if (n == 6) then
do i=1,3
do j=1,3
do na=1,nat
@ -1112,19 +1117,19 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
! constraints
q=1
l=1
do while((l.le.m).and.(q.ne.0))
if ((ind_v(l,1,1).eq.n1).and.(ind_v(l,1,2).eq.n2).and. &
(ind_v(l,1,3).eq.n3).and.(ind_v(l,1,4).eq.i).and. &
(ind_v(l,1,5).eq.j).and.(ind_v(l,1,6).eq.na).and. &
(ind_v(l,1,7).eq.nb)) q=0
if ((ind_v(l,2,1).eq.n1).and.(ind_v(l,2,2).eq.n2).and. &
(ind_v(l,2,3).eq.n3).and.(ind_v(l,2,4).eq.i).and. &
(ind_v(l,2,5).eq.j).and.(ind_v(l,2,6).eq.na).and. &
(ind_v(l,2,7).eq.nb)) q=0
do while((l <= m).and.(q.ne.0))
if ((ind_v(l,1,1) == n1).and.(ind_v(l,1,2) == n2).and. &
(ind_v(l,1,3) == n3).and.(ind_v(l,1,4) == i).and. &
(ind_v(l,1,5) == j).and.(ind_v(l,1,6) == na).and. &
(ind_v(l,1,7) == nb)) q=0
if ((ind_v(l,2,1) == n1).and.(ind_v(l,2,2) == n2).and. &
(ind_v(l,2,3) == n3).and.(ind_v(l,2,4) == i).and. &
(ind_v(l,2,5) == j).and.(ind_v(l,2,6) == na).and. &
(ind_v(l,2,7) == nb)) q=0
l=l+1
enddo
if ((n1.eq.MOD(nr1+1-n1,nr1)+1).and.(n2.eq.MOD(nr2+1-n2,nr2)+1) &
.and.(n3.eq.MOD(nr3+1-n3,nr3)+1).and.(i.eq.j).and.(na.eq.nb)) q=0
if ((n1 == MOD(nr1+1-n1,nr1)+1).and.(n2 == MOD(nr2+1-n2,nr2)+1) &
.and.(n3 == MOD(nr3+1-n3,nr3)+1).and.(i == j).and.(na == nb)) q=0
if (q.ne.0) then
m=m+1
ind_v(m,1,1)=n1
@ -1175,20 +1180,20 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
w(n1,n2,n3,i,j,na,nb)=w(n1,n2,n3,i,j,na,nb)-scal*v(l,r)
enddo
enddo
if (k.le.(9*nat)) then
if (k <= (9*nat)) then
na1=MOD(k,nat)
if (na1.eq.0) na1=nat
if (na1 == 0) na1=nat
j1=MOD((k-na1)/nat,3)+1
i1=MOD((((k-na1)/nat)-j1+1)/3,3)+1
else
q=k-9*nat
if (n.eq.4) then
if (n == 4) then
na1=MOD(q,nat)
if (na1.eq.0) na1=nat
if (na1 == 0) na1=nat
i1=MOD((q-na1)/nat,3)+1
else
na1=MOD(q,nat)
if (na1.eq.0) na1=nat
if (na1 == 0) na1=nat
j1=MOD((q-na1)/nat,3)+1
i1=MOD((((q-na1)/nat)-j1+1)/3,3)+1
endif
@ -1196,7 +1201,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
do q=1,k-1
r=1
do i_less=1,n_less
if (u_less(i_less).eq.q) r=0
if (u_less(i_less) == q) r=0
enddo
if (r.ne.0) then
call sp3(x,u(q) % vec (:,:,:,:,:,:,:), i1,na1,nr1,nr2,nr3,nat,scal)
@ -1204,7 +1209,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
endif
enddo
call sp1(w,w,nr1,nr2,nr3,nat,norm2)
if (norm2.gt.1.0d-16) then
if (norm2 > 1.0d-16) then
u(k) % vec (:,:,:,:,:,:,:) = w(:,:,:,:,:,:,:) / DSQRT(norm2)
else
n_less=n_less+1
@ -1232,7 +1237,7 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
do k=1,p
r=1
do i_less=1,n_less
if (u_less(i_less).eq.k) r=0
if (u_less(i_less) == k) r=0
enddo
if (r.ne.0) then
x(:,:,:,:,:,:,:)=u(k) % vec (:,:,:,:,:,:,:)
@ -1254,13 +1259,13 @@ SUBROUTINE set_asr2 (asr, nr1, nr2, nr3, frc, zeu, nat, ibrav, tau)
!write(6,'("Check projection IFC")')
!do l=1,m
! call sp2(frc_new,v(l,:),ind_v(l,:,:),nr1,nr2,nr3,nat,scal)
! if (DABS(scal).gt.1d-10) write(6,'("l= ",I8," frc_new|v(l)= ",F15.10)')
! if (DABS(scal) > 1d-10) write(6,'("l= ",I8," frc_new|v(l)= ",F15.10)')
! l,scal
!enddo
!do k=1,p
! x(:,:,:,:,:,:,:)=u(k) % vec (:,:,:,:,:,:,:)
! call sp1(x,frc_new,nr1,nr2,nr3,nat,scal)
! if (DABS(scal).gt.1d-10) write(6,'("k= ",I8," frc_new|u(k)= ",F15.10)')
! if (DABS(scal) > 1d-10) write(6,'("k= ",I8," frc_new|u(k)= ",F15.10)')
! k,scal
! deallocate(u(k) % vec)
!enddo
@ -1420,3 +1425,49 @@ subroutine sp3(u,v,i,na,nr1,nr2,nr3,nat,scal)
end subroutine sp3
!
!-------------------------------------------------------------------------------
SUBROUTINE check_is_xml_file(filename, is_xml_file)
!-------------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!!
!! This subroutine checks if a file is formatted in XML. It does so by
!! checking if the file exists and if the file + '.xml' in its name exists.
!! If both of them or none of them exists, an error is raised. If only one of
!! them exists, it sets the 'is_xml_file' to .true. of .false. depending of
!! the file found.
!!
!-----------------------------------------------------------------------------
IMPLICIT NONE
!
! input variables
!
CHARACTER(len=256), INTENT(IN) :: filename
!! The name of the file to check if formatted in XML format
!! This string is assumed to be trimmed
LOGICAL, INTENT(OUT) :: is_xml_file
!! Is .true. if the file is in xml format. .false. otherwise.
!
! local variables
!
CHARACTER(len=256) :: filename_xml, errmsg
LOGICAL :: is_plain_text_file
filename_xml = TRIM(filename) // '.xml'
filename_xml = TRIM(filename_xml)
INQUIRE(FILE=filename, EXIST=is_plain_text_file)
INQUIRE(FILE=filename_xml, EXIST=is_xml_file)
! Tell user if any inconsistencies
IF (is_xml_file .AND. is_plain_text_file) THEN
! 2 different type of files exist => warn user
errmsg = "Detected both: '" // filename // "' and '" // filename_xml // &
&"' which one to choose?"
CALL errore('check_is_xml_file', errmsg, 1)
ELSE IF (.NOT. is_xml_file .AND. .NOT. is_plain_text_file) THEN
errmsg = "Expected a file named either '" // filename //"' or '"&
&// filename_xml // "' but none was found."
CALL errore('check_is_xml_file', errmsg, 1)
ENDIF
! else one of the file in exists
!------------------------------------------------------------------------------
END SUBROUTINE check_is_xml_file
!------------------------------------------------------------------------------

9
EPW/src/readwfc.f90
View File

@ -16,11 +16,6 @@
! Imported the noncolinear case implemented by xlzhang
!
!-------------------------------------------------------------
#if defined (__ALPHA)
# define DIRECT_IO_FACTOR 2
# else
# define DIRECT_IO_FACTOR 8
#endif
!
USE kinds, ONLY : DP
USE io_files, ONLY : prefix, tmp_dir
@ -43,6 +38,7 @@
! Local variables
!
INTEGER :: unf_recl, ios
REAL(DP) :: dummy
CHARACTER(len=256) :: tempfile
CHARACTER(len=3) :: nd_nmbr0
! file number for shuffle
@ -56,7 +52,8 @@
# else
tempfile = trim(tmp_dir) // trim(prefix) // '.wfc'
#endif
unf_recl = DIRECT_IO_FACTOR * lrwfc
INQUIRE (IOLENGTH = unf_recl) dummy
unf_recl = unf_recl * lrwfc
!
OPEN(iuwfc, file = tempfile, form = 'unformatted', &
access = 'direct', iostat = ios, recl = unf_recl)

483
EPW/src/rigid_epw.f90
View File

@ -19,6 +19,8 @@
!! implemented: the Ewald parameter alpha must be large enough to
!! have negligible r-space contribution
!!
!! This implements Eq. 98 of Rev. Mod. Phys., 73, 515 (2001)
!!
USE kinds, ONLY : DP
USE constants_epw, ONLY : pi, fpi, e2
USE cell_base, ONLY : bg, omega
@ -37,35 +39,64 @@
!
REAL (kind=DP), INTENT (in) :: q(3)
!! q-vector from the full coarse or fine grid.
REAL (kind=DP), INTENT (in) :: epsil(3,3)
REAL (kind=DP), INTENT (in) :: epsil(3, 3)
!! dielectric constant tensor
REAL (kind=DP), INTENT (in) :: zeu(3,3,nat)
REAL (kind=DP), INTENT (in) :: zeu(3, 3, nat)
!! effective charges tensor
REAL (kind=DP), INTENT (in) :: signe
!! signe=+/-1.0 ==> add/subtract rigid-ion term
REAL (kind=DP), INTENT (in) :: tau(3,nat)
REAL (kind=DP), INTENT (in) :: tau(3, nat)
!! Atomic positions
!
COMPLEX (kind=DP), INTENT (inout) :: dyn(3*nat,3*nat)
COMPLEX (kind=DP), INTENT (inout) :: dyn(3 * nat, 3 * nat)
!! Dynamical matrix
!
! Local variables
!
INTEGER :: na, nb, i, j, m1, m2, m3
INTEGER :: nrx1, nrx2, nrx3
INTEGER :: na
!! Atom index 1
INTEGER :: nb
!! Atom index 2
INTEGER :: i
!! Cartesian direction 1
INTEGER :: j
!! Cartesian direction 1
INTEGER :: m1, m2, m3
!! Loop over q-points
!INTEGER :: nrx1, nrx2, nrx3
!
REAL(DP):: geg
!! <q+G| epsil | q+G>
REAL(DP) :: alph, fac,g1,g2,g3, facgd, arg, gmax
REAL(DP) :: zag(3),zbg(3),zcg(3), fnat(3)
!
COMPLEX(DP) :: facg
REAL(kind=DP) :: alph
!! Ewald parameter
REAL(kind=DP) :: fac
!! Missing definition
REAL(kind=DP) :: g1, g2, g3
!! Missing definition
REAL(kind=DP) :: facgd
!! fac * EXP(-geg / (alph * 4.0d0)) / geg
REAL(kind=DP) :: arg
!! Missing definition
REAL(kind=DP) :: gmax
!! Maximum G
REAL(kind=DP) :: zag(3)
!! Z * G
REAL(kind=DP) :: zbg(3)
!! Z * G
REAL(kind=DP) :: zcg(3)
!! Z * G
REAL(kind=DP) :: fnat(3)
!! Missing definition
COMPLEX(kind=DP) :: facg
!! Missing definition
!
! alph is the Ewald parameter, geg is an estimate of G^2
! such that the G-space sum is convergent for that alph
! very rough estimate: geg/4/alph > gmax = 14
! (exp (-14) = 10^-6)
!
IF ( abs(abs(signe) - 1.0) > eps6 ) &
CALL errore('rgd_blk',' wrong value for signe ',1)
gmax = 14.d0
alph = 1.0d0
geg = gmax * alph * 4.0d0
@ -75,104 +106,106 @@
! and nr2=1, then the G-vectors run along nr3 only.
! (useful if system is in vacuum, e.g. 1D or 2D)
!
IF (nq1 == 1) THEN
nrx1=0
ELSE
nrx1 = int( sqrt (geg) / &
sqrt (bg (1, 1) **2 + bg (2, 1) **2 + bg (3, 1) **2) ) + 1
ENDIF
IF (nq2 == 1) THEN
nrx2=0
ELSE
nrx2 = int( sqrt (geg) / &
sqrt (bg (1, 2) **2 + bg (2, 2) **2 + bg (3, 2) **2) ) + 1
ENDIF
IF (nq3 == 1) THEN
nrx3=0
ELSE
nrx3 = int( sqrt (geg) / &
sqrt (bg (1, 3) **2 + bg (2, 3) **2 + bg (3, 3) **2) ) + 1
ENDIF
! SP - Apr 2019 - Should be overkill
!IF (nq1 == 1) THEN
! nrx1=0
!ELSE
! nrx1 = int( sqrt (geg) / &
! sqrt (bg (1, 1) **2 + bg (2, 1) **2 + bg (3, 1) **2) ) + 1
!ENDIF
!IF (nq2 == 1) THEN
! nrx2=0
!ELSE
! nrx2 = int( sqrt (geg) / &
! sqrt (bg (1, 2) **2 + bg (2, 2) **2 + bg (3, 2) **2) ) + 1
!ENDIF
!IF (nq3 == 1) THEN
! nrx3=0
!ELSE
! nrx3 = int( sqrt (geg) / &
! sqrt (bg (1, 3) **2 + bg (2, 3) **2 + bg (3, 3) **2) ) + 1
!ENDIF
!
IF ( abs(abs(signe) - 1.0) > eps6 ) &
CALL errore('rgd_blk',' wrong value for signe ',1)
!
fac = signe*e2*fpi/omega
DO m1 = -nrx1, nrx1
DO m2 = -nrx2, nrx2
DO m3 = -nrx3, nrx3
fac = signe * e2 * fpi / omega
! DO m1 = -nrx1, nrx1
! DO m2 = -nrx2, nrx2
! DO m3 = -nrx3, nrx3
DO m1=-nq1, nq1
DO m2=-nq2, nq2
DO m3=-nq3, nq3
!
g1 = m1*bg(1,1) + m2*bg(1,2) + m3*bg(1,3)
g2 = m1*bg(2,1) + m2*bg(2,2) + m3*bg(2,3)
g3 = m1*bg(3,1) + m2*bg(3,2) + m3*bg(3,3)
g1 = m1 * bg(1, 1) + m2 * bg(1, 2) + m3 * bg(1,3)
g2 = m1 * bg(2, 1) + m2 * bg(2, 2) + m3 * bg(2,3)
g3 = m1 * bg(3, 1) + m2 * bg(3, 2) + m3 * bg(3,3)
!
geg = ( g1 * ( epsil(1,1)*g1 + epsil(1,2)*g2 + epsil(1,3)*g3 ) + &
g2 * ( epsil(2,1)*g1 + epsil(2,2)*g2 + epsil(2,3)*g3 ) + &
g3 * ( epsil(3,1)*g1 + epsil(3,2)*g2 + epsil(3,3)*g3 ) )
geg = (g1 * (epsil(1, 1) * g1 + epsil(1, 2) * g2 + epsil(1, 3) * g3) + &
g2 * (epsil(2, 1) * g1 + epsil(2, 2) * g2 + epsil(2, 3) * g3) + &
g3 * (epsil(3, 1) * g1 + epsil(3, 2) * g2 + epsil(3, 3) * g3))
!
IF ( geg > 0.0d0 .AND. geg/alph/4.0d0 < gmax ) THEN
IF ( geg > 0.0d0 .AND. geg / (alph * 4.0d0) < gmax ) THEN
!
facgd = fac * exp(-geg/alph/4.0d0) / geg
facgd = fac * EXP(-geg / (alph * 4.0d0)) / geg
!
DO na = 1, nat
zag(:) = g1*zeu(1,:,na) + g2*zeu(2,:,na) + g3*zeu(3,:,na)
DO na=1, nat
zag(:) = g1 * zeu(1, :, na) + g2 * zeu(2, :, na) + g3 * zeu(3, :, na)
fnat(:) = 0.d0
DO nb = 1,nat
arg = 2.d0*pi* ( g1 * ( tau(1,na) - tau(1,nb) ) + &
g2 * ( tau(2,na) - tau(2,nb) ) + &
g3 * ( tau(3,na) - tau(3,nb) ) )
zcg(:) = g1*zeu(1,:,nb) + g2*zeu(2,:,nb) + g3*zeu(3,:,nb)
fnat(:) = fnat(:) + zcg(:)*cos(arg)
DO nb=1, nat
arg = 2.d0 * pi * (g1 * (tau(1, na) - tau(1, nb)) + &
g2 * (tau(2, na) - tau(2, nb)) + &
g3 * (tau(3, na) - tau(3, nb)))
zcg(:) = g1 * zeu(1, :, nb) + g2 * zeu(2, :, nb) + g3 * zeu(3, :, nb)
fnat(:) = fnat(:) + zcg(:) * COS(arg)
ENDDO
DO j = 1, 3
DO i = 1, 3
dyn( (na-1)*3+i,(na-1)*3+j ) = dyn((na-1)*3+i,(na-1)*3+j) &
DO j=1, 3
DO i=1, 3
dyn((na - 1) * 3 + i, (na - 1) * 3 + j) = dyn((na - 1) * 3 + i,(na - 1) * 3 + j) &
- facgd * zag(i) * fnat(j)
ENDDO
ENDDO
ENDDO
ENDIF
ENDDO ! i
ENDDO ! j
ENDDO ! nat
ENDIF ! geg
!
g1 = g1 + q(1)
g2 = g2 + q(2)
g3 = g3 + q(3)
!
geg = ( g1 * ( epsil(1,1)*g1 + epsil(1,2)*g2 + epsil(1,3)*g3 ) + &
g2 * ( epsil(2,1)*g1 + epsil(2,2)*g2 + epsil(2,3)*g3 ) + &
g3 * ( epsil(3,1)*g1 + epsil(3,2)*g2 + epsil(3,3)*g3 ) )
geg = (g1 * (epsil(1, 1) * g1 + epsil(1, 2) * g2 + epsil(1, 3) * g3) + &
g2 * (epsil(2, 1) * g1 + epsil(2, 2) * g2 + epsil(2, 3) * g3) + &
g3 * (epsil(3, 1) * g1 + epsil(3, 2) * g2 + epsil(3, 3) * g3))
!
IF ( geg > 0.0d0 .AND. geg/alph/4.0d0 < gmax ) THEN
IF ( geg > 0.0d0 .AND. geg / (alph * 4.0d0) < gmax ) THEN
!
facgd = fac * exp(-geg/alph/4.0d0) / geg
facgd = fac * exp(- geg / (alph * 4.0d0)) / geg
!
DO nb = 1,nat
zbg(:) = g1*zeu(1,:,nb) + g2*zeu(2,:,nb) + g3*zeu(3,:,nb)
DO na = 1, nat
zag(:) = g1*zeu(1,:,na) + g2*zeu(2,:,na) + g3*zeu(3,:,na)
arg = 2.d0*pi* ( g1 * ( tau(1,na) - tau(1,nb) ) + &
g2 * ( tau(2,na) - tau(2,nb) ) + &
g3 * ( tau(3,na) - tau(3,nb) ) )
DO nb=1, nat
zbg(:) = g1 * zeu(1, :, nb) + g2 * zeu(2, :, nb) + g3 * zeu(3, :, nb)
DO na=1, nat
zag(:) = g1 * zeu(1, :, na) + g2 * zeu(2, :, na) + g3 * zeu(3, :, na)
arg = 2.d0 * pi * (g1 * (tau(1, na) - tau(1 ,nb)) + &
g2 * (tau(2, na) - tau(2, nb)) + &
g3 * (tau(3, na) - tau(3, nb)) )
!
facg = facgd * CMPLX(cos(arg),sin(arg),DP)
DO j = 1, 3
DO i = 1, 3
dyn( (na-1)*3+i,(nb-1)*3+j ) = dyn((na-1)*3+i,(nb-1)*3+j) &
facg = facgd * CMPLX(COS(arg), SIN(arg), DP)
DO j=1, 3
DO i=1, 3
dyn((na - 1) * 3 + i, (nb - 1) * 3 + j) = dyn((na - 1) * 3 + i, (nb - 1) * 3 + j) &
+ facg * zag(i) * zbg(j)
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO ! i
ENDDO ! j
ENDDO ! na
ENDDO ! nb
ENDIF
!
ENDDO
ENDDO
ENDDO
!
END SUBROUTINE rgd_blk
!
ENDDO ! m3
ENDDO ! m2
ENDDO ! m1
!
!-------------------------------------------------------------------------------
SUBROUTINE rgd_blk_epw( nq1, nq2, nq3, q, uq, epmat, nmodes, epsil, zeu, bmat, signe )
END SUBROUTINE rgd_blk
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
SUBROUTINE rgd_blk_epw (nq1, nq2, nq3, q, uq, epmat, nmodes, epsil, zeu, bmat, signe)
!-------------------------------------------------------------------------------
!!
!! Compute the long range term for the e-ph vertex
@ -215,9 +248,9 @@
!
REAL (kind=DP), INTENT (in) :: q(3)
!! q-vector from the full coarse or fine grid.
REAL (kind=DP), INTENT (in) :: epsil(3,3)
REAL (kind=DP), INTENT (in) :: epsil(3, 3)
!! dielectric constant tensor
REAL (kind=DP), INTENT (in) :: zeu(3,3,nat)
REAL (kind=DP), INTENT (in) :: zeu(3, 3, nat)
!! effective charges tensor
REAL (kind=DP), INTENT (in) :: signe
!! signe=+/-1.0 ==> add/subtract long range term
@ -231,18 +264,43 @@
!
! work variables
!
INTEGER :: na, ipol, m1, m2, m3 !, nrx1, nrx2, nrx3
REAL(DP) :: qeq
INTEGER :: na
!! Atom index 1
INTEGER :: nb
!! Atom index 2
INTEGER :: ipol
!! Polarison
INTEGER :: m1, m2, m3
!! Loop over q-points
!
REAL(kind=DP) :: qeq
!! <q+G| epsil | q+G>
REAL(DP) :: arg, zaq, g1, g2, g3, gmax, alph, geg
REAL(kind=DP) :: arg
!!
REAL(kind=DP) :: zaq
!!
REAL(kind=DP) :: g1, g2, g3
!!
REAL(kind=DP) :: gmax
!!
REAL(kind=DP) :: alph
!!
REAL(kind=DP) :: geg
!!
!
COMPLEX(DP) :: fac, facqd, facq, epmatl(nmodes)
COMPLEX(kind=DP) :: fac
!!
COMPLEX(kind=DP) :: facqd
!!
COMPLEX(kind=DP) :: facq
!!
COMPLEX(kind=DP) :: epmatl(nmodes)
!! Long-range part of the el-ph matrix elements
!
IF( abs ( abs(signe) - 1.0 ) > eps12 ) &
CALL errore('rgd_blk',' wrong value for signe ',1)
IF(ABS(ABS(signe) - 1.0) > eps12) &
CALL errore('rgd_blk_epw','Erong value for signe ',1)
!
gmax = 14.d0
gmax = 14.d0
alph = 1.0d0
geg = gmax * alph * 4.0d0
fac = signe * e2 * fpi / omega * ci
@ -267,42 +325,41 @@
! ENDIF
!
epmatl(:) = czero
!
!DO m1 = -nrx1, nrx1
! TO be test
DO m1 = -nq1, nq1
DO m2 = -nq2, nq2
DO m3 = -nq3, nq3
DO m1=-nq1, nq1
DO m2=-nq2, nq2
DO m3=-nq3, nq3
!
g1 = m1*bg(1,1) + m2*bg(1,2) + m3*bg(1,3) + q(1)
g2 = m1*bg(2,1) + m2*bg(2,2) + m3*bg(2,3) + q(2)
g3 = m1*bg(3,1) + m2*bg(3,2) + m3*bg(3,3) + q(3)
g1 = m1 * bg(1, 1) + m2 * bg(1, 2) + m3 * bg(1, 3) + q(1)
g2 = m1 * bg(2, 1) + m2 * bg(2, 2) + m3 * bg(2, 3) + q(2)
g3 = m1 * bg(3, 1) + m2 * bg(3, 2) + m3 * bg(3, 3) + q(3)
!
qeq = ( g1 * ( epsil(1,1)*g1 + epsil(1,2)*g2 + epsil(1,3)*g3 ) + &
g2 * ( epsil(2,1)*g1 + epsil(2,2)*g2 + epsil(2,3)*g3 ) + &
g3 * ( epsil(3,1)*g1 + epsil(3,2)*g2 + epsil(3,3)*g3 ) ) !*twopi/alat
qeq = (g1 * (epsil(1, 1) * g1 + epsil(1, 2) * g2 + epsil(1, 3) * g3) + &
g2 * (epsil(2, 1) * g1 + epsil(2, 2) * g2 + epsil(2, 3) * g3) + &
g3 * (epsil(3, 1) * g1 + epsil(3, 2) * g2 + epsil(3, 3) * g3)) !*twopi/alat
!
IF ( qeq > 0.0d0 .AND. qeq/alph/4.0d0 < gmax ) THEN
IF ( qeq > 0.0d0 .AND. qeq / (alph * 4.0d0) < gmax ) THEN
!
qeq = qeq * twopi / alat
facqd = fac * exp(-qeq/alph/4.0d0 ) /qeq !/(two*wq)
facqd = fac * EXP(-qeq / (alph * 4.0d0)) / qeq !/(two*wq)
!
DO na = 1, nat
arg = -twopi * ( g1*tau(1,na) + g2*tau(2,na) + g3*tau(3,na) )
facq = facqd * CMPLX(cos(arg),sin(arg),DP)
DO ipol = 1, 3
zaq = g1*zeu(1,ipol,na) + g2*zeu(2,ipol,na) + g3*zeu(3,ipol,na)
DO na=1, nat
arg = - twopi * (g1 * tau(1, na) + g2 * tau(2, na) + g3 * tau(3, na))
facq = facqd * CMPLX(COS(arg), SIN(arg), DP)
DO ipol=1, 3
zaq = g1 * zeu(1, ipol, na) + g2 * zeu(2, ipol, na) + g3 * zeu(3, ipol, na)
!
epmat = epmat + facq * zaq * uq(3*(na-1)+ipol,:) * bmat
epmatl = epmatl + facq * zaq * uq(3*(na-1)+ipol,:) * bmat
epmat = epmat + facq * zaq * uq(3 * (na - 1) + ipol, :) * bmat
epmatl = epmatl + facq * zaq * uq(3 * (na - 1) + ipol, :) * bmat
!
ENDDO !ipol
ENDDO !nat
ENDIF
!
ENDDO
ENDDO
ENDDO
ENDDO ! m3
ENDDO ! m2
ENDDO ! m1
!
! In case we want only the short-range we do
! g_s = sqrt(g*g - g_l*g_l)
@ -313,15 +370,15 @@
! In any case, when g_s will be squared both will become real numbers.
IF (shortrange) THEN
!epmat = ZSQRT(epmat*conjg(epmat) - epmatl*conjg(epmatl))
epmat = SQRT(epmat*conjg(epmat) - epmatl*conjg(epmatl))
epmat = SQRT(epmat * CONJG(epmat) - epmatl * CONJG(epmatl))
ENDIF
!
!
!-------------------------------------------------------------------------------
END SUBROUTINE rgd_blk_epw
!
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
SUBROUTINE rgd_blk_epw_fine( nq1, nq2, nq3, q, uq, epmat, nmodes, epsil, zeu, bmat, signe )
SUBROUTINE rgd_blk_epw_fine (nq1, nq2, nq3, q, uq, epmat, nmodes, epsil, zeu, bmat, signe)
!-------------------------------------------------------------------------------
!!
!! Compute the long range term for the e-ph vertex
@ -354,44 +411,70 @@
!
IMPLICIT NONE
!
INTEGER, INTENT (in) :: nq1
INTEGER, INTENT(in) :: nq1
!! Coarse q-point grid
INTEGER, INTENT (in) :: nq2
INTEGER, INTENT(in) :: nq2
!! Coarse q-point grid
INTEGER, INTENT (in) :: nq3
INTEGER, INTENT(in) :: nq3
!! Coarse q-point grid
INTEGER, INTENT (in) :: nmodes
INTEGER, INTENT(in) :: nmodes
!! Max number of modes
!
REAL (kind=DP), INTENT (in) :: q(3)
REAL (kind=DP), INTENT(in) :: q(3)
!! q-vector from the full coarse or fine grid.
REAL (kind=DP), INTENT (in) :: epsil(3,3)
REAL (kind=DP), INTENT(in) :: epsil(3, 3)
!! dielectric constant tensor
REAL (kind=DP), INTENT (in) :: zeu(3,3,nat)
REAL (kind=DP), INTENT(in) :: zeu(3, 3, nat)
!! effective charges tensor
REAL (kind=DP), INTENT (in) :: signe
REAL (kind=DP), INTENT(in) :: signe
!! signe=+/-1.0 ==> add/subtract long range term
!
COMPLEX (kind=DP), INTENT (in) :: uq(nmodes, nmodes)
COMPLEX (kind=DP), INTENT(in) :: uq(nmodes, nmodes)
!! phonon eigenvec associated with q
COMPLEX (kind=DP), INTENT (inout) :: epmat(nbndsub,nbndsub,nmodes)
COMPLEX (kind=DP), INTENT(inout) :: epmat(nbndsub, nbndsub, nmodes)
!! e-ph matrix elements
COMPLEX (kind=DP), INTENT (in) :: bmat(nbndsub,nbndsub)
COMPLEX (kind=DP), INTENT(in) :: bmat(nbndsub, nbndsub)
!! Overlap matrix elements $$<U_{mk+q}|U_{nk}>$$
!
! work variables
!
INTEGER :: na, ipol, m1,m2,m3, imode
INTEGER :: na
!! Atom index 1
INTEGER :: nb
!! Atom index 2
INTEGER :: ipol
!! Polarison
INTEGER :: m1, m2, m3
!! Loop over q-points
INTEGER :: imode
!! Mode index
!
REAL(DP) :: qeq
!!&! <q+G| epsil | q+G>
REAL(DP) :: arg, zaq, g1, g2, g3, gmax, alph, geg
REAL(kind=DP) :: qeq
!! <q+G| epsil | q+G>
REAL(kind=DP) :: arg
!!
REAL(kind=DP) :: zaq
!!
REAL(kind=DP) :: g1, g2, g3
!!
REAL(kind=DP) :: gmax
!!
REAL(kind=DP) :: alph
!!
REAL(kind=DP) :: geg
!!
!
COMPLEX(DP) :: fac, facqd, facq
COMPLEX(DP) :: epmatl(nbndsub,nbndsub,nmodes)
COMPLEX(kind=DP) :: fac
!!
COMPLEX(kind=DP) :: facqd
!!
COMPLEX(kind=DP) :: facq
!!
COMPLEX(kind=DP) :: epmatl(nbndsub, nbndsub, nmodes)
!! Long-range part of the matrix element
!
IF ( abs( abs(signe) - 1.0 ) > eps12 ) &
CALL errore ('rgd_blk',' wrong value for signe ',1)
IF (ABS(ABS(signe) - 1.0) > eps12) &
CALL errore ('rgd_blk_epw_fine','Wrong value for signe ',1)
!
gmax = 14.d0
alph = 1.0d0
@ -400,41 +483,41 @@
!
epmatl(:,:,:) = czero
!
DO m1 = -nq1, nq1
DO m2 = -nq2, nq2
DO m3 = -nq3, nq3
DO m1=-nq1, nq1
DO m2=-nq2, nq2
DO m3=-nq3, nq3
!
g1 = m1*bg(1,1) + m2*bg(1,2) + m3*bg(1,3) + q(1)
g2 = m1*bg(2,1) + m2*bg(2,2) + m3*bg(2,3) + q(2)
g3 = m1*bg(3,1) + m2*bg(3,2) + m3*bg(3,3) + q(3)
g1 = m1 * bg(1, 1) + m2 * bg(1, 2) + m3 * bg(1, 3) + q(1)
g2 = m1 * bg(2, 1) + m2 * bg(2, 2) + m3 * bg(2, 3) + q(2)
g3 = m1 * bg(3, 1) + m2 * bg(3, 2) + m3 * bg(3, 3) + q(3)
!
qeq = ( g1 * (epsil(1,1)*g1 + epsil(1,2)*g2 + epsil(1,3)*g3 ) + &
g2 * (epsil(2,1)*g1 + epsil(2,2)*g2 + epsil(2,3)*g3 ) + &
g3 * (epsil(3,1)*g1 + epsil(3,2)*g2 + epsil(3,3)*g3 ) ) !*twopi/alat
qeq = (g1 * (epsil(1, 1) * g1 + epsil(1, 2) * g2 + epsil(1, 3) * g3) + &
g2 * (epsil(2, 1) * g1 + epsil(2, 2) * g2 + epsil(2, 3) * g3) + &
g3 * (epsil(3, 1) * g1 + epsil(3, 2) * g2 + epsil(3, 3) * g3)) !*twopi/alat
!
IF (qeq > 0.0d0 .AND. qeq/alph/4.0d0 < gmax ) THEN
IF (qeq > 0.0d0 .AND. qeq / (alph * 4.0d0) < gmax ) THEN
!
qeq = qeq * twopi / alat
facqd = fac * exp(-qeq/alph/4.0d0) / qeq !/(two*wq)
facqd = fac * EXP(-qeq / (alph * 4.0d0)) / qeq !/(two*wq)
!
DO na = 1, nat
arg = -twopi* ( g1*tau(1,na)+ g2*tau(2,na)+ g3*tau(3,na) )
facq = facqd * CMPLX(cos(arg),sin(arg),DP)
DO ipol = 1, 3
zaq = g1*zeu(1,ipol,na) + g2*zeu(2,ipol,na) + g3*zeu(3,ipol,na)
DO na=1, nat
arg = -twopi * (g1 * tau(1, na) + g2 * tau(2, na) + g3 * tau(3, na))
facq = facqd * CMPLX(COS(arg), SIN(arg), DP)
DO ipol=1, 3
zaq = g1 * zeu(1, ipol, na) + g2 * zeu(2, ipol, na) + g3 * zeu(3, ipol, na)
!
DO imode=1, nmodes
CALL zaxpy(nbndsub**2, facq * zaq * uq(3*(na-1)+ipol,imode), bmat(:,:), 1, epmat(:,:,imode), 1)
CALL zaxpy(nbndsub**2, facq * zaq * uq(3*(na-1)+ipol,imode), bmat(:,:), 1, epmatl(:,:,imode), 1)
CALL zaxpy(nbndsub**2, facq * zaq * uq(3 * (na - 1) + ipol, imode), bmat(:, :), 1, epmat(:, :, imode), 1)
CALL zaxpy(nbndsub**2, facq * zaq * uq(3 * (na - 1) + ipol, imode), bmat(:, :), 1, epmatl(:, :, imode), 1)
ENDDO
!
ENDDO !ipol
ENDDO !nat
ENDIF
!
ENDDO
ENDDO
ENDDO
ENDDO ! m3
ENDDO ! m2
ENDDO ! m1
!
! In case we want only the short-range we do
! g_s = sqrt(g*g - g_l*g_l)
@ -445,14 +528,15 @@
! In any case, when g_s will be squared both will become real numbers.
IF (shortrange) THEN
!epmat = ZSQRT(epmat*conjg(epmat) - epmatl*conjg(epmatl))
epmat = SQRT(epmat*conjg(epmat) - epmatl*conjg(epmatl))
epmat = SQRT(epmat * CONJG(epmat) - epmatl * CONJG(epmatl))
ENDIF
!
!
!-----------------------------------------------------------------------------
END SUBROUTINE rgd_blk_epw_fine
!-----------------------------------------------------------------------------
!
!-----------------------------------------------------------------------------
SUBROUTINE rpa_epsilon( q, w, nmodes, epsil, eps_rpa )
SUBROUTINE rpa_epsilon (q, w, nmodes, epsil, eps_rpa)
!-----------------------------------------------------------------------------
!
! Compute the Lindhard dielectric function for the homogeneous electron gas
@ -522,10 +606,10 @@
n = nel / omega
EF = fermi_diff / ha2ev
kF = (3.d0 * pi**2 * n)**(1.d0/3.d0)
eps_ave = ( epsil(1,1) + epsil(2,2) + epsil(3,3) ) / 3.d0
rs = ( 3.d0 / ( 4.d0 * pi * n ) )**(1.d0/3.d0) * meff /eps_ave
eps_ave = (epsil(1, 1) + epsil(2, 2) + epsil(3, 3)) / 3.d0
rs = (3.d0 / ( 4.d0 * pi * n ) )**(1.d0/3.d0) * meff / eps_ave
w = w * 0.5d0 / EF / 4.d0 !Ha&internal units for Hedin's formula
pref = ( 4.d0 / 9.d0 / pi )**(1.d0/3.0) * ( rs / 8.d0 / pi )
pref = (4.d0 / 9.d0 / pi )**(1.d0 / 3.0) * (rs / 8.d0 / pi)
eta = smear_rpa / ha2ev / EF / 4.d0
!
IF (first_call) THEN
@ -535,18 +619,18 @@
!WRITE(stdout,'(a,f12.8,a,f12.8)') ' omega(nmodes) (eV) ', w(nmodes)*ha2ev*EF*4.d0,' eta ',eta*EF*4.d0*ha2ev
WRITE(stdout,'(5x,a,f12.8,a,f12.8,a,f12.8)') 'Nel = ', nel, ', n = ', n, ' au^-3, meff = ', meff
WRITE(stdout,'(5x,a,f12.8,a,f12.8,a,f12.8)') 'EF = ', EF*ha2ev, ' eV, kF = ', kF, ' au^-1, rs = ', rs
IF (eps_ave .lt. eps5) WRITE(stdout,'(5x,"Warning: dielectric constant not found; set to 1")')
IF (eps_ave < eps5) WRITE(stdout,'(5x,"Warning: dielectric constant not found; set to 1")')
ENDIF
IF (eps_ave .lt. eps5) eps_ave = 1.d0
IF (eps_ave < eps5) eps_ave = 1.d0
!
CALL cryst_to_cart(1, q, bg, 1)
q2 = q(1)**2 + q(2)**2 + q(3)**2
qm = sqrt(q2) * ( twopi / alat ) / kF / 2.d0 ! internal units for Hedin's formula
!
IF ( abs(qm) .gt. eps10 ) THEN
DO im = 1, nmodes
u = w(im) + sign(eta,w(im)) * ci
eps_rpa(im) = 1.d0 + pref * ( H_eps(qm+u/qm) + H_eps(qm-u/qm) ) / qm**3
IF (ABS(qm) > eps10 ) THEN
DO im=1, nmodes
u = w(im) + SIGN(eta, w(im)) * ci
eps_rpa(im) = 1.d0 + pref * ( H_eps(qm + u / qm) + H_eps( qm - u / qm) ) / qm**3
!WRITE(stdout,'(a)') " ! epsilon(q,w) "
!WRITE(stdout,'(f12.8,i4,3f12.8)') qm*2*kF/(2.d0*pi/alat), im,
!real(eps_rpa(im)), aimag(eps_rpa(im)), abs(eps_rpa(im))
@ -558,35 +642,44 @@
w = w / ( 0.5d0 / EF / 4.d0 )
CALL cryst_to_cart(1, q, at, -1)
!
!--------------------------------------------------------------------------
END SUBROUTINE rpa_epsilon
!--------------------------------------------------------------------------
!
!--------------------------------------------------------------------------
COMPLEX(DP) FUNCTION H_eps(z)
COMPLEX(DP) FUNCTION H_eps (z)
!--------------------------------------------------------------------------
! Function used in the Lindhard function. See Eq.(56) of Hedin (1965)
USE kinds, ONLY : DP
!!
!! Function used in the Lindhard function. See Eq.(56) of Hedin (1965)
!!
!--------------------------------------------------------------------------
USE kinds, ONLY : DP
USE constants_epw, ONLY : eps10
!
IMPLICIT NONE
!
COMPLEX(DP), INTENT (in) :: z
!! Argument of the Lindhard function
!
IF ( abs(z-1.d0) .gt. 1.d-10 ) THEN
IF ( abs( (z+1.d0) / (z-1.d0) ) .gt. 1.d-10 ) THEN
H_eps = 2.d0 * z + ( 1.d0 - z**2 ) * log( (z+1.d0) / (z-1.d0) )
IF (ABS(z - 1.d0) > eps10) THEN
IF (ABS( (z + 1.d0) / (z - 1.d0) ) > eps10) THEN
H_eps = 2.d0 * z + ( 1.d0 - z**2 ) * LOG( (z + 1.d0) / (z - 1.d0))
ENDIF
ENDIF
!
RETURN
!
!--------------------------------------------------------------------------
END FUNCTION H_eps
!--------------------------------------------------------------------------
!
!--------------------------------------------------------------------------
SUBROUTINE tf_epsilon( q, nmodes, epsil, eps_tf )
SUBROUTINE tf_epsilon (q, nmodes, epsil, eps_tf)
!--------------------------------------------------------------------------
!!
!! Compute the Thomas-Fermi dielectric screening
!!
!--------------------------------------------------------------------------
!
! Compute the Thomas-Fermi dielectric screening
!
USE kinds, ONLY : DP
USE cell_base, ONLY : at, bg, omega, alat
USE constants_epw, ONLY : pi, twopi, ha2ev, cone, eps5, eps10
@ -628,9 +721,9 @@
!
n = nel / omega
EF = fermi_diff / ha2ev
eps_ave = ( epsil(1,1) + epsil(2,2) + epsil(3,3) ) / 3.d0
qtf = ( 6.d0 * pi * n / EF / eps_ave )**(1.d0/2.d0)
qtfc = qtf / ( twopi / alat )
eps_ave = (epsil(1, 1) + epsil(2, 2) + epsil(3, 3)) / 3.d0
qtf = (6.d0 * pi * n / EF / eps_ave )**(1.d0 / 2.d0)
qtfc = qtf / (twopi / alat)
!
IF (first_call) THEN
first_call = .false.
@ -638,14 +731,14 @@
WRITE(stdout,'(5x,"Warning: current implementation for doubly degenerate band, one valley")')
WRITE(stdout,'(5x,a,f12.8,a,f12.8,a,f12.8)') 'Nel = ', nel, ', n = ', n, ' au^-3, EF (eV) = ', EF*ha2ev
WRITE(stdout,'(5x,a,f12.8,a,f12.8)') 'q_tf (au-1) = ', qtf, ', q_tf (tpiba) = ', qtfc
IF (eps_ave .lt. eps5) WRITE(stdout,'(5x,"Warning: dielectric constant not found; set to 1")')
IF (eps_ave < eps5) WRITE(stdout,'(5x,"Warning: dielectric constant not found; set to 1")')
ENDIF
IF (eps_ave .lt. eps5) eps_ave = 1.d0
IF (eps_ave < eps5) eps_ave = 1.d0
!
CALL cryst_to_cart(1, q, bg, 1)
q2 = q(1)**2 + q(2)**2 + q(3)**2
qm = sqrt(q2) ! in tpiba
IF ( abs(qm) .gt. eps10 ) THEN
qm = SQRT(q2) ! in tpiba
IF (ABS(qm) > eps10) THEN
eps_tf = 1.d0 + qtfc**2 / q2
!WRITE(stdout,'(a)') " ! epsilon_tf "
!WRITE(stdout,'(2f12.8)') qm, real(eps_tf)
@ -655,10 +748,12 @@
!
CALL cryst_to_cart (1, q, at, -1)
!
!--------------------------------------------------------------------------
END SUBROUTINE tf_epsilon
!--------------------------------------------------------------------------
!
!-----------------------------------------------------------------------
SUBROUTINE compute_umn_f( nbnd, cufkk, cufkq, bmatf )
SUBROUTINE compute_umn_f (nbnd, cufkk, cufkq, bmatf)
!-----------------------------------------------------------------------
!!
!! Calculates $$ U_{k+q} U_k^\dagger = <\Psi_{mk+q}|e^{i{q+G}r}|\Psi_{nk}> $$
@ -696,7 +791,7 @@
END SUBROUTINE compute_umn_f
!
!-----------------------------------------------------------------------
SUBROUTINE compute_umn_c( nbnd, nbndsub, nks, cuk, cukq, bmat )
SUBROUTINE compute_umn_c (nbnd, nbndsub, nks, cuk, cukq, bmat)
!-----------------------------------------------------------------------
!!
!! Calculates $$ U_{k+q} U_k^\dagger = <\Psi_{mk+q}|e^{i(q+G)r}|\Psi_{nk}> $$
@ -714,9 +809,9 @@
INTEGER, INTENT(in) :: nbndsub
!! Number of band on the subspace of Wannier
!
COMPLEX(kind=DP), INTENT(in) :: cuk(nbnd,nbndsub,nks)
COMPLEX(kind=DP), INTENT(in) :: cuk(nbnd, nbndsub, nks)
!! rotation matrix U(k), coarse mesh
COMPLEX(kind=DP), INTENT(in) :: cukq(nbnd,nbndsub,nks)
COMPLEX(kind=DP), INTENT(in) :: cukq(nbnd, nbndsub, nks)
!! rotation matrix U(k+q), coarse mesh
COMPLEX(kind=DP), INTENT(out) :: bmat(nbnd, nbnd, nks)
!! overlap wfcs in Bloch representation, fine grid

16
EPW/src/rotate_eigenm.f90
View File

@ -115,12 +115,12 @@
0, 0,-1.0, neig, w1, cz1, nmodes, cwork, &
rwork, iwork, ifail, info)
!
IF (iverbosity.eq.1) then
IF (iverbosity == 1) then
!
! check the frequencies
!
DO nu = 1, nmodes
IF ( w1 (nu) .gt. 0.d0 ) then
IF ( w1 (nu) > 0.d0 ) then
wtmp(nu) = sqrt(abs( w1 (nu) ))
ELSE
wtmp(nu) = -sqrt(abs( w1 (nu) ))
@ -171,7 +171,7 @@
!
! possibly run some consistency checks
!
IF ( iverbosity .eq. 1 ) then
IF ( iverbosity == 1 ) then
!
! D_{Sq} = gamma * D_q * gamma^\dagger (Maradudin & Vosko, RMP, eq. 3.5)
!
@ -194,7 +194,7 @@
! check the frequencies
!
DO nu = 1, nmodes
IF ( w2 (nu) .gt. 0.d0 ) then
IF ( w2 (nu) > 0.d0 ) then
wtmp(nu) = sqrt(abs( w2 (nu) ))
ELSE
wtmp(nu) = -sqrt(abs( w2 (nu) ))
@ -223,7 +223,7 @@
END DO
!
! the rotated matrix and the one read from file
IF (iverbosity.eq.1) write (6,'(2f15.10)') dyn2-dyn1
IF (iverbosity == 1) write (6,'(2f15.10)') dyn2-dyn1
!
! here I have checked that the matrix rotated with gamma
! is perfectly equal to the one read from file for this q in the star
@ -236,17 +236,17 @@
DO nu = 1, nmodes
w2(nu) = abs(dyn2(nu,nu))
DO mu = 1, nmodes
IF ( mu.ne.nu .and. abs(dyn2(mu,nu)).gt.eps ) call errore &
IF ( mu.ne.nu .and. abs(dyn2(mu,nu)) > eps ) call errore &
('rotate_eigenm','problem with rotated eigenmodes',0)
ENDDO
ENDDO
!
IF (iverbosity.eq.1) then
IF (iverbosity == 1) then
!
! a simple check on the frequencies
!
DO nu = 1, nmodes
IF ( w2 (nu) .gt. 0.d0 ) then
IF ( w2 (nu) > 0.d0 ) then
wtmp(nu) = sqrt(abs( w2 (nu) ))
ELSE
wtmp(nu) = -sqrt(abs( w2 (nu) ))

2
EPW/src/rotate_epmat.f90
View File

@ -114,7 +114,7 @@
!
epmatq_opt = czero
epmatq_tmp = czero
IF (nexband_tmp .gt. 0) THEN
IF (nexband_tmp > 0) THEN
DO ik = 1, nks
jbnd = 0
DO j = 1, nbnd

211
EPW/src/selfen_elec.f90
View File

@ -37,7 +37,7 @@
fsthick, eptemp, ngaussw, degaussw, &
eps_acustic, efermi_read, fermi_energy,&
restart, restart_freq
USE pwcom, ONLY : ef !, nelec, isk
USE pwcom, ONLY : ef
USE elph2, ONLY : etf, ibndmin, ibndmax, nkqf, xqf, &
nkf, epf17, wf, wqf, xkf, nkqtotf, &
sigmar_all, sigmai_all, sigmai_mode, zi_all, efnew
@ -126,8 +126,6 @@
!! If the phonon frequency is too small discart g
REAL(kind=DP) :: inv_degaussw
!! Inverse of the smearing for efficiency reasons
!REAL(kind=DP), external :: efermig
!! Function to compute the Fermi energy
REAL(kind=DP), external :: dos_ef
!! Function to compute the Density of States at the Fermi level
REAL(kind=DP), external :: wgauss
@ -146,13 +144,13 @@
inv_eptemp0 = 1.0/eptemp
inv_degaussw = 1.0/degaussw
!
IF ( iqq == 1 ) THEN
IF (iqq == 1) THEN
!
WRITE(stdout,'(/5x,a)') repeat('=',67)
WRITE(stdout,'(5x,"Electron (Imaginary) Self-Energy in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick .lt. 1.d3 ) &
IF (fsthick < 1.d3) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Golden Rule strictly enforced with T = ',eptemp * ryd2ev, ' eV'
@ -161,20 +159,17 @@
!
! Fermi level and corresponding DOS
!
IF ( efermi_read ) THEN
IF (efermi_read) THEN
!
ef0 = fermi_energy
!
ELSE
!
ef0 = efnew
!ef0 = efermig(etf,nbndsub,nkqf,nelec,wkf,degaussw,ngaussw,0,isk)
! if some bands are skipped (nbndskip.neq.0), nelec has already been recalculated
! in ephwann_shuffle
!
ENDIF
!
IF ( iqq == 1 ) THEN
IF (iqq == 1) THEN
WRITE (stdout, 100) degaussw * ryd2ev, ngaussw
WRITE (stdout,'(a)') ' '
ENDIF
@ -194,19 +189,6 @@
!
ENDIF
!
IF ( iq .eq. 1 ) THEN
IF ( .not. ALLOCATED (sigmar_all) ) ALLOCATE( sigmar_all(ibndmax-ibndmin+1, nksqtotf) )
IF ( .not. ALLOCATED (sigmai_all) ) ALLOCATE( sigmai_all(ibndmax-ibndmin+1, nksqtotf) )
IF ( .not. ALLOCATED (zi_all) ) ALLOCATE( zi_all(ibndmax-ibndmin+1, nksqtotf) )
IF ( iverbosity == 3 ) THEN
IF ( .not. ALLOCATED (sigmai_mode) ) ALLOCATE( sigmai_mode(ibndmax-ibndmin+1, nmodes, nksqtotf) )
sigmai_mode(:,:,:) = zero
ENDIF
sigmar_all(:,:) = zero
sigmai_all(:,:) = zero
zi_all(:,:) = zero
ENDIF
!
! In the case of a restart do not add the first step
IF (first_cycle) THEN
first_cycle = .FALSE.
@ -223,20 +205,20 @@
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
! (but in this case they are the same)
!
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .and. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
IF (( MINVAL(ABS(etf(:, ikk) - ef)) < fsthick) .AND. &
( MINVAL(ABS(etf(:, ikq) - ef)) < fsthick)) THEN
!
fermicount = fermicount + 1
DO imode = 1, nmodes
DO imode=1, nmodes
!
! the phonon frequency and Bose occupation
wq = wf (imode, iq)
!
! SP: Avoid if statement in inner loops
IF (wq .gt. eps_acustic) THEN
IF (wq > eps_acustic) THEN
! SP: Define the inverse for efficiency
inv_wq = 1.0/( two * wq )
wgq = wgauss( -wq*inv_eptemp0, -99)
wgq = wgauss( -wq * inv_eptemp0, -99)
wgq = wgq / ( one - two * wgq )
g2_tmp = 1.0
ELSE
@ -245,12 +227,12 @@
g2_tmp = 0.0
ENDIF
!
DO ibnd = 1, ibndmax-ibndmin+1
DO ibnd=1, ibndmax-ibndmin+1
!
! the energy of the electron at k (relative to Ef)
ekk = etf (ibndmin-1+ibnd, ikk) - ef0
!
DO jbnd = 1, ibndmax-ibndmin+1
DO jbnd=1, ibndmax-ibndmin+1
!
! the fermi occupation for k+q
ekq = etf (ibndmin-1+jbnd, ikq) - ef0
@ -277,7 +259,6 @@
( ( wgkq + wgq ) / ( ekk - ( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( ekk - ( ekq + wq ) - ci * degaussw ) ) )
! ecutse needs to be defined if it's used
!@ if ( abs(ekq-ekk) .gt. ecutse ) weight = 0.d0
!
sigmar_all(ibnd,ik+lower_bnd-1) = sigmar_all(ibnd,ik+lower_bnd-1) + g2 * weight
!
@ -285,7 +266,6 @@
! weight = wqf(iq) * aimag ( &
! ( ( wgkq + wgq ) / ( ekk - ( ekq - wq ) - ci * degaussw ) + &
! ( one - wgkq + wgq ) / ( ekk - ( ekq + wq ) - ci * degaussw ) ) )
!@ if ( abs(ekq-ekk) .gt. ecutse ) weight = 0.d0
!
! Delta implementation
w0g1=w0gauss( (ekk-ekq+wq)/degaussw, 0) /degaussw
@ -307,11 +287,10 @@
! Z FACTOR: -\frac{\partial\Re\Sigma}{\partial\omega}
!
weight = wqf(iq) * &
( ( wgkq + wgq ) * ( (ekk - ( ekq - wq ))**two - degaussw**two ) / &
( (ekk - ( ekq - wq ))**two + degaussw**two )**two + &
( one - wgkq + wgq ) * ( (ekk - ( ekq + wq ))**two - degaussw**two ) / &
( (ekk - ( ekq + wq ))**two + degaussw**two )**two )
!@ if ( abs(ekq-ekk) .gt. ecutse ) weight = 0.d0
(( wgkq + wgq ) * ( (ekk - ( ekq - wq ))**two - degaussw**two ) / &
( (ekk - ( ekq - wq ))**two + degaussw**two )**two + &
(one - wgkq + wgq ) * ( (ekk - ( ekq + wq ))**two - degaussw**two ) / &
( (ekk - ( ekq + wq ))**two + degaussw**two )**two)
!
zi_all(ibnd,ik+lower_bnd-1) = zi_all(ibnd,ik+lower_bnd-1) + g2 * weight
!
@ -344,10 +323,10 @@
!
! The k points are distributed among pools: here we collect them
!
IF ( iqq == totq ) THEN
IF (iqq == totq) THEN
!
ALLOCATE ( xkf_all ( 3, nkqtotf ), &
etf_all ( nbndsub, nkqtotf ) )
ALLOCATE (xkf_all(3, nkqtotf))
ALLOCATE (etf_all(nbndsub, nkqtotf))
xkf_all(:,:) = zero
etf_all(:,:) = zero
!
@ -374,19 +353,19 @@
! Average over degenerate eigenstates:
WRITE(stdout,'(5x,"Average over degenerate eigenstates is performed")')
!
DO ik = 1, nksqtotf
DO ik=1, nksqtotf
ikk = 2 * ik - 1
ikq = ikk + 1
!
DO ibnd = 1, ibndmax-ibndmin+1
ekk = etf_all (ibndmin-1+ibnd, ikk)
DO ibnd=1, ibndmax - ibndmin + 1
ekk = etf_all(ibndmin - 1 + ibnd, ikk)
n = 0
tmp = 0.0_DP
tmp2 = 0.0_DP
tmp3 = 0.0_DP
DO jbnd = 1, ibndmax-ibndmin+1
ekk2 = etf_all (ibndmin-1+jbnd, ikk)
IF ( ABS(ekk2-ekk) < eps6 ) THEN
DO jbnd=1, ibndmax - ibndmin + 1
ekk2 = etf_all(ibndmin - 1 + jbnd, ikk)
IF (ABS(ekk2 - ekk) < eps6) THEN
n = n + 1
tmp = tmp + sigmar_all (jbnd,ik)
tmp2 = tmp2 + sigmai_all (jbnd,ik)
@ -394,14 +373,14 @@
ENDIF
!
ENDDO ! jbnd
sigmar_tmp(ibnd) = tmp / float(n)
sigmar_tmp(ibnd) = tmp / float(n)
sigmai_tmp(ibnd) = tmp2 / float(n)
zi_tmp(ibnd) = tmp3 / float(n)
zi_tmp(ibnd) = tmp3 / float(n)
!
ENDDO ! ibnd
sigmar_all (:,ik) = sigmar_tmp(:)
sigmai_all (:,ik) = sigmai_tmp(:)
zi_all (:,ik) = zi_tmp(:)
sigmar_all(:, ik) = sigmar_tmp(:)
sigmai_all(:, ik) = sigmai_tmp(:)
zi_all(:, ik) = zi_tmp(:)
!
ENDDO ! nksqtotf
!
@ -410,87 +389,83 @@
!
WRITE(stdout,'(5x,"WARNING: only the eigenstates within the Fermi window are meaningful")')
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
! Write to file
OPEN(unit=linewidth_elself,file='linewidth.elself')
WRITE(linewidth_elself, '(a)') '# Electron lifetime (meV)'
IF ( iverbosity == 3 ) THEN
WRITE(linewidth_elself, '(a)') '# ik ibnd E(ibnd) imode Im(Sgima)(meV)'
OPEN(UNIT=linewidth_elself, FILE='linewidth.elself')
WRITE(linewidth_elself, '(a)') '# Electron linewidth = 2*Im(Sigma) (meV)'
IF (iverbosity == 3) THEN
WRITE(linewidth_elself, '(a)') '# ik ibnd E(ibnd) imode Im(Sigma)(meV)'
ELSE
WRITE(linewidth_elself, '(a)') '# ik ibnd E(ibnd) Im(Sgima)(meV)'
WRITE(linewidth_elself, '(a)') '# ik ibnd E(ibnd) Im(Sigma)(meV)'
ENDIF
!
DO ik = 1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
WRITE(stdout,'(/5x,"ik = ",i7," coord.: ", 3f12.7)') ik, xkf_all(:,ikk)
WRITE(stdout,'(5x,a)') repeat('-',67)
!
DO ibnd = 1, ibndmax-ibndmin+1
!
! note that ekk does not depend on q
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
! calculate Z = 1 / ( 1 -\frac{\partial\Sigma}{\partial\omega} )
zi_all (ibnd,ik) = one / ( one + zi_all (ibnd,ik) )
!
WRITE(stdout, 102) ibndmin-1+ibnd, ryd2ev * ekk, ryd2mev * sigmar_all (ibnd,ik), &
ryd2mev * sigmai_all (ibnd,ik), zi_all (ibnd,ik), one/zi_all(ibnd,ik)-one
! WRITE(stdout, 103) ik, ryd2ev * ekk, ryd2mev * sigmar_all (ibnd,ik), &
! ryd2mev * sigmai_all (ibnd,ik), zi_all (ibnd,ik)
IF ( iverbosity == 3 ) THEN
DO imode=1, nmodes
WRITE(linewidth_elself,'(i9,2x)',advance='no') ik
WRITE(linewidth_elself,'(i9,2x)',advance='no') ibndmin-1+ibnd
WRITE(linewidth_elself,'(E22.14,2x)',advance='no') ryd2ev * ekk
WRITE(linewidth_elself,'(i9,2x)',advance='no') imode
WRITE(linewidth_elself,'(E22.14,2x)') ryd2mev*sigmai_mode(ibnd,imode,ik)
ENDDO
ELSE
WRITE(linewidth_elself,'(i9,2x)',advance='no') ik
WRITE(linewidth_elself,'(i9,2x)',advance='no') ibndmin-1+ibnd
WRITE(linewidth_elself,'(E22.14,2x)',advance='no') ryd2ev * ekk
WRITE(linewidth_elself,'(E22.14,2x)') ryd2mev*sigmai_all(ibnd,ik)
ENDIF
!
ENDDO
WRITE(stdout,'(5x,a/)') repeat('-',67)
!
ENDDO
ENDIF
!
DO ibnd = 1, ibndmax-ibndmin+1
!
DO ik = 1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
DO ik=1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
WRITE(stdout,'(/5x,"ik = ",i7," coord.: ", 3f12.7)') ik, xkf_all(:,ikk)
WRITE(stdout,'(5x,a)') repeat('-',67)
!
DO ibnd=1, ibndmax - ibndmin + 1
!
! note that ekk does not depend on q
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
! calculate Z = 1 / ( 1 -\frac{\partial\Sigma}{\partial\omega} )
!zi_all (ibnd,ik) = one / ( one + zi_all (ibnd,ik) )
zi_all (ibnd,ik) = one / ( one + zi_all (ibnd,ik) )
!
WRITE(stdout,'(2i9,5f12.4)') ik, ibndmin-1+ibnd, ryd2ev * ekk, ryd2mev * sigmar_all(ibnd,ik), &
ryd2mev * sigmai_all (ibnd,ik), zi_all (ibnd,ik), one/zi_all(ibnd,ik)-one
!
ENDDO
!
WRITE(stdout,'(a)') ' '
!
WRITE(stdout, 102) ibndmin-1+ibnd, ryd2ev * ekk, ryd2mev * sigmar_all (ibnd,ik), &
ryd2mev * sigmai_all (ibnd,ik), zi_all (ibnd,ik), one/zi_all(ibnd,ik)-one
! WRITE(stdout, 103) ik, ryd2ev * ekk, ryd2mev * sigmar_all (ibnd,ik), &
! ryd2mev * sigmai_all (ibnd,ik), zi_all (ibnd,ik)
IF ( iverbosity == 3 ) THEN
DO imode=1, nmodes
WRITE(linewidth_elself,'(i9,2x)',advance='no') ik
WRITE(linewidth_elself,'(i9,2x)',advance='no') ibndmin-1+ibnd
WRITE(linewidth_elself,'(E22.14,2x)',advance='no') ryd2ev * ekk
WRITE(linewidth_elself,'(i9,2x)',advance='no') imode
WRITE(linewidth_elself,'(E22.14,2x)') ryd2mev*sigmai_mode(ibnd,imode,ik)
ENDDO
ELSE
WRITE(linewidth_elself,'(i9,2x)',advance='no') ik
WRITE(linewidth_elself,'(i9,2x)',advance='no') ibndmin-1+ibnd
WRITE(linewidth_elself,'(E22.14,2x)',advance='no') ryd2ev * ekk
WRITE(linewidth_elself,'(E22.14,2x)') ryd2mev*sigmai_all(ibnd,ik)
ENDIF
!
ENDDO
WRITE(stdout,'(5x,a/)') repeat('-',67)
!
ENDDO
ENDIF
!
DO ibnd=1, ibndmax - ibndmin + 1
!
DO ik=1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
! note that ekk does not depend on q
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
! calculate Z = 1 / ( 1 -\frac{\partial\Sigma}{\partial\omega} )
!zi_all (ibnd,ik) = one / ( one + zi_all (ibnd,ik) )
!
WRITE(stdout,'(2i9,5f12.4)') ik, ibndmin-1+ibnd, ryd2ev * ekk, ryd2mev * sigmar_all(ibnd,ik), &
ryd2mev * sigmai_all (ibnd,ik), zi_all (ibnd,ik), one/zi_all(ibnd,ik)-one
!
ENDDO
!
WRITE(stdout,'(a)') ' '
!
ENDDO
!
CLOSE(linewidth_elself)
!
IF ( ALLOCATED(xkf_all) ) DEALLOCATE( xkf_all )
IF ( ALLOCATED(etf_all) ) DEALLOCATE( etf_all )
IF ( ALLOCATED(sigmar_all) ) DEALLOCATE( sigmar_all )
IF ( ALLOCATED(sigmai_all) ) DEALLOCATE( sigmai_all )
IF ( ALLOCATED(zi_all) ) DEALLOCATE( zi_all )
IF ( ALLOCATED(sigmai_mode) ) DEALLOCATE( sigmai_mode )
DEALLOCATE (xkf_all)
DEALLOCATE (etf_all)
!
ENDIF
!

60
EPW/src/selfen_phon.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE selfen_phon_q ( iqq, iq, totq )
SUBROUTINE selfen_phon_q(iqq, iq, totq)
!-----------------------------------------------------------------------
!!
!! compute the imaginary part of the phonon self energy due to electron-
@ -33,7 +33,8 @@
eptemp, ngaussw, degaussw, shortrange, &
nsmear, delta_smear, eps_acustic, specfun_ph, &
delta_approx, vme
use pwcom, ONLY : nelec, ef, isk
use pwcom, ONLY : nelec, ef
USE klist_epw, ONLY : isk_dummy
use elph2, ONLY : epf17, ibndmax, ibndmin, etf, wkf, xqf, wqf, nkqf, &
nkf, wf, nkqtotf, xqf, lambda_all, lambda_v_all, &
dmef, vmef, gamma_all,gamma_v_all, efnew
@ -159,21 +160,12 @@
WRITE(stdout,'(5x,"Phonon (Imaginary) Self-Energy in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick.lt.1.d3 ) &
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Golden Rule strictly enforced with T = ',eptemp * ryd2ev, ' eV'
!
IF ( .not. ALLOCATED (lambda_all) ) ALLOCATE( lambda_all (nmodes, totq, nsmear) )
IF ( .not. ALLOCATED (lambda_v_all) ) ALLOCATE( lambda_v_all(nmodes, totq, nsmear) )
lambda_all(:,:,:) = zero
lambda_v_all(:,:,:) = zero
IF ( .not. ALLOCATED (gamma_all) ) ALLOCATE( gamma_all (nmodes, totq, nsmear) )
IF ( .not. ALLOCATED (gamma_v_all) ) ALLOCATE( gamma_v_all(nmodes, totq, nsmear) )
gamma_all(:,:,:) = zero
gamma_v_all(:,:,:) = zero
!
ENDIF
!
DO ismear = 1, nsmear
@ -194,8 +186,8 @@
!
ELSE IF (nsmear > 1) THEN
!
ef0 = efermig(etf,nbndsub,nkqf,nelec,wkf,degaussw0,ngaussw,0,isk)
! if some bands are skipped (nbndskip.neq.0), nelec has already been
ef0 = efermig(etf, nbndsub, nkqf, nelec, wkf, degaussw0, ngaussw, 0, isk_dummy)
! if some bands are skipped (nbndskip /= 0), nelec has already been
! recalculated
! in ephwann_shuffle
!
@ -234,9 +226,9 @@
! we may implement the approximation to the angle between k and k+q
! vectors also listed in Grimvall
!
IF (vme ) THEN
DO ibnd = 1, ibndmax-ibndmin+1
DO jbnd = 1, ibndmax-ibndmin+1
IF (vme) THEN
DO ibnd=1, ibndmax-ibndmin+1
DO jbnd=1, ibndmax-ibndmin+1
!
! vmef is in units of Ryd * bohr
!
@ -248,8 +240,8 @@
ENDDO
ENDDO
ELSE
DO ibnd = 1, ibndmax-ibndmin+1
DO jbnd = 1, ibndmax-ibndmin+1
DO ibnd=1, ibndmax-ibndmin+1
DO jbnd=1, ibndmax-ibndmin+1
!
! v_(k,i) = 1/m <ki|p|ki> = 2 * dmef (:, i,i,k)
! 1/m = 2 in Rydberg atomic units
@ -270,51 +262,51 @@
!ENDIF
!
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
IF ((MINVAL(ABS(etf (:, ikk) - ef) ) < fsthick) .AND. &
(MINVAL(ABS(etf (:, ikq) - ef) ) < fsthick)) THEN
!
fermicount = fermicount + 1
DO imode = 1, nmodes
DO imode=1, nmodes
!
! the phonon frequency
wq = wf (imode, iq)
wq = wf(imode, iq)
!
! SP : We should avoid branching statements (if statements) in
! innerloops. Therefore we do it here.
inv_wq = 1.0/(two * wq)
! the coupling from Gamma acoustic phonons is negligible
IF ( wq .gt. eps_acustic ) THEN
IF (wq > eps_acustic) THEN
g2_tmp = 1.0
ELSE
g2_tmp = 0.0
ENDIF
!
DO ibnd = 1, ibndmax-ibndmin+1
DO ibnd=1, ibndmax-ibndmin+1
!
! the fermi occupation for k
ekk = etf (ibndmin-1+ibnd, ikk) - ef0
ekk = etf(ibndmin - 1 + ibnd, ikk) - ef0
IF (delta_approx) THEN
w0g1 = w0gauss ( ekk / degaussw0, 0) / degaussw0
w0g1 = w0gauss( ekk / degaussw0, 0) / degaussw0
ELSE
wgkk = wgauss( -ekk*inv_eptemp0, -99)
wgkk = wgauss(-ekk*inv_eptemp0, -99)
ENDIF
!
DO jbnd = 1, ibndmax-ibndmin+1
DO jbnd=1, ibndmax-ibndmin+1
!
! the fermi occupation for k+q
ekq = etf (ibndmin-1+jbnd, ikq) - ef0
ekq = etf(ibndmin - 1 + jbnd, ikq) - ef0
!
! here we take into account the zero-point sqrt(hbar/2M\omega)
! with hbar = 1 and M already contained in the eigenmodes
! g2 is Ry^2, wkf must already account for the spin factor
!
IF ( shortrange .AND. ( abs(xqf (1, iq))> eps8 .OR. abs(xqf (2, iq))> eps8 &
.OR. abs(xqf (3, iq))> eps8 )) THEN
IF (shortrange .AND. (ABS(xqf(1, iq)) > eps8 .OR. ABS(xqf(2, iq)) > eps8 &
.OR. ABS(xqf(3, iq)) > eps8)) THEN
! SP: The abs has to be removed. Indeed the epf17 can be a pure imaginary
! number, in which case its square will be a negative number.
g2 = REAL( (epf17 (jbnd, ibnd, imode, ik)**two)*inv_wq*g2_tmp )
ELSE
g2 = (abs(epf17 (jbnd, ibnd, imode, ik))**two)*inv_wq*g2_tmp
g2 = (ABS(epf17 (jbnd, ibnd, imode, ik))**two)*inv_wq*g2_tmp
ENDIF
!
IF (delta_approx) THEN
@ -377,7 +369,7 @@
wq_tmp = wf (jmode, iq)
IF ( ABS(wq - wq_tmp) < eps6 ) THEN
n = n + 1
IF ( wq_tmp .gt. eps_acustic ) THEN
IF ( wq_tmp > eps_acustic ) THEN
tmp = tmp + gamma ( jmode ) / pi / wq**two / dosef
tmp2 = tmp2 + gamma_v( jmode ) / pi / wq**two / dosef
ENDIF

1047
EPW/src/selfen_pl.f90
View File

File diff suppressed because it is too large Load Diff

503
EPW/src/setphases.f90
View File

@ -1,503 +0,0 @@
!
! Copyright (C) 2010-2016 Samuel Ponce', Roxana Margine, Carla Verdi, Feliciano Giustino
! Copyright (C) 2007-2009 Jesse Noffsinger, Brad Malone, Feliciano Giustino
!
! This file is distributed under the terms of the GNU General Public
! License. See the file `LICENSE' in the root directory of the
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
subroutine setphases ( kunit, ik0, nng, unimat )
!---------------------------------------------------------------------
!
! This subroutine gives the rotations which bring the
! eigenstates of the Hamiltonian (evc) into a uniquely defined
! gauge (independent of the machine or the numerical libraries)
!
! This is done by diagonalizing a fake perturbation within the
! degenerate hamiltonian manifold. The eigenstates are assumed
! to be labeled in order of increasing energy (as it is usually
! the case).
!
! The first step is the diagonalization of the perturbation.
! This still leaves a phase arbitrariness, which is the fixed
! by requiring some c(G) be real.
!
! It should be : |psi^\prime_i> = \sum_j U_{ji} * |psi_j>
! and A^\prime = U^\dagger * A * U = matmul(conjg(transpose(U)),matmul(A,U))
! with U = unimat
!
! Only for 1 proc/pool (This limitation can be removed)
!
! ----------------------------------------------------------------------
!
USE mp_global, ONLY : my_pool_id, nproc_pool, &
me_pool, intra_pool_comm
USE mp, ONLY : mp_barrier, mp_sum
USE io_global, ONLY : stdout
USE kinds, ONLY : DP
USE wvfct, ONLY : et
USE phcom, ONLY : evq
USE qpoint, ONLY : igkq
USE control_flags, ONLY : iverbosity
USE pwcom, ONLY : igk
USE constants_epw, ONLY : ci, czero
USE wavefunctions, ONLY : evc
USE fft_base, ONLY : dfftp, dffts
USE wvfct, ONLY : nbnd
USE gvecs, ONLY : nls
USE fft_interfaces, ONLY : fwfft, invfft
!$$
use cell_base, ONLY : omega, pi
! necessary in generating the fake perturbation
!$$
!
implicit none
!
INTEGER, PARAMETER :: nnglen = 100, ndig = 5
! reduced size of evc, evq, this is just for setting individual phases
! this may be taken = 1 in principle, but if C(G1) = 0 we are in trouble, so...
! number of digits used in integer comparisons to decide the largest c(G) in the set
COMPLEX(KIND=DP), POINTER :: evtmp(:,:)
! pointer to wavefunctions in the PW basis (either evc or evq)
INTEGER, POINTER :: igktmp(:)
! correspondence k+G <-> G
INTEGER :: nng, kunit, ik0, nset, ndeg(nbnd)
! size of evc, evq ( this is npw or npwq from elphel2)
! granularity of k point distribution
! the current k point
! number of degenerate subsets for this k point
! degeneracy of each subset
COMPLEX(kind=DP) :: c (nnglen,nbnd) , unimat (nbnd,nbnd), cnew (nnglen,nbnd)
! the chunk of evc used for setting the phases
! the global rotation matrix
! the rotated chunks
COMPLEX(kind=DP), ALLOCATABLE :: u (:,:)
! the rotation matrix for the degenarate subset
REAL(kind=DP) :: deltav (dffts%nnr)
! the fake (local) perturbation in real space, it is real to guarantee Hermiticity
REAL(kind=DP), PARAMETER :: eps = 1.d-5, epsc = 1.d-8
! threshold for deciding whether two states are degenerate
! threshold for deciding whether c(G) = 0
!
! variables for lapack ZHPEVX
!
integer :: neig, info
integer, allocatable :: ifail(:), iwork(:)
real(kind=DP), allocatable :: w(:), rwork(:)
complex(kind=DP), allocatable :: up(:), cwork(:), cz(:,:)
!
! work variables
!
complex(kind=DP) :: unitcheck (nbnd, nbnd), ctmp
real(kind=DP) :: theta, tmp
integer :: ir, ig, igmax, ibnd, jbnd, mbnd, pbnd, iset, n0, n1, n2, &
nsmall, ibndg, jbndg, itmp, imaxnorm
logical :: tdegen
complex(kind=DP) :: aux1 (dffts%nnr), deltavpsi (nng)
complex(kind=DP) :: ZDOTC
!$$ parameters used in generating deltav(ir)
integer :: i,j,k
integer :: na1,na2,na3,na4,na5
! na1 ~ na3 : initial seed for perturbation
!
! na4: increment of the real space indices corresponding to
! the atomic scale variation, here set to 0.5 bohr. This is
! a very important criterion for the fake perturbation.
! If the variation of the fake perturbation is too rapid or
! too slow, it will not capture the variation of the electronic
! wavefunctions, which again is in atomic scale.
!
! na5: integers between (0 ~ na5-1) is assigned first and
! then renormalized such that the eigenvalues of the fake
! perturbation is a number between 0 and 1.
!$$
! In the case of multiple procs per pool, the fake perturbation defined
! by deltav (ir) = ir will depend on the division of nr1x*nr2x*nr3x
! (This can be removed by defined a serious perturbation below...)
!
IF (nproc_pool>1) call errore &
('setphases', 'only one proc per pool to guarantee the same gauge', 1)
!
! initialize
!
! if we are working with a k (k+q) point, evtmp points to evc (evq)
!
IF ( (kunit.eq.1) .or. ((kunit.eq.2).and.(ik0-2*(ik0/2).eq.1)) ) then
evtmp => evc
igktmp => igk
ELSE
evtmp => evq
igktmp => igkq
ENDIF
c = evtmp(1:nnglen,:)
!
! build the fake perturbation
!
! This is crap but it works fine. I think it is important to normalize
! the pert to 1 so as to easily keep control on the eigenvalues.
! According to wikipedia the word crap is from latin "crappa".
! If you do something better you should take into account the
! parallalization on nrxxs.
!
! do ir = 1, nrxxs
! deltav(ir) = dble(ir)/dble(nrxxs)
! enddo
!
! the above is not ok for my BC53 structure... A better choice:
! read dvscf (without the bare term) for a few patterns.
! The spin index is irrelevant and is kept only for compatibility with davcio_drho.
! To get a unique ordering independent of q, the same deltav must be used!
! Therefore in input we supply fildvscf0 (the fildvscf calculated, say, at gamma)
!
!$$ call davcio_drho ( v1, lrdrho, iudvscf0, 1, -1 )
!$$ call davcio_drho ( v2, lrdrho, iudvscf0, 3*nat/2, -1 )
!$$ call davcio_drho ( v3, lrdrho, iudvscf0, 3*nat , -1 )
!$$ deltav = real ( v1(:,1) + v2(:,1) + v3(:,1) )
!$$ deltav = deltav ** 3.d0
!
nset = 1
DO ibnd = 1, nbnd
ndeg (ibnd) = 1
DO jbnd = 1, nbnd
unimat (ibnd, jbnd) = czero
ENDDO
unimat (ibnd, ibnd) = 1.d0
ENDDO
!
! count subsets and their degeneracy
!
DO ibnd = 2, nbnd
tdegen = abs( et (ibnd, ik0) - et (ibnd-1, ik0) ) .lt. eps
IF (tdegen) then
ndeg (nset) = ndeg(nset) + 1
ELSE
nset = nset + 1
ENDIF
ENDDO
IF (iverbosity.eq.1) write (stdout, *) &
ik0, nset, (ndeg (iset) ,iset=1,nset)
!
! -----------------------------------------------------------
! determine rotations within each subset
! and copy into the global matrix
! -----------------------------------------------------------
!
!$$ initialize the perturbation
deltav = 0.0d0
n0 = 0
DO iset = 1, nset
!
!
! the size of the small rotation
nsmall = ndeg (iset)
!
! unimat is initialized to the identity matrix,
! so when the subset has dimension 1, just do nothing
!
IF (nsmall.gt.1) then
!
! form the matrix elements of the "perturbation"
!
allocate ( u (nsmall, nsmall) )
!$$ allocate matrices for rotation at first
allocate ( ifail( nsmall ), iwork( 5*nsmall ), w( nsmall ), rwork( 7*nsmall ),&
up( nsmall*(nsmall+1)/2 ), cwork( 2*nsmall ), cz( nsmall, nsmall) )
tdegen = .true.
!$$ initial seed for perturbation
na1 = 1
na2 = 2
na3 = 3
na4 = nint(0.5/(omega/dffts%nnr)**(1.0/3.0))
! na4 is the number of real space grid points
! that roughly corresponds to 0.5 bohr.
! (omega is the volume of the unit cell in bohr^3)
na5 = dfftp%nr1x*dfftp%nr2x/(na4*na4) + dfftp%nr1x/na4
! an integer between 0 and na5-1 is going to be picked.
!$$
!$$
!$$ repeat until we find a good u matrix
!$$
DO while(tdegen)
!$$ set up deltav(ir)
DO i=1,dfftp%nr1x,na4
DO j=1,dfftp%nr2x,na4
DO k=1,dfftp%nr3x,na4
ir = i + (j - 1) * dfftp%nr1x + (k - 1)*dfftp%nr1x*dfftp%nr2x
deltav(ir) = mod(na1*i*j+na2*j*k+na3*k*i,na5)*na4*na4*na4/na5
! here, deltav(ir) is assigned a number so that the
! eigenvalue of the fake perturbation is between 0 and 1, roughly
ENDDO
ENDDO
ENDDO
!$$
u = czero
DO ibnd =1, nsmall
!
! ibnd and jbnd are the indexes of the bands within the subsets
! ibndg and jbndg are the global indexes of the bands
!
ibndg = ibnd + n0
!
aux1(:) = (0.d0, 0.d0)
DO ig = 1, nng
aux1 (nls (igktmp (ig) ) ) = evtmp (ig, ibndg)
ENDDO
CALL invfft ('Wave', aux1, dffts)
DO ir = 1, dffts%nnr
aux1 (ir) = aux1 (ir) * deltav (ir)
ENDDO
CALL fwfft ('Wave', aux1, dffts)
deltavpsi (1:nng) = aux1 (nls (igktmp (1:nng) ) )
!
DO jbnd = 1, nsmall
!
jbndg = jbnd + n0
!
u (ibnd, jbnd) = ZDOTC (nng, deltavpsi, 1, evtmp(:, jbndg), 1)
ENDDO
!
ENDDO
!
! ok I veryfied that when deltav(ir)=1, u is the unity matrix (othonormality)
!
CALL mp_sum(u, intra_pool_comm)
!
! check hermiticity
!
DO ibnd = 1, nsmall
DO jbnd = 1, nsmall
IF ( abs( conjg (u (jbnd, ibnd)) - u (ibnd, jbnd) ) .gt. eps ) then
DO mbnd = 1,nsmall
WRITE(stdout,'(10f15.10)') (u (pbnd, mbnd), pbnd=1,nsmall)
ENDDO
CALL errore ('setphases','perturbation matrix non hermitian',1)
ENDIF
ENDDO
ENDDO
!
! now diagonalize the "perturbation" matrix within the degenerate subset
!
!$$ allocation is done outside the loop
!$$ allocate ( ifail( nsmall ), iwork( 5*nsmall ), w( nsmall ), rwork( 7*nsmall ),&
!$$ up( nsmall*(nsmall+1)/2 ), cwork( 2*nsmall ), cz( nsmall, nsmall) )
!$$
!
! packed upper triangular part for zhpevx
DO jbnd = 1, nsmall
DO ibnd = 1, nsmall
up (ibnd + (jbnd - 1) * jbnd/2 ) = u ( ibnd, jbnd)
ENDDO
ENDDO
!
CALL zhpevx ('V', 'A', 'U', nsmall, up , 0.0, 0.0, &
0, 0,-1.0, neig, w, cz, nsmall, cwork, &
rwork, iwork, ifail, info)
IF (iverbosity.eq.1) then
!$$ if (.true.) then
!
WRITE(stdout, '(5x, "Eigenvalues of fake perturbation: ", 10f9.5)') &
(w(ibnd),ibnd=1,nsmall)
WRITE(stdout, *)
WRITE(stdout,*) 'before diagonalizing the perturbation:'
DO ibnd = 1, nsmall
WRITE(stdout,'(10f9.4)') (u (ibnd, jbnd), jbnd=1, nsmall)
ENDDO
!
! recalculate u via similarity transform
!
u = matmul ( conjg(transpose( cz)), matmul (u, cz) )
WRITE(stdout,*) 'after diagonalizing the perturbation: via matmul'
DO ibnd = 1, nsmall
WRITE(stdout,'(10f9.4)') (u (ibnd, jbnd), jbnd=1, nsmall)
ENDDO
WRITE(stdout, '("-----------------"/)')
!
ENDIF
!
! now make sure that all the eigenvalues are nondegenerate
!
tdegen = .false.
DO ibnd = 2, nsmall
tdegen = tdegen .or. ( abs( w(ibnd) - w(ibnd-1) ) .lt. eps )
ENDDO
IF(tdegen) write(stdout,*) 'eigenvalues of pert matrix degenerate'
!$$ in the following, instead of killing the program when the perturbation
!$$ gives degenerate eigenvalues, it changes the perturbation and repeat
!$$ until the degeneracy is broken. The perturbation should not be the same
!$$ for wavefunctions with different wavevector or band indices.
!$$
!$$ if (tdegen) call errore ('setphases', &
!$$ 'eigenvalues of pert matrix degenerate',1)
!
! ...that they are nonvanishing...
!
!$$ do ibnd = 1, nsmall
!$$ tdegen = tdegen .or. ( abs( w(ibnd) ) .lt. eps )
!$$ enddo
!$$ if (tdegen) call errore ('setphases', &
!$$ 'eigenvalues of pert matrix too small',1)
!
! ...and that they are not too close to 1 (orthonormality...)
!
!$$ do ibnd = 1, nsmall
!$$ tdegen = tdegen .or. ( abs( w(ibnd) - 1.d0 ) .lt. eps )
!$$ enddo
!$$ if (tdegen) call errore ('setphases', &
!$$ 'eigenvalues of pert matrix too close to 1',1)
!$$ change the perturbation
na1 = na1 + 3
na2 = na2 + 1
na3 = na3 + 1
na4 = na4 + 1
na5 = na5 + 10
!$$
ENDDO !$$ repeat until finding a perturbation that gives non-degenerate eigenvalues
!
! copy the rotation for the subset into the global rotation
!
n1 = n0 + 1
n2 = n0 + ndeg(iset)
unimat ( n1:n2, n1:n2) = cz ( 1:nsmall, 1:nsmall)
!
deallocate ( ifail, iwork, w, rwork, up, cwork, cz )
deallocate ( u )
!
ENDIF
!
! update global band index
!
n0 = n0 + ndeg(iset)
ENDDO
!
IF (iverbosity.eq.1) then
!$$ if (.true.) then
WRITE(stdout, *) '--- rotations for unitary gauge ----'
WRITE(stdout,'(i4)') ik0
WRITE(stdout,'(8f9.5)') (et(ibnd,ik0),ibnd=1,nbnd)
DO ibnd = 1, nbnd
WRITE(stdout,'(10f9.4)') (unimat (ibnd, jbnd), jbnd=1, nbnd)
ENDDO
ENDIF
!
! -----------------------------------------------------------
! now fix the phases and update rotation matrix
! -----------------------------------------------------------
!
! rotate the coefficients with the matrix u
! (to set the phase on the evc's *after* the rotation)
!
cnew(:,:) = czero
DO ibnd = 1, nbnd
DO jbnd = 1, nbnd
cnew(1:nnglen, ibnd) = cnew(1:nnglen, ibnd) &
+ unimat (jbnd, ibnd) * c (1:nnglen, jbnd)
ENDDO
ENDDO
!
! for every band, find the largest coefficient and determine
! the rotation which makes it real and positive
!
DO ibnd = 1, nbnd
!
! this is to identify the largest c(G) by using *integer*
! comparisons on ndig digits [see remarks at the bottom about this]
!
imaxnorm = 0
DO ig = 1, nnglen
ctmp = cnew (ig, ibnd)
tmp = REAL(conjg ( ctmp ) * ctmp)
itmp = nint (10.d0**dble(ndig) * tmp)
IF (itmp.gt.imaxnorm) then
imaxnorm = itmp
igmax = ig
ENDIF
ENDDO
!
ctmp = cnew (igmax, ibnd)
tmp = REAL(conjg ( ctmp ) * ctmp)
!
! ...and the corresponding phase
!
IF ( abs(tmp) .gt. epsc ) then
! note that if x + i * y = rho * cos(theta) + i * rho * sin(theta),
! then theta = atan2 ( y, x) (reversed order of x and y!)
theta = atan2 ( aimag( ctmp ), real ( ctmp ) )
ELSE
CALL errore ('setphases','cnew = 0 for some bands: increase nnglen',1)
ENDIF
!
IF (iverbosity.eq.1) then
!$$ if (.true.) then
WRITE(stdout, '(3i4,2x,f15.10,2(3x,2f9.5))') ik0, ibnd, igmax, theta/pi*180.d0, &
ctmp, ctmp * exp ( -ci * theta), exp ( -ci * theta)
ENDIF
!
! now cancel this phase in the rotation matrix
!
unimat (:, ibnd) = unimat (:, ibnd) * exp ( -ci * theta)
!
ENDDO
!
IF (iverbosity.eq.1) then
!$$ if (.true.) then
WRITE(stdout, *) '--- rotations including phases ----'
DO ibnd = 1, nbnd
WRITE(stdout,'(10f9.4)') (unimat (ibnd, jbnd), jbnd=1, nbnd)
ENDDO
ENDIF
!
! last check: unitarity
! (if this test is passed, even with wrong phases the final
! results -nonwannierized- should be ok)
!
unitcheck = matmul ( conjg( transpose (unimat)), unimat)
DO ibnd = 1, nbnd
DO jbnd = 1, nbnd
IF ( (ibnd.ne.jbnd) .and. ( abs(unitcheck (ibnd, jbnd)) .gt. eps ) &
.or. (ibnd.eq.jbnd) .and. ( abs ( abs(unitcheck (ibnd, jbnd)) - 1.d0 ) .gt. eps ) )&
CALL errore ('setphases','final transform not unitary',1)
ENDDO
ENDDO
!
nullify ( evtmp )
nullify ( igktmp )
!
end subroutine setphases
!---------------------------------------------------------------------
!
! NOTA BENE: I truncate the c(G) to a given number of digits in
! order to guarantee that the same norm-ordering of c(G) holds
! for different q-runs, machines, libraries etc:
! run q = 0 : ig = 3 |c(igmax)| = 0.34.....263 <-- igmax = 3
! run q = 0 : ig = 4 |c(igmax)| = 0.34.....261
! run q /= 0 : ig = 3 |c(igmax)| = 0.34.....260
! run q /= 0 : ig = 4 |c(igmax)| = 0.34.....265 <-- igmax = 4
! In the situation above, I will have psi(r) with a phase difference
! corresponding to that of c(3) and c(4)...
! (Note that the ordering of the G-vectors is always the same)
! Mind : ndig should be smaller than machine precision, otherwise the
! integere comparison is useless
!
!---------------------------------------------------------------------
!

103
EPW/src/setphases_wrap.f90
View File

@ -26,88 +26,59 @@
use mp, only : mp_sum
use elph2, only : umat, umat_all
use pwcom, only : nbnd, nks
! use epwcom, only : tphases, iudvscf0
!
!
implicit none
!
!complex(kind=DP) :: v1(dffts%nnr,nspin), v2(dffts%nnr,nspin), v3(dffts%nnr,nspin)
! tmp matrices to build deltav
!real(kind=DP) :: deltav(dffts%nnr)
! the fake (local) perturbation in real space, it is real to guarantee
! hermiticity
integer :: ik, ibnd, jbnd
real(kind=DP) :: zero_vect(3)
INTEGER :: ik
!! K-point
INTEGER :: ibnd
!! Band-index
INTEGER :: jbnd
!! Band index
REAL(kind=DP) :: zero_vect(3)
!! Real vector
!
IF (nproc_pool>1) call errore &
('setphases_wrap', 'only one proc per pool', 1)
!
allocate (umat_all (nbnd, nbnd, nkstot))
allocate (umat(nbnd,nbnd,nks))
ALLOCATE (umat_all(nbnd, nbnd, nkstot))
ALLOCATE (umat(nbnd, nbnd, nks))
umat_all = (0.d0, 0.d0)
zero_vect = 0.d0
!
! SP: Phase setting is depreciated. We keep it in case it might be usefull.
! Since we read the pattern, it should not be required.
!IF (tphases) then
! !
! WRITE (stdout,'(5x,a)') 'Setting the phases on |psi_k>'
! !
! CALL davcio_drho ( v1, lrdrho, iudvscf0, 1, -1 )
! CALL davcio_drho ( v2, lrdrho, iudvscf0, 3*nat/2, -1 )
! CALL davcio_drho ( v3, lrdrho, iudvscf0, 3*nat , -1 )
! deltav= real ( v1(:,1) + v2(:,1) + v3(:,1))
! deltav=deltav ** 3.d0
! !
! !
! DO ik=1,nks
! !
! IF (nks.gt.1) then
! CALL davcio (evc, lrwfc, iuwfc, ik, - 1)
! ENDIF
! !
! CALL ktokpmq ( xk(:,ik), zero_vect, +1, ipool, nkk, nkk_abs)
! !
! CALL setphases ( 1, ik, ngk(ik), umat(:,:,ik))
! umat_all(:,:,nkk_abs) = umat(:,:,ik)
! !
! !
! END DO
!ELSE ! no phases, rotation matrix is then the identity
!
WRITE(stdout,'(5x,a)') 'No wavefunction gauge setting applied'
!
IF (ionode) then
DO ik = 1, nkstot
DO ibnd = 1, nbnd
DO jbnd = 1, nbnd
IF (ibnd .eq. jbnd) then
umat_all(ibnd,jbnd,ik) = (1.d0, 0.d0)
ELSE
umat_all(ibnd,jbnd,ik) = (0.d0,0.d0)
ENDIF
ENDDO
ENDDO
!
WRITE(stdout,'(5x,a)') 'No wavefunction gauge setting applied'
!
IF (ionode) THEN
DO ik=1, nkstot
DO ibnd=1, nbnd
DO jbnd=1, nbnd
IF (ibnd == jbnd) then
umat_all(ibnd, jbnd, ik) = (1.d0, 0.d0)
ELSE
umat_all(ibnd, jbnd, ik) = (0.d0, 0.d0)
ENDIF
ENDDO
ENDIF
DO ik = 1, nks
DO ibnd = 1, nbnd
DO jbnd = 1, nbnd
IF (ibnd .eq. jbnd) then
umat(ibnd,jbnd,ik) = (1.d0, 0.d0)
ELSE
umat(ibnd,jbnd,ik) = (0.d0,0.d0)
ENDIF
ENDDO
ENDDO
ENDDO
!ENDIF
ENDDO
ENDDO
ENDIF
DO ik=1, nks
DO ibnd=1, nbnd
DO jbnd=1, nbnd
IF (ibnd == jbnd) then
umat(ibnd, jbnd, ik) = (1.d0, 0.d0)
ELSE
umat(ibnd, jbnd, ik) = (0.d0, 0.d0)
ENDIF
ENDDO
ENDDO
ENDDO
!
! collect the global phase-setting matrix
!
CALL mp_sum(umat_all, inter_pool_comm)
!
!IF (iverbosity .eq. 1) then
!IF (iverbosity == 1) then
! WRITE (stdout,* ) "Phase setting matrices:"
! DO ik = 1, nkstot
! DO ibnd = 1, nbnd

20
EPW/src/sort.f90
View File

@ -40,13 +40,13 @@
real(DP) :: rra
!
! initialize index array
IF (ind (1) .eq.0) then
IF (ind (1) == 0) then
DO i = 1, n
ind (i) = i
ENDDO
ENDIF
! nothing to order
IF (n.lt.2) return
IF (n < 2) return
! initialize indices for hiring and retirement-promotion phase
l = n / 2 + 1
@ -55,7 +55,7 @@
sorting: do
! still in hiring phase
IF ( l .gt. 1 ) then
IF ( l > 1 ) then
l = l - 1
rra = ra (l)
iind = ind (l)
@ -72,7 +72,7 @@
! decrease the size of the corporation
ir = ir - 1
! done with the last promotion
IF ( ir .eq. 1 ) then
IF ( ir == 1 ) then
! the least competent worker at all !
ra (1) = rra
!
@ -85,14 +85,14 @@
! set up to place rra in its proper level
j = l + l
!
DO while ( j .le. ir )
IF ( j .lt. ir ) then
DO while ( j <= ir )
IF ( j < ir ) then
! compare to better underling
IF ( hslt( ra (j), ra (j + 1) ) ) then
j = j + 1
!else if ( .not. hslt( ra (j+1), ra (j) ) ) then
!else if ( .NOT. hslt( ra (j+1), ra (j) ) ) then
! this means ra(j) == ra(j+1) within tolerance
! if (ind (j) .lt.ind (j + 1) ) j = j + 1
! if (ind (j) < ind (j + 1) ) j = j + 1
ENDIF
ENDIF
! demote rra
@ -101,10 +101,10 @@
ind (i) = ind (j)
i = j
j = j + j
!else if ( .not. hslt ( ra(j) , rra ) ) then
!else if ( .NOT. hslt ( ra(j) , rra ) ) then
!this means rra == ra(j) within tolerance
! demote rra
! if (iind.lt.ind (j) ) then
! if (iind < ind (j) ) then
! ra (i) = ra (j)
! ind (i) = ind (j)
! i = j

36
EPW/src/spectral_cumulant.f90
View File

@ -92,7 +92,7 @@
WRITE(stdout,'(5x,a)') 'Warning: the routine is sequential but very fast.'
WRITE(stdout,'(5x,a/)') repeat('=',75)
!
OPEN (unit=iospectral_sup, file='specfun_sup.elself', status='old', iostat=ios)
OPEN (UNIT=iospectral_sup, FILE='specfun_sup.elself', status='old', iostat=ios)
IF (ios /= 0) CALL errore ('spectral_cumulant', 'opening file specfun_sup.elself', abs(ios) )
!
! determine number of k points, ibndmin, ibndmax
@ -101,9 +101,9 @@
ENDDO
DO im=1,maxrecs
READ (iospectral_sup,*,iostat=ios) i1, i2
IF (im.eq.1) ibndmin = i2
IF (im == 1) ibndmin = i2
IF (ios /= 0) EXIT
IF (im.eq.maxrecs) CALL errore ('spectral_cumulant', 'increase maxrecs', 1)
IF (im == maxrecs) CALL errore ('spectral_cumulant', 'increase maxrecs', 1)
ENDDO
!
REWIND (iospectral_sup)
@ -142,14 +142,14 @@
CLOSE (iospectral_sup)
!
! open file for cumulant spectral function
IF (bnd_cum.lt.10) THEN
IF (bnd_cum < 10) THEN
WRITE(filespec,'(a,i1,a)') 'specfun_cum',bnd_cum,'.elself'
ELSE IF (bnd_cum.gt.9 .and. bnd_cum.lt.100) THEN
ELSE IF (bnd_cum > 9 .and. bnd_cum < 100) THEN
WRITE(filespec,'(a,i2,a)') 'specfun_cum',bnd_cum,'.elself'
ELSE
WRITE(filespec,'(a,i3,a)') 'specfun_cum',bnd_cum,'.elself'
ENDIF
OPEN (unit=iospectral_cum,file=filespec)
OPEN (UNIT=iospectral_cum,FILE=filespec)
!
WRITE(iospectral_cum,'(a)') '# k Energy [eV] A(k,w) [meV^-1] Z-factor '
WRITE(iospectral_cum,'(a)') '# with convolutions | using FFT '
@ -158,7 +158,7 @@
!
! define index corresponding to omega=0 (Fermi level)
i0 = MINLOC( abs(ww(:)), dim=1 )
IF (abs(ww(i0)).gt.dw) CALL errore &
IF (abs(ww(i0)) > dw) CALL errore &
('spectral_cumulant', 'w=0 needs to be included in [wmin:wmax]', 1 )
!WRITE(stdout,'(5x,a,i4)') " Check: ind(0) = ", i0
a_cw = zero
@ -167,7 +167,7 @@
!
DO ik = 1, nk
!
IF ( ek(ik) .lt. e_thresh ) THEN
IF ( ek(ik) < e_thresh ) THEN
!
ekk = ek(ik)
!
@ -182,7 +182,7 @@
DO iw = 1, nw_specfun
!
! map the indices of the FFT frequency grid onto the original one
IF ( iw.ge.i0) THEN
IF ( iw >= i0) THEN
a_ct(iw) = a_tmp(iw-i0+1)
ELSE
a_ct(iw) = a_tmp(iw+nw_specfun-i0+1)
@ -328,7 +328,7 @@
DO iw2 = 1, nw_specfun
!
indw = i0+iw-iw2
IF ( indw.le.nw_specfun .and. indw.gt.0 ) THEN
IF ( indw <= nw_specfun .and. indw > 0 ) THEN
a_cum(iw) = a_cum(iw) + abs( a_s(iw2) * conv(indw) ) * dw
ENDIF
!
@ -336,9 +336,9 @@
!
ENDDO
!
IF (isat.eq.1) a_s1 = a_cum
IF (isat.eq.2) a_s2 = a_cum / 2.d0
IF (isat.eq.3) a_s3 = a_cum / 6.d0
IF (isat == 1) a_s1 = a_cum
IF (isat == 2) a_s2 = a_cum / 2.d0
IF (isat == 3) a_s3 = a_cum / 6.d0
conv = a_cum
!
ENDDO ! isat
@ -429,7 +429,7 @@
dt = 2.d0*pi / ( (wmax_specfun - wmin_specfun) * fact )
nw_new = int( fact * (nw_specfun-1) + 1 ) ! to be consistent with dt above
!
ALLOCATE( cumS(nw_new), cum(nw_new) )
ALLOCATE ( cumS(nw_new), cum(nw_new) )
!
i0 = MINLOC( abs(ww(:)), dim=1 )
!
@ -448,10 +448,10 @@
DO iw = 1, nw_new
!
! the w shift is needed because FFT uses positive w \in [0:Omega], Omega=wmax-wmin
IF ( iw.le.(nw_specfun-i0+1) ) THEN
IF ( iw <= (nw_specfun-i0+1) ) THEN
ind1 = iw+i0-1
cumS(iw) = dw * abs(sigmai(ind1))/pi * real(1.d0 / (ek-ww(ind1)-ci*smeart)**2.d0 )
ELSE IF ( iw.gt.(nw_new-i0+1) ) THEN
ELSE IF ( iw > (nw_new-i0+1) ) THEN
ind2 = iw-nw_new+i0-1
cumS(iw) = dw * abs(sigmai(ind2))/pi * real(1.d0 / (ek-ww(ind2)-ci*smeart)**2.d0 )
ENDIF
@ -475,7 +475,7 @@
!
! extract the spectral function a_cum on the original w FFT grid (nw_specfun points)
DO iw = 1, nw_specfun
IF ( iw.le.(nw_specfun-i0+1) ) THEN
IF ( iw <= (nw_specfun-i0+1) ) THEN
a_cum(iw) = real(real(cum(iw)))
ELSE
ind1 = iw+nw_new-nw_specfun
@ -483,6 +483,6 @@
ENDIF
ENDDO
!
DEALLOCATE( cumS, cum )
DEALLOCATE ( cumS, cum )
!
END SUBROUTINE cumulant_time

104
EPW/src/spectral_func.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE spectral_func_q ( iqq, iq, totq )
SUBROUTINE spectral_func_q (iqq, iq, totq)
!-----------------------------------------------------------------------
!!
!! Compute the electron spectral function including the electron-
@ -30,7 +30,8 @@
fsthick, eptemp, ngaussw, degaussw, wmin_specfun,&
wmax_specfun, nw_specfun, shortrange, &
efermi_read, fermi_energy
USE pwcom, ONLY : nelec, ef, isk
USE pwcom, ONLY : nelec, ef
USE klist_epw, ONLY : isk_dummy
USE elph2, ONLY : etf, ibndmin, ibndmax, nkqf, xqf, &
epf17, wkf, nkf, wf, wqf, xkf, nkqtotf,&
esigmar_all, esigmai_all, a_all
@ -121,36 +122,36 @@
!
dw = ( wmax_specfun - wmin_specfun ) / dble (nw_specfun-1)
!
IF ( iqq == 1 ) THEN
!
WRITE(stdout,'(/5x,a)') repeat('=',67)
WRITE(stdout,'(5x,"Electron Spectral Function in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick .lt. 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Golden Rule strictly enforced with T = ',eptemp * ryd2ev, ' eV'
!
IF (iqq == 1) THEN
!
WRITE(stdout,'(/5x,a)') repeat('=',67)
WRITE(stdout,'(5x,"Electron Spectral Function in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Golden Rule strictly enforced with T = ',eptemp * ryd2ev, ' eV'
!
ENDIF
!
! Fermi level and corresponding DOS
!
IF ( efermi_read ) THEN
!
ef0 = fermi_energy
!
IF (efermi_read) THEN
!
ef0 = fermi_energy
!
ELSE
!
ef0 = efermig(etf,nbndsub,nkqf,nelec,wkf,degaussw,ngaussw,0,isk)
! if some bands are skipped (nbndskip.neq.0), nelec has already been recalculated
! in ephwann_shuffle
!
!
ef0 = efermig(etf, nbndsub, nkqf, nelec, wkf, degaussw, ngaussw, 0, isk_dummy)
! if some bands are skipped (nbndskip /= 0), nelec has already been recalculated
! in ephwann_shuffle
!
ENDIF
!
IF ( iq == 1 ) THEN
WRITE (stdout, 100) degaussw * ryd2ev, ngaussw
WRITE (stdout,'(a)') ' '
IF (iq == 1) THEN
WRITE (stdout, 100) degaussw * ryd2ev, ngaussw
WRITE (stdout,'(a)') ' '
ENDIF
!
! The total number of k points
@ -160,15 +161,8 @@
! find the bounds of k-dependent arrays in the parallel case in each pool
CALL fkbounds( nksqtotf, lower_bnd, upper_bnd )
!
IF ( iq == 1 ) THEN
IF ( .not. ALLOCATED(esigmar_all) ) ALLOCATE( esigmar_all(ibndmax-ibndmin+1, nksqtotf, nw_specfun) )
IF ( .not. ALLOCATED(esigmai_all) ) ALLOCATE( esigmai_all(ibndmax-ibndmin+1, nksqtotf, nw_specfun) )
esigmar_all(:,:,:) = zero
esigmai_all(:,:,:) = zero
ENDIF
!
! SP: Sum rule added to conserve the number of electron.
IF ( iq == 1 ) THEN
IF (iq == 1) THEN
WRITE (stdout,'(5x,a)') 'The sum rule to conserve the number of electron is enforced.'
WRITE (stdout,'(5x,a)') 'The self energy is rescaled so that its real part is zero at the Fermi level.'
WRITE (stdout,'(5x,a)') 'The sum rule replace the explicit calculation of the Debye-Waller term.'
@ -178,7 +172,7 @@
! loop over all k points of the fine mesh
!
fermicount = 0
DO ik = 1, nkf
DO ik=1, nkf
!
ikk = 2 * ik - 1
ikq = ikk + 1
@ -186,11 +180,11 @@
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
! (but in this case they are the same)
!
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
IF ((MINVAL(ABS(etf (:, ikk) - ef) ) < fsthick) .AND. &
(MINVAL(ABS(etf (:, ikq) - ef) ) < fsthick)) THEN
!
fermicount = fermicount + 1
DO imode = 1, nmodes
DO imode=1, nmodes
!
! the phonon frequency and Bose occupation
wq = wf (imode, iq)
@ -200,7 +194,7 @@
wgq = wgq / ( one - two * wgq )
!
! SP: Avoid if statement in inner loops
IF (wq .gt. eps_acustic) THEN
IF (wq > eps_acustic) THEN
g2_tmp = 1.0
ELSE
g2_tmp = 0.0
@ -266,10 +260,10 @@
!
! The k points are distributed among pools: here we collect them
!
IF ( iqq == totq ) THEN
IF (iqq == totq) THEN
!
ALLOCATE ( xkf_all ( 3, nkqtotf ), &
etf_all ( nbndsub, nkqtotf ) )
ALLOCATE (xkf_all(3, nkqtotf))
ALLOCATE (etf_all(nbndsub, nkqtotf))
xkf_all(:,:) = zero
etf_all(:,:) = zero
!
@ -299,12 +293,9 @@
! construct the trace of the spectral function (assume diagonal selfenergy
! and constant matrix elements for dipole transitions)
!
IF (.not. ALLOCATED (a_all)) ALLOCATE ( a_all(nw_specfun, nksqtotf) )
a_all(:,:) = zero
!
IF (me_pool == 0) then
OPEN(unit=iospectral,file='specfun.elself')
OPEN(unit=iospectral_sup,file='specfun_sup.elself')
OPEN(UNIT=iospectral,FILE='specfun.elself')
OPEN(UNIT=iospectral_sup,FILE='specfun_sup.elself')
ENDIF
IF (me_pool == 0) then
WRITE(iospectral, '(/2x,a/)') '#Electronic spectral function (meV)'
@ -316,7 +307,7 @@
& Real Sigma[meV] Im Sigma[meV]'
ENDIF
!
DO ik = 1, nksqtotf
DO ik=1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
@ -324,11 +315,11 @@
WRITE(stdout,'(/5x,"ik = ",i5," coord.: ", 3f12.7)') ik, xkf_all (:,ikk)
WRITE(stdout,'(5x,a)') repeat('-',67)
!
DO iw = 1, nw_specfun
DO iw=1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
!
DO ibnd = 1, ibndmax-ibndmin+1
DO ibnd=1, ibndmax-ibndmin+1
!
! the energy of the electron at k
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
@ -346,12 +337,12 @@
!
ENDDO
!
DO ik = 1, nksqtotf
DO ik=1, nksqtotf
!
! The spectral function should integrate to 1 for each k-point
specfun_sum = 0.0
!
DO iw = 1, nw_specfun
DO iw=1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
fermi(iw) = wgauss(-ww/eptemp, -99)
@ -373,9 +364,9 @@
!
IF (me_pool == 0) CLOSE(iospectral)
!
DO ibnd = 1, ibndmax-ibndmin+1
DO ibnd=1, ibndmax-ibndmin+1
!
DO ik = 1, nksqtotf
DO ik=1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
@ -405,11 +396,8 @@
!
IF (me_pool == 0) CLOSE(iospectral_sup)
!
IF ( ALLOCATED(xkf_all) ) DEALLOCATE( xkf_all )
IF ( ALLOCATED(etf_all) ) DEALLOCATE( etf_all )
IF ( ALLOCATED(esigmar_all) ) DEALLOCATE( esigmar_all )
IF ( ALLOCATED(esigmai_all) ) DEALLOCATE( esigmai_all )
IF ( ALLOCATED(a_all) ) DEALLOCATE( a_all )
DEALLOCATE (xkf_all)
DEALLOCATE (etf_all)
!
ENDIF
!

43
EPW/src/spectral_func_ph.f90
View File

@ -7,7 +7,7 @@
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE spectral_func_ph ( iqq, iq, totq )
SUBROUTINE spectral_func_ph (iqq, iq, totq)
!-----------------------------------------------------------------------
!
! Compute the imaginary part of the phonon self energy due to electron-
@ -31,9 +31,10 @@
shortrange, nsmear, delta_smear, eps_acustic, &
efermi_read, fermi_energy, wmin_specfun,&
wmax_specfun, nw_specfun
USE pwcom, ONLY : nelec, ef, isk
USE pwcom, ONLY : nelec, ef
USE klist_epw, ONLY : isk_dummy
USE elph2, ONLY : epf17, ibndmax, ibndmin, etf, &
wkf, xqf, nkqf, nkf, wf, a_all, efnew
wkf, xqf, nkqf, nkf, wf, a_all_ph, efnew
USE constants_epw, ONLY : ryd2mev, ryd2ev, two, zero, pi, cone, ci, eps8
USE mp_world, ONLY : mpime
USE mp, ONLY : mp_barrier, mp_sum
@ -123,12 +124,12 @@
!qsquared = (xqf(1,iq)**2 + xqf(2,iq)**2 + xqf(3,iq)**2) * tpiba2
!epsTF = (qTF**2 + qsquared) / (qTF**2/eps0 * sin (sqrt(qsquared)*RTF)/(sqrt(qsquared)*RTF)+qsquared)
!
IF ( iqq == 1 ) THEN
IF (iqq == 1) THEN
WRITE(stdout,'(/5x,a)') repeat('=',67)
WRITE(stdout,'(5x,"Phonon Spectral Function Self-Energy in the Migdal Approximation (on the fly)")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick.lt.1.d3 ) &
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
@ -149,8 +150,8 @@
!
ELSE IF (nsmear > 1) THEN
!
ef0 = efermig(etf,nbndsub,nkqf,nelec,wkf,degaussw,ngaussw,0,isk)
! if some bands are skipped (nbndskip.neq.0), nelec has already been
ef0 = efermig(etf, nbndsub, nkqf, nelec, wkf, degaussw, ngaussw, 0, isk_dummy)
! if some bands are skipped (nbndskip /= 0), nelec has already been
! recalculated in ephwann_shuffle
!
ELSE !SP: This is added for efficiency reason because the efermig routine is slow
@ -161,7 +162,7 @@
! N(Ef) in the equation for lambda is the DOS per spin
dosef = dosef / two
!
IF ( iqq .eq. 1 ) THEN
IF ( iqq == 1 ) THEN
WRITE (stdout, 100) degaussw * ryd2ev, ngaussw
WRITE (stdout, 101) dosef / ryd2ev, ef0 * ryd2ev
ENDIF
@ -176,8 +177,8 @@
ikq = ikk + 1
!
! Here we must have ef, not ef0, to be consistent with ephwann_shuffle
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
IF ( ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) < fsthick ) ) THEN
!
fermicount = fermicount + 1
!
@ -190,7 +191,7 @@
! innerloops. Therefore we do it here.
inv_wq = 1.0/(two * wq)
! the coupling from Gamma acoustic phonons is negligible
IF ( wq .gt. eps_acustic ) THEN
IF ( wq > eps_acustic ) THEN
g2_tmp = 1.0
ELSE
g2_tmp = 0.0
@ -281,13 +282,11 @@
#endif
!
WRITE(stdout,'(5x,a)')
IF (.not. ALLOCATED (a_all)) ALLOCATE ( a_all(nw_specfun, totq) )
a_all(:,iqq) = zero
!
IF (iqq == 1 ) THEN
IF (mpime.eq.ionode_id) THEN
OPEN(unit=iospectral,file='specfun.phon')
OPEN(unit=iospectral_sup,file='specfun_sup.phon')
IF (iqq == 1) THEN
IF (mpime == ionode_id) THEN
OPEN(UNIT=iospectral,FILE='specfun.phon')
OPEN(UNIT=iospectral_sup,FILE='specfun_sup.phon')
WRITE(iospectral, '(/2x,a)') '#Phonon spectral function (meV)'
WRITE(iospectral_sup, '(2x,a)') '#Phonon eigenenergies + real and im part of phonon self-energy (meV)'
WRITE(iospectral, '(/2x,a)') '#Q-point Energy[eV] A(q,w)[meV^-1]'
@ -319,11 +318,11 @@
! ( ( ww - wq - gammar_all (imode,iq,iw) + gamma0 (imode))**two + (gammai_all(imode,iq,iw) )**two )
! SP: From Eq. 16 of PRB 9, 4733 (1974)
! Also in Eq.2 of PRL 119, 017001 (2017).
a_all(iw,iqq) = a_all(iw,iqq) + (1.0d0/pi) * ((2*wq)**2) * ABS( gammai_all(iw, imode) ) / &
( ( ww**2 - wq**2 - 2 * wq * ( gammar_all (iw, imode) - gamma0 (imode) ) )**two +&
a_all_ph(iw, iqq) = a_all_ph(iw, iqq) + (1.0d0 / pi) * ((2 * wq)**2) * ABS(gammai_all(iw, imode)) / &
( ( ww**2 - wq**2 - 2 * wq * (gammar_all(iw, imode) - gamma0(imode)))**two + &
(2 * wq * gammai_all(iw, imode) )**two )
!
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
WRITE(iospectral_sup,'(2i9,2x,f12.5,2x,f12.5,2x,E22.14,2x,E22.14,2x,E22.14)') iq,&
imode, ryd2ev * wq, ryd2ev * ww, ryd2mev * gammar_all(iw, imode), ryd2mev * gamma0(imode),&
ryd2mev * gammai_all(iw, imode)
@ -331,8 +330,8 @@
!
ENDDO
!
IF (mpime.eq.ionode_id) THEN
WRITE(iospectral,'(2x,i7,2x,f12.5,2x,E22.14)') iq, ryd2ev * ww, a_all(iw,iqq) / ryd2mev ! print to file
IF (mpime == ionode_id) THEN
WRITE(iospectral,'(2x,i7,2x,f12.5,2x,E22.14)') iq, ryd2ev * ww, a_all_ph(iw, iqq) / ryd2mev ! print to file
ENDIF
!
ENDDO

807
EPW/src/spectral_func_pl.f90
View File

@ -1,410 +1,397 @@
!
! Copyright (C) 2010-2016 Samuel Ponce', Roxana Margine, Carla Verdi, Feliciano Giustino
! Copyright (C) 2007-2009 Jesse Noffsinger, Brad Malone, Feliciano Giustino
!
! This file is distributed under the terms of the GNU General Public
! License. See the file `LICENSE' in the root directory of the
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE spectral_func_pl_q ( iqq, iq, totq )
!-----------------------------------------------------------------------
!
! Compute the electron spectral function including the electron-
! phonon interaction in the Migdal approximation.
!
! We take the trace of the spectral function to simulate the photoemission
! intensity. I do not consider the c-axis average for the time being.
! The main approximation is constant dipole matrix element and diagonal
! selfenergy. The diagonality can be checked numerically.
!
! Use matrix elements, electronic eigenvalues and phonon frequencies
! from ep-wannier interpolation
!
!-----------------------------------------------------------------------
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE io_epw, ONLY : iospectral_sup, iospectral
USE epwcom, ONLY : nbndsub, &
fsthick, eptemp, ngaussw, degaussw, wmin_specfun,&
wmax_specfun, nw_specfun, &
efermi_read, fermi_energy,&
nel, meff, epsiHEG
USE pwcom, ONLY : nelec, ef, isk
USE elph2, ONLY : etf, ibndmin, ibndmax, nkqf, &
wkf, nkf, wqf, xkf, nkqtotf,&
esigmar_all, esigmai_all, a_all,&
xqf, dmef
USE constants_epw, ONLY : ryd2mev, one, ryd2ev, two, zero, pi, ci
USE mp, ONLY : mp_barrier, mp_sum
USE mp_global, ONLY : me_pool, inter_pool_comm
USE cell_base, ONLY : omega, alat, bg
USE division, ONLY : fkbounds
!
implicit none
!
INTEGER, INTENT(IN) :: iqq
!! Q-point index in selecq
INTEGER, INTENT(IN) :: iq
!! Q-point index
INTEGER, INTENT(IN) :: totq
!! Total number of q-points in fsthick window
!
! variables for collecting data from all pools in parallel case
!
INTEGER :: iw, ik, ikk, ikq, ibnd, jbnd, fermicount
INTEGER :: nksqtotf, lower_bnd, upper_bnd
REAL(kind=DP), external :: efermig, dos_ef, wgauss
REAL(kind=DP) :: g2, ekk, ekq, wq, ef0, wgq, wgkq, ww, dw, weight
REAL(kind=DP) :: specfun_sum, esigmar0, tpiba_new
REAL(kind=DP) :: fermi(nw_specfun)
REAL(kind=DP), allocatable :: xkf_all(:,:) , etf_all(:,:)
REAL(kind=DP) :: kF, vF, fermiHEG, qin, wpl0, eps0, deltaeps, qcut, &
qsquared, qTF, dipole, rs, ekk1, degen
REAL(kind=DP) :: q(3)
!! The q-point in cartesian unit.
!
! loop over temperatures can be introduced
!
! energy range and spacing for spectral function
!
dw = ( wmax_specfun - wmin_specfun ) / dble (nw_specfun-1)
!
IF ( iqq == 1 ) THEN
!
WRITE(stdout,'(/5x,a)') repeat('=',67)
WRITE(stdout,'(5x,"Electron Spectral Function in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick .lt. 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Golden Rule strictly enforced with T = ',eptemp * ryd2ev, ' eV'
!
ENDIF
!
! Fermi level and corresponding DOS
!
IF ( efermi_read ) THEN
!
ef0 = fermi_energy
!
ELSE
!
ef0 = efermig(etf,nbndsub,nkqf,nelec,wkf,degaussw,ngaussw,0,isk)
! if some bands are skipped (nbndskip.neq.0), nelec has already been recalculated
! in ephwann_shuffle
!
ENDIF
!
IF ( iqq == 1 ) THEN
WRITE (stdout, 100) degaussw * ryd2ev, ngaussw
WRITE (stdout,'(a)') ' '
ENDIF
!
! The total number of k points
!
nksqtotf = nkqtotf/2 ! odd-even for k,k+q
!
! find the bounds of k-dependent arrays in the parallel case in each pool
CALL fkbounds( nksqtotf, lower_bnd, upper_bnd )
!
IF ( iqq == 1 ) THEN
IF ( .not. ALLOCATED(esigmar_all) ) ALLOCATE( esigmar_all(ibndmax-ibndmin+1, nksqtotf, nw_specfun) )
IF ( .not. ALLOCATED(esigmai_all) ) ALLOCATE( esigmai_all(ibndmax-ibndmin+1, nksqtotf, nw_specfun) )
esigmar_all(:,:,:) = zero
esigmai_all(:,:,:) = zero
ENDIF
!
! SP: Sum rule added to conserve the number of electron.
IF ( iqq == 1 ) THEN
WRITE (stdout,'(5x,a)') 'The sum rule to conserve the number of electron is enforced.'
WRITE (stdout,'(5x,a)') 'The self energy is rescaled so that its real part is zero at the Fermi level.'
WRITE (stdout,'(5x,a)') 'The sum rule replace the explicit calculation of the Debye-Waller term.'
WRITE (stdout,'(a)') ' '
ENDIF
!
!
!nel = 0.01 ! this should be read from input - # of doping electrons
!epsiHEG = 12.d0 ! this should be read from input - # dielectric constant at zero doping
!meff = 0.25 ! this should be read from input - effective mass
tpiba_new= 2.0d0 * pi / alat
degen = 1.0d0
rs = (3.d0/(4.d0*pi*nel/omega/degen))**(1.d0/3.d0)*meff*degen ! omega is the unit cell volume in Bohr^3
! rs = (3.d0/(4.d0*pi*nel/omega/degen))**(1.d0/3.d0)*meff*degen/epsiHEG ! omega is the unit cell volume in Bohr^3
kF = (3.d0*pi**2*nel/omega/degen )**(1.d0/3.d0)
vF = 1.d0/meff * (3.d0*pi**2*nel/omega/degen)**(1.d0/3.d0)
fermiHEG = 1.d0/(2.d0*meff) * (3.d0*pi**2*nel/omega/degen)**(2.d0/3.d0) * 2.d0 ! [Ryd] multiplication by 2 converts from Ha to Ry
qTF = (6.d0*pi*nel/omega/degen/(fermiHEG/2.d0))**(1.d0/2.d0) ! [a.u.]
wpl0 = sqrt(4.d0*pi*nel/omega/meff/epsiHEG) * 2.d0 ! [Ryd] multiplication by 2 converts from Ha to Ryd
wq = wpl0 ! [Ryd]
q(:) = xqf(:,iq)
CALL cryst_to_cart (1, q, bg, 1)
qsquared = (q(1)**2 + q(2)**2 + q(3)**2)
qin = sqrt(qsquared)*tpiba_new
qcut = wpl0 / vF / tpiba_new / 2.d0 ! 1/2 converts from Ryd to Ha
!qcut = qcut / 2.d0 ! phenomenological Landau damping
!
! qcut2 = kF * ( sqrt( 1.d0 + wpl0 / fermiHEG) - 1.d0 ) / tpiba_new
CALL get_eps_mahan (qin,rs,kF,eps0) ! qin should be in atomic units for Mahan formula
!call get_eps_mahan (qin,qTF,kF,eps0) ! qin should be in atomic units for Mahan formula
deltaeps = -(1.d0/(epsiHEG+eps0-1.d0)-1.d0/epsiHEG)
!
IF (iq .EQ. 1) THEN
WRITE(stdout,'(12x," nel = ", E15.10)') nel
WRITE(stdout,'(12x," meff = ", E15.10)') meff
WRITE(stdout,'(12x," rs = ", E15.10)') rs
WRITE(stdout,'(12x," kF = ", E15.10)') kF
WRITE(stdout,'(12x," vF = ", E15.10)') vF
WRITE(stdout,'(12x," fermi_en = ", E15.10)') fermiHEG
WRITE(stdout,'(12x," qTF = ", E15.10)') qTF
WRITE(stdout,'(12x," wpl = ", E15.10)') wpl0
WRITE(stdout,'(12x," qcut = ", E15.10)') qcut
WRITE(stdout,'(12x," eps0 = ", E15.10)') eps0
WRITE(stdout,'(12x," epsiHEG = ", E15.10)') epsiHEG
WRITE(stdout,'(12x," deltaeps = ", E15.10)') deltaeps
ENDIF
!
IF (sqrt(qsquared) < qcut) THEN
!
! loop over all k points of the fine mesh
!
fermicount = 0
DO ik = 1, nkf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
! (but in this case they are the same)
!
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
!
fermicount = fermicount + 1
!
! Bose occupation
wgq = wgauss( -wq/eptemp, -99)
wgq = wgq / ( one - two * wgq )
!
DO ibnd = 1, ibndmax-ibndmin+1
!
! the energy of the electron at k (relative to Ef)
ekk = etf (ibndmin-1+ibnd, ikk) - ef0
!
DO jbnd = 1, ibndmax-ibndmin+1
!
! the fermi occupation for k+q
ekk1 = etf (ibndmin-1+jbnd, ikk) - ef0
ekq = etf (ibndmin-1+jbnd, ikq) - ef0
wgkq = wgauss( -ekq/eptemp, -99)
!
!computation of the dipole
if (ibnd==jbnd) then
if(sqrt(qsquared) .gt. 1d-6)then
dipole = 1./(qsquared * tpiba_new * tpiba_new)
else
dipole = 0.d0
endif
else
if (abs(ekq-ekk1) > 1d-6) then
dipole = REAL( dmef(1,ibndmin-1+jbnd,ibndmin-1+ibnd,ikk) * &
conjg(dmef(1,ibndmin-1+jbnd,ibndmin-1+ibnd,ikk))/((ekk1-ekk)**2 + degaussw**2) )
else
dipole = 0.d0
endif
endif
!
g2 = dipole*4.d0*pi * (wq*deltaeps/2.d0)/omega * 2.d0 ! The q^-2 is cancelled by the q->0 limit of the dipole. See e.g., pg. 258 of Grosso Parravicini.
!
DO iw = 1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
!
weight = wqf(iq) * real ( &
( ( wgkq + wgq ) / ( ww - ( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( ww - ( ekq + wq ) - ci * degaussw ) ) )
!
esigmar_all(ibnd,ik+lower_bnd-1,iw) = esigmar_all(ibnd,ik+lower_bnd-1,iw) + g2 * weight
!
! SP : Application of the sum rule
esigmar0 = g2 * wqf(iq) * real ( &
( ( wgkq + wgq ) / ( -( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( -( ekq + wq ) - ci * degaussw ) ) )
esigmar_all(ibnd,ik+lower_bnd-1,iw)=esigmar_all(ibnd,ik+lower_bnd-1,iw)-esigmar0
!
weight = wqf(iq) * aimag ( &
( ( wgkq + wgq ) / ( ww - ( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( ww - ( ekq + wq ) - ci * degaussw ) ) )
!
esigmai_all(ibnd,ik+lower_bnd-1,iw) = esigmai_all(ibnd,ik+lower_bnd-1,iw) + g2 * weight
!
ENDDO
!
ENDDO !jbnd
!
ENDDO !ibnd
!
!
ENDIF ! endif fsthick
!
ENDDO ! end loop on k
!
ENDIF
!
! The k points are distributed among pools: here we collect them
!
IF ( iqq == totq ) THEN
!
ALLOCATE ( xkf_all ( 3, nkqtotf ), &
etf_all ( nbndsub, nkqtotf ) )
xkf_all(:,:) = zero
etf_all(:,:) = zero
!
#if defined(__MPI)
!
! note that poolgather2 works with the doubled grid (k and k+q)
!
CALL poolgather2 ( 3, nkqtotf, nkqf, xkf, xkf_all )
CALL poolgather2 ( nbndsub, nkqtotf, nkqf, etf, etf_all )
CALL mp_sum( esigmar_all, inter_pool_comm )
CALL mp_sum( esigmai_all, inter_pool_comm )
CALL mp_sum( fermicount, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
#else
!
xkf_all = xkf
etf_all = etf
!
#endif
!
! Output electron spectral function here after looping over all q-points
! (with their contributions summed in a etc.)
!
WRITE(stdout,'(5x,"WARNING: only the eigenstates within the Fermi window are meaningful")')
!
! construct the trace of the spectral function (assume diagonal selfenergy
! and constant matrix elements for dipole transitions)
!
IF (.not. ALLOCATED (a_all)) ALLOCATE ( a_all(nw_specfun, nksqtotf) )
a_all(:,:) = zero
!
IF (me_pool == 0) then
OPEN(unit=iospectral,file='specfun.plself')
OPEN(unit=iospectral_sup,file='specfun_sup.plself')
ENDIF
IF (me_pool == 0) then
WRITE(iospectral, '(/2x,a/)') '#Electron-plasmon spectral function (meV)'
WRITE(iospectral_sup, '(/2x,a/)') '#KS eigenenergies + real and im part of electron-plasmon self-energy (meV)'
ENDIF
IF (me_pool == 0) then
WRITE(iospectral, '(/2x,a/)') '#K-point Energy[meV] A(k,w)[meV^-1]'
WRITE(iospectral_sup, '(/2x,a/)') '#K-point Band e_nk[eV] w[eV] &
& Real Sigma[meV] Im Sigma[meV]'
ENDIF
!
DO ik = 1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
WRITE(stdout,'(/5x,"ik = ",i5," coord.: ", 3f12.7)') ik, xkf_all (:,ikk)
WRITE(stdout,'(5x,a)') repeat('-',67)
!
DO iw = 1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
!
DO ibnd = 1, ibndmax-ibndmin+1
!
! the energy of the electron at k
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
a_all(iw,ik) = a_all(iw,ik) + abs( esigmai_all(ibnd,ik,iw) ) / pi / &
( ( ww - ekk - esigmar_all(ibnd,ik,iw) )**two + (esigmai_all(ibnd,ik,iw) )**two )
!
ENDDO
!
WRITE(stdout, 103) ik, ryd2ev * ww, a_all(iw,ik) / ryd2mev
!
ENDDO
!
WRITE(stdout,'(5x,a/)') repeat('-',67)
!
ENDDO
!
DO ik = 1, nksqtotf
!
! The spectral function should integrate to 1 for each k-point
specfun_sum = 0.0
!
DO iw = 1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
fermi(iw) = wgauss(-ww/eptemp, -99)
! WRITE(stdout,'(2x,i7,2x,f12.4,2x,e12.5)') ik, ryd2ev * ww, a_all(iw,ik) / ryd2mev
!
specfun_sum = specfun_sum + a_all(iw,ik)* fermi(iw) * dw !/ ryd2mev
!
IF (me_pool == 0) &
WRITE(iospectral,'(2x,i7,2x,f10.5,2x,e12.5)') ik, ryd2ev * ww, a_all(iw,ik) / ryd2mev
!
ENDDO
!
IF (me_pool == 0) &
WRITE(iospectral,'(a)') ' '
IF (me_pool == 0) &
WRITE(iospectral,'(2x,a,2x,e12.5)') '# Integrated spectral function ',specfun_sum
!
ENDDO
!
IF (me_pool == 0) CLOSE(iospectral)
!
DO ibnd = 1, ibndmax-ibndmin+1
!
DO ik = 1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
! the energy of the electron at k
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
DO iw = 1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
WRITE(stdout,'(2i9,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4)') ik,&
ibndmin-1+ibnd, ryd2ev * ekk, ryd2ev * ww, ryd2mev * esigmar_all(ibnd,ik,iw),&
ryd2mev * esigmai_all(ibnd,ik,iw)
!
IF (me_pool == 0) &
WRITE(iospectral_sup,'(2i9,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4)') ik,&
ibndmin-1+ibnd, ryd2ev * ekk, ryd2ev * ww, ryd2mev * esigmar_all(ibnd,ik,iw),&
ryd2mev * esigmai_all(ibnd,ik,iw)
!
ENDDO
!
ENDDO
!
WRITE(stdout,*) ' '
!
ENDDO
!
IF (me_pool == 0) CLOSE(iospectral_sup)
!
IF ( ALLOCATED(xkf_all) ) DEALLOCATE( xkf_all )
IF ( ALLOCATED(etf_all) ) DEALLOCATE( etf_all )
IF ( ALLOCATED(esigmar_all) ) DEALLOCATE( esigmar_all )
IF ( ALLOCATED(esigmai_all) ) DEALLOCATE( esigmai_all )
IF ( ALLOCATED(a_all) ) DEALLOCATE( a_all )
!
ENDIF
!
100 FORMAT(5x,'Gaussian Broadening: ',f10.6,' eV, ngauss=',i4)
103 FORMAT(5x,'ik = ',i7,' w = ',f9.4,' eV A(k,w) = ',e12.5,' meV^-1')
!
RETURN
!
END SUBROUTINE spectral_func_pl_q
!
! Copyright (C) 2010-2016 Samuel Ponce', Roxana Margine, Carla Verdi, Feliciano Giustino
! Copyright (C) 2007-2009 Jesse Noffsinger, Brad Malone, Feliciano Giustino
!
! This file is distributed under the terms of the GNU General Public
! License. See the file `LICENSE' in the root directory of the
! present distribution, or http://www.gnu.org/copyleft.gpl.txt .
!
!-----------------------------------------------------------------------
SUBROUTINE spectral_func_pl_q(iqq, iq, totq)
!-----------------------------------------------------------------------
!
! Compute the electron spectral function including the electron-
! phonon interaction in the Migdal approximation.
!
! We take the trace of the spectral function to simulate the photoemission
! intensity. I do not consider the c-axis average for the time being.
! The main approximation is constant dipole matrix element and diagonal
! selfenergy. The diagonality can be checked numerically.
!
! Use matrix elements, electronic eigenvalues and phonon frequencies
! from ep-wannier interpolation
!
!-----------------------------------------------------------------------
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE io_epw, ONLY : iospectral_sup, iospectral
USE epwcom, ONLY : nbndsub, &
fsthick, eptemp, ngaussw, degaussw, wmin_specfun,&
wmax_specfun, nw_specfun, &
efermi_read, fermi_energy,&
nel, meff, epsiHEG
USE pwcom, ONLY : nelec, ef
USE klist_epw, ONLY : isk_dummy
USE elph2, ONLY : etf, ibndmin, ibndmax, nkqf, &
wkf, nkf, wqf, xkf, nkqtotf,&
esigmar_all, esigmai_all, a_all,&
xqf, dmef
USE constants_epw, ONLY : ryd2mev, one, ryd2ev, two, zero, pi, ci
USE mp, ONLY : mp_barrier, mp_sum
USE mp_global, ONLY : me_pool, inter_pool_comm
USE cell_base, ONLY : omega, alat, bg
USE division, ONLY : fkbounds
!
implicit none
!
INTEGER, INTENT(IN) :: iqq
!! Q-point index in selecq
INTEGER, INTENT(IN) :: iq
!! Q-point index
INTEGER, INTENT(IN) :: totq
!! Total number of q-points in fsthick window
!
! variables for collecting data from all pools in parallel case
!
INTEGER :: iw, ik, ikk, ikq, ibnd, jbnd, fermicount
INTEGER :: nksqtotf, lower_bnd, upper_bnd
REAL(kind=DP), external :: efermig, dos_ef, wgauss
REAL(kind=DP) :: g2, ekk, ekq, wq, ef0, wgq, wgkq, ww, dw, weight
REAL(kind=DP) :: specfun_sum, esigmar0, tpiba_new
REAL(kind=DP) :: fermi(nw_specfun)
REAL(kind=DP), allocatable :: xkf_all(:,:) , etf_all(:,:)
REAL(kind=DP) :: kF, vF, fermiHEG, qin, wpl0, eps0, deltaeps, qcut, &
qsquared, qTF, dipole, rs, ekk1, degen
REAL(kind=DP) :: q(3)
!! The q-point in cartesian unit.
!
! loop over temperatures can be introduced
!
! energy range and spacing for spectral function
!
dw = ( wmax_specfun - wmin_specfun ) / dble (nw_specfun-1)
!
IF ( iqq == 1 ) THEN
!
WRITE(stdout,'(/5x,a)') repeat('=',67)
WRITE(stdout,'(5x,"Electron Spectral Function in the Migdal Approximation")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(/5x,a,f10.6,a)' ) &
'Golden Rule strictly enforced with T = ',eptemp * ryd2ev, ' eV'
!
ENDIF
!
! Fermi level and corresponding DOS
!
IF ( efermi_read ) THEN
!
ef0 = fermi_energy
!
ELSE
!
ef0 = efermig(etf, nbndsub, nkqf, nelec, wkf, degaussw, ngaussw, 0, isk_dummy)
! if some bands are skipped (nbndskip /= 0), nelec has already been recalculated
! in ephwann_shuffle
!
ENDIF
!
IF ( iqq == 1 ) THEN
WRITE (stdout, 100) degaussw * ryd2ev, ngaussw
WRITE (stdout,'(a)') ' '
ENDIF
!
! The total number of k points
!
nksqtotf = nkqtotf/2 ! odd-even for k,k+q
!
! find the bounds of k-dependent arrays in the parallel case in each pool
CALL fkbounds( nksqtotf, lower_bnd, upper_bnd )
!
! SP: Sum rule added to conserve the number of electron.
IF (iqq == 1) THEN
WRITE (stdout,'(5x,a)') 'The sum rule to conserve the number of electron is enforced.'
WRITE (stdout,'(5x,a)') 'The self energy is rescaled so that its real part is zero at the Fermi level.'
WRITE (stdout,'(5x,a)') 'The sum rule replace the explicit calculation of the Debye-Waller term.'
WRITE (stdout,'(a)') ' '
ENDIF
!
!
!nel = 0.01 ! this should be read from input - # of doping electrons
!epsiHEG = 12.d0 ! this should be read from input - # dielectric constant at zero doping
!meff = 0.25 ! this should be read from input - effective mass
tpiba_new= 2.0d0 * pi / alat
degen = 1.0d0
rs = (3.d0/(4.d0*pi*nel/omega/degen))**(1.d0/3.d0)*meff*degen ! omega is the unit cell volume in Bohr^3
! rs = (3.d0/(4.d0*pi*nel/omega/degen))**(1.d0/3.d0)*meff*degen/epsiHEG ! omega is the unit cell volume in Bohr^3
kF = (3.d0*pi**2*nel/omega/degen )**(1.d0/3.d0)
vF = 1.d0/meff * (3.d0*pi**2*nel/omega/degen)**(1.d0/3.d0)
fermiHEG = 1.d0/(2.d0*meff) * (3.d0*pi**2*nel/omega/degen)**(2.d0/3.d0) * 2.d0 ! [Ryd] multiplication by 2 converts from Ha to Ry
qTF = (6.d0*pi*nel/omega/degen/(fermiHEG/2.d0))**(1.d0/2.d0) ! [a.u.]
wpl0 = sqrt(4.d0*pi*nel/omega/meff/epsiHEG) * 2.d0 ! [Ryd] multiplication by 2 converts from Ha to Ryd
wq = wpl0 ! [Ryd]
q(:) = xqf(:,iq)
CALL cryst_to_cart (1, q, bg, 1)
qsquared = (q(1)**2 + q(2)**2 + q(3)**2)
qin = sqrt(qsquared)*tpiba_new
qcut = wpl0 / vF / tpiba_new / 2.d0 ! 1/2 converts from Ryd to Ha
!qcut = qcut / 2.d0 ! phenomenological Landau damping
!
! qcut2 = kF * ( sqrt( 1.d0 + wpl0 / fermiHEG) - 1.d0 ) / tpiba_new
CALL get_eps_mahan (qin,rs,kF,eps0) ! qin should be in atomic units for Mahan formula
!call get_eps_mahan (qin,qTF,kF,eps0) ! qin should be in atomic units for Mahan formula
deltaeps = -(1.d0/(epsiHEG+eps0-1.d0)-1.d0/epsiHEG)
!
IF (iq .EQ. 1) THEN
WRITE(stdout,'(12x," nel = ", E15.10)') nel
WRITE(stdout,'(12x," meff = ", E15.10)') meff
WRITE(stdout,'(12x," rs = ", E15.10)') rs
WRITE(stdout,'(12x," kF = ", E15.10)') kF
WRITE(stdout,'(12x," vF = ", E15.10)') vF
WRITE(stdout,'(12x," fermi_en = ", E15.10)') fermiHEG
WRITE(stdout,'(12x," qTF = ", E15.10)') qTF
WRITE(stdout,'(12x," wpl = ", E15.10)') wpl0
WRITE(stdout,'(12x," qcut = ", E15.10)') qcut
WRITE(stdout,'(12x," eps0 = ", E15.10)') eps0
WRITE(stdout,'(12x," epsiHEG = ", E15.10)') epsiHEG
WRITE(stdout,'(12x," deltaeps = ", E15.10)') deltaeps
ENDIF
!
IF (sqrt(qsquared) < qcut) THEN
!
! loop over all k points of the fine mesh
!
fermicount = 0
DO ik = 1, nkf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
! (but in this case they are the same)
!
IF ( ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) < fsthick ) ) THEN
!
fermicount = fermicount + 1
!
! Bose occupation
wgq = wgauss( -wq/eptemp, -99)
wgq = wgq / ( one - two * wgq )
!
DO ibnd = 1, ibndmax-ibndmin+1
!
! the energy of the electron at k (relative to Ef)
ekk = etf (ibndmin-1+ibnd, ikk) - ef0
!
DO jbnd = 1, ibndmax-ibndmin+1
!
! the fermi occupation for k+q
ekk1 = etf (ibndmin-1+jbnd, ikk) - ef0
ekq = etf (ibndmin-1+jbnd, ikq) - ef0
wgkq = wgauss( -ekq/eptemp, -99)
!
!computation of the dipole
if (ibnd==jbnd) then
if(sqrt(qsquared) > 1d-6)then
dipole = 1./(qsquared * tpiba_new * tpiba_new)
else
dipole = 0.d0
endif
else
if (abs(ekq-ekk1) > 1d-6) then
dipole = REAL( dmef(1,ibndmin-1+jbnd,ibndmin-1+ibnd,ikk) * &
conjg(dmef(1,ibndmin-1+jbnd,ibndmin-1+ibnd,ikk))/((ekk1-ekk)**2 + degaussw**2) )
else
dipole = 0.d0
endif
endif
!
g2 = dipole*4.d0*pi * (wq*deltaeps/2.d0)/omega * 2.d0 ! The q^-2 is cancelled by the q->0 limit of the dipole. See e.g., pg. 258 of Grosso Parravicini.
!
DO iw = 1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
!
weight = wqf(iq) * real ( &
( ( wgkq + wgq ) / ( ww - ( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( ww - ( ekq + wq ) - ci * degaussw ) ) )
!
esigmar_all(ibnd,ik+lower_bnd-1,iw) = esigmar_all(ibnd,ik+lower_bnd-1,iw) + g2 * weight
!
! SP : Application of the sum rule
esigmar0 = g2 * wqf(iq) * real ( &
( ( wgkq + wgq ) / ( -( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( -( ekq + wq ) - ci * degaussw ) ) )
esigmar_all(ibnd,ik+lower_bnd-1,iw)=esigmar_all(ibnd,ik+lower_bnd-1,iw)-esigmar0
!
weight = wqf(iq) * aimag ( &
( ( wgkq + wgq ) / ( ww - ( ekq - wq ) - ci * degaussw ) + &
( one - wgkq + wgq ) / ( ww - ( ekq + wq ) - ci * degaussw ) ) )
!
esigmai_all(ibnd,ik+lower_bnd-1,iw) = esigmai_all(ibnd,ik+lower_bnd-1,iw) + g2 * weight
!
ENDDO
!
ENDDO !jbnd
!
ENDDO !ibnd
!
!
ENDIF ! endif fsthick
!
ENDDO ! end loop on k
!
ENDIF
!
! The k points are distributed among pools: here we collect them
!
IF (iqq == totq) THEN
!
ALLOCATE (xkf_all(3, nkqtotf))
ALLOCATE (etf_all(nbndsub, nkqtotf))
xkf_all(:, :) = zero
etf_all(:, :) = zero
!
#if defined(__MPI)
!
! note that poolgather2 works with the doubled grid (k and k+q)
!
CALL poolgather2 ( 3, nkqtotf, nkqf, xkf, xkf_all )
CALL poolgather2 ( nbndsub, nkqtotf, nkqf, etf, etf_all )
CALL mp_sum( esigmar_all, inter_pool_comm )
CALL mp_sum( esigmai_all, inter_pool_comm )
CALL mp_sum( fermicount, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
#else
!
xkf_all = xkf
etf_all = etf
!
#endif
!
! Output electron spectral function here after looping over all q-points
! (with their contributions summed in a etc.)
!
WRITE(stdout,'(5x,"WARNING: only the eigenstates within the Fermi window are meaningful")')
!
! construct the trace of the spectral function (assume diagonal selfenergy
! and constant matrix elements for dipole transitions)
!
IF (me_pool == 0) then
OPEN(UNIT=iospectral,FILE='specfun.plself')
OPEN(UNIT=iospectral_sup,FILE='specfun_sup.plself')
ENDIF
IF (me_pool == 0) then
WRITE(iospectral, '(/2x,a/)') '#Electron-plasmon spectral function (meV)'
WRITE(iospectral_sup, '(/2x,a/)') '#KS eigenenergies + real and im part of electron-plasmon self-energy (meV)'
ENDIF
IF (me_pool == 0) then
WRITE(iospectral, '(/2x,a/)') '#K-point Energy[meV] A(k,w)[meV^-1]'
WRITE(iospectral_sup, '(/2x,a/)') '#K-point Band e_nk[eV] w[eV] &
& Real Sigma[meV] Im Sigma[meV]'
ENDIF
!
DO ik = 1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
WRITE(stdout,'(/5x,"ik = ",i5," coord.: ", 3f12.7)') ik, xkf_all (:,ikk)
WRITE(stdout,'(5x,a)') repeat('-',67)
!
DO iw = 1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
!
DO ibnd = 1, ibndmax-ibndmin+1
!
! the energy of the electron at k
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
a_all(iw,ik) = a_all(iw,ik) + abs( esigmai_all(ibnd,ik,iw) ) / pi / &
( ( ww - ekk - esigmar_all(ibnd,ik,iw) )**two + (esigmai_all(ibnd,ik,iw) )**two )
!
ENDDO
!
WRITE(stdout, 103) ik, ryd2ev * ww, a_all(iw,ik) / ryd2mev
!
ENDDO
!
WRITE(stdout,'(5x,a/)') repeat('-',67)
!
ENDDO
!
DO ik=1, nksqtotf
!
! The spectral function should integrate to 1 for each k-point
specfun_sum = 0.0
!
DO iw=1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
fermi(iw) = wgauss(-ww/eptemp, -99)
! WRITE(stdout,'(2x,i7,2x,f12.4,2x,e12.5)') ik, ryd2ev * ww, a_all(iw,ik) / ryd2mev
!
specfun_sum = specfun_sum + a_all(iw,ik)* fermi(iw) * dw !/ ryd2mev
!
IF (me_pool == 0) &
WRITE(iospectral,'(2x,i7,2x,f10.5,2x,e12.5)') ik, ryd2ev * ww, a_all(iw,ik) / ryd2mev
!
ENDDO
!
IF (me_pool == 0) &
WRITE(iospectral,'(a)') ' '
IF (me_pool == 0) &
WRITE(iospectral,'(2x,a,2x,e12.5)') '# Integrated spectral function ',specfun_sum
!
ENDDO
!
IF (me_pool == 0) CLOSE(iospectral)
!
DO ibnd=1, ibndmax-ibndmin+1
!
DO ik=1, nksqtotf
!
ikk = 2 * ik - 1
ikq = ikk + 1
!
! the energy of the electron at k
ekk = etf_all (ibndmin-1+ibnd, ikk) - ef0
!
DO iw=1, nw_specfun
!
ww = wmin_specfun + dble (iw-1) * dw
WRITE(stdout,'(2i9,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4)') ik,&
ibndmin-1+ibnd, ryd2ev * ekk, ryd2ev * ww, ryd2mev * esigmar_all(ibnd,ik,iw),&
ryd2mev * esigmai_all(ibnd,ik,iw)
!
IF (me_pool == 0) &
WRITE(iospectral_sup,'(2i9,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4,2x,f12.4)') ik,&
ibndmin-1+ibnd, ryd2ev * ekk, ryd2ev * ww, ryd2mev * esigmar_all(ibnd,ik,iw),&
ryd2mev * esigmai_all(ibnd,ik,iw)
!
ENDDO
!
ENDDO
!
WRITE(stdout,*) ' '
!
ENDDO
!
IF (me_pool == 0) CLOSE(iospectral_sup)
!
DEALLOCATE (xkf_all)
DEALLOCATE (etf_all)
ENDIF
!
100 FORMAT(5x,'Gaussian Broadening: ',f10.6,' eV, ngauss=',i4)
103 FORMAT(5x,'ik = ',i7,' w = ',f9.4,' eV A(k,w) = ',e12.5,' meV^-1')
!
RETURN
!
END SUBROUTINE spectral_func_pl_q

248
EPW/src/superconductivity.f90
View File

@ -41,9 +41,9 @@
!
IF ( eliashberg .AND. liso .AND. laniso ) CALL errore('eliashberg_init', &
'liso or laniso needs to be true',1)
IF ( .not.eliashberg .AND. liso ) CALL errore('eliashberg_init', &
IF ( .NOT. eliashberg .AND. liso ) CALL errore('eliashberg_init', &
'liso requires eliashberg true',1)
IF ( .not.eliashberg .AND. laniso ) CALL errore('eliashberg_init', &
IF ( .NOT. eliashberg .AND. laniso ) CALL errore('eliashberg_init', &
'laniso requires eliashberg true',1)
IF ( laniso .and. (fila2f .ne. ' ') ) &
CALL errore('eliashberg_init', 'anisotropic case can not use fila2f',1)
@ -55,62 +55,62 @@
CALL errore('eliashberg_init', 'lreal or lacon needs to be true',1)
IF ( eliashberg .AND. lreal .AND. lpade ) &
CALL errore('eliashberg_init', 'lreal or lpade needs to be true',1)
IF ( eliashberg .AND. imag_read .AND. .not.limag .AND. .not.laniso ) &
IF ( eliashberg .AND. imag_read .AND. .NOT. limag .AND. .NOT. laniso ) &
CALL errore('eliashberg_init', 'imag_read requires limag true and laniso true',1)
IF ( eliashberg .AND. lpade .AND. .not.limag ) &
IF ( eliashberg .AND. lpade .AND. .NOT. limag ) &
CALL errore('eliashberg_init', 'lpade requires limag true',1)
IF ( eliashberg .AND. lacon .AND. (.not.limag .OR. .not.lpade ) ) &
IF ( eliashberg .AND. lacon .AND. ( .NOT. limag .OR. .NOT. lpade ) ) &
CALL errore('eliashberg_init', 'lacon requires both limag and lpade true',1)
IF ( eliashberg .AND. lreal .AND. (kerread .AND. kerwrite) ) &
CALL errore('eliashberg_init', 'kerread cannot be used with kerwrite',1)
IF ( eliashberg .AND. lreal .AND. (.not.kerread .AND. .not.kerwrite) ) &
IF ( eliashberg .AND. lreal .AND. ( .NOT. kerread .AND. .NOT. kerwrite) ) &
CALL errore('eliashberg_init', 'kerread or kerwrite must be true',1)
IF ( eliashberg .AND. lreal .AND. wsfc .gt. wscut ) CALL errore('eliashberg_init', &
'wsfc should be .lt. wscut',1)
IF ( eliashberg .AND. lreal .AND. wsfc .lt. 0.d0 ) CALL errore('eliashberg_init', &
'wsfc should be .gt. 0.d0',1)
IF ( eliashberg .AND. nswi .gt. 0 .AND. .not.limag ) &
IF ( eliashberg .AND. lreal .AND. wsfc > wscut ) CALL errore('eliashberg_init', &
'wsfc should be < wscut',1)
IF ( eliashberg .AND. lreal .AND. wsfc < 0.d0 ) CALL errore('eliashberg_init', &
'wsfc should be > 0.d0',1)
IF ( eliashberg .AND. nswi > 0 .AND. .NOT. limag ) &
CALL errore('eliashberg_init', 'nswi requires limag true',1)
IF ( eliashberg .AND. nswi .lt. 0 ) CALL errore('eliashberg_init', &
'nswi should be .gt. 0',1)
IF ( eliashberg .AND. wscut .lt. 0.d0 ) &
CALL errore('eliashberg_init', 'wscut should be .gt. 0.d0',1)
IF ( eliashberg .AND. nstemp .lt. 1 ) CALL errore('eliashberg_init', &
IF ( eliashberg .AND. nswi < 0 ) CALL errore('eliashberg_init', &
'nswi should be > 0',1)
IF ( eliashberg .AND. wscut < 0.d0 ) &
CALL errore('eliashberg_init', 'wscut should be > 0.d0',1)
IF ( eliashberg .AND. nstemp < 1 ) CALL errore('eliashberg_init', &
'wrong number of nstemp',1)
IF ( eliashberg .AND. maxval(temps(:)) .gt. 0.d0 .AND. &
tempsmin .gt. 0.d0 .AND. tempsmax .gt. 0.d0 ) &
IF ( eliashberg .AND. maxval(temps(:)) > 0.d0 .AND. &
tempsmin > 0.d0 .AND. tempsmax > 0.d0 ) &
CALL errore('eliashberg_init', &
'define either (tempsmin and tempsmax) or temp(:)',1)
IF ( eliashberg .AND. tempsmax .lt. tempsmin ) &
IF ( eliashberg .AND. tempsmax < tempsmin ) &
CALL errore('eliashberg_init', &
'tempsmax should be greater than tempsmin',1)
IF ( eliashberg .AND. nsiter .lt. 1 ) CALL errore('eliashberg_init', &
IF ( eliashberg .AND. nsiter < 1 ) CALL errore('eliashberg_init', &
'wrong number of nsiter',1)
IF ( eliashberg .AND. muc .lt. 0.d0 ) CALL errore('eliashberg_init', &
'muc should be .ge. 0.d0',1)
IF ( eliashberg .and. (rand_k .OR. rand_q ) .and. (fila2f .eq. ' ') ) &
IF ( eliashberg .AND. muc < 0.d0 ) CALL errore('eliashberg_init', &
'muc should be >= 0.d0',1)
IF ( eliashberg .and. (rand_k .OR. rand_q ) .and. (fila2f == ' ') ) &
CALL errore('eliashberg_init', 'eliashberg requires a uniform grid when fila2f is not used',1)
IF ( eliashberg .and. (mod(nkf1,nqf1) .ne. 0 .OR. mod(nkf2,nqf2) &
.ne. 0 .OR. mod(nkf3,nqf3) .ne. 0 ) .and. (fila2f .eq. ' ') ) &
.ne. 0 .OR. mod(nkf3,nqf3) .ne. 0 ) .and. (fila2f == ' ') ) &
CALL errore('eliashberg_init', &
'eliashberg requires nkf1,nkf2,nkf3 to be multiple of nqf1,nqf2,nqf3 when fila2f is not used',1)
!
DO itemp = 1, ntempxx
IF (temps(itemp) .gt. 0.d0) THEN
IF (temps(itemp) > 0.d0) THEN
nstemp = itemp
ENDIF
ENDDO
!
IF ( .not. ALLOCATED(estemp) ) ALLOCATE( estemp(nstemp) )
IF ( .NOT. ALLOCATED(estemp) ) ALLOCATE ( estemp(nstemp) )
estemp(:) = 0.d0
!
! go from K to eV
IF ( maxval(temps(:)) .gt. 0.d0 ) THEN
IF ( maxval(temps(:)) > 0.d0 ) THEN
DO itemp= 1, nstemp
estemp(itemp) = temps(itemp) * kelvin2eV
ENDDO
ELSE
IF ( nstemp .eq. 1 ) THEN
IF ( nstemp == 1 ) THEN
estemp(1) = tempsmin * kelvin2eV
ELSE
dtemp = ( tempsmax - tempsmin ) * kelvin2eV / dble(nstemp-1)
@ -122,7 +122,7 @@
!
IF ( lreal ) THEN
!
IF ( ABS(wsfc) < eps6 .OR. ABS(wscut) < eps6 .OR. nswfc .eq. 0 .OR. nswc .eq. 0 ) THEN
IF ( ABS(wsfc) < eps6 .OR. ABS(wscut) < eps6 .OR. nswfc == 0 .OR. nswc == 0 ) THEN
wsfc = 5.d0 * wsphmax
wscut = 15.d0 * wsphmax
nswfc = 5 * nqstep
@ -132,22 +132,22 @@
WRITE(stdout,'(5x,a7,f12.6,a11,f12.6)') 'wsfc = ', wsfc, ' wscut = ', wscut
WRITE(stdout,'(5x,a8,i8,a10,i8,a9,i8)') 'nswfc = ', nswfc, ' nswc = ', nswc, &
' nsw = ', nsw
IF ( nsw .eq. 0 ) CALL errore('eliashberg_setup','wrong number of nsw',1)
IF ( nsw == 0 ) CALL errore('eliashberg_setup','wrong number of nsw',1)
!
ELSEIF ( limag ) THEN
!
IF ( .not. ALLOCATED(nsiw) ) ALLOCATE( nsiw(nstemp) )
IF ( .NOT. ALLOCATED(nsiw) ) ALLOCATE ( nsiw(nstemp) )
nsiw(:) = 0
!
IF ( nswi .gt. 0 ) THEN
IF ( nswi > 0 ) THEN
nsiw(:) = nswi
ELSEIF ( wscut .gt. 0.d0 ) THEN
ELSEIF ( wscut > 0.d0 ) THEN
DO itemp = 1, nstemp
nsiw(itemp) = int(0.5d0 * ( wscut / pi / estemp(itemp) - 1.d0 )) + 1
ENDDO
ELSEIF ( nswi .gt. 0 .AND. wscut .gt. 0.d0 ) THEN
ELSEIF ( nswi > 0 .AND. wscut > 0.d0 ) THEN
nsiw(:) = nswi
WRITE(stdout,'(5x,a)') 'when nswi .gt. 0, wscut is not used for limag=.true.'
WRITE(stdout,'(5x,a)') 'when nswi > 0, wscut is not used for limag=.true.'
ENDIF
!
IF ( ABS(wscut) < eps6 ) THEN
@ -156,7 +156,7 @@
!
IF ( lpade .OR. lacon ) THEN
nsw = nqstep * nint(wscut/wsphmax)
IF ( nsw .eq. 0 ) CALL errore('eliashberg_setup','wrong number of nsw',1)
IF ( nsw == 0 ) CALL errore('eliashberg_setup','wrong number of nsw',1)
ENDIF
!
ENDIF
@ -165,7 +165,7 @@
!
!dwsph = wsphmax / dble(nqstep-1)
dwsph = wsphmax / dble(nqstep)
IF ( .not. ALLOCATED(wsph) ) ALLOCATE( wsph(nqstep) )
IF ( .NOT. ALLOCATED(wsph) ) ALLOCATE ( wsph(nqstep) )
wsph(:) = 0.d0
DO iwph = 1, nqstep
!wsph(iwph) = dble(iwph-1) * dwsph
@ -206,7 +206,7 @@
INTEGER :: iwph
REAL(DP):: l_a2f, logavg, tc
!
IF ( mpime .eq. ionode_id ) THEN
IF ( mpime == ionode_id ) THEN
l_a2f = 0.0d0
logavg = 0.0d0
DO iwph = 1, nqstep
@ -227,8 +227,8 @@
! initial guess for the gap edge using BCS superconducting ratio 3.52
!
gap0 = 3.52d0 * tc / 2.d0
IF ( gap0 .le. 0.d0 ) CALL errore('estimate_tc_gap', &
'initial guess for gap edge should be .gt. 0.d0',1)
IF ( gap0 <= 0.d0 ) CALL errore('estimate_tc_gap', &
'initial guess for gap edge should be > 0.d0',1)
!
! tc in K
!
@ -237,15 +237,15 @@
WRITE(stdout,'(a)') ' '
WRITE(stdout,'(5x,a,f15.7,a)') 'Estimated BCS superconducting gap = ', gap0, ' eV'
!
IF ( tempsmin .gt. 1.3d0*tc .OR. minval(temps(:)) .gt. 1.3d0*tc ) THEN
CALL errore('eliashberg_init','tempsmin or minval(temps) .gt. estimated Allen-Dynes 1.3*Tc',-1)
ELSEIF ( tempsmax .gt. tc .OR. maxval(temps(:)) .gt. tc ) THEN
IF ( tempsmin > 1.3d0*tc .OR. minval(temps(:)) > 1.3d0*tc ) THEN
CALL errore('eliashberg_init','tempsmin or minval(temps) > estimated Allen-Dynes 1.3*Tc',-1)
ELSEIF ( tempsmax > tc .OR. maxval(temps(:)) > tc ) THEN
WRITE(stdout,'(a)') ' '
WRITE(stdout,'(5x,a)') 'WARNING WARNING WARNING '
WRITE(stdout,'(a)') ' '
WRITE(stdout,'(5x,a)') 'The code will crash for tempsmax much larger than Allen-Dynes Tc'
ELSEIF ( tempsmax .gt. 1.5d0*tc .OR. maxval(temps(:)) .gt. 1.5d0*tc ) THEN
CALL errore('eliashberg_init','tempsmax or maxval(temps) .gt. estimated Allen-Dynes 1.5*Tc',-1)
ELSEIF ( tempsmax > 1.5d0*tc .OR. maxval(temps(:)) > 1.5d0*tc ) THEN
CALL errore('eliashberg_init','tempsmax or maxval(temps) > estimated Allen-Dynes 1.5*Tc',-1)
ENDIF
!
ENDIF
@ -292,11 +292,11 @@
CALL mp_sum( memlt_pool, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( maxval(memlt_pool(:)) .gt. max_memlt ) THEN
IF ( maxval(memlt_pool(:)) > max_memlt ) THEN
WRITE(stdout,'(/,5x,a,a,f9.4,a)') "Size of required memory per pool :", &
" ~= ", maxval(memlt_pool(:)), " Gb"
CALL errore('mem_size_eliashberg', 'Size of required memory exceeds max_memlt',1)
ELSEIF( maxval(memlt_pool(:)) .gt. 0.5d0*max_memlt ) THEN
ELSEIF( maxval(memlt_pool(:)) > 0.5d0*max_memlt ) THEN
WRITE(stdout,'(/,5x,a,a,f9.4,a)') "Size of allocated memory per pool :", &
" ~= ", maxval(memlt_pool(:)), " Gb"
ENDIF
@ -342,11 +342,11 @@
CALL mp_sum( memlt_pool, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( maxval(memlt_pool(:)) .gt. max_memlt ) THEN
IF ( maxval(memlt_pool(:)) > max_memlt ) THEN
WRITE(stdout,'(/,5x,a,a,f9.4,a)') "Size of required memory per pool :", &
" ~= ", maxval(memlt_pool(:)), " Gb"
CALL errore('mem_integer_size_eliashberg', 'Size of required memory exceeds max_memlt',1)
ELSEIF( maxval(memlt_pool(:)) .gt. 0.5d0*max_memlt ) THEN
ELSEIF( maxval(memlt_pool(:)) > 0.5d0*max_memlt ) THEN
WRITE(stdout,'(/,5x,a,a,f9.4,a)') "Size of allocated memory per pool :", &
" ~= ", maxval(memlt_pool(:)), " Gb"
ENDIF
@ -391,16 +391,16 @@
ENDIF
!
temp = estemp(itemp) / kelvin2eV
IF ( temp .lt. 10.d0 ) THEN
IF ( temp < 10.d0 ) THEN
WRITE(fildos,'(a,a8,f4.2)') TRIM(prefix),'.qdos_00', temp
ELSEIF ( temp .ge. 10.d0 .AND. temp .lt. 100.d0 ) THEN
ELSEIF ( temp >= 10.d0 .AND. temp < 100.d0 ) THEN
WRITE(fildos,'(a,a7,f5.2)') TRIM(prefix),'.qdos_0', temp
ELSEIF ( temp .ge. 100.d0 ) THEN
ELSEIF ( temp >= 100.d0 ) THEN
WRITE(fildos,'(a,a6,f6.2)') TRIM(prefix),'.qdos_', temp
ENDIF
OPEN(iuqdos, file=fildos, form='formatted')
OPEN(iuqdos, FILE=fildos, FORM='formatted')
!
IF ( .not. ALLOCATED(dos_qp) ) ALLOCATE( dos_qp(nsw) )
IF ( .NOT. ALLOCATED(dos_qp) ) ALLOCATE ( dos_qp(nsw) )
dos_qp(:) = 0.d0
!
IF ( laniso ) THEN
@ -409,7 +409,7 @@
omega = ws(iw) + ci*degaussw0
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
weight = 0.5d0 * wkfs(ik) * w0g(ibnd,ik)
dos_qp(iw) = dos_qp(iw) + weight &
* real( omega / sqrt( omega*omega - ADelta(ibnd,ik,iw)*ADelta(ibnd,ik,iw) ) )
@ -428,7 +428,7 @@
ENDIF
CLOSE(iuqdos)
!
IF ( ALLOCATED(dos_qp) ) DEALLOCATE(dos_qp)
IF ( ALLOCATED(dos_qp) ) DEALLOCATE (dos_qp)
!
RETURN
!
@ -462,21 +462,21 @@
CHARACTER (len=256) :: filfe
!
temp = estemp(itemp) / kelvin2eV
IF ( temp .lt. 10.d0 ) THEN
IF ( temp < 10.d0 ) THEN
WRITE(filfe,'(a,a6,f4.2)') TRIM(prefix),'.fe_00', temp
ELSEIF ( temp .ge. 10.d0 .AND. temp .lt. 100.d0 ) THEN
ELSEIF ( temp >= 10.d0 .AND. temp < 100.d0 ) THEN
WRITE(filfe,'(a,a5,f5.2)') TRIM(prefix),'.fe_0', temp
ELSEIF ( temp .ge. 100.d0 ) THEN
ELSEIF ( temp >= 100.d0 ) THEN
WRITE(filfe,'(a,a4,f6.2)') TRIM(prefix),'.fe_', temp
ENDIF
OPEN(iufe, file=filfe, form='formatted')
OPEN(iufe, FILE=filfe, FORM='formatted')
!
dFE = 0.d0
IF ( laniso ) THEN
DO iw = 1, nsiw(itemp)
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
weight = 0.5d0 * wkfs(ik) * w0g(ibnd,ik)
omega = sqrt( wsi(iw)*wsi(iw) + ADeltai(ibnd,ik,iw)*ADeltai(ibnd,ik,iw) )
dFE = dFE - weight * ( omega - wsi(iw) ) &
@ -548,7 +548,7 @@
CALL mp_sum( memlt_pool, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( maxval(memlt_pool(:)) .gt. max_memlt ) THEN
IF ( maxval(memlt_pool(:)) > max_memlt ) THEN
WRITE(stdout,'(/,5x,a,a,f9.4,a)') "Size of required memory per pool :", &
" ~= ", maxval(memlt_pool(:)), " Gb"
limag_fly = .true.
@ -625,7 +625,7 @@
CALL mp_sum( memlt_pool, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( maxval(memlt_pool(:)) .gt. max_memlt ) THEN
IF ( maxval(memlt_pool(:)) > max_memlt ) THEN
WRITE(stdout,'(/,5x,a,a,f9.4,a)') "Size of required memory per pool :", &
" ~= ", maxval(memlt_pool(:)), " Gb"
lacon_fly = .true.
@ -675,8 +675,8 @@
WRITE(stdout,'(5x,a,i6,a,f12.6,a,f12.6)') 'nswc = ', nswc, ' from ', wsfc, ' to ', wscut
WRITE(stdout,'(a)') ' '
!
IF ( .not. ALLOCATED(ws) ) ALLOCATE( ws(nsw) )
IF ( .not. ALLOCATED(dws) ) ALLOCATE( dws(nsw) )
IF ( .NOT. ALLOCATED(ws) ) ALLOCATE ( ws(nsw) )
IF ( .NOT. ALLOCATED(dws) ) ALLOCATE ( dws(nsw) )
ws(:) = 0.d0
dws(:) = 0.d0
!
@ -694,7 +694,7 @@
ENDIF
ENDDO
!
IF ( .not. lunif ) THEN
IF ( .NOT. lunif ) THEN
DO iw = nswfc+1, nsw-1
dws(iw) = ws(iw+1) - ws(iw)
ENDDO
@ -731,7 +731,7 @@
imelt = nsiw(itemp) + nsw
CALL mem_size_eliashberg( imelt )
!
IF ( .not. ALLOCATED(wsi) ) ALLOCATE( wsi(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(wsi) ) ALLOCATE ( wsi(nsiw(itemp)) )
wsi(:) = 0.d0
DO iw = 1, nsiw(itemp)
n = iw - 1
@ -742,10 +742,10 @@
! frequency-grid for real-axis ( Pade approximants and analytic continuation)
!
IF ( lpade .OR. lacon ) THEN
IF ( .not. ALLOCATED(ws) ) ALLOCATE( ws(nsw) )
IF ( .NOT. ALLOCATED(ws) ) ALLOCATE ( ws(nsw) )
ws(:) = 0.d0
DO iw = 1, nsw
IF ( iw .le. nqstep ) THEN
IF ( iw <= nqstep ) THEN
ws(iw) = wsph(iw)
ELSE
ws(iw) = wsphmax + dble(iw-nqstep)*dwsph
@ -815,7 +815,7 @@
COMPLEX(kind=DP) :: tmp1, tmp2
!
do p = 1, N
if (p.eq.1) then
if (p == 1) then
do i = 1, N
g (p,i) = u(i)
enddo
@ -829,7 +829,7 @@
! becomes unstable - certainly it happens only
! when u(:) is very small
!
!if(abs(g(p-1,i)) .eq. 0) then
!if(abs(g(p-1,i)) == 0) then
! write(6,'(4x, "fitting parameter too small. g(p-1,i)= ",2f9.5)')g(p-1,i)
! stop
!end if
@ -933,7 +933,7 @@
IF ( ABS(temp) < eps6 ) THEN
rgammap = 0.d0
rgammam = 1.d0
ELSEIF ( omegap .gt. 0.d0 ) THEN
ELSEIF ( omegap > 0.d0 ) THEN
rgammap = 0.5d0 * ( tanh( 0.5d0 * ( omega + omegap ) / temp ) &
- 1.d0 / tanh( 0.5d0 * omegap / temp ) )
rgammam = 0.5d0 * ( tanh( 0.5d0 * ( omega - omegap ) / temp ) &
@ -957,8 +957,8 @@
!
IMPLICIT NONE
!
IF( ALLOCATED(wsph) ) DEALLOCATE(wsph)
IF( ALLOCATED(estemp)) DEALLOCATE(estemp)
IF( ALLOCATED(wsph) ) DEALLOCATE (wsph)
IF( ALLOCATED(estemp)) DEALLOCATE (estemp)
!
IF ( liso ) THEN
IF ( limag ) THEN
@ -972,8 +972,8 @@
CALL deallocate_eliashberg_aniso_iaxis
ENDIF
CALL deallocate_eliashberg_aniso_raxis
IF( ALLOCATED(gap)) DEALLOCATE(gap)
IF( ALLOCATED(Agap)) DEALLOCATE(Agap)
IF( ALLOCATED(gap)) DEALLOCATE (gap)
IF( ALLOCATED(Agap)) DEALLOCATE (Agap)
ENDIF
!
CALL deallocate_elphon
@ -994,12 +994,12 @@
!
IMPLICIT NONE
!
IF( ALLOCATED(wsi) ) DEALLOCATE(wsi)
IF( ALLOCATED(Deltai) ) DEALLOCATE(Deltai)
IF( ALLOCATED(Deltaip) ) DEALLOCATE(Deltaip)
IF( ALLOCATED(Znormi) ) DEALLOCATE(Znormi)
IF( ALLOCATED(NZnormi) ) DEALLOCATE(NZnormi)
IF( ALLOCATED(Keri) ) DEALLOCATE(Keri)
IF( ALLOCATED(wsi) ) DEALLOCATE (wsi)
IF( ALLOCATED(Deltai) ) DEALLOCATE (Deltai)
IF( ALLOCATED(Deltaip) ) DEALLOCATE (Deltaip)
IF( ALLOCATED(Znormi) ) DEALLOCATE (Znormi)
IF( ALLOCATED(NZnormi) ) DEALLOCATE (NZnormi)
IF( ALLOCATED(Keri) ) DEALLOCATE (Keri)
!
RETURN
!
@ -1016,27 +1016,27 @@
!
IMPLICIT NONE
!
IF( ALLOCATED(ws) ) DEALLOCATE(ws)
IF( ALLOCATED(ws) ) DEALLOCATE (ws)
!
IF( ALLOCATED(Delta)) DEALLOCATE(Delta)
IF( ALLOCATED(Deltap)) DEALLOCATE(Deltap)
IF( ALLOCATED(Znorm)) DEALLOCATE(Znorm)
IF( ALLOCATED(Znormp)) DEALLOCATE(Znormp)
IF( ALLOCATED(gap)) DEALLOCATE(gap)
IF( ALLOCATED(Delta)) DEALLOCATE (Delta)
IF( ALLOCATED(Deltap)) DEALLOCATE (Deltap)
IF( ALLOCATED(Znorm)) DEALLOCATE (Znorm)
IF( ALLOCATED(Znormp)) DEALLOCATE (Znormp)
IF( ALLOCATED(gap)) DEALLOCATE (gap)
!
IF ( lreal ) THEN
IF( ALLOCATED(dws) ) DEALLOCATE(dws)
IF( ALLOCATED(fdwp) ) DEALLOCATE(fdwp)
IF( ALLOCATED(bewph) ) DEALLOCATE(bewph)
IF( ALLOCATED(Kp)) DEALLOCATE(Kp)
IF( ALLOCATED(Km)) DEALLOCATE(Km)
IF( ALLOCATED(dws) ) DEALLOCATE (dws)
IF( ALLOCATED(fdwp) ) DEALLOCATE (fdwp)
IF( ALLOCATED(bewph) ) DEALLOCATE (bewph)
IF( ALLOCATED(Kp)) DEALLOCATE (Kp)
IF( ALLOCATED(Km)) DEALLOCATE (Km)
ENDIF
!
IF ( limag .AND. lacon ) THEN
IF( ALLOCATED(Gp)) DEALLOCATE(Gp)
IF( ALLOCATED(Gm)) DEALLOCATE(Gm)
IF( ALLOCATED(Dsumi) ) DEALLOCATE(Dsumi)
IF( ALLOCATED(Zsumi) ) DEALLOCATE(Zsumi)
IF( ALLOCATED(Gp)) DEALLOCATE (Gp)
IF( ALLOCATED(Gm)) DEALLOCATE (Gm)
IF( ALLOCATED(Dsumi) ) DEALLOCATE (Dsumi)
IF( ALLOCATED(Zsumi) ) DEALLOCATE (Zsumi)
ENDIF
!
RETURN
@ -1053,15 +1053,15 @@
!
IMPLICIT NONE
!
IF( ALLOCATED(wsi) ) DEALLOCATE(wsi)
IF( ALLOCATED(wsi) ) DEALLOCATE (wsi)
!
IF( ALLOCATED(Deltai) ) DEALLOCATE(Deltai)
IF( ALLOCATED(Znormi) ) DEALLOCATE(Znormi)
IF( ALLOCATED(Deltai) ) DEALLOCATE (Deltai)
IF( ALLOCATED(Znormi) ) DEALLOCATE (Znormi)
!
IF( ALLOCATED(ADeltai) ) DEALLOCATE(ADeltai)
IF( ALLOCATED(ADeltaip) ) DEALLOCATE(ADeltaip)
IF( ALLOCATED(AZnormi) ) DEALLOCATE(AZnormi)
IF( ALLOCATED(NAZnormi) ) DEALLOCATE(NAZnormi)
IF( ALLOCATED(ADeltai) ) DEALLOCATE (ADeltai)
IF( ALLOCATED(ADeltaip) ) DEALLOCATE (ADeltaip)
IF( ALLOCATED(AZnormi) ) DEALLOCATE (AZnormi)
IF( ALLOCATED(NAZnormi) ) DEALLOCATE (NAZnormi)
!
RETURN
!
@ -1077,15 +1077,15 @@
!
IMPLICIT NONE
!
IF( ALLOCATED(ws)) DEALLOCATE(ws)
IF( ALLOCATED(ws)) DEALLOCATE (ws)
!
IF( ALLOCATED(Delta)) DEALLOCATE(Delta)
IF( ALLOCATED(Znorm)) DEALLOCATE(Znorm)
IF( ALLOCATED(Delta)) DEALLOCATE (Delta)
IF( ALLOCATED(Znorm)) DEALLOCATE (Znorm)
!
IF( ALLOCATED(ADelta) ) DEALLOCATE(ADelta)
IF( ALLOCATED(ADeltap) ) DEALLOCATE(ADeltap)
IF( ALLOCATED(AZnorm) ) DEALLOCATE(AZnorm)
IF( ALLOCATED(AZnormp) ) DEALLOCATE(AZnormp)
IF( ALLOCATED(ADelta) ) DEALLOCATE (ADelta)
IF( ALLOCATED(ADeltap) ) DEALLOCATE (ADeltap)
IF( ALLOCATED(AZnorm) ) DEALLOCATE (AZnorm)
IF( ALLOCATED(AZnormp) ) DEALLOCATE (AZnormp)
!
RETURN
!
@ -1102,19 +1102,19 @@
!
IMPLICIT NONE
!
IF( ALLOCATED(wf) ) DEALLOCATE(wf)
IF( ALLOCATED(wqf) ) DEALLOCATE(wqf)
IF( ALLOCATED(ekfs) ) DEALLOCATE(ekfs)
IF( ALLOCATED(xkfs) ) DEALLOCATE(xkfs)
IF( ALLOCATED(wkfs) ) DEALLOCATE(wkfs)
IF( ALLOCATED(xkff) ) DEALLOCATE(xkff)
IF( ALLOCATED(g2) ) DEALLOCATE(g2)
IF( ALLOCATED(a2f_iso) ) DEALLOCATE(a2f_iso)
IF( ALLOCATED(w0g) ) DEALLOCATE(w0g)
IF( ALLOCATED(ixkff) ) DEALLOCATE(ixkff)
IF( ALLOCATED(ixkqf) ) DEALLOCATE(ixkqf)
IF( ALLOCATED(ixqfs) ) DEALLOCATE(ixqfs)
IF( ALLOCATED(nqfs) ) DEALLOCATE(nqfs)
IF( ALLOCATED(wf) ) DEALLOCATE (wf)
IF( ALLOCATED(wqf) ) DEALLOCATE (wqf)
IF( ALLOCATED(ekfs) ) DEALLOCATE (ekfs)
IF( ALLOCATED(xkfs) ) DEALLOCATE (xkfs)
IF( ALLOCATED(wkfs) ) DEALLOCATE (wkfs)
IF( ALLOCATED(xkff) ) DEALLOCATE (xkff)
IF( ALLOCATED(g2) ) DEALLOCATE (g2)
IF( ALLOCATED(a2f_iso) ) DEALLOCATE (a2f_iso)
IF( ALLOCATED(w0g) ) DEALLOCATE (w0g)
IF( ALLOCATED(ixkff) ) DEALLOCATE (ixkff)
IF( ALLOCATED(ixkqf) ) DEALLOCATE (ixkqf)
IF( ALLOCATED(ixqfs) ) DEALLOCATE (ixqfs)
IF( ALLOCATED(nqfs) ) DEALLOCATE (nqfs)
!
RETURN
!

324
EPW/src/superconductivity_aniso.f90
View File

@ -70,7 +70,7 @@
WRITE(stdout,'(a)') ' '
WRITE(stdout,'(5x,a,i3,a,f8.4,a,a,i3,a)') 'temp(', itemp, ') = ', estemp(itemp)/kelvin2eV, ' K '
WRITE(stdout,'(a)') ' '
IF ( limag .AND. .not. imag_read ) THEN
IF ( limag .AND. .NOT. imag_read ) THEN
WRITE(stdout,'(5x,a)') 'Solve anisotropic Eliashberg equations on imaginary-axis '
ELSEIF ( limag .AND. imag_read ) THEN
WRITE(stdout,'(5x,a)') 'Read from file Delta and Znorm on imaginary-axis '
@ -82,15 +82,15 @@
CALL start_clock( 'iaxis_imag' )
CALL gen_freqgrid_iaxis( itemp )
!
IF ( ( limag .AND. .not. imag_read ) .OR. ( limag .AND. imag_read .AND. itemp .ne. 1 ) ) THEN
IF ( ( limag .AND. .NOT. imag_read ) .OR. ( limag .AND. imag_read .AND. itemp .ne. 1 ) ) THEN
iter = 1
conv = .false.
DO WHILE ( .not. conv .AND. iter .le. nsiter )
DO WHILE ( .NOT. conv .AND. iter <= nsiter )
CALL sum_eliashberg_aniso_iaxis( itemp, iter, conv )
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
CALL mix_broyden_aniso( ik, ibnd, nsiw(itemp), &
ADeltai(ibnd,ik,:), ADeltaip(ibnd,ik,:), broyden_beta, iter, broyden_ndim, conv )
ENDIF
@ -104,12 +104,12 @@
ENDDO ! iter
!
IF ( conv ) THEN
IF ( ALLOCATED(ADeltaip) ) DEALLOCATE(ADeltaip)
IF ( ALLOCATED(ADeltaip) ) DEALLOCATE (ADeltaip)
!
! SP : Only print the Free energy if the user want it
!
IF ( iverbosity .eq. 2 ) THEN
IF (mpime .eq. ionode_id) THEN
IF ( iverbosity == 2 ) THEN
IF (mpime == ionode_id) THEN
CALL free_energy( itemp )
ENDIF
CALL mp_barrier(inter_pool_comm)
@ -118,7 +118,7 @@
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'iaxis_imag' )
CALL print_clock( 'iaxis_imag' )
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') 'not converged '
CALL stop_clock( 'iaxis_imag' )
@ -126,7 +126,7 @@
CALL errore('sum_eliashberg_aniso_iaxis','convergence was not reached',1)
RETURN
ENDIF
ELSEIF ( limag .AND. imag_read .AND. itemp .eq. 1 ) THEN
ELSEIF ( limag .AND. imag_read .AND. itemp == 1 ) THEN
CALL eliashberg_read_aniso_iaxis( itemp )
ENDIF
!
@ -142,14 +142,14 @@
CALL pade_cont_aniso_iaxis_to_raxis( itemp, N, conv )
!
IF ( conv ) THEN
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
CALL dos_quasiparticle( itemp )
ENDIF
CALL mp_barrier(inter_pool_comm)
CALL stop_clock( 'raxis_pade' )
CALL print_clock( 'raxis_pade' )
WRITE(stdout,'(a)') ' '
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'raxis_pade' )
@ -170,12 +170,12 @@
!
iter = 1
conv = .false.
DO WHILE ( .not. conv .AND. iter .le. nsiter )
DO WHILE ( .NOT. conv .AND. iter <= nsiter )
CALL analytic_cont_aniso_iaxis_to_raxis( itemp, iter, conv )
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
rdeltain(:) = real(ADeltap(ibnd,ik,:))
cdeltain(:) = aimag(ADeltap(ibnd,ik,:))
rdeltaout(:) = real(ADelta(ibnd,ik,:))
@ -194,14 +194,14 @@
ENDDO ! iter
!
IF ( conv ) THEN
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
CALL dos_quasiparticle( itemp )
ENDIF
CALL mp_barrier(inter_pool_comm)
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'raxis_acon' )
CALL print_clock( 'raxis_acon' )
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'raxis_acon' )
@ -303,14 +303,14 @@
REAL(DP), ALLOCATABLE, SAVE :: Deltaold(:)
!! gap
!
IF ( .not. ALLOCATED(wesqrt) ) ALLOCATE( wesqrt(nbndfs,nkfs,nsiw(itemp)) )
IF ( .not. ALLOCATED(desqrt) ) ALLOCATE( desqrt(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(wesqrt) ) ALLOCATE ( wesqrt(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(desqrt) ) ALLOCATE ( desqrt(nbndfs,nkfs,nsiw(itemp)) )
wesqrt(:,:,:) = zero
desqrt(:,:,:) = zero
!
IF ( iter .eq. 1 ) THEN
IF ( iter == 1 ) THEN
!
IF ( itemp .eq. 1 ) THEN
IF ( itemp == 1 ) THEN
! get the size of required memory for gap, Agap
imelt = ( 1 + nbndfs * nkfs ) * nstemp
CALL mem_size_eliashberg( imelt )
@ -321,24 +321,24 @@
imelt = ( 4 + 6 * nbndfs * nkfs ) * nsiw(itemp)
CALL mem_size_eliashberg( imelt )
!
IF ( .not. ALLOCATED(gap) ) ALLOCATE( gap(nstemp) )
IF ( .not. ALLOCATED(Agap) ) ALLOCATE( Agap(nbndfs,nkfs,nstemp) )
IF ( .not. ALLOCATED(Deltai) ) ALLOCATE( Deltai(nsiw(itemp)) )
IF ( .not. ALLOCATED(Znormi) ) ALLOCATE( Znormi(nsiw(itemp)) )
IF ( .not. ALLOCATED(NZnormi) ) ALLOCATE( NZnormi(nsiw(itemp)) )
IF ( .not. ALLOCATED(ADeltai) ) ALLOCATE( ADeltai(nbndfs,nkfs,nsiw(itemp)) )
IF ( .not. ALLOCATED(ADeltaip) ) ALLOCATE( ADeltaip(nbndfs,nkfs,nsiw(itemp)) )
IF ( .not. ALLOCATED(AZnormi) ) ALLOCATE( AZnormi(nbndfs,nkfs,nsiw(itemp)) )
IF ( .not. ALLOCATED(NAZnormi) ) ALLOCATE( NAZnormi(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(gap) ) ALLOCATE ( gap(nstemp) )
IF ( .NOT. ALLOCATED(Agap) ) ALLOCATE ( Agap(nbndfs,nkfs,nstemp) )
IF ( .NOT. ALLOCATED(Deltai) ) ALLOCATE ( Deltai(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(Znormi) ) ALLOCATE ( Znormi(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(NZnormi) ) ALLOCATE ( NZnormi(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(ADeltai) ) ALLOCATE ( ADeltai(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(ADeltaip) ) ALLOCATE ( ADeltaip(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(AZnormi) ) ALLOCATE ( AZnormi(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(NAZnormi) ) ALLOCATE ( NAZnormi(nbndfs,nkfs,nsiw(itemp)) )
gap(itemp) = zero
Agap(:,:,itemp) = zero
ADeltaip(:,:,:) = zero
!
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iw = 1, nsiw(itemp)
IF ( wsi(iw) .lt. 2.d0*wsphmax ) THEN
IF ( wsi(iw) < 2.d0*wsphmax ) THEN
ADeltaip(ibnd,ik,iw) = gap0
ELSE
ADeltaip(ibnd,ik,iw) = zero
@ -349,7 +349,7 @@
ENDDO ! ik
!
CALL eliashberg_memlt_aniso_iaxis( itemp )
IF ( .not. limag_fly ) CALL kernel_aniso_iaxis( itemp )
IF ( .NOT. limag_fly ) CALL kernel_aniso_iaxis( itemp )
!
ENDIF
Deltai(:) = zero
@ -363,18 +363,18 @@
!
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) ) THEN
IF ( ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) ) THEN
IF ( ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) ) THEN
weight = wqf(iq) * w0g(jbnd,ixkqf(ik,iq0)) / dosef
DO iw = 1, nsiw(itemp) ! loop over omega
DO iwp = 1, nsiw(itemp) ! loop over omega_prime
!
! this step is performed at each iter step only for iw=1
IF ( iw .eq. 1 ) THEN
IF ( iw == 1 ) THEN
esqrt = 1.d0 / sqrt( wsi(iwp)**2.d0 + ADeltaip(jbnd,ixkqf(ik,iq0),iwp)**2.d0 )
wesqrt(jbnd,ixkqf(ik,iq0),iwp) = wsi(iwp) * esqrt
desqrt(jbnd,ixkqf(ik,iq0),iwp) = ADeltaip(jbnd,ixkqf(ik,iq0),iwp) * esqrt
@ -402,8 +402,8 @@
ENDDO ! ibnd
ENDDO ! ik
!
IF( ALLOCATED(wesqrt) ) DEALLOCATE(wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE(desqrt)
IF( ALLOCATED(wesqrt) ) DEALLOCATE (wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE (desqrt)
!
! collect contributions from all pools
CALL mp_sum( AZnormi, inter_pool_comm )
@ -411,9 +411,9 @@
CALL mp_sum( ADeltai, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF (mpime .eq. ionode_id) THEN
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(Deltaold) ) ALLOCATE( Deltaold(nsiw(itemp)) )
IF (mpime == ionode_id) THEN
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(Deltaold) ) ALLOCATE ( Deltaold(nsiw(itemp)) )
Deltaold(:) = gap0
ENDIF
absdelta = zero
@ -421,7 +421,7 @@
DO iw = 1, nsiw(itemp) ! loop over omega
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
weight = 0.5d0 * wkfs(ik) * w0g(ibnd,ik) / dosef
Znormi(iw) = Znormi(iw) + weight * AZnormi(ibnd,ik,iw)
Deltai(iw) = Deltai(iw) + weight * ADeltai(ibnd,ik,iw)
@ -444,8 +444,8 @@
' relerr = ', errdelta, ' abserr = ', reldelta / dble(nsiw(itemp)), &
' Znormi(1) = ', Znormi(1), ' Deltai(1) = ', Deltai(1)
!
IF ( errdelta .lt. conv_thr_iaxis) conv = .true.
IF ( errdelta .lt. conv_thr_iaxis .OR. iter .eq. nsiter ) THEN
IF ( errdelta < conv_thr_iaxis) conv = .true.
IF ( errdelta < conv_thr_iaxis .OR. iter == nsiter ) THEN
gap(itemp) = Deltai(1)
gap0 = gap(itemp)
!
@ -453,11 +453,11 @@
!
ENDIF
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE(Deltaold)
IF ( conv .OR. iter == nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE (Deltaold)
WRITE(stdout,'(5x,a,i6)') 'Convergence was reached in nsiter = ', iter
ENDIF
IF ( .not. conv .AND. iter .eq. nsiter ) THEN
IF ( .NOT. conv .AND. iter == nsiter ) THEN
WRITE(stdout,'(a)') ' '
WRITE(stdout,'(5x,a,i6)') 'Convergence was not reached in nsiter = ', iter
CALL errore('sum_eliashberg_aniso_iaxis','increase nsiter or reduce conv_thr_iaxis',1)
@ -474,15 +474,15 @@
CALL mp_bcast( conv, ionode_id, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF ( conv .OR. iter == nsiter ) THEN
!
! remove memory allocated for wesqrt, desqrt, ADeltaip, Deltaold
imelt = ( 1 + 3 * nbndfs * nkfs ) * nsiw(itemp)
CALL mem_size_eliashberg( -imelt )
!
IF ( .not. limag_fly ) THEN
IF ( .NOT. limag_fly ) THEN
!
IF ( ALLOCATED(AKeri) ) DEALLOCATE(AKeri)
IF ( ALLOCATED(AKeri) ) DEALLOCATE (AKeri)
!
! remove memory allocated for AKeri
imelt = ( upper_bnd - lower_bnd + 1 ) * maxval(nqfs(:)) * nbndfs**2 * ( 2 * nsiw(itemp) )
@ -576,7 +576,7 @@
! SP: Need initialization
a2f_ = zero
!
IF ( iter .eq. 1 ) THEN
IF ( iter == 1 ) THEN
!
! get the size of required allocated memory for
! Delta, Znorm, Deltaold, ADelta, ADeltap, AZnorm, AZnormp, Gp, Gm
@ -587,13 +587,13 @@
ENDIF
CALL mem_size_eliashberg( imelt )
!
IF ( .not. ALLOCATED(Delta) ) ALLOCATE( Delta(nsw) )
IF ( .not. ALLOCATED(Znorm) ) ALLOCATE( Znorm(nsw) )
IF ( .not. ALLOCATED(ADelta) ) ALLOCATE( ADelta(nbndfs,nkfs,nsw) )
IF ( .not. ALLOCATED(ADeltap) ) ALLOCATE( ADeltap(nbndfs,nkfs,nsw) )
IF ( .not. ALLOCATED(AZnorm) ) ALLOCATE( AZnorm(nbndfs,nkfs,nsw) )
IF ( .not. ALLOCATED(AZnormp) ) ALLOCATE( AZnormp(nbndfs,nkfs,nsw) )
IF ( .not. ALLOCATED(Deltaold) ) ALLOCATE( Deltaold(nsw) )
IF ( .NOT. ALLOCATED(Delta) ) ALLOCATE ( Delta(nsw) )
IF ( .NOT. ALLOCATED(Znorm) ) ALLOCATE ( Znorm(nsw) )
IF ( .NOT. ALLOCATED(ADelta) ) ALLOCATE ( ADelta(nbndfs,nkfs,nsw) )
IF ( .NOT. ALLOCATED(ADeltap) ) ALLOCATE ( ADeltap(nbndfs,nkfs,nsw) )
IF ( .NOT. ALLOCATED(AZnorm) ) ALLOCATE ( AZnorm(nbndfs,nkfs,nsw) )
IF ( .NOT. ALLOCATED(AZnormp) ) ALLOCATE ( AZnormp(nbndfs,nkfs,nsw) )
IF ( .NOT. ALLOCATED(Deltaold) ) ALLOCATE ( Deltaold(nsw) )
ADeltap(:,:,:) = czero
AZnormp(:,:,:) = cone
Deltaold(:) = czero
@ -603,7 +603,7 @@
ELSE
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
ADeltap(ibnd,ik,:) = Agap(ibnd,ik,itemp)
ENDIF
ENDDO ! ibnd
@ -611,8 +611,8 @@
Deltaold(:) = gap(itemp)
ENDIF
!
IF ( .not. ALLOCATED(Gp) ) ALLOCATE( Gp(nsw,nqstep) )
IF ( .not. ALLOCATED(Gm) ) ALLOCATE( Gm(nsw,nqstep) )
IF ( .NOT. ALLOCATED(Gp) ) ALLOCATE ( Gp(nsw,nqstep) )
IF ( .NOT. ALLOCATED(Gm) ) ALLOCATE ( Gm(nsw,nqstep) )
DO iw = 1, nsw ! loop over omega
DO iwp = 1, nqstep ! loop over omega_prime
CALL gamma_acont( ws(iw), ws(iwp), estemp(itemp), rgammap, rgammam )
@ -622,7 +622,7 @@
ENDDO
CALL kernel_aniso_iaxis_analytic_cont( itemp )
CALL eliashberg_memlt_aniso_acon
IF ( .not. lacon_fly ) CALL evaluate_a2fij
IF ( .NOT. lacon_fly ) CALL evaluate_a2fij
ENDIF
Delta(:) = czero
Znorm(:) = czero
@ -633,16 +633,16 @@
!
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) THEN
!
IF ( lacon_fly ) THEN ! evaluate a2fij on the fly
DO imode = 1, nmodes
IF ( wf(imode,iq0) .gt. eps_acustic ) THEN
IF ( wf(imode,iq0) > eps_acustic ) THEN
DO iwph = 1, nqstep
weight = w0gauss( ( wsph(iwph) - wf(imode,iq0) ) / degaussq, 0 ) / degaussq
a2f_ = weight * dosef * g2(ik,iq,ibnd,jbnd,imode)
@ -656,10 +656,10 @@
DO iwp = 1, nqstep ! loop over omega_prime
!
i = iw + iwp - 1
IF ( i .le. nsw ) THEN
IF ( i <= nsw ) THEN
root = sqrt( AZnormp(jbnd,ixkqf(ik,iq0),i)**2.d0 &
* ( ws(i)**2.d0 - ADeltap(jbnd,ixkqf(ik,iq0),i)**2.d0 ) )
IF ( aimag(root) .lt. zero ) THEN
IF ( aimag(root) < zero ) THEN
esqrt = AZnormp(jbnd,ixkqf(ik,iq0),i) / conjg(root)
ELSE
esqrt = AZnormp(jbnd,ixkqf(ik,iq0),i) / root
@ -676,13 +676,13 @@
i = abs(iw - iwp) + 1
root = sqrt( AZnormp(jbnd,ixkqf(ik,iq0),i)**2.d0 &
* ( ws(i)**2.d0 - ADeltap(jbnd,ixkqf(ik,iq0),i)**2.d0 ) )
IF ( aimag(root) .lt. zero ) THEN
IF ( aimag(root) < zero ) THEN
esqrt = AZnormp(jbnd,ixkqf(ik,iq0),i) / conjg(root)
ELSE
esqrt = AZnormp(jbnd,ixkqf(ik,iq0),i) / root
ENDIF
esqrt = esqrt * weight * Gm(iw,iwp) * a2fij(ik,iq,ibnd,jbnd,iwp)
IF ( iw .lt. iwp ) THEN
IF ( iw < iwp ) THEN
AZnorm(ibnd,ik,iw) = AZnorm(ibnd,ik,iw) - ws(i) * esqrt
ELSE
AZnorm(ibnd,ik,iw) = AZnorm(ibnd,ik,iw) + ws(i) * esqrt
@ -706,13 +706,13 @@
CALL mp_sum( ADelta, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
absdelta = zero
reldelta = zero
DO iw = 1, nsw ! loop over omega
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
weight = 0.5d0 * wkfs(ik) * w0g(ibnd,ik) / dosef
Znorm(iw) = Znorm(iw) + weight * AZnorm(ibnd,ik,iw)
Delta(iw) = Delta(iw) + weight * ADelta(ibnd,ik,iw)
@ -733,16 +733,16 @@
' error = ', errdelta, ' Re[Znorm(1)] = ', real(Znorm(1)), &
' Re[Delta(1)] = ', real(Delta(1))
!
IF ( errdelta .lt. conv_thr_racon ) conv = .true.
IF ( errdelta .lt. conv_thr_racon .OR. iter .eq. nsiter ) THEN
IF ( errdelta < conv_thr_racon ) conv = .true.
IF ( errdelta < conv_thr_racon .OR. iter == nsiter ) THEN
cname = 'acon'
CALL eliashberg_write_raxis( itemp, cname )
ENDIF
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF ( conv .OR. iter == nsiter ) THEN
WRITE(stdout,'(5x,a,i6)') 'Convergence was reached in nsiter = ', iter
ENDIF
IF ( .not. conv .AND. iter .eq. nsiter ) THEN
IF ( .NOT. conv .AND. iter == nsiter ) THEN
WRITE(stdout,'(5x,a,i6)') 'Convergence was not reached in nsiter = ', iter
CALL errore('analytic_cont_aniso_iaxis_to_raxis','increase nsiter or reduce conv_thr_racon',1)
ENDIF
@ -755,21 +755,21 @@
CALL mp_bcast( conv, ionode_id, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF ( conv .OR. iter == nsiter ) THEN
!
IF( ALLOCATED(Deltaold) ) DEALLOCATE(Deltaold)
IF( ALLOCATED(Gp) ) DEALLOCATE(Gp)
IF( ALLOCATED(Gm) ) DEALLOCATE(Gm)
IF( ALLOCATED(ADsumi) ) DEALLOCATE(ADsumi)
IF( ALLOCATED(AZsumi) ) DEALLOCATE(AZsumi)
IF( ALLOCATED(Deltaold) ) DEALLOCATE (Deltaold)
IF( ALLOCATED(Gp) ) DEALLOCATE (Gp)
IF( ALLOCATED(Gm) ) DEALLOCATE (Gm)
IF( ALLOCATED(ADsumi) ) DEALLOCATE (ADsumi)
IF( ALLOCATED(AZsumi) ) DEALLOCATE (AZsumi)
!
! remove memory allocated for Deltaold, Gp, Gm, ADsumi, AZsumi
imelt = 2 * nsw + 2 * nqstep * nsw + 2 * ( upper_bnd - lower_bnd + 1 ) * nbndfs * nsw
CALL mem_size_eliashberg( -imelt )
!
IF ( .not. lacon_fly ) THEN
IF ( .NOT. lacon_fly ) THEN
!
IF ( ALLOCATED(a2fij) ) DEALLOCATE(a2fij)
IF ( ALLOCATED(a2fij) ) DEALLOCATE (a2fij)
!
! remove memory allocated for a2fij
imelt = ( upper_bnd - lower_bnd + 1 ) * maxval(nqfs(:)) * nbndfs**2 * nqstep
@ -858,16 +858,16 @@
imelt = 2 * 5 * N + 2 * ( 3 + 2 * nbndfs * nkfs ) * nsw
CALL mem_size_eliashberg( imelt )
!
IF ( .not. ALLOCATED(Delta) ) ALLOCATE( Delta(nsw) )
IF ( .not. ALLOCATED(Znorm) ) ALLOCATE( Znorm(nsw) )
IF ( .not. ALLOCATED(ADelta) ) ALLOCATE( ADelta(nbndfs,nkfs,nsw) )
IF ( .not. ALLOCATED(AZnorm) ) ALLOCATE( AZnorm(nbndfs,nkfs,nsw) )
IF ( .not. ALLOCATED(Deltaold) ) ALLOCATE( Deltaold(nsw) )
IF ( .not. ALLOCATED(a) ) ALLOCATE( a(N) )
IF ( .not. ALLOCATED(b) ) ALLOCATE( b(N) )
IF ( .not. ALLOCATED(z) ) ALLOCATE( z(N) )
IF ( .not. ALLOCATED(u) ) ALLOCATE( u(N) )
IF ( .not. ALLOCATED(v) ) ALLOCATE( v(N) )
IF ( .NOT. ALLOCATED(Delta) ) ALLOCATE ( Delta(nsw) )
IF ( .NOT. ALLOCATED(Znorm) ) ALLOCATE ( Znorm(nsw) )
IF ( .NOT. ALLOCATED(ADelta) ) ALLOCATE ( ADelta(nbndfs,nkfs,nsw) )
IF ( .NOT. ALLOCATED(AZnorm) ) ALLOCATE ( AZnorm(nbndfs,nkfs,nsw) )
IF ( .NOT. ALLOCATED(Deltaold) ) ALLOCATE ( Deltaold(nsw) )
IF ( .NOT. ALLOCATED(a) ) ALLOCATE ( a(N) )
IF ( .NOT. ALLOCATED(b) ) ALLOCATE ( b(N) )
IF ( .NOT. ALLOCATED(z) ) ALLOCATE ( z(N) )
IF ( .NOT. ALLOCATED(u) ) ALLOCATE ( u(N) )
IF ( .NOT. ALLOCATED(v) ) ALLOCATE ( v(N) )
Delta(:) = czero
Znorm(:) = czero
ADelta(:,:,:) = czero
@ -885,7 +885,7 @@
!
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iw = 1, N
z(iw) = ci * wsi(iw)
u(iw) = cone * ADeltai(ibnd,ik,iw)
@ -909,11 +909,11 @@
CALL mp_sum( ADelta, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF (mpime .eq. ionode_id) THEN
IF (mpime == ionode_id) THEN
DO iw = 1, nsw ! loop over omega
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
weight = 0.5d0 * wkfs(ik) * w0g(ibnd,ik) / dosef
Znorm(iw) = Znorm(iw) + weight * AZnorm(ibnd,ik,iw)
Delta(iw) = Delta(iw) + weight * ADelta(ibnd,ik,iw)
@ -925,7 +925,7 @@
ENDDO ! iw
errdelta = reldelta / absdelta
!
IF ( errdelta .gt. zero ) THEN
IF ( errdelta > zero ) THEN
conv = .true.
WRITE(stdout,'(5x,a,i6,a,ES20.10,a,ES20.10,a,ES20.10)') 'pade = ', N, &
' error = ', errdelta, ' Re[Znorm(1)] = ', real(Znorm(1)), &
@ -941,12 +941,12 @@
CALL mp_bcast( conv, ionode_id, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF( ALLOCATED(Deltaold) ) DEALLOCATE(Deltaold)
IF( ALLOCATED(a) ) DEALLOCATE(a)
IF( ALLOCATED(b) ) DEALLOCATE(b)
IF( ALLOCATED(z) ) DEALLOCATE(z)
IF( ALLOCATED(u) ) DEALLOCATE(u)
IF( ALLOCATED(v) ) DEALLOCATE(v)
IF( ALLOCATED(Deltaold) ) DEALLOCATE (Deltaold)
IF( ALLOCATED(a) ) DEALLOCATE (a)
IF( ALLOCATED(b) ) DEALLOCATE (b)
IF( ALLOCATED(z) ) DEALLOCATE (z)
IF( ALLOCATED(u) ) DEALLOCATE (u)
IF( ALLOCATED(v) ) DEALLOCATE (v)
!
! remove memory allocated for Deltaold, a, b, z, u, v
imelt = 2 * ( nsw + 5 * N )
@ -998,19 +998,19 @@
!! electron-phonon coupling
!
CALL fkbounds( nkfs, lower_bnd, upper_bnd )
IF ( .not. ALLOCATED(AKeri) ) ALLOCATE( AKeri(lower_bnd:upper_bnd,maxval(nqfs(:)),nbndfs,nbndfs,2*nsiw(itemp)) )
IF ( .NOT. ALLOCATED(AKeri) ) ALLOCATE ( AKeri(lower_bnd:upper_bnd,maxval(nqfs(:)),nbndfs,nbndfs,2*nsiw(itemp)) )
AKeri(:,:,:,:,:) = zero
!
! RM - if lambdar_aniso_ver2 is used then one needs to CALL evaluate_a2fij
!
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) THEN
DO iw = 1, 2*nsiw(itemp)
n = iw - 1
omega = dble(2*n) * pi * estemp(itemp)
@ -1069,7 +1069,7 @@
iq0 = ixqfs(ik,iq)
lambda_eph = zero
DO imode = 1, nmodes ! loop over frequency modes
IF ( wf(imode,iq0) .gt. eps_acustic ) THEN
IF ( wf(imode,iq0) > eps_acustic ) THEN
lambda_eph = lambda_eph + g2(ik,iq,ibnd,jbnd,imode) * wf(imode,iq0) &
/ ( wf(imode,iq0)**2.d0 + omega**2.d0 )
ENDIF
@ -1179,12 +1179,12 @@
imelt = 2 * nbndfs * nkfs * nsiw(itemp) + 2 * ( upper_bnd - lower_bnd + 1 ) * nbndfs * nsw
CALL mem_size_eliashberg( imelt )
!
IF ( .not. ALLOCATED(wesqrt) ) ALLOCATE( wesqrt(nbndfs,nkfs,nsiw(itemp)) )
IF ( .not. ALLOCATED(desqrt) ) ALLOCATE( desqrt(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(wesqrt) ) ALLOCATE ( wesqrt(nbndfs,nkfs,nsiw(itemp)) )
IF ( .NOT. ALLOCATED(desqrt) ) ALLOCATE ( desqrt(nbndfs,nkfs,nsiw(itemp)) )
!
DO ik = lower_bnd, upper_bnd
IF ( .not. ALLOCATED(ADsumi) ) ALLOCATE( ADsumi(nbndfs,lower_bnd:upper_bnd,nsw) )
IF ( .not. ALLOCATED(AZsumi) ) ALLOCATE( AZsumi(nbndfs,lower_bnd:upper_bnd,nsw) )
IF ( .NOT. ALLOCATED(ADsumi) ) ALLOCATE ( ADsumi(nbndfs,lower_bnd:upper_bnd,nsw) )
IF ( .NOT. ALLOCATED(AZsumi) ) ALLOCATE ( AZsumi(nbndfs,lower_bnd:upper_bnd,nsw) )
ENDDO
ADsumi(:,:,:) = zero
AZsumi(:,:,:) = zero
@ -1193,12 +1193,12 @@
!
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) THEN
weight = wqf(iq) * w0g(jbnd,ixkqf(ik,iq0)) / dosef
DO iw = 1, nsw ! loop over omega
DO iwp = 1, nsiw(itemp) ! loop over iw_n
@ -1206,7 +1206,7 @@
!CALL lambdai_aniso_ver2( ik, iq, ibnd, jbnd, ws(iw), wsi(iwp), lambda_eph )
kernelp = 2.d0 * real(lambda_eph)
kernelm = 2.d0 * aimag(lambda_eph)
IF ( iw .eq. 1 ) THEN
IF ( iw == 1 ) THEN
esqrt = 1.d0 / sqrt( wsi(iwp)**2.d0 + ADeltai(jbnd,ixkqf(ik,iq0),iwp)**2.d0 )
wesqrt(jbnd,ixkqf(ik,iq0),iwp) = wsi(iwp) * esqrt
desqrt(jbnd,ixkqf(ik,iq0),iwp) = ADeltai(jbnd,ixkqf(ik,iq0),iwp) * esqrt
@ -1224,8 +1224,8 @@
ENDDO ! ibnd
ENDDO ! ik
!
IF( ALLOCATED(wesqrt) ) DEALLOCATE(wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE(desqrt)
IF( ALLOCATED(wesqrt) ) DEALLOCATE (wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE (desqrt)
!
! remove memory allocated for wesqrt, desqrt
imelt = 2 * nbndfs * nkfs * nsiw(itemp)
@ -1276,7 +1276,7 @@
iq0 = ixqfs(ik,iq)
lambda_eph = czero
DO imode = 1, nmodes ! loop over frequency modes
IF ( wf(imode,iq0) .gt. eps_acustic ) THEN
IF ( wf(imode,iq0) > eps_acustic ) THEN
lambda_eph = lambda_eph + g2(ik,iq,ibnd,jbnd,imode) * wf(imode,iq0) &
/ ( wf(imode,iq0)**2.d0 - (omega - ci*omegap)**2.d0 )
ENDIF
@ -1373,19 +1373,19 @@
REAL(DP), EXTERNAL :: w0gauss
!
CALL fkbounds( nkfs, lower_bnd, upper_bnd )
IF ( .not. ALLOCATED(a2fij) ) ALLOCATE(a2fij(lower_bnd:upper_bnd,maxval(nqfs(:)),nbndfs,nbndfs,nqstep))
IF ( .NOT. ALLOCATED(a2fij) ) ALLOCATE (a2fij(lower_bnd:upper_bnd,maxval(nqfs(:)),nbndfs,nbndfs,nqstep))
a2fij(:,:,:,:,:) = zero
!
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) THEN
DO imode = 1, nmodes
IF ( wf(imode,iq0) .gt. eps_acustic ) THEN
IF ( wf(imode,iq0) > eps_acustic ) THEN
DO iwph = 1, nqstep
weight = w0gauss( ( wsph(iwph) - wf(imode,iq0) ) / degaussq, 0 ) / degaussq
a2fij(ik,iq,ibnd,jbnd,iwph) = a2fij(ik,iq,ibnd,jbnd,iwph) &
@ -1454,16 +1454,16 @@
!
CALL fkbounds( nkfs, lower_bnd, upper_bnd )
!
IF ( .not. ALLOCATED(a2f_iso) ) ALLOCATE( a2f_iso(nqstep) )
IF ( .not. ALLOCATED(a2f) ) ALLOCATE( a2f(nqstep,nqsmear) )
IF ( .not. ALLOCATED(a2f_modeproj) ) ALLOCATE( a2f_modeproj(nmodes,nqstep) )
IF ( .NOT. ALLOCATED(a2f_iso) ) ALLOCATE ( a2f_iso(nqstep) )
IF ( .NOT. ALLOCATED(a2f) ) ALLOCATE ( a2f(nqstep,nqsmear) )
IF ( .NOT. ALLOCATED(a2f_modeproj) ) ALLOCATE ( a2f_modeproj(nmodes,nqstep) )
a2f_iso(:) = 0.d0
a2f(:,:) = 0.d0
a2f_modeproj(:,:) = 0.d0
!
! RM - the 0 index in k is required when printing out values of lambda_k
! When the k-point is outside the Fermi shell, ixkff(ik)=0
IF ( .not. ALLOCATED(lambda_k) ) ALLOCATE(lambda_k(0:nkfs,nbndfs))
IF ( .NOT. ALLOCATED(lambda_k) ) ALLOCATE (lambda_k(0:nkfs,nbndfs))
lambda_k(:,:) = 0.d0
!
l_sum = 0.d0
@ -1472,34 +1472,34 @@
sigma = degaussq + (ismear-1) * delta_qsmear
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) THEN
weight = wkfs(ik) * wqf(iq) * w0g(ibnd,ik) * w0g(jbnd,ixkqf(ik,iq0))
lambda_eph = 0.d0
DO imode = 1, nmodes
IF ( wf(imode,iq0) .gt. eps_acustic ) THEN
IF ( ismear .eq. 1 ) THEN
IF ( wf(imode,iq0) > eps_acustic ) THEN
IF ( ismear == 1 ) THEN
lambda_eph = lambda_eph + g2(ik,iq,ibnd,jbnd,imode) / wf(imode,iq0)
ENDIF
DO iwph = 1, nqstep
weightq = w0gauss( ( wsph(iwph) - wf(imode,iq0) ) / sigma, 0 ) / sigma
a2f(iwph,ismear) = a2f(iwph,ismear) + weight * weightq * g2(ik,iq,ibnd,jbnd,imode)
IF ( ismear .eq. 1 ) THEN
IF ( ismear == 1 ) THEN
a2f_modeproj(imode,iwph) = a2f_modeproj(imode,iwph) +&
weight * weightq * g2(ik,iq,ibnd,jbnd,imode)
ENDIF
ENDDO ! iwph
ENDIF ! wf
ENDDO ! imode
IF ( ismear .eq. 1 .AND. lambda_eph .gt. 0.d0 ) THEN
IF ( ismear == 1 .AND. lambda_eph > 0.d0 ) THEN
l_sum = l_sum + weight * lambda_eph
weight = wqf(iq) * w0g(jbnd,ixkqf(ik,iq0))
lambda_k(ik,ibnd) = lambda_k(ik,ibnd) + weight * lambda_eph
IF ( lambda_eph .gt. lambda_max(my_pool_id+1) ) THEN
IF ( lambda_eph > lambda_max(my_pool_id+1) ) THEN
lambda_max(my_pool_id+1) = lambda_eph
ENDIF
ENDIF
@ -1525,13 +1525,13 @@
CALL mp_sum( lambda_k, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( mpime .eq. ionode_id ) THEN
IF ( mpime == ionode_id ) THEN
!
OPEN( unit = iua2ffil, file = TRIM(prefix)//".a2f", form = 'formatted')
OPEN( unit = iudosfil, file = TRIM(prefix)//".phdos", form = 'formatted')
!
IF ( .not. ALLOCATED(phdos) ) ALLOCATE( phdos(nqstep,nqsmear) )
IF ( .not. ALLOCATED(phdos_modeproj) ) ALLOCATE( phdos_modeproj(nmodes,nqstep) )
IF ( .NOT. ALLOCATED(phdos) ) ALLOCATE ( phdos(nqstep,nqsmear) )
IF ( .NOT. ALLOCATED(phdos_modeproj) ) ALLOCATE ( phdos_modeproj(nmodes,nqstep) )
phdos(:,:) = 0.d0
phdos_modeproj(:,:) = 0.d0
!
@ -1539,11 +1539,11 @@
sigma = degaussq + (ismear-1) * delta_qsmear
DO iq = 1, nqtotf
DO imode = 1, nmodes
IF ( wf(imode,iq) .gt. eps_acustic ) THEN
IF ( wf(imode,iq) > eps_acustic ) THEN
DO iwph = 1, nqstep
weightq = w0gauss( ( wsph(iwph) - wf(imode,iq)) / sigma, 0 ) / sigma
phdos(iwph,ismear) = phdos(iwph,ismear) + wqf(iq) * weightq
IF ( ismear .eq. 1 ) THEN
IF ( ismear == 1 ) THEN
phdos_modeproj(imode,iwph) = phdos_modeproj(imode,iwph) + wqf(iq) * weightq
ENDIF
ENDDO ! iwph
@ -1552,15 +1552,15 @@
ENDDO ! iq
ENDDO ! ismear
!
IF ( .not. ALLOCATED(l_a2f) ) ALLOCATE( l_a2f(nqsmear) )
IF ( .NOT. ALLOCATED(l_a2f) ) ALLOCATE ( l_a2f(nqsmear) )
l_a2f(:) = 0.d0
!
DO ismear = 1, nqsmear
DO iwph = 1, nqstep
l_a2f(ismear) = l_a2f(ismear) + a2f(iwph,ismear) / wsph(iwph)
! wsph in meV (from eV) and phdos in states/meV (from states/eV)
IF (ismear .eq. nqsmear) WRITE (iua2ffil,'(f12.7,15f12.7)') wsph(iwph)*1000.d0, a2f(iwph,:)
IF (ismear .eq. nqsmear) WRITE (iudosfil,'(f12.7,15f15.7)') wsph(iwph)*1000.d0, phdos(iwph,:)/1000.d0
IF (ismear == nqsmear) WRITE (iua2ffil,'(f12.7,15f12.7)') wsph(iwph)*1000.d0, a2f(iwph,:)
IF (ismear == nqsmear) WRITE (iudosfil,'(f12.7,15f15.7)') wsph(iwph)*1000.d0, phdos(iwph,:)/1000.d0
ENDDO
l_a2f(ismear) = 2.d0 * l_a2f(ismear) * dwsph
ENDDO
@ -1587,22 +1587,22 @@
CLOSE(iua2ffil)
CLOSE(iudosfil)
!
IF ( ALLOCATED(phdos) ) DEALLOCATE( phdos )
IF ( ALLOCATED(phdos_modeproj) ) DEALLOCATE( phdos_modeproj )
IF ( ALLOCATED(l_a2f) ) DEALLOCATE( l_a2f )
IF ( ALLOCATED(phdos) ) DEALLOCATE ( phdos )
IF ( ALLOCATED(phdos_modeproj) ) DEALLOCATE ( phdos_modeproj )
IF ( ALLOCATED(l_a2f) ) DEALLOCATE ( l_a2f )
!
ENDIF
!
CALL mp_bcast( a2f_iso, ionode_id, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( ALLOCATED(a2f) ) DEALLOCATE( a2f )
IF ( ALLOCATED(a2f_modeproj) ) DEALLOCATE( a2f_modeproj )
IF ( ALLOCATED(a2f) ) DEALLOCATE ( a2f )
IF ( ALLOCATED(a2f_modeproj) ) DEALLOCATE ( a2f_modeproj )
!
nbink = NINT( 1.1d0 * MAXVAL(lambda_k(:,:)) / eps2 ) + 1
dbink = 1.1d0 * MAXVAL(lambda_k(:,:)) / DBLE(nbink)
!
IF ( .not. ALLOCATED(lambda_k_bin) ) ALLOCATE ( lambda_k_bin(nbink) )
IF ( .NOT. ALLOCATED(lambda_k_bin) ) ALLOCATE ( lambda_k_bin(nbink) )
lambda_k_bin(:) = zero
!
!SP : Should be initialized
@ -1612,7 +1612,7 @@
IF ( iverbosity == 2 ) THEN
nbin = nint( 1.1d0 * MAXVAL(lambda_max(:)) / eps2 ) + 1
dbin = 1.1d0 * MAXVAL(lambda_max(:)) / dble(nbin)
IF ( .not. ALLOCATED(lambda_pairs) ) ALLOCATE ( lambda_pairs(nbin) )
IF ( .NOT. ALLOCATED(lambda_pairs) ) ALLOCATE ( lambda_pairs(nbin) )
lambda_pairs(:) = zero
ENDIF
!
@ -1623,12 +1623,12 @@
lambda_k(:,:) = 0.d0
DO ik = lower_bnd, upper_bnd
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
DO iq = 1, nqfs(ik)
! iq0 - index of q-point on the full q-mesh
iq0 = ixqfs(ik,iq)
DO jbnd = 1, nbndfs
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(jbnd,ixkqf(ik,iq0)) - ef0 ) < fsthick ) THEN
weight = wqf(iq) * w0g(jbnd,ixkqf(ik,iq0)) / dosef
CALL lambdar_aniso_ver1( ik, iq, ibnd, jbnd, 0.d0, lambda_eph )
lambda_k(ik,ibnd) = lambda_k(ik,ibnd) + weight * lambda_eph
@ -1649,21 +1649,21 @@
!
! collect contributions from all pools
CALL mp_sum( lambda_k, inter_pool_comm )
IF ( iverbosity .eq. 2 ) THEN
IF ( iverbosity == 2 ) THEN
CALL mp_sum( lambda_pairs, inter_pool_comm )
ENDIF
CALL mp_sum( lambda_k_bin, inter_pool_comm )
CALL mp_barrier(inter_pool_comm)
!
IF ( mpime .eq. ionode_id ) THEN
IF ( mpime == ionode_id ) THEN
!
! SP: Produced if user really wants it
IF ( iverbosity .eq. 2 ) THEN
IF ( iverbosity == 2 ) THEN
OPEN(unit = iufillambda, file = TRIM(prefix)//".lambda_aniso", form = 'formatted')
WRITE(iufillambda,'(2a12,2a7)') '# enk-e0[eV]',' lambda_nk','# kpt','# band'
DO ik = 1, nkfs
DO ibnd = 1, nbndfs
IF ( abs( ekfs(ibnd,ik) - ef0 ) .lt. fsthick ) THEN
IF ( abs( ekfs(ibnd,ik) - ef0 ) < fsthick ) THEN
WRITE(iufillambda,'(2f12.7,2i7)') ekfs(ibnd,ik) - ef0, lambda_k(ik,ibnd), ik, ibnd
ENDIF
ENDDO
@ -1693,7 +1693,7 @@
! RM - If the k-point is outside the Fermi shell,
! ixkff(ik)=0 and lambda_k(0,ibnd) = 0.0
!
IF ( iverbosity .eq. 2 ) THEN
IF ( iverbosity == 2 ) THEN
!
DO ibnd = 1, nbndfs
!
@ -1707,7 +1707,7 @@
CALL errore( 'eliashberg_setup', 'Too many bands ',1)
ENDIF
!
OPEN(iufillambdaFS, file=name1, form='formatted')
OPEN(iufillambdaFS, FILE=name1, FORM='formatted')
WRITE(iufillambdaFS,*) 'Cubfile created from EPW calculation'
WRITE(iufillambdaFS,*) 'lambda'
WRITE(iufillambdaFS,'(i5,3f12.6)') 1, 0.0d0, 0.0d0, 0.0d0
@ -1725,17 +1725,17 @@
! Cartesian coordinate, band index, energy distance from Fermi level
! and lambda value.
!
OPEN(unit = iufillambdaFS, file = TRIM(prefix)//".lambda_FS", form='formatted')
OPEN(unit = iufillambdaFS, file = TRIM(prefix)//".lambda_FS", FORM='formatted')
WRITE(iufillambdaFS,'(a75)') '# k-point Band Enk-Ef [eV] lambda'
DO i = 1, nkf1
DO j = 1, nkf2
DO k = 1, nkf3
ik = k + (j-1)*nkf3 + (i-1)*nkf2*nkf3
IF ( ixkff(ik) .gt. 0 ) THEN
IF ( ixkff(ik) > 0 ) THEN
DO ibnd = 1, nbndfs
! SP: Here take a 0.2 eV interval around the FS.
IF ( abs( ekfs(ibnd,ixkff(ik)) - ef0 ) .lt. fsthick ) THEN
!IF ( abs( ekfs(ibnd,ixkff(ik)) - ef0 ) .lt. 0.2 ) THEN
IF ( abs( ekfs(ibnd,ixkff(ik)) - ef0 ) < fsthick ) THEN
!IF ( abs( ekfs(ibnd,ixkff(ik)) - ef0 ) < 0.2 ) THEN
x1 = bg(1,1)*(i-1)/nkf1+bg(1,2)*(j-1)/nkf2+bg(1,3)*(k-1)/nkf3
x2 = bg(2,1)*(i-1)/nkf1+bg(2,2)*(j-1)/nkf2+bg(2,3)*(k-1)/nkf3
x3 = bg(3,1)*(i-1)/nkf1+bg(3,2)*(j-1)/nkf2+bg(3,3)*(k-1)/nkf3
@ -1751,9 +1751,9 @@
ENDIF
CALL mp_barrier(inter_pool_comm)
!
IF ( ALLOCATED(lambda_k) ) DEALLOCATE(lambda_k)
IF ( ALLOCATED(lambda_pairs) ) DEALLOCATE(lambda_pairs)
IF ( ALLOCATED(lambda_k_bin) ) DEALLOCATE(lambda_k_bin)
IF ( ALLOCATED(lambda_k) ) DEALLOCATE (lambda_k)
IF ( ALLOCATED(lambda_pairs) ) DEALLOCATE (lambda_pairs)
IF ( ALLOCATED(lambda_k_bin) ) DEALLOCATE (lambda_k_bin)
!
RETURN
!

177
EPW/src/superconductivity_iso.f90
View File

@ -69,7 +69,7 @@
IF ( limag ) THEN
iter = 1
conv = .false.
DO WHILE ( .not. conv .AND. iter .le. nsiter )
DO WHILE ( .NOT. conv .AND. iter <= nsiter )
CALL sum_eliashberg_iso_iaxis( itemp, iter, conv )
CALL mix_broyden( nsiw(itemp), Deltai, Deltaip, broyden_beta, iter, broyden_ndim, conv )
iter = iter + 1
@ -79,13 +79,13 @@
!
! SP : Only print the Free energy if the user want it
!
IF ( iverbosity .eq. 2 ) THEN
IF ( iverbosity == 2 ) THEN
CALL free_energy( itemp )
ENDIF
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'iaxis_imag' )
CALL print_clock( 'iaxis_imag' )
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') 'not converged '
CALL stop_clock( 'iaxis_imag' )
@ -105,7 +105,7 @@
conv = .false.
N = 80 * nsiw(itemp) / 100
IF ( mod(N,2) .ne. 0 ) N = N + 1
DO WHILE ( .not. conv .AND. iter .le. nsiter )
DO WHILE ( .NOT. conv .AND. iter <= nsiter )
CALL pade_cont_iso_iaxis_to_raxis( itemp, N, conv )
N = N - 2
iter = iter + 1
@ -117,7 +117,7 @@
CALL stop_clock( 'raxis_pade' )
CALL print_clock( 'raxis_pade' )
WRITE(stdout,'(a)') ' '
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'raxis_pade' )
@ -137,7 +137,7 @@
!
iter = 1
conv = .false.
DO WHILE ( .not. conv .AND. iter .le. nsiter )
DO WHILE ( .NOT. conv .AND. iter <= nsiter )
CALL analytic_cont_iso_iaxis_to_raxis( itemp, iter, conv )
rdeltain(:) = real(Deltap(:))
cdeltain(:) = aimag(Deltap(:))
@ -155,7 +155,7 @@
CALL stop_clock( 'raxis_acon' )
CALL print_clock( 'raxis_acon' )
WRITE(stdout,'(a)') ' '
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'raxis_acon' )
@ -217,15 +217,15 @@
REAL(DP), ALLOCATABLE, SAVE :: Deltaold(:)
!! gap
!
IF ( .not. ALLOCATED(wesqrt) ) ALLOCATE( wesqrt(nsiw(itemp)) )
IF ( .not. ALLOCATED(desqrt) ) ALLOCATE( desqrt(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(wesqrt) ) ALLOCATE ( wesqrt(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(desqrt) ) ALLOCATE ( desqrt(nsiw(itemp)) )
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(gap) ) ALLOCATE( gap(nstemp) )
IF ( .not. ALLOCATED(Deltai) ) ALLOCATE( Deltai(nsiw(itemp)) )
IF ( .not. ALLOCATED(Deltaip) ) ALLOCATE( Deltaip(nsiw(itemp)) )
IF ( .not. ALLOCATED(Znormi) ) ALLOCATE( Znormi(nsiw(itemp)) )
IF ( .not. ALLOCATED(NZnormi) ) ALLOCATE( NZnormi(nsiw(itemp)) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(gap) ) ALLOCATE ( gap(nstemp) )
IF ( .NOT. ALLOCATED(Deltai) ) ALLOCATE ( Deltai(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(Deltaip) ) ALLOCATE ( Deltaip(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(Znormi) ) ALLOCATE ( Znormi(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(NZnormi) ) ALLOCATE ( NZnormi(nsiw(itemp)) )
gap(itemp) = zero
Deltaip(:) = zero
Deltaip(:) = gap0
@ -236,8 +236,8 @@
NZnormi(:) = zero
Deltai(:) = zero
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(Deltaold) ) ALLOCATE( Deltaold(nsiw(itemp)) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(Deltaold) ) ALLOCATE ( Deltaold(nsiw(itemp)) )
Deltaold(:) = gap0
ENDIF
absdelta = zero
@ -245,7 +245,7 @@
DO iw = 1, nsiw(itemp) ! loop over omega
DO iwp = 1, nsiw(itemp) ! loop over omega_prime
! this step is performed at each iter step only for iw=1 since it is independ of wsi(iw)
IF ( iw .eq. 1 ) THEN
IF ( iw == 1 ) THEN
esqrt = 1.d0 / sqrt( wsi(iwp)**2.d0 + Deltaip(iwp)**2.d0 )
wesqrt(iwp) = wsi(iwp) * esqrt
desqrt(iwp) = Deltaip(iwp) * esqrt
@ -270,21 +270,21 @@
WRITE(stdout,'(5x,a,i6,a,ES20.10,a,ES20.10,a,ES20.10)') 'iter = ', iter, ' error = ', errdelta, &
' Znormi(1) = ', Znormi(1), ' Deltai(1) = ', Deltai(1)
!
IF ( errdelta .lt. conv_thr_iaxis ) conv = .true.
IF ( errdelta .lt. conv_thr_iaxis .OR. iter .eq. nsiter ) THEN
IF ( errdelta < conv_thr_iaxis ) conv = .true.
IF ( errdelta < conv_thr_iaxis .OR. iter == nsiter ) THEN
gap(itemp) = Deltai(1)
gap0 = gap(itemp)
CALL eliashberg_write_iaxis( itemp )
ENDIF
!
IF( ALLOCATED(wesqrt) ) DEALLOCATE(wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE(desqrt)
IF( ALLOCATED(wesqrt) ) DEALLOCATE (wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE (desqrt)
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE(Deltaold)
IF ( conv .OR. iter == nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE (Deltaold)
WRITE(stdout,'(5x,a,i6)') 'Convergence was reached in nsiter = ', iter
ENDIF
IF ( .not. conv .AND. iter .eq. nsiter ) THEN
IF ( .NOT. conv .AND. iter == nsiter ) THEN
WRITE(stdout,'(5x,a,i6)') 'Convergence was not reached in nsiter = ', iter
CALL errore('sum_eliashberg_iso_iaxis','increase nsiter or reduce conv_thr_iaxis',1)
!CALL deallocate_eliashberg
@ -336,12 +336,12 @@
CHARACTER (len=256) :: cname
!! character in file name
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(Delta) ) ALLOCATE( Delta(nsw) )
IF ( .not. ALLOCATED(Deltap) ) ALLOCATE( Deltap(nsw) )
IF ( .not. ALLOCATED(Znorm) ) ALLOCATE( Znorm(nsw) )
IF ( .not. ALLOCATED(Znormp) ) ALLOCATE( Znormp(nsw) )
IF ( .not. ALLOCATED(Deltaold) ) ALLOCATE( Deltaold(nsw) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(Delta) ) ALLOCATE ( Delta(nsw) )
IF ( .NOT. ALLOCATED(Deltap) ) ALLOCATE ( Deltap(nsw) )
IF ( .NOT. ALLOCATED(Znorm) ) ALLOCATE ( Znorm(nsw) )
IF ( .NOT. ALLOCATED(Znormp) ) ALLOCATE ( Znormp(nsw) )
IF ( .NOT. ALLOCATED(Deltaold) ) ALLOCATE ( Deltaold(nsw) )
Deltap(:) = czero
Deltaold(:) = czero
IF ( lpade ) THEN
@ -352,10 +352,10 @@
Deltaold(:) = gap(itemp)
ENDIF
Znormp(:) = cone
IF ( .not. ALLOCATED(Gp) ) ALLOCATE( Gp(nsw,nqstep) )
IF ( .not. ALLOCATED(Gm) ) ALLOCATE( Gm(nsw,nqstep) )
IF ( .not. ALLOCATED(Dsumi) ) ALLOCATE( Dsumi(nsw) )
IF ( .not. ALLOCATED(Zsumi) ) ALLOCATE( Zsumi(nsw) )
IF ( .NOT. ALLOCATED(Gp) ) ALLOCATE ( Gp(nsw,nqstep) )
IF ( .NOT. ALLOCATED(Gm) ) ALLOCATE ( Gm(nsw,nqstep) )
IF ( .NOT. ALLOCATED(Dsumi) ) ALLOCATE ( Dsumi(nsw) )
IF ( .NOT. ALLOCATED(Zsumi) ) ALLOCATE ( Zsumi(nsw) )
CALL kernel_iso_iaxis_analytic_cont( itemp )
ENDIF
Znorm(:) = czero
@ -365,16 +365,16 @@
reldelta = zero
DO iw = 1, nsw ! loop over omega
DO iwp = 1, nqstep ! loop over omega_prime
IF ( iter .eq. 1 ) THEN
IF ( iter == 1 ) THEN
CALL gamma_acont( ws(iw), ws(iwp), estemp(itemp), rgammap, rgammam )
Gp(iw,iwp) = rgammap
Gm(iw,iwp) = rgammam
ENDIF
!
i = iw + iwp - 1
IF ( i .le. nsw ) THEN
IF ( i <= nsw ) THEN
root = sqrt( Znormp(i)**2.d0 * ( ws(i)**2.d0 - Deltap(i)**2.d0 ) )
IF ( aimag(root) .lt. zero ) THEN
IF ( aimag(root) < zero ) THEN
esqrt = Znormp(i) / conjg(root)
ELSE
esqrt = Znormp(i) / root
@ -386,13 +386,13 @@
!
i = abs(iw - iwp) + 1
root = sqrt( Znormp(i)**2.d0 * ( ws(i)**2.d0 - Deltap(i)**2.d0 ) )
IF ( aimag(root) .lt. zero ) THEN
IF ( aimag(root) < zero ) THEN
esqrt = Znormp(i) / conjg(root)
ELSE
esqrt = Znormp(i) / root
ENDIF
esqrt = esqrt * Gm(iw,iwp) * a2f_iso(iwp)
IF ( iw .lt. iwp ) THEN
IF ( iw < iwp ) THEN
Znorm(iw) = Znorm(iw) - ws(i) * esqrt
ELSE
Znorm(iw) = Znorm(iw) + ws(i) * esqrt
@ -411,17 +411,17 @@
' error = ', errdelta, ' Re[Znorm(1)] = ', real(Znorm(1)), &
' Re[Delta(1)] = ', real(Delta(1))
!
IF ( errdelta .lt. conv_thr_racon ) conv = .true.
IF ( errdelta .lt. conv_thr_racon .OR. iter .eq. nsiter ) THEN
IF ( errdelta < conv_thr_racon ) conv = .true.
IF ( errdelta < conv_thr_racon .OR. iter == nsiter ) THEN
cname = 'acon'
CALL eliashberg_write_raxis( itemp, cname )
ENDIF
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE(Deltaold)
IF ( conv .OR. iter == nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE (Deltaold)
WRITE(stdout,'(5x,a,i6)') 'Convergence was reached in nsiter = ', iter
ENDIF
IF ( .not. conv .AND. iter .eq. nsiter ) THEN
IF ( .NOT. conv .AND. iter == nsiter ) THEN
WRITE(stdout,'(5x,a,i6)') 'Convergence was not reached in nsiter = ', iter
CALL errore('analytic_cont_iso_iaxis_to_raxis','increase nsiter or reduce conv_thr_racon',-1)
ENDIF
@ -482,8 +482,8 @@
absdelta = zero
reldelta = zero
!
IF ( .not. ALLOCATED(Delta) ) ALLOCATE( Delta(nsw) )
IF ( .not. ALLOCATED(Znorm) ) ALLOCATE( Znorm(nsw) )
IF ( .NOT. ALLOCATED(Delta) ) ALLOCATE ( Delta(nsw) )
IF ( .NOT. ALLOCATED(Znorm) ) ALLOCATE ( Znorm(nsw) )
Znorm(:) = czero
Delta(:) = czero
!
@ -507,7 +507,7 @@
ENDDO
errdelta = reldelta / absdelta
!
IF ( errdelta .gt. zero ) THEN
IF ( errdelta > zero ) THEN
conv = .true.
WRITE(stdout,'(5x,a,i6,a,ES20.10,a,ES20.10,a,ES20.10)') 'pade = ', N, &
' error = ', errdelta, ' Re[Znorm(1)] = ', real(Znorm(1)), &
@ -516,7 +516,7 @@
CALL eliashberg_write_raxis( itemp, cname )
ENDIF
!
! IF ( .not. conv ) THEN
! IF ( .NOT. conv ) THEN
! WRITE(stdout,'(5x,a,i6)') 'Convergence was not reached pade = ', N
! CALL errore('pade_cont_iso_iaxis_to_raxis','decrease number of Pade approximants',-1)
! ENDIF
@ -550,7 +550,7 @@
REAL(DP) :: lambda_eph
!! electron-phonon coupling
!
IF ( .not. ALLOCATED(Keri) ) ALLOCATE( Keri(2*nsiw(itemp)) )
IF ( .NOT. ALLOCATED(Keri) ) ALLOCATE ( Keri(2*nsiw(itemp)) )
Keri(:) = zero
!
DO iw = 1, 2*nsiw(itemp)
@ -629,10 +629,10 @@
COMPLEX(DP) :: lambda_eph
!! electron-phonon coupling lambda(w-iw_n)
!
IF ( .not. ALLOCATED(wesqrt) ) ALLOCATE( wesqrt(nsiw(itemp)) )
IF ( .not. ALLOCATED(desqrt) ) ALLOCATE( desqrt(nsiw(itemp)) )
IF ( .not. ALLOCATED(Dsumi) ) ALLOCATE( Dsumi(nsw) )
IF ( .not. ALLOCATED(Zsumi) ) ALLOCATE( Zsumi(nsw) )
IF ( .NOT. ALLOCATED(wesqrt) ) ALLOCATE ( wesqrt(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(desqrt) ) ALLOCATE ( desqrt(nsiw(itemp)) )
IF ( .NOT. ALLOCATED(Dsumi) ) ALLOCATE ( Dsumi(nsw) )
IF ( .NOT. ALLOCATED(Zsumi) ) ALLOCATE ( Zsumi(nsw) )
Dsumi(:) = zero
Zsumi(:) = zero
!
@ -641,7 +641,7 @@
CALL lambdai_iso( ws(iw), wsi(iwp), lambda_eph )
kernelp = 2.d0 * real(lambda_eph)
kernelm = 2.d0 * aimag(lambda_eph)
IF ( iw .eq. 1 ) THEN
IF ( iw == 1 ) THEN
esqrt = 1.d0 / sqrt( wsi(iwp)**2.d0 + Deltai(iwp)**2.d0 )
wesqrt(iwp) = wsi(iwp) * esqrt
desqrt(iwp) = Deltai(iwp) * esqrt
@ -723,7 +723,7 @@
IF ( ABS(temp) < eps6 ) THEN
rgammap = zero
rgammam = one
ELSEIF ( omegap .gt. zero ) THEN
ELSEIF ( omegap > zero ) THEN
rgammap = 0.5d0 * ( tanh( 0.5d0 * ( omega + omegap ) / temp ) &
- 1.d0 / tanh( 0.5d0 * omegap / temp ) )
rgammam = 0.5d0 * ( tanh( 0.5d0 * ( omega - omegap ) / temp ) &
@ -749,7 +749,6 @@
!
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE io_files, ONLY : prefix
USE epwcom, ONLY : nsiter, nstemp, broyden_beta, broyden_ndim
USE eliashbergcom, ONLY : nsw, Delta, Deltap, gap, estemp
USE constants_epw, ONLY : kelvin2eV, ci
@ -782,7 +781,7 @@
WRITE(stdout,'(a)') ' '
iter = 1
conv = .false.
DO WHILE ( .not. conv .AND. iter .le. nsiter )
DO WHILE ( .NOT. conv .AND. iter <= nsiter )
CALL integrate_eliashberg_iso_raxis( itemp, iter, conv )
rdeltain(:) = real(Deltap(:))
cdeltain(:) = aimag(Deltap(:))
@ -805,7 +804,7 @@
WRITE(stdout,'(a)') ' '
CALL print_clock( 'iso_raxis' )
WRITE(stdout,'(a)') ' '
ELSEIF ( .not. conv .AND. (iter-1) .eq. nsiter ) THEN
ELSEIF ( .NOT. conv .AND. (iter-1) == nsiter ) THEN
CALL deallocate_eliashberg
WRITE(stdout,'(a)') ' '
CALL stop_clock( 'iso_raxis' )
@ -870,44 +869,44 @@
REAL(DP), EXTERNAL :: wgauss
CHARACTER(len=256) :: name1, cname
!
IF ( .not. ALLOCATED(wesqrt) ) ALLOCATE( wesqrt(nsw) )
IF ( .not. ALLOCATED(desqrt) ) ALLOCATE( desqrt(nsw) )
IF ( .NOT. ALLOCATED(wesqrt) ) ALLOCATE ( wesqrt(nsw) )
IF ( .NOT. ALLOCATED(desqrt) ) ALLOCATE ( desqrt(nsw) )
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(gap) ) ALLOCATE( gap(nstemp) )
IF ( .not. ALLOCATED(Delta) ) ALLOCATE( Delta(nsw) )
IF ( .not. ALLOCATED(Deltap) ) ALLOCATE( Deltap(nsw) )
IF ( .not. ALLOCATED(Znorm) ) ALLOCATE( Znorm(nsw) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(gap) ) ALLOCATE ( gap(nstemp) )
IF ( .NOT. ALLOCATED(Delta) ) ALLOCATE ( Delta(nsw) )
IF ( .NOT. ALLOCATED(Deltap) ) ALLOCATE ( Deltap(nsw) )
IF ( .NOT. ALLOCATED(Znorm) ) ALLOCATE ( Znorm(nsw) )
gap(itemp) = zero
Deltap(:) = czero
Deltap(:) = gap0
IF ( .not. ALLOCATED(fdwp) ) ALLOCATE( fdwp(nsw) )
IF ( .not. ALLOCATED(Kp) ) ALLOCATE( Kp(nsw,nsw) )
IF ( .not. ALLOCATED(Km) ) ALLOCATE( Km(nsw,nsw) )
IF ( .NOT. ALLOCATED(fdwp) ) ALLOCATE ( fdwp(nsw) )
IF ( .NOT. ALLOCATED(Kp) ) ALLOCATE ( Kp(nsw,nsw) )
IF ( .NOT. ALLOCATED(Km) ) ALLOCATE ( Km(nsw,nsw) )
ENDIF
Delta(:) = czero
Znorm(:) = czero
!
temp = estemp(itemp) / kelvin2eV
IF ( temp .lt. 10.d0 ) THEN
IF ( temp < 10.d0 ) THEN
WRITE(name1,'(a,a7,f4.2)') TRIM(prefix),'.ker_00', temp
ELSEIF ( temp .ge. 10.d0 ) THEN
ELSEIF ( temp >= 10.d0 ) THEN
WRITE(name1,'(a,a6,f5.2)') TRIM(prefix),'.ker_0', temp
ELSEIF ( temp .ge. 100.d0 ) THEN
ELSEIF ( temp >= 100.d0 ) THEN
WRITE(name1,'(a,a5,f6.2)') TRIM(prefix),'.ker_', temp
ENDIF
OPEN(iufilker, file=name1, form='unformatted')
OPEN(iufilker, FILE=name1, FORM='unformatted')
!
IF ( iter .eq. 1 ) THEN
IF ( .not. ALLOCATED(Deltaold) ) ALLOCATE( Deltaold(nsw) )
IF ( iter == 1 ) THEN
IF ( .NOT. ALLOCATED(Deltaold) ) ALLOCATE ( Deltaold(nsw) )
Deltaold(:) = gap0
ENDIF
absdelta = zero
reldelta = zero
DO iw = 1, nsw ! loop over omega
DO iwp = 1, nsw ! loop over omega_prime
IF ( iter .eq. 1 ) THEN
IF ( iw .eq. 1 ) THEN
IF ( iter == 1 ) THEN
IF ( iw == 1 ) THEN
IF ( ABS(estemp(itemp)) < eps6 ) THEN
fdwp(iwp) = zero
ELSE
@ -931,17 +930,17 @@
ENDIF
!
! this step is performed at each iter step only for iw=1 since it is independent of w(iw)
IF ( iw .eq. 1 ) THEN
IF ( iw == 1 ) THEN
esqrt = 1.d0 / sqrt( ws(iwp)**2.d0 - Deltap(iwp)**2.d0 )
wesqrt(iwp) = real( ws(iwp) * esqrt )
desqrt(iwp) = real( Deltap(iwp) * esqrt )
ENDIF
!
! end points contribute only half ( trapezoidal integration rule )
IF ( (iwp .eq. 1) .OR. (iwp .eq. nsw) ) THEN
IF ( (iwp == 1) .OR. (iwp == nsw) ) THEN
dstep = 0.5d0 * dws(iwp)
! boundary points contribute half from left and half from right side
ELSEIF ( iwp .eq. nswfc ) THEN
ELSEIF ( iwp == nswfc ) THEN
dstep = 0.5d0 * ( dws(iwp) + dws(iwp+1) )
ELSE
dstep = dws(iwp)
@ -962,20 +961,20 @@
WRITE(stdout,'(5x,a,i6,a,ES20.10,a,ES20.10,a,ES20.10)') 'iter = ', iter, ' error = ', errdelta, &
' Re[Znorm(1)] = ', real(Znorm(1)), ' Re[Delta(1)] = ', real(Delta(1))
!
IF ( errdelta .lt. conv_thr_raxis) conv = .true.
IF ( errdelta .lt. conv_thr_raxis .OR. iter .eq. nsiter ) THEN
IF ( errdelta < conv_thr_raxis) conv = .true.
IF ( errdelta < conv_thr_raxis .OR. iter == nsiter ) THEN
cname = 'real'
CALL eliashberg_write_raxis( itemp, cname )
gap0 = gap(itemp)
ENDIF
!
IF( ALLOCATED(wesqrt) ) DEALLOCATE(wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE(desqrt)
IF( ALLOCATED(wesqrt) ) DEALLOCATE (wesqrt)
IF( ALLOCATED(desqrt) ) DEALLOCATE (desqrt)
!
IF ( conv .OR. iter .eq. nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE(Deltaold)
IF ( conv .OR. iter == nsiter ) THEN
IF( ALLOCATED(Deltaold) ) DEALLOCATE (Deltaold)
ENDIF
IF ( .not. conv .AND. iter .eq. nsiter ) THEN
IF ( .NOT. conv .AND. iter == nsiter ) THEN
WRITE(stdout,'(5x,a,i6)') 'Convergence was not reached in nsiter = ', iter
CALL errore('integrate_eliashberg_iso_raxis','increase nsiter or reduce conv_thr_raxis',-1)
ENDIF
@ -1031,10 +1030,10 @@
e3 = czero
e4 = czero
!
IF ( .not. ALLOCATED(bewph) ) ALLOCATE( bewph(nqstep) )
IF ( .NOT. ALLOCATED(bewph) ) ALLOCATE ( bewph(nqstep) )
! Bose-Einstein distribution
DO iwph = 1, nqstep ! loop over Omega (integration variable)
IF ( iw .eq. 1 .AND. iwp .eq. 1 ) THEN
IF ( iw == 1 .AND. iwp == 1 ) THEN
IF ( ABS(estemp(itemp)) < eps6 ) THEN
bewph(iwph) = zero
ELSE

10
EPW/src/system_mem_usage.f90
View File

@ -45,21 +45,21 @@
!--- read system file
inquire (file=filename,exist=ifxst)
if (.not.ifxst) then
inquire (FILE=filename,exist=ifxst)
if ( .NOT. ifxst) then
write (stdout,'(a)') 'System file does not exist'
return
endif
open(unit=iunimem, file=filename, action='read')
open(UNIT=iunimem, FILE=filename, action='read')
do
read (iunimem,'(a)',end=120) line
! Peak virtual memory usage
if (line(1:7).eq.'VmPeak:') then
if (line(1:7) == 'VmPeak:') then
read (line(8:),*) valueRSS(1)
endif
! Peak resident set size
if (line(1:6).eq.'VmHWM:') then
if (line(1:6) == 'VmHWM:') then
read (line(7:),*) valueRSS(2)
CLOSE (unit = iunimem, status = 'keep')
exit

106
EPW/src/transport.f90
View File

@ -142,16 +142,16 @@
!
IF (exst) THEN
IF (mpime == ionode_id) THEN
OPEN(unit=iunselecq, file='selecq.fmt', status='old', iostat=ios)
OPEN(UNIT=iunselecq, FILE='selecq.fmt', status='old', iostat=ios)
READ (iunselecq,*) totq
ALLOCATE(selecq(totq))
ALLOCATE (selecq(totq))
selecq(:) = 0
READ (iunselecq,*) nqtot
READ (iunselecq,*) selecq(:)
CLOSE(iunselecq)
ENDIF
CALL mp_bcast(totq , ionode_id, world_comm )
IF (.NOT. ALLOCATED(selecq)) ALLOCATE(selecq(totq))
IF (.NOT. ALLOCATED(selecq)) ALLOCATE (selecq(totq))
CALL mp_bcast(nqtot , ionode_id, world_comm )
CALL mp_bcast(selecq, ionode_id, world_comm )
IF (nqtot /= nqtotf) THEN
@ -160,7 +160,7 @@
ENDIF
!
ELSE
ALLOCATE(selecq(nqf))
ALLOCATE (selecq(nqf))
selecq(:) = 0
etf_loc(:,:) = zero
etf_locq(:,:) = zero
@ -403,7 +403,7 @@
ENDIF ! homogeneous
!
IF (mpime == ionode_id) THEN
OPEN(unit=iunselecq, file='selecq.fmt', action='write')
OPEN(UNIT=iunselecq, FILE='selecq.fmt', action='write')
WRITE (iunselecq,*) totq ! Selected number of q-points
WRITE (iunselecq,*) nqtotf ! Total number of q-points
WRITE (iunselecq,*) selecq(1:totq)
@ -545,14 +545,14 @@
WRITE(stdout,'(5x,"Scattering rate")')
WRITE(stdout,'(5x,a/)') repeat('=',67)
!
IF ( fsthick .lt. 1.d3 ) &
IF ( fsthick < 1.d3 ) &
WRITE(stdout, '(/5x,a,f10.6,a)' ) 'Fermi Surface thickness = ', fsthick * ryd2ev, ' eV'
WRITE(stdout, '(5x,a,f10.6,a)' ) 'This is computed with respect to the fine Fermi level ',ef * ryd2ev, ' eV'
WRITE(stdout, '(5x,a,f10.6,a,f10.6,a)' ) 'Only states between ',(ef-fsthick) * ryd2ev, ' eV and ',&
(ef+fsthick) * ryd2ev, ' eV will be included'
WRITE(stdout,'(5x,a/)')
!
!IF ( .not. ALLOCATED (inv_tau_all) ) ALLOCATE( inv_tau_all(nstemp,ibndmax-ibndmin+1,nkqtotf/2) )
!IF ( .NOT. ALLOCATED (inv_tau_all) ) ALLOCATE ( inv_tau_all(nstemp,ibndmax-ibndmin+1,nkqtotf/2) )
!inv_tau_all(:,:,:) = zero
!
ENDIF
@ -618,10 +618,10 @@
!
! We are not consistent with ef from ephwann_shuffle but it should not
! matter if fstick is large enough.
!IF ( ( minval ( abs(etf (:, ikk) - ef0(itemp)) ) .lt. fsthick ) .AND. &
! ( minval ( abs(etf (:, ikq) - ef0(itemp)) ) .lt. fsthick ) ) THEN
IF ( ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) .lt. fsthick ) ) THEN
!IF ( ( minval ( abs(etf (:, ikk) - ef0(itemp)) ) < fsthick ) .AND. &
! ( minval ( abs(etf (:, ikq) - ef0(itemp)) ) < fsthick ) ) THEN
IF ( ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) .AND. &
( minval ( abs(etf (:, ikq) - ef) ) < fsthick ) ) THEN
!
DO imode = 1, nmodes
!
@ -630,7 +630,7 @@
!
! SP : Avoid if statement in inner loops
! the coupling from Gamma acoustic phonons is negligible
IF ( wq .gt. eps_acustic ) THEN
IF ( wq > eps_acustic ) THEN
g2_tmp = 1.0
wgq = wgauss( -wq*inv_etemp, -99)
wgq = wgq / ( one - two * wgq )
@ -859,13 +859,14 @@
! In case we read another q-file, merge the scattering here
IF (restart_filq .ne. '') THEN
!
ALLOCATE( inv_tau_all_new(nstemp, ibndmax-ibndmin+1, nkqtotf/2) )
ALLOCATE (inv_tau_all_new(nstemp, ibndmax-ibndmin+1, nkqtotf/2))
inv_tau_all_new(:,:,:) = zero
!
CALL merge_read( nkqtotf/2, nqtotf_new, inv_tau_all_new )
!
inv_tau_all(:,:,:) = ( inv_tau_all(:,:,:) * totq &
+ inv_tau_all_new(:,:,:) * nqtotf_new ) / (totq+nqtotf_new)
DEALLOCATE (inv_tau_all_new)
!
WRITE(stdout, '(a)' ) ' '
WRITE(stdout, '(a,i10,a)' ) ' Merge scattering for a total of ',totq+nqtotf_new,' q-points'
@ -945,7 +946,7 @@
!
ENDDO !nstemp
!
IF ( ALLOCATED(etf_all) ) DEALLOCATE( etf_all )
DEALLOCATE (etf_all)
!
! Creation of a restart point at the end
IF (restart) THEN
@ -976,7 +977,7 @@
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
SUBROUTINE transport_coeffs (ef0,efcb)
SUBROUTINE transport_coeffs (ef0, efcb)
!-----------------------------------------------------------------------
!!
!! This subroutine computes the transport coefficients
@ -1144,37 +1145,42 @@
! We can read the scattering rate from files.
IF ( scatread ) THEN
conv_factor1 = electron_SI / ( hbar * bohr2ang * Ang2m )
Sigma_m(:,:,:) = zero
!
! Compute the Fermi level
DO itemp = 1, nstemp
DO itemp=1, nstemp
!
etemp = transp_temp(itemp)
!
! Lets gather the velocities from all pools
#ifdef __MPI
IF ( vme ) THEN
IF ( .not. ALLOCATED(vmef_all) ) ALLOCATE( vmef_all(3,nbndsub,nbndsub,nkqtotf) )
vmef_all(:,:,:,:) = czero
CALL poolgatherc4 ( 3, nbndsub, nbndsub, nkqtotf, 2*nkf, vmef, vmef_all )
IF (vme) THEN
ALLOCATE (vmef_all(3, nbndsub, nbndsub, nkqtotf))
vmef_all(:, :, :, :) = czero
CALL poolgatherc4(3, nbndsub, nbndsub, nkqtotf, 2 * nkf, vmef, vmef_all)
ELSE
IF ( .not. ALLOCATED(dmef_all) ) ALLOCATE( dmef_all(3,nbndsub,nbndsub,nkqtotf) )
dmef_all(:,:,:,:) = czero
CALL poolgatherc4 ( 3, nbndsub, nbndsub, nkqtotf, 2*nkf, dmef, dmef_all )
ALLOCATE (dmef_all(3, nbndsub, nbndsub, nkqtotf))
dmef_all(:, :, :, :) = czero
CALL poolgatherc4(3, nbndsub, nbndsub, nkqtotf, 2 * nkf, dmef, dmef_all)
ENDIF
IF ( .not. ALLOCATED(wkf_all) ) ALLOCATE( wkf_all(nkqtotf) )
ALLOCATE (wkf_all(nkqtotf))
wkf_all(:) = zero
CALL poolgather2 ( 1, nkqtotf, 2*nkf, wkf, wkf_all )
CALL poolgather2(1, nkqtotf, 2 * nkf, wkf, wkf_all)
#else
IF ( vme ) THEN
IF (vme) THEN
ALLOCATE (vmef_all(3, nbndsub, nbndsub, nkqtotf))
vmef_all = vmef
ELSE
ALLOCATE (dmef_all(3, nbndsub, nbndsub, nkqtotf))
dmef_all = dmef
ENDIF
#endif
ALLOCATE (tdf_sigma_m(3, 3, ibndmax-ibndmin+1, nkqtotf))
tdf_sigma_m(:,:,:,:) = zero
!
! In this case, the sum over q has already been done. It should therefore be ok
! to do the mobility in sequential. Each cpu does the same thing below
ALLOCATE ( etf_all ( nbndsub, nkqtotf/2 ) )
ALLOCATE (etf_all(nbndsub, nkqtotf/2))
!
CALL scattering_read(etemp, ef0(itemp), etf_all, inv_tau_all)
!
@ -1186,14 +1192,8 @@
WRITE(stdout,'(5x,a/)') repeat('=',67)
ENDIF
!
IF ( itemp .eq. 1 ) THEN
IF ( .not. ALLOCATED(tdf_sigma_m) ) ALLOCATE( tdf_sigma_m(3,3,ibndmax-ibndmin+1,nkqtotf) )
tdf_sigma_m(:,:,:,:) = zero
Sigma_m(:,:,:) = zero
ENDIF
!
DO ik = 1, nkqtotf/2
ikk = 2 * ik - 1
DO ik=1, nkqtotf/2
ikk=2 * ik - 1
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
IF ( minval ( abs(etf_all (:, ik) - ef ) ) < fsthick ) THEN
DO ibnd = 1, ibndmax-ibndmin+1
@ -1265,11 +1265,7 @@
WRITE(stdout,'(5x,a/)') repeat('=',67)
ENDIF
!
IF ( itemp .eq. 1 ) THEN
IF ( .not. ALLOCATED(tdf_sigma_m) ) ALLOCATE( tdf_sigma_m(3,3,ibndmax-ibndmin+1,nkqtotf) )
tdf_sigma_m(:,:,:,:) = zero
Sigma_m(:,:,:) = zero
ENDIF
tdf_sigma_m(:,:,:,:) = zero
!
DO ik = 1, nkqtotf/2
ikk = 2 * ik - 1
@ -1336,13 +1332,20 @@
!
ENDIF ! int_mob .OR. (ncarrier > 1E5)
!
IF (vme) THEN
DEALLOCATE (vmef_all)
ELSE
DEALLOCATE (dmef_all)
ENDIF
DEALLOCATE (tdf_sigma_m)
DEALLOCATE (etf_all)
ENDDO ! itemp
!
ELSE ! Case without reading the scattering rates from files.
!
! SP - Uncomment to use symmetries on velocities
IF (mp_mesh_k) THEN
IF ( mpime .eq. ionode_id ) THEN
IF ( mpime == ionode_id ) THEN
!
CALL set_sym_bl( )
BZtoIBZ(:) = 0
@ -1388,7 +1391,7 @@
!write(stdout,*)'inv_tau_all ', SUM(inv_tau_all(itemp,:,:))
!write(stdout,*)'inv_tau_all ', SUM(inv_tau_all(:,:,:))
!
IF ( itemp .eq. 1 ) THEN
IF ( itemp == 1 ) THEN
!
! tdf_sigma_ij(ibnd,ik) = v_i(ik,ibnd) * v_j(ik,ibnd) * tau(ik,ibnd)
! i,j - cartesian components and ij combined (i,j) index
@ -1407,7 +1410,7 @@
ikk = 2 * ik - 1
!
! here we must have ef, not ef0, to be consistent with ephwann_shuffle
IF ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) THEN
IF ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) THEN
!
DO ibnd = 1, ibndmax-ibndmin+1
!
@ -1516,11 +1519,10 @@
CALL mp_sum( SigmaZ(:,itemp), world_comm )
!DBSP
!write(stdout,*) 'ef0(itemp) ',ef0(itemp)
!write(stdout,*) 'Sigma ',SUM(Sigma(:,itemp))
!
ENDDO ! nstemp
!
IF (mpime .eq. meta_ionode_id) THEN
IF (mpime == meta_ionode_id) THEN
filsigma = TRIM(prefix) // '_elcond_h'
OPEN(iufilsigma, file = filsigma, form = 'formatted')
WRITE(iufilsigma,'(a)') "# Electrical conductivity in 1/(Ohm * m)"
@ -1538,7 +1540,7 @@
DO itemp = 1, nstemp
etemp = transp_temp(itemp)
! Sigma in units of 1/(a.u.) is converted to 1/(Ohm * m)
IF (mpime.eq. meta_ionode_id) THEN
IF (mpime == meta_ionode_id) THEN
WRITE(iufilsigma,'(11E16.8)') ef0(itemp) * ryd2ev, etemp * ryd2ev / kelvin2eV, &
conv_factor1 * Sigma(:,itemp) * inv_cell
ENDIF
@ -1619,7 +1621,7 @@
!
ENDDO ! nstemp
!
IF (mpime .eq. meta_ionode_id) CLOSE(iufilsigma)
IF (mpime == meta_ionode_id) CLOSE(iufilsigma)
!
ENDIF ! Hole mob
!
@ -1629,14 +1631,14 @@
DO itemp = 1, nstemp
!
etemp = transp_temp(itemp)
IF ( itemp .eq. 1 ) THEN
IF ( itemp == 1 ) THEN
tdf_sigma(:) = zero
Sigma(:,:) = zero
SigmaZ(:,:) = zero
ENDIF
DO ik = 1, nkf
ikk = 2 * ik - 1
IF ( minval ( abs(etf (:, ikk) - ef) ) .lt. fsthick ) THEN
IF ( minval ( abs(etf (:, ikk) - ef) ) < fsthick ) THEN
IF ( ABS(efcb(itemp)) < eps ) THEN
DO ibnd = 1, ibndmax-ibndmin+1
! This selects only cond bands for electron conduction
@ -1830,7 +1832,7 @@
CALL mp_sum( SigmaZ(:,itemp), world_comm )
!
ENDDO ! nstemp
IF (mpime .eq. meta_ionode_id) THEN
IF (mpime == meta_ionode_id) THEN
filsigma = TRIM(prefix) // '_elcond_e'
OPEN(iufilsigma, file = filsigma, form = 'formatted')
WRITE(iufilsigma,'(a)') "# Electrical conductivity in 1/(Ohm * m)"
@ -1845,7 +1847,7 @@
WRITE(stdout,'(5x,a/)') repeat('=',67)
DO itemp = 1, nstemp
etemp = transp_temp(itemp)
IF (mpime .eq. meta_ionode_id) THEN
IF (mpime == meta_ionode_id) THEN
! Sigma in units of 1/(a.u.) is converted to 1/(Ohm * m)
IF ( ABS(efcb(itemp)) < eps ) THEN
WRITE(iufilsigma,'(11E16.8)') ef0(itemp) * ryd2ev, etemp * ryd2ev / kelvin2eV, &
@ -1957,7 +1959,7 @@
WRITE(stdout,'(5x," to the expected (x,y,z) axis.")')
WRITE(stdout,'(5x)')
!
IF (mpime .eq. meta_ionode_id) CLOSE(iufilsigma)
IF (mpime == meta_ionode_id) CLOSE(iufilsigma)
!
ENDIF ! Electron mobilities
ENDIF ! scatread

59
EPW/src/transport_iter.f90
View File

@ -17,8 +17,8 @@
CONTAINS
!
!-----------------------------------------------------------------------
SUBROUTINE ibte( nind, etf_all, vkk_all, wkf_all, trans_prob, ef0, &
sparse_q, sparse_k, sparse_i, sparse_j, sparse_t )
SUBROUTINE ibte (nind, etf_all, vkk_all, wkf_all, trans_prob, ef0, &
sparse_q, sparse_k, sparse_i, sparse_j, sparse_t)
!-----------------------------------------------------------------------
!!
!! This subroutine computes the scattering rate with the iterative BTE
@ -122,7 +122,7 @@
!! BZ to IBZ mapping
INTEGER :: s_BZtoIBZ(3,3,nkf1*nkf2*nkf3)
!! symmetry matrix for each k-point from the full BZ
INTEGER :: BZtoIBZ_mat(nrot,nkqtotf/2)
INTEGER, ALLOCATABLE :: BZtoIBZ_mat(:, :)
!! For a given k-point in the IBZ gives the k-point index
!! of all the k-point in the full BZ that are connected to the current
!! one by symmetry. nrot is the max number of symmetry
@ -191,8 +191,8 @@
! print*,'allocated s_BZtoIBZ_full',ALLOCATED(s_BZtoIBZ_full)
! Deal with symmetries
IF (mp_mesh_k) THEN
ALLOCATE(ixkqf_tr(nind), STAT=ierr)
ALLOCATE(s_BZtoIBZ_full(3,3,nind), STAT=ierr)
ALLOCATE (ixkqf_tr(nind), STAT=ierr)
ALLOCATE (s_BZtoIBZ_full(3, 3, nind), STAT=ierr)
! For a given k-point in the IBZ gives the k-point index
! of all the k-point in the full BZ that are connected to the current
! one by symmetry. nrot is the max number of symmetry
@ -201,13 +201,16 @@
ixkqf_tr(:) = 0
!call move_alloc(test1, s_BZtoIBZ_full)
s_BZtoIBZ_full(:,:,:) = 0
BZtoIBZ_mat(:,:) = 0
nsym(:) = 0
!
IF ( mpime .eq. ionode_id ) THEN
!
IF ( mpime == ionode_id ) THEN
!
! Computes nrot
CALL set_sym_bl( )
!
ALLOCATE (BZtoIBZ_mat(nrot, nkqtotf/2))
BZtoIBZ_mat(:, :) = 0
!
! What we get from this call is BZtoIBZ
CALL kpoint_grid_epw ( nrot, time_reversal, .false., s, t_rev, bg, nkf1*nkf2*nkf3, &
nkf1,nkf2,nkf3, nkqtotf_tmp, xkf_tmp, wkf_tmp,BZtoIBZ,s_BZtoIBZ)
@ -227,8 +230,10 @@
!
ENDIF ! mpime
!
CALL mp_bcast( nrot, ionode_id, inter_pool_comm )
CALL mp_bcast( s_BZtoIBZ, ionode_id, inter_pool_comm )
CALL mp_bcast( BZtoIBZ, ionode_id, inter_pool_comm )
IF (mpime /= ionode_id) ALLOCATE (BZtoIBZ_mat(nrot, nkqtotf/2))
CALL mp_bcast( BZtoIBZ_mat, ionode_id, inter_pool_comm )
!
WRITE(stdout,'(5x,"Symmetry mapping finished")')
@ -243,7 +248,7 @@
ixkqf_tr(ind) = BZtoIBZ(nkq_abs)
ENDDO
!
ENDIF
ENDIF ! mp_mesh_k
!
! First computes the SERTA solution as the first step of the IBTE
F_SERTA(:,:,:,:) = zero
@ -444,6 +449,12 @@
!
!
ENDDO ! end of while loop
!
IF ((mp_mesh_k)) THEN
DEALLOCATE (ixkqf_tr)
DEALLOCATE (s_BZtoIBZ_full)
ENDIF
!
RETURN
!
@ -584,9 +595,9 @@
! SP - The implementation only works with MPI so far
#ifdef __MPI
! Read velocities
IF (mpime.eq.ionode_id) THEN
IF (mpime == ionode_id) THEN
!
OPEN(unit=iufilibtev_sup,file='IBTEvel_sup.fmt',status='old',iostat=ios)
OPEN(UNIT=iufilibtev_sup,FILE='IBTEvel_sup.fmt',status='old',iostat=ios)
READ(iufilibtev_sup,'(a)')
READ(iufilibtev_sup,*) ind_tot, ind_totcb
READ(iufilibtev_sup,'(a)')
@ -623,7 +634,7 @@
! Allocate the local size
nind = upper_bnd - lower_bnd + 1
WRITE(stdout,'(5x,a,i10)') 'Number of elements per core ',nind
ALLOCATE ( trans_prob ( nind ) )
ALLOCATE (trans_prob(nind))
trans_prob(:) = 0.0d0
!
! Open file containing trans_prob
@ -703,12 +714,12 @@
IF( ierr /= 0 ) CALL errore( 'iter_restart', 'error in MPI_FILE_CLOSE',1)
CALL MPI_FILE_CLOSE(iunsparset,ierr)
IF( ierr /= 0 ) CALL errore( 'iter_restart', 'error in MPI_FILE_CLOSE',1)
DEALLOCATE(trans_prob)
DEALLOCATE(sparse_q)
DEALLOCATE(sparse_k)
DEALLOCATE(sparse_i)
DEALLOCATE(sparse_j)
DEALLOCATE(sparse_t)
DEALLOCATE (trans_prob)
DEALLOCATE (sparse_q)
DEALLOCATE (sparse_k)
DEALLOCATE (sparse_i)
DEALLOCATE (sparse_j)
DEALLOCATE (sparse_t)
!
ENDIF
! Electrons
@ -798,12 +809,12 @@
IF( ierr /= 0 ) CALL errore( 'iter_restart', 'error in MPI_FILE_CLOSE',1)
CALL MPI_FILE_CLOSE(iunsparsetcb,ierr)
IF( ierr /= 0 ) CALL errore( 'iter_restart', 'error in MPI_FILE_CLOSE',1)
DEALLOCATE(trans_probcb)
DEALLOCATE(sparsecb_q)
DEALLOCATE(sparsecb_k)
DEALLOCATE(sparsecb_i)
DEALLOCATE(sparsecb_j)
DEALLOCATE(sparsecb_t)
DEALLOCATE (trans_probcb)
DEALLOCATE (sparsecb_q)
DEALLOCATE (sparsecb_k)
DEALLOCATE (sparsecb_i)
DEALLOCATE (sparsecb_j)
DEALLOCATE (sparsecb_t)
!
ENDIF
#endif

291
EPW/src/wan2bloch.f90
View File

@ -17,7 +17,7 @@
CONTAINS
!
!--------------------------------------------------------------------------
SUBROUTINE hamwan2bloch ( nbnd, nrr, cuf, eig, chw, cfac, dims)
SUBROUTINE hamwan2bloch (nbnd, nrr, cuf, eig, chw, cfac, dims)
!--------------------------------------------------------------------------
!
! From the Hamiltonian in Wannier representation, find the corresponding
@ -52,19 +52,19 @@
INTEGER, INTENT (in) :: dims
!! dims = nbndsub if use_ws or 1 otherwise
!
REAL(kind=DP), INTENT (out) :: eig (nbnd)
REAL(kind=DP), INTENT (out) :: eig(nbnd)
!! interpolated hamiltonian eigenvalues for this kpoint
!
COMPLEX(kind=DP), INTENT (in) :: cfac(nrr, dims, dims)
!! Exponential factor
COMPLEX(kind=DP), INTENT (in) :: chw( nbnd, nbnd, nrr)
COMPLEX(kind=DP), INTENT (in) :: chw(nbnd, nbnd, nrr)
!! Hamiltonian in Wannier basis
COMPLEX(kind=DP), INTENT (out) :: cuf(nbnd, nbnd)
!! Rotation matrix U^\dagger, fine mesh
!
! variables for lapack ZHPEVX
!
INTEGER :: neig, info, ifail( nbnd ), iwork( 5*nbnd )
INTEGER :: neig, info, ifail(nbnd), iwork( 5*nbnd )
REAL(kind=DP) :: w( nbnd )
REAL(kind=DP) :: rwork( 7*nbnd )
COMPLEX(kind=DP) :: champ( nbnd*(nbnd+1)/2 )
@ -154,8 +154,8 @@
!
! DS - Impose phase
IF (lphase) THEN
DO jbnd = 1, nbnd
INNER : DO ibnd = 1, nbnd
DO jbnd=1, nbnd
INNER : DO ibnd=1, nbnd
IF ( ABS(cz(ibnd, jbnd)) > eps12 ) THEN
cz(:, jbnd) = cz(:, jbnd) * conjg( cz(ibnd,jbnd) )
cz(:, jbnd) = cz(:, jbnd)/sqrt(zdotu(nbnd,conjg(cz(:,jbnd)),1,cz(:, jbnd),1) )
@ -170,7 +170,7 @@
!
! U^\dagger is cuf(nbnd,nbnd)
!
cuf = conjg( transpose ( cz ) )
cuf = CONJG(TRANSPOSE(cz))
eig = w
!
CALL stop_clock('HamW2B')
@ -380,7 +380,7 @@
USE cell_base, ONLY : at, bg
USE phcom, ONLY : nq1, nq2, nq3
USE ions_base, ONLY : amass, tau, nat, ityp
USE elph2, ONLY : ifc, epsi, zstar
USE elph2, ONLY : ifc, epsi, zstar, wscache
USE epwcom, ONLY : lpolar
USE constants_epw, ONLY : twopi, czero, zero, one
USE io_global, ONLY : stdout
@ -435,7 +435,6 @@
!! inverse square root of masses
!
REAL(kind=DP), EXTERNAL :: wsweight
REAL(kind=DP), SAVE, ALLOCATABLE :: wscache(:,:,:,:,:)
REAL(kind=DP) total_weight, weight, arg, r(3), r_ws(3)
!
COMPLEX(kind=DP) :: chf(nmodes, nmodes)
@ -443,33 +442,33 @@
COMPLEX(kind=DP) :: dyn(3,3,nat,nat)
!! Dynamical matrix
!
CALL start_clock ( 'DynW2B' )
!
xq = xxq
! bring xq in cart. coordinates
CALL cryst_to_cart (1, xq, bg, 1)
CALL cryst_to_cart(1, xq, bg, 1)
!
FIRST_TIME : IF (first) THEN
first=.false.
ALLOCATE( wscache(-2*nq3:2*nq3, -2*nq2:2*nq2, -2*nq1:2*nq1, nat,nat) )
IF (first) THEN
first = .false.
DO na=1, nat
DO nb=1, nat
total_weight = zero
!
DO n1=-2*nq1,2*nq1
DO n2=-2*nq2,2*nq2
DO n3=-2*nq3,2*nq3
DO i=1, 3
r(i) = n1*at(i,1)+n2*at(i,2)+n3*at(i,3)
r_ws(i) = r(i) + tau(i,na)-tau(i,nb)
END DO
wscache(n3,n2,n1,nb,na) = wsweight(r_ws,rws,nrws)
ENDDO
ENDDO
DO nb=1, nat
total_weight = zero
!
DO n1=-2 * nq1, 2 * nq1
DO n2=-2 * nq2, 2 * nq2
DO n3=-2 * nq3, 2 * nq3
DO i=1, 3
r(i) = n1 * at(i, 1) + n2 * at(i, 2) + n3 * at(i, 3)
r_ws(i) = r(i) + tau(i, na) - tau(i, nb)
END DO
wscache(n3, n2, n1, nb, na) = wsweight(r_ws, rws, nrws)
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDIF FIRST_TIME
ENDIF
!
CALL start_clock ( 'DynW2B' )
!----------------------------------------------------------
! STEP 3: inverse Fourier transform to fine k and k+q meshes
!----------------------------------------------------------
@ -485,59 +484,59 @@
dyn = czero
!
DO na=1, nat
DO nb=1, nat
total_weight=zero
DO n1=-2*nq1,2*nq1
DO n2=-2*nq2,2*nq2
DO n3=-2*nq3,2*nq3
!
! SUM OVER R VECTORS IN THE SUPERCELL - VERY VERY SAFE RANGE!
!
DO i=1, 3
r(i) = n1*at(i,1)+n2*at(i,2)+n3*at(i,3)
END DO
!
weight = wscache(n3,n2,n1,nb,na)
IF (weight .GT. 0.0d0) THEN
!
! FIND THE VECTOR CORRESPONDING TO R IN THE ORIGINAL CELL
!
m1 = MOD(n1+1,nq1)
IF(m1.LE.0) m1=m1+nq1
m2 = MOD(n2+1,nq2)
IF(m2.LE.0) m2=m2+nq2
m3 = MOD(n3+1,nq3)
IF(m3.LE.0) m3=m3+nq3
!
arg = twopi*(xq(1)*r(1) + xq(2)*r(2) + xq(3)*r(3))
DO ipol=1, 3
DO jpol=1, 3
dyn(ipol,jpol,na,nb) = &
dyn(ipol,jpol,na,nb) + &
ifc(m1,m2,m3,ipol,jpol,na,nb)*CMPLX(COS(arg),-SIN(arg),kind=DP)*weight
END DO
END DO
END IF
total_weight=total_weight + weight
END DO
END DO
END DO
IF (ABS(total_weight-nq1*nq2*nq3).GT.1.0d-8) THEN
WRITE(stdout,*) total_weight
CALL errore ('dynifc2bloch','wrong total_weight',1)
END IF
END DO
DO nb=1, nat
total_weight = zero
DO n1=-2*nq1, 2*nq1
DO n2=-2*nq2, 2*nq2
DO n3=-2*nq3, 2*nq3
!
! SUM OVER R VECTORS IN THE SUPERCELL - VERY VERY SAFE RANGE!
!
DO i=1, 3
r(i) = n1 * at(i, 1) + n2 * at(i, 2) + n3 * at(i, 3)
ENDDO
!
weight = wscache(n3, n2, n1, nb, na)
IF (weight > zero) THEN
!
! FIND THE VECTOR CORRESPONDING TO R IN THE ORIGINAL CELL
!
m1 = MOD(n1 + 1, nq1)
IF (m1 <= 0) m1 = m1 + nq1
m2 = MOD(n2 + 1, nq2)
IF (m2 <= 0) m2 = m2 + nq2
m3 = MOD(n3 + 1, nq3)
IF (m3 <= 0) m3 = m3 + nq3
!
arg = twopi * (xq(1) * r(1) + xq(2) * r(2) + xq(3) * r(3))
DO ipol=1, 3
DO jpol=1, 3
dyn(ipol, jpol, na, nb) = &
dyn(ipol, jpol, na, nb) + &
ifc(m1, m2, m3, ipol, jpol, na, nb) * CMPLX(COS(arg), -SIN(arg), kind=DP) * weight
ENDDO
ENDDO
ENDIF
total_weight = total_weight + weight
ENDDO
ENDDO
ENDDO
IF (ABS(total_weight - nq1 * nq2 * nq3) > 1.0d-8) THEN
WRITE(stdout,*) total_weight
CALL errore ('dynifc2bloch','wrong total_weight',1)
END IF
END DO
END DO
!
do na = 1,nat
do nb = 1,nat
do ipol = 1,3
do jpol = 1,3
chf((na-1)*3+ipol, (nb-1)*3+jpol) = dyn(ipol,jpol,na,nb)
end do
end do
end do
end do
DO na=1, nat
DO nb=1, nat
DO ipol=1, 3
DO jpol=1, 3
chf((na - 1) * 3 + ipol, (nb - 1) * 3 + jpol) = dyn(ipol, jpol, na, nb)
ENDDO
ENDDO
ENDDO
ENDDO
!
IF (lpolar) THEN
! xq has to be in 2pi/a
@ -547,12 +546,12 @@
!
! divide by the square root of masses
!
DO na = 1, nat
DO nb = 1, nat
massfac = 1.d0 / sqrt ( amass(ityp(na)) * amass(ityp(nb)) )
DO na=1, nat
DO nb=1, nat
massfac = 1.d0 / SQRT ( amass(ityp(na)) * amass(ityp(nb)) )
!
chf(3*(na-1)+1:3*na, 3*(nb-1)+1:3*nb) = &
chf(3*(na-1)+1:3*na, 3*(nb-1)+1:3*nb) * massfac
chf(3 * (na - 1) + 1:3 * na, 3 * (nb - 1) + 1:3 * nb) = &
chf(3 * (na - 1) + 1:3 * na, 3 * (nb - 1) + 1:3 * nb) * massfac
!
ENDDO
ENDDO
@ -565,8 +564,8 @@
! champ: complex hamiltonian packed (upper triangular part for zhpevx)
! after hermitian-ization
!
DO jmode = 1, nmodes
DO imode = 1, jmode
DO jmode=1, nmodes
DO imode=1, jmode
champ (imode + (jmode - 1) * jmode/2 ) = &
( chf ( imode, jmode) + conjg ( chf ( jmode, imode) ) ) * 0.5d0
ENDDO
@ -599,7 +598,7 @@
USE cell_base, ONLY : at
USE phcom, ONLY : nq1, nq2, nq3
USE ions_base, ONLY : tau, nat
USE elph2, ONLY : ifc, epsi, zstar
USE elph2, ONLY : ifc, epsi, zstar, wscache
USE epwcom, ONLY : lpolar
USE constants_epw, ONLY : twopi, czero, zero
USE io_global, ONLY : stdout
@ -636,7 +635,6 @@
!! Counter on polarizations
!
REAL(kind=DP), EXTERNAL :: wsweight
REAL(kind=DP), SAVE, ALLOCATABLE :: wscache(:,:,:,:,:)
REAL(kind=DP) total_weight, weight, arg, r(3), r_ws(3)
!
COMPLEX(kind=DP) :: dyn(3,3,nat,nat)
@ -645,27 +643,26 @@
! bring xq in cart. coordinates
!CALL cryst_to_cart (1, xq, bg, 1)
!
FIRST_TIME : IF (first) THEN
first=.false.
ALLOCATE( wscache(-2*nq3:2*nq3, -2*nq2:2*nq2, -2*nq1:2*nq1, nat,nat) )
IF (first) THEN
first = .false.
DO na=1, nat
DO nb=1, nat
total_weight = zero
!
DO n1=-2*nq1,2*nq1
DO n2=-2*nq2,2*nq2
DO n3=-2*nq3,2*nq3
DO i=1, 3
r(i) = n1*at(i,1)+n2*at(i,2)+n3*at(i,3)
r_ws(i) = r(i) + tau(i,na)-tau(i,nb)
END DO
wscache(n3,n2,n1,nb,na) = wsweight(r_ws,rws,nrws)
ENDDO
ENDDO
DO nb=1, nat
total_weight = zero
!
DO n1=-2 * nq1, 2 * nq1
DO n2=-2 * nq2, 2 * nq2
DO n3=-2 * nq3, 2 * nq3
DO i=1, 3
r(i) = n1 * at(i, 1) + n2 * at(i, 2) + n3 * at(i, 3)
r_ws(i) = r(i) + tau(i, na)-tau(i, nb)
END DO
wscache(n3,n2,n1,nb,na) = wsweight(r_ws,rws,nrws)
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDIF FIRST_TIME
ENDIF
!
chf = czero
dyn = czero
@ -853,7 +850,7 @@
IF (eig_read) THEN
DO ibnd = 1, nbnd
DO jbnd = 1, nbnd
IF (abs(etf_ks(ibnd) - etf_ks(jbnd)) .gt. eps4) THEN
IF (abs(etf_ks(ibnd) - etf_ks(jbnd)) > eps4) THEN
dmef(:,ibnd,jbnd) = dmef(:,ibnd,jbnd) * &
( etf(ibnd) - etf(jbnd) )/ &
( etf_ks(ibnd) - etf_ks(jbnd) )
@ -990,7 +987,7 @@
! convert irvec from reduce to cartesian coordinates
! multiply by alat since the crystal axis 'at' are in
! cart. coords. in units of a_0
irvec_tmp(:) = alat * matmul( at, dble(irvec(:,ir)) )
irvec_tmp(:) = alat * MATMUL( at, dble(irvec(:,ir)) )
DO ipol = 1, 3
chf_a(ipol,:,:) = chf_a(ipol,:,:) + &
ci * irvec_tmp(ipol) * cfac(ir,:,:) * chw(:,:,ir)
@ -999,7 +996,7 @@
ENDDO
ELSE
DO ir = 1, nrr
irvec_tmp(:) = alat * matmul( at, dble(irvec(:,ir)) )
irvec_tmp(:) = alat * MATMUL( at, dble(irvec(:,ir)) )
DO ipol = 1, 3
chf_a(ipol,:,:) = chf_a(ipol,:,:) + &
ci * irvec_tmp(ipol) * cfac(ir,1,1) * chw(:,:,ir)
@ -1018,8 +1015,8 @@
!
DO ipol = 1, 3
!
! cvmef_tmp(:,:) = matmul( cvmef(ipol,:,:), conjg(transpose(cuf(:,:))) )
! vmef(ipol,:,:) = matmul( cuf(:,:), cvmef_tmp(:,:) )
! cvmef_tmp(:,:) = MATMUL( cvmef(ipol,:,:), conjg(transpose(cuf(:,:))) )
! vmef(ipol,:,:) = MATMUL( cuf(:,:), cvmef_tmp(:,:) )
!
CALL zgemm ('n', 'c', nbnd, nbnd, nbnd, cone, cvmef(ipol,:,:), &
nbnd, cuf(:,:), nbnd, czero, cvmef_tmp(:,:), nbnd)
@ -1036,8 +1033,8 @@
!
DO ipol = 1, 3
!
! chf_a_tmp(:,:) = matmul( chf_a(ipol,:,:), conjg(transpose(cuf(:,:))) )
! chf_a(ipol,:,:) = matmul(cuf(:,:), chf_a_tmp(:,:) )
! chf_a_tmp(:,:) = MATMUL( chf_a(ipol,:,:), conjg(transpose(cuf(:,:))) )
! chf_a(ipol,:,:) = MATMUL(cuf(:,:), chf_a_tmp(:,:) )
!
CALL zgemm ('n', 'c', nbnd, nbnd, nbnd, cone, chf_a(ipol,:,:), &
nbnd, cuf(:,:), nbnd, czero, chf_a_tmp(:,:), nbnd)
@ -1240,18 +1237,18 @@
IF (use_ws) THEN
!
#if defined(__MPI)
ALLOCATE(epmatw ( nbnd, nbnd, nrr_k, 3))
ALLOCATE (epmatw(nbnd, nbnd, nrr_k, 3))
! Although this should almost never be problematic (see explaination below)
lrepmatw2 = 2_MPI_OFFSET_KIND * INT( nbnd , kind = MPI_OFFSET_KIND ) * &
INT( nbnd , kind = MPI_OFFSET_KIND ) * &
INT( nrr_k , kind = MPI_OFFSET_KIND ) * &
3_MPI_OFFSET_KIND
#else
ALLOCATE(epmatw ( nbnd, nbnd, nrr_k, nmodes))
ALLOCATE (epmatw(nbnd, nbnd, nrr_k, nmodes))
lrepmatw2 = INT( 2 * nbnd * nbnd * nrr_k * 3, kind = 8)
#endif
!
DO irn = ir_start, ir_stop
DO irn=ir_start, ir_stop
ir = (irn-1)/nat + 1
na = MOD(irn-1,nat) + 1
#if defined(__MPI)
@ -1274,10 +1271,12 @@
! or noncollective (=non blocking) if using MPI_FILE_SEEK & MPI_FILE_READ.
! Here we want non blocking because not all the process have the same nb of ir.
!
CALL MPI_FILE_SEEK(iunepmatwp2,lrepmatw,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_READ(iunepmatwp2, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_READ_ALL',1 )
!CALL MPI_FILE_SEEK(iunepmatwp2,lrepmatw,MPI_SEEK_SET,ierr)
!IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_SEEK',1 )
!CALL MPI_FILE_READ(iunepmatwp2, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE,ierr)
!IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_READ_ALL',1 )
CALL MPI_FILE_READ_AT(iunepmatwp2, lrepmatw, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('ephwan2blochp', 'error in MPI_FILE_READ_AT',1)
!
DO iw2=1, dims
DO iw=1, dims
@ -1299,17 +1298,17 @@
! --------------------------------
ELSE ! use_ws
#if defined(__MPI)
ALLOCATE(epmatw ( nbnd, nbnd, nrr_k, 1))
ALLOCATE (epmatw(nbnd, nbnd, nrr_k, 1))
! Although this should almost never be problematic (see explaination below)
lrepmatw2 = 2_MPI_OFFSET_KIND * INT( nbnd , kind = MPI_OFFSET_KIND ) * &
INT( nbnd , kind = MPI_OFFSET_KIND ) * &
INT( nrr_k, kind = MPI_OFFSET_KIND )
#else
ALLOCATE(epmatw ( nbnd, nbnd, nrr_k, nmodes))
lrepmatw2 = INT( 2 * nbnd * nbnd * nrr_k, kind = 8)
ALLOCATE (epmatw(nbnd, nbnd, nrr_k, nmodes))
lrepmatw2 = INT(2 * nbnd * nbnd * nrr_k, kind = 8)
#endif
!
DO irn = ir_start, ir_stop
DO irn=ir_start, ir_stop
ir = (irn-1)/nmodes + 1
imode = MOD(irn-1,nmodes) + 1
#if defined(__MPI)
@ -1320,7 +1319,7 @@
INT( nbnd , kind=MPI_OFFSET_KIND ) * &
INT( nrr_k, kind=MPI_OFFSET_KIND ) * &
( INT( imode - 1_MPI_OFFSET_KIND, kind=MPI_OFFSET_KIND ) + &
INT( nmodes, kind=MPI_OFFSET_KIND ) * ( INT( ir, kind=MPI_OFFSET_KIND ) - 1_MPI_OFFSET_KIND ) )
INT(nmodes, kind=MPI_OFFSET_KIND ) * ( INT( ir, kind=MPI_OFFSET_KIND ) - 1_MPI_OFFSET_KIND ) )
!
! SP: mpi seek is used to set the position at which we should start
! reading the file. It is given in bits.
@ -1328,10 +1327,12 @@
! or noncollective (=non blocking) if using MPI_FILE_SEEK & MPI_FILE_READ.
! Here we want non blocking because not all the process have the same nb of ir.
!
CALL MPI_FILE_SEEK(iunepmatwp2,lrepmatw,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_READ(iunepmatwp2, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_READ_ALL',1 )
!CALL MPI_FILE_SEEK(iunepmatwp2,lrepmatw,MPI_SEEK_SET,ierr)
!IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_SEEK',1 )
!CALL MPI_FILE_READ(iunepmatwp2, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE,ierr)
!IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_READ_ALL',1 )
CALL MPI_FILE_READ_AT(iunepmatwp2, lrepmatw, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('ephwan2blochp', 'error in MPI_FILE_READ_AT',1)
!
CALL ZAXPY(nbnd * nbnd * nrr_k, cfac(1,ir,1,1), epmatw(:,:,:,1), 1, &
eptmp(:,:,:,imode), 1)
@ -1345,7 +1346,7 @@
#endif
ENDDO ! irn
ENDIF ! use_ws
DEALLOCATE(epmatw)
DEALLOCATE (epmatw)
ENDIF ! etf_mem
!
#if defined(__MPI)
@ -1359,8 +1360,8 @@
! [Eqn. 22 of PRB 76, 165108 (2007)]
! epmatf(j) = sum_i eptmp(i) * uf(i,j)
!
Call zgemm( 'n', 'n', nbnd * nbnd * nrr_k, nmodes, nmodes, cone, eptmp, &
nbnd * nbnd * nrr_k, cuf, nmodes, czero, epmatf, nbnd * nbnd * nrr_k )
Call zgemm('n', 'n', nbnd * nbnd * nrr_k, nmodes, nmodes, cone, eptmp, &
nbnd * nbnd * nrr_k, cuf, nmodes, czero, epmatf, nbnd * nbnd * nrr_k)
!
CALL stop_clock('ephW2Bp')
@ -1439,17 +1440,17 @@
! !
!ENDDO
!
DO imode = 1, nmodes
DO imode=1, nmodes
IF (use_ws) THEN
DO iw2=1, dims
DO iw=1, dims
DO ir=1, nrr
epmatf(iw,iw2,imode) = epmatf(iw,iw2,imode) + epmatw(iw,iw2,ir,imode) * cfac(ir,iw,iw2)
epmatf(iw, iw2, imode) = epmatf(iw, iw2, imode) + epmatw(iw, iw2, ir, imode) * cfac(ir, iw, iw2)
ENDDO
ENDDO
ENDDO
ELSE
CALL zgemv('n', nbnd**2, nrr, cone, epmatw(:,:,:,imode), nbnd**2, cfac(:,1,1), 1, cone, epmatf(:,:,imode), 1 )
CALL zgemv('n', nbnd**2, nrr, cone, epmatw(:, :, :, imode), nbnd**2, cfac(:, 1, 1), 1, cone, epmatf(:, :, imode), 1 )
ENDIF
ENDDO
!
@ -1466,12 +1467,12 @@
! the two zgemm calls perform the following ops:
! epmatf = [ cufkq * epmatf ] * cufkk^\dagger
!
DO imode = 1, nmodes
DO imode=1, nmodes
!
CALL zgemm ('n', 'n', nbnd, nbnd, nbnd, cone, cufkq, &
nbnd, epmatf (:,:,imode), nbnd, czero, eptmp, nbnd)
nbnd, epmatf (:, :, imode), nbnd, czero, eptmp, nbnd)
CALL zgemm ('n', 'c', nbnd, nbnd, nbnd, cone, eptmp, &
nbnd, cufkk, nbnd, czero, epmatf(:,:,imode), nbnd)
nbnd, cufkk, nbnd, czero, epmatf(:, :, imode), nbnd)
!
ENDDO
!
@ -1706,7 +1707,7 @@
ENDDO
ENDIF
!
ALLOCATE(epmatw( nbnd, nbnd, nrr_k))
ALLOCATE (epmatw( nbnd, nbnd, nrr_k))
epmatw(:,:,:) = czero
!
#if defined(__MPI)
@ -1737,10 +1738,12 @@
! or noncollective (=non blocking) if using MPI_FILE_SEEK & MPI_FILE_READ.
! Here we want non blocking because not all the process have the same nb of ir.
!
CALL MPI_FILE_SEEK(iunepmatwp2,lrepmatw,MPI_SEEK_SET,ierr)
IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_SEEK',1 )
CALL MPI_FILE_READ(iunepmatwp2, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE,ierr)
IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_READ_ALL',1 )
!CALL MPI_FILE_SEEK(iunepmatwp2,lrepmatw,MPI_SEEK_SET,ierr)
!IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_SEEK',1 )
!CALL MPI_FILE_READ(iunepmatwp2, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE,ierr)
!IF( ierr /= 0 ) CALL errore( 'ephwan2blochp', 'error in MPI_FILE_READ_ALL',1 )
CALL MPI_FILE_READ_AT(iunepmatwp2, lrepmatw, epmatw, lrepmatw2, MPI_DOUBLE_PRECISION, MPI_STATUS_IGNORE, ierr)
IF (ierr /= 0) CALL errore('ephwan2blochp_mem', 'error in MPI_FILE_READ_AT',1)
#endif
!
!write(stdout,*)'ir epmatw ',use_ws, ir, sum(epmatw)
@ -1759,7 +1762,7 @@
!IF (mpime==1) write(999,*),'cpu2 ir cfac(ir,1,1) epmatf ',ir, cfac(ir,1,1), sum(epmatf)
!
ENDDO
DEALLOCATE(epmatw)
DEALLOCATE (epmatw)
!
CALL mp_sum(epmatf, world_comm)
!

30
EPW/src/wannierize.f90
View File

@ -19,10 +19,9 @@
USE kinds, ONLY : DP
USE io_global, ONLY : stdout, ionode_id
USE wvfct, ONLY : nbnd
USE ions_base, ONLY : nat
USE start_k, ONLY : nk1, nk2, nk3
USE pwcom, ONLY : nkstot
USE epwcom, ONLY : xk_cryst
USE klist_epw, ONLY : xk_cryst
USE wannierEPW, ONLY : mp_grid, n_wannier, kpt_latt
USE mp, ONLY : mp_bcast
USE mp_world, ONLY : world_comm
@ -44,10 +43,10 @@
!
IF ( num_kpts .ne. nkstot ) &
CALL errore('wannierize','inconsistent nscf and elph k-grids',1)
IF ( nbnd .lt. n_wannier ) &
IF ( nbnd < n_wannier ) &
CALL errore('wannierize','Must have as many or more bands than Wannier functions',1)
!
ALLOCATE( kpt_latt(3,num_kpts) )
ALLOCATE (kpt_latt(3, num_kpts) )
!
WRITE(stdout, '(5x,a)') repeat("-",67)
WRITE(stdout, '(a, i2,a,i2,a,i2,a)') " Wannierization on ", nk1, " x ", nk2, " x ", nk3 , " electronic grid"
@ -67,6 +66,7 @@
! project the Wannier functions onto energy space
!
! CALL proj_w90
DEALLOCATE (kpt_latt)
!
WRITE(stdout, '(5x,a)') repeat("-",67)
CALL print_clock( 'WANNIER' )
@ -110,7 +110,7 @@
!
IF (meta_ionode) THEN
!
IF (nbndsub .gt. nwanxx) call errore('write_winfil',"Too many wannier bands",nbndsub)
IF (nbndsub > nwanxx) call errore('write_winfil',"Too many wannier bands",nbndsub)
!
OPEN (unit = iuwinfil, file = trim(prefix)//".win", form = 'formatted')
!
@ -137,10 +137,10 @@
! SP: This is not ok. Indeed you can have more bands in nscf.in than in
! nbndskip+nbndsub. In which case the dis_win_max can be larger than
! nbndskip+nbndsub. This is crucial for disantanglement.
!IF ( dis_win_min .lt. minval(et_tmp) ) dis_win_min = minval(et_tmp)
!IF ( dis_win_max .gt. maxval(et_tmp) ) dis_win_max = maxval(et_tmp)
IF ( dis_froz_min .lt. minval(et_tmp) ) dis_froz_min = minval(et_tmp)
IF ( dis_froz_max .gt. maxval(et_tmp) ) dis_froz_max = maxval(et_tmp)
!IF ( dis_win_min < minval(et_tmp) ) dis_win_min = minval(et_tmp)
!IF ( dis_win_max > maxval(et_tmp) ) dis_win_max = maxval(et_tmp)
IF ( dis_froz_min < minval(et_tmp) ) dis_froz_min = minval(et_tmp)
IF ( dis_froz_max > maxval(et_tmp) ) dis_froz_max = maxval(et_tmp)
!
WRITE(iuwinfil, '("dis_win_min ", f18.12)') dis_win_min
WRITE(iuwinfil, '("dis_win_max ", f18.12)') dis_win_max
@ -201,13 +201,13 @@
! maxvalue = dis_win_max + 1
! minvalue = dis_win_min - 1
ne = int( (dis_win_max - dis_win_min + 1) / dE )
IF (ne .lt. 1) CALL errore('proj_wan','Problem with disentanglement window',1)
IF (ne < 1) CALL errore('proj_wan','Problem with disentanglement window',1)
!
ALLOCATE (proj_wf(n_wannier, ne+1))
proj_wf = 0.d0
!
ALLOCATE(cu (nbnd, n_wannier, nks) )
ALLOCATE(cuq(nbnd, n_wannier, nks) )
ALLOCATE (cu (nbnd, n_wannier, nks) )
ALLOCATE (cuq(nbnd, n_wannier, nks) )
!
CALL loadumat(nbnd, n_wannier, nks, nkstot, xxq, cu, cuq, lwin, lwinq, exband)
! FG: introduced after ifort checks
@ -245,9 +245,9 @@
CLOSE (iuprojfil)
ENDIF
!
IF ( ALLOCATED(proj_wf)) DEALLOCATE(proj_wf)
IF ( ALLOCATED(cu)) DEALLOCATE(cu)
IF ( ALLOCATED(cuq)) DEALLOCATE(cuq)
IF ( ALLOCATED(proj_wf)) DEALLOCATE (proj_wf)
IF ( ALLOCATED(cu)) DEALLOCATE (cu)
IF ( ALLOCATED(cuq)) DEALLOCATE (cuq)
!
!------------------------------------------------------------
END SUBROUTINE proj_w90

8
EPW/src/wigner.f90
View File

@ -328,7 +328,7 @@
found = .true.
ENDIF
ENDDO !nrr
IF(.not. found) THEN
IF( .NOT. found) THEN
nrr = nrr + 1
irvec(:, nrr) = irvec_tmp(:, ir, iw, iw2)
ENDIF
@ -397,7 +397,7 @@
! if (ndegen(i,1,2)>0) print*, i,irvec(:,i), ndegen(i,1,2)
!ENDDO
!
DEALLOCATE(ind)
DEALLOCATE (ind)
!
!-----------------------------------------------------------------------------
END SUBROUTINE wigner_seitzkq
@ -582,7 +582,7 @@
found = .true.
ENDIF
ENDDO !nrr
IF(.not. found) THEN
IF( .NOT. found) THEN
nrr = nrr + 1
irvec(:, nrr) = irvec_tmp(:, ir, na, iw, iw2)
ENDIF
@ -662,7 +662,7 @@
CALL cryst_to_cart(dims2,tau(:,:),at,1)
CALL cryst_to_cart(dims,w_centers(:,:),at,1)
!
DEALLOCATE(ind)
DEALLOCATE (ind)
!
! -----------------------------------------------------------------------------------------
END SUBROUTINE wigner_seitzg

11
FFTXlib/Makefile
View File

@ -18,6 +18,9 @@ fft_parallel.o \
fft_interfaces.o \
fft_interpolate.o \
stick_base.o \
fftw.o \
fftw_sp.o \
fftw_dp.o \
fft_smallbox.o \
fft_smallbox_type.o \
fft_support.o \
@ -38,7 +41,13 @@ libqefft.a: $(FFTX)
fft_scalar.o : fft_scalar.f90 fft_scalar.FFTW3.f90 fft_scalar.FFTW.f90 fft_scalar.SX6.f90 fft_scalar.DFTI.f90 fft_scalar.ESSL.f90
fft_stick.o : fft_stick.c fftw.c fftw.h konst.h
fft_stick.o : fft_stick.c fftw_sp.h fftw_dp.h
fftw.o : fftw.c fftw.h
fftw_sp.o : fftw_sp.c fftw_sp.h fftw.h konst.h
fftw_dp.o : fftw_dp.c fftw_dp.h fftw.h konst.h
TEST : test.o libqefft.a
$(LD) $(LDFLAGS) -o fft_test.x test.o libqefft.a $(QELIBS)

58
FFTXlib/fft_stick.c
View File

@ -10,35 +10,45 @@
/* Always compile FFTW beside external driver to be used as fallback
* hook for higher level FFT drivers in the FFTX library */
#ifndef __FFTW
#define __FFTW
#endif
#if defined(__FFTW)
#include "fftw.c"
#include "fftw_dp.h"
#include "fftw_sp.h"
int create_plan_1d (fftw_plan *p, int *n, int *idir)
{
fftw_direction dir = ( (*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD );
*p = fftw_create_plan(*n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
*p = qe_fftw_create_plan(*n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
if( *p == NULL ) fprintf(stderr," *** CREATE_PLAN: warning empty plan ***\n");
/* printf(" pointer size = %d, value = %d\n", sizeof ( *p ), *p ); */
return 0;
}
int float_create_plan_1d(float_fftw_plan* p, int* n, int* idir)
{
fftw_direction dir = ((*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD);
*p = qe_float_fftw_create_plan(*n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
if (*p == NULL) fprintf(stderr, " *** CREATE_PLAN: warning empty plan ***\n");
/* printf(" pointer size = %d, value = %d\n", sizeof ( *p ), *p ); */
return 0;
}
int destroy_plan_1d (fftw_plan *p)
{
if ( *p != NULL ) fftw_destroy_plan(*p);
if ( *p != NULL ) qe_fftw_destroy_plan(*p);
else fprintf(stderr," *** DESTROY_PLAN: warning empty plan ***\n");
return 0;
}
int float_destroy_plan_1d(float_fftw_plan* p)
{
if (*p != NULL) qe_float_fftw_destroy_plan(*p);
else fprintf(stderr, " *** DESTROY_PLAN: warning empty plan ***\n");
return 0;
}
int create_plan_2d (fftwnd_plan *p, int *n, int *m, int *idir)
{
fftw_direction dir = ( (*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD );
*p = fftw2d_create_plan(*m, *n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
*p = qe_fftw2d_create_plan(*m, *n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
if( *p == NULL ) fprintf(stderr," *** CREATE_PLAN_2D: warning empty plan ***\n");
/* printf(" pointer size = %d, value = %d\n", sizeof ( *p ), *p ); */
return 0;
@ -46,7 +56,7 @@ int create_plan_2d (fftwnd_plan *p, int *n, int *m, int *idir)
int destroy_plan_2d (fftwnd_plan *p)
{
if ( *p != NULL ) fftwnd_destroy_plan(*p);
if ( *p != NULL ) qe_fftwnd_destroy_plan(*p);
else fprintf(stderr," *** DESTROY_PLAN_2D: warning empty plan ***\n");
return 0;
}
@ -54,7 +64,7 @@ int destroy_plan_2d (fftwnd_plan *p)
int create_plan_3d (fftwnd_plan *p, int *n, int *m, int *l, int *idir)
{
fftw_direction dir = ( (*idir < 0) ? FFTW_FORWARD : FFTW_BACKWARD );
*p = fftw3d_create_plan(*l, *m, *n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
*p = qe_fftw3d_create_plan(*l, *m, *n, dir, FFTW_ESTIMATE | FFTW_IN_PLACE);
if( *p == NULL ) {
fprintf(stderr," *** CREATE_PLAN_3D: warning empty plan ***\n");
fprintf(stderr," *** input was (n,m,l,dir): %d %d %d %d ***\n", *l, *m, *n, *idir);
@ -66,7 +76,7 @@ int create_plan_3d (fftwnd_plan *p, int *n, int *m, int *l, int *idir)
int destroy_plan_3d (fftwnd_plan *p)
{
if ( *p != NULL ) fftwnd_destroy_plan(*p);
if ( *p != NULL ) qe_fftwnd_destroy_plan(*p);
else fprintf(stderr," *** DESTROY_PLAN_3D: warning empty plan ***\n");
return 0;
}
@ -76,10 +86,9 @@ int fft_x_stick
(fftw_plan *p, FFTW_COMPLEX *a, int *nx, int *ny, int *nz, int *ldx, int *ldy )
{
int i, j, ind;
int i;
int xstride, bigstride;
int xhowmany, xidist;
double * ptr;
/* trasform along x and y */
bigstride = (*ldx) * (*ldy);
@ -140,10 +149,8 @@ int fft_x_stick_single
(fftw_plan *p, FFTW_COMPLEX *a, int *nx, int *ny, int *nz, int *ldx, int *ldy )
{
int i, j, ind;
int xstride, bigstride;
int xhowmany, xidist;
double * ptr;
/* trasform along x and y */
bigstride = (*ldx) * (*ldy);
@ -165,6 +172,13 @@ int fft_z_stick_single (fftw_plan *p, FFTW_COMPLEX *a, int *ldz)
return 0;
}
int float_fft_z_stick_single(float_fftw_plan* p, FFTW_FLOAT_COMPLEX* a, int* ldz)
{
float_fftw(*p, 1, a, 1, 0, 0, 0, 0);
return 0;
}
/* Computing the N-Dimensional FFT
void fftwnd(fftwnd_plan plan, int howmany,
FFTW_COMPLEX *in, int istride, int idist,
@ -206,13 +220,3 @@ as scratch space and its contents destroyed. In this case, out must be an
ordinary array whose elements are contiguous in memory (no striding).
*/
#else
/* This dummy subroutine is there for compilers that dislike empty files */
int dumfftwdrv() {
return 0;
}
#endif

Some files were not shown because too many files have changed in this diff Show More