! ! Copyright (C) 2002-2005 FPMD-CPV groups ! 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 . ! MODULE optical_properties USE kinds IMPLICIT NONE SAVE PRIVATE INTEGER :: nfreq REAL(dbl) :: maxdie ! Hartree units REAL(dbl) :: ddie ! Hartree units REAL(dbl) :: temperature ! Kelvin REAL(dbl), PARAMETER :: small_freq = 1.d-6 ! Hartree units COMPLEX(dbl), ALLOCATABLE :: dielec_total(:) REAL(dbl), ALLOCATABLE :: sigma_total(:) INTEGER, ALLOCATABLE :: n_total(:) PUBLIC :: optical_setup, optical_closeup, opticalp, write_dielec CONTAINS SUBROUTINE optical_setup(woptical, noptical, boptical) USE constants, ONLY: au REAL(dbl), INTENT(IN) :: woptical REAL(dbl), INTENT(IN) :: boptical INTEGER, INTENT(IN) :: noptical IF( noptical < 1 ) THEN CALL errore(' optical_properties: optical_setup ',' noptical out of range ',noptical) END IF IF( woptical < small_freq ) THEN CALL errore(' optical_properties: optical_setup ',' woptical out of range ',INT(woptical)) END IF nfreq = noptical maxdie = woptical / au ddie = maxdie / REAL(nfreq) temperature = boptical ALLOCATE( dielec_total(nfreq), sigma_total(nfreq), n_total(nfreq) ) dielec_total = 0.0d0 sigma_total = 0.0d0 n_total = 0 RETURN END SUBROUTINE optical_setup SUBROUTINE optical_closeup IF( ALLOCATED( dielec_total ) ) DEALLOCATE( dielec_total ) IF( ALLOCATED( sigma_total ) ) DEALLOCATE( sigma_total ) IF( ALLOCATED( n_total ) ) DEALLOCATE( n_total ) RETURN END SUBROUTINE optical_closeup SUBROUTINE opticalp(nfi, box, atoms, c0, wfill, occ, ce, wempt, vpot, fnl, eigr, ps, kp) USE cp_types USE cell_module, ONLY: boxdimensions USE wave_types, ONLY: wave_descriptor USE pseudo_projector, ONLY: projector, allocate_projector, deallocate_projector USE pseudopotential, ONLY: nsanl USE nl, ONLY: nlsm1 USE forces, ONLY: dforce_all USE brillouin, ONLY: kpoints USE electrons_module, ONLY: ei, ei_emp USE kohn_sham_states, ONLY: kohn_sham USE constants, ONLY: au, pi, k_boltzman_au, au_to_ohmcmm1 USE cell_base, ONLY: tpiba2 USE mp, ONLY: mp_sum USE mp_global, ONLY: group USE io_global, ONLY: ionode USE atoms_type_module, ONLY: atoms_type USE io_files, ONLY: dielecunit, dielecfile USE control_flags, ONLY: force_pairing USE reciprocal_vectors, ONLY: gx, g USE reciprocal_space_mesh, ONLY: gkx_l USE uspp_param, ONLY: nhm INTEGER, INTENT(IN) :: nfi TYPE(boxdimensions), INTENT(IN) :: box TYPE(atoms_type), INTENT(INOUT) :: atoms ! ions structure COMPLEX(dbl), INTENT(IN) :: c0(:,:,:,:) COMPLEX(dbl), INTENT(INOUT) :: ce(:,:,:,:) TYPE(wave_descriptor), INTENT(IN) :: wempt, wfill REAL(dbl), INTENT(IN) :: occ(:,:,:) TYPE(projector) :: fnl(:,:) REAL (dbl), INTENT(in) :: vpot(:,:,:,:) TYPE (kpoints), INTENT(in) :: kp TYPE (pseudo), INTENT(in) :: ps COMPLEX(dbl) :: eigr(:,:) TYPE (projector) :: fnle( SIZE(ce, 1) ) INTEGER :: nspin, ispin, ngw, nb_l, nk, ngw_g INTEGER :: ie, if, nf, ne, ik, idie, ig, ierr COMPLEX(dbl), ALLOCATABLE :: eforce(:,:,:) REAL(dbl) :: curr(3), currt, wef COMPLEX(dbl) :: ccurr(3), ccurrt COMPLEX(dbl), ALLOCATABLE :: diet(:), cf(:,:,:,:) INTEGER :: cif, cie REAL(dbl), ALLOCATABLE :: sigma(:), fi(:), eig(:), ff(:,:) INTEGER, ALLOCATABLE :: ndiet(:) REAL(dbl) :: FACT, ef, beta LOGICAL :: gamma_symmetry, gzero ! ... SUBROUTINE BODY IF( force_pairing ) & CALL errore( ' opticalp ', ' force_pairing not implemented ', 1 ) ALLOCATE( cf( SIZE(c0,1), SIZE(c0,2), SIZE(c0,3), SIZE(c0,4) ) ) cf = c0 nk = wfill%nkl nspin = wfill%nspin beta = 1.0d0 / ( k_boltzman_au * temperature ) ALLOCATE( diet(nfreq), ndiet(nfreq), sigma(nfreq) ) diet = 0.0d0 sigma = 0.0d0 dielec_total = 0.0d0 sigma_total = 0.0d0 ndiet = 0 DO ispin = 1, nspin ngw = wfill%ngwl nb_l = wfill%nbl( ispin ) ALLOCATE( eforce( ngw, nb_l, nk ) ) CALL nlsm1( ispin, ps%wnl(:,:,:,1), atoms, eigr, cf(:,:,1,ispin), wfill, g, & gx, fnl(1,ispin)) CALL dforce_all( ispin, cf(:,:,:,ispin), wfill, occ(:,:,ispin), eforce, vpot(:,:,:,ispin), & fnl(:,ispin), eigr, ps) CALL kohn_sham( ispin, cf(:,:,:,ispin), wfill, eforce, kp ) DEALLOCATE( eforce ) ngw = wempt%ngwl nb_l = wempt%nbl( ispin ) ALLOCATE( ff( nb_l, nk ) ) DO ik = 1, nk ff( 1:nb_l, ik ) = 2.0d0 / nspin END DO ALLOCATE( eforce( ngw, nb_l, nk ) ) CALL allocate_projector(fnle, nsanl, nb_l, nhm, kp%gamma_only) CALL nlsm1( ispin, ps%wnl(:,:,:,1), atoms, eigr, ce(:,:,1,ispin), wempt, g, & gx, fnle(1)) CALL dforce_all( ispin, ce(:,:,:,ispin), wempt, ff, eforce, vpot(:,:,:,ispin), & fnle, eigr, ps) CALL kohn_sham( ispin, ce(:,:,:,ispin), wempt, eforce, kp ) CALL deallocate_projector(fnle) DEALLOCATE( eforce ) DEALLOCATE( ff ) END DO fact = 2.0d0 * pi / ( 3.0d0 * box%deth ) gamma_symmetry = wfill%gamma ierr = 0 IF( ionode ) THEN OPEN(UNIT=dielecunit, FILE=dielecfile, STATUS='unknown', POSITION='append', IOSTAT=ierr) END IF CALL mp_sum( ierr ) IF( ierr /= 0 ) & CALL errore(' opticalp ', ' opening file '//TRIM(dielecfile), 1 ) #if defined __CONDUCTIVITY WRITE( dielecunit, * ) 'STEP: ',nfi DO ispin = 1, nspin nf = wfill%nbl( ispin ) ne = wempt%nbl( ispin ) ngw = wfill%ngwl nk = kp%nkpt ALLOCATE( fi( nf + ne ), eig( nf + ne ) ) DO ik = 1, nk ef = ( ei_emp(1,ik,ispin) + ei(nf,ik,ispin) ) / 2.0 DO if = 1, nf fi( if ) = 1.0 / nspin / ( exp( beta * (ei(if,ik,ispin) - ef) ) + 1 ) eig( if ) = ei( if, ik, ispin ) IF( ionode ) WRITE( dielecunit, fmt = '(I4,2F12.6)' ) if, fi(if), eig(if) END DO DO ie = nf+1, ne+nf fi( ie ) = 1.0 / nspin / ( exp( beta * (ei_emp(ie-nf,ik,ispin) - ef) ) + 1 ) eig( ie ) = ei_emp( ie-nf, ik, ispin ) IF( ionode ) WRITE( dielecunit, fmt = '(I4,2F12.6)' ) ie, fi(ie), eig(ie) END DO DO if = 1, (nf + ne - 1) DO ie = if + 1, (nf + ne) ! frequencies in atomic units wef = eig(ie) - eig(if) ! discretize the frequency idie = wef / ddie + 1 IF( (wef > small_freq) .AND. (idie <= nfreq) ) THEN IF( ie <= nf ) THEN cie = ie ELSE cie = ie-nf END IF IF( if <= nf ) THEN cif = if ELSE cif = if-nf END IF IF( gamma_symmetry ) THEN curr = 0.0d0 DO ig = 1, ngw curr(1) = curr(1) + gx(1,ig) * & AIMAG( ce( ig, cie, ik, ispin ) * CONJG( cf( ig, cif, ik, ispin ) ) curr(2) = curr(2) + gx(2,ig) * & AIMAG( ce( ig, cie, ik, ispin ) * CONJG( cf( ig, cif, ik, ispin ) ) curr(3) = curr(3) + gx(3,ig) * & AIMAG( ce( ig, cie, ik, ispin ) * CONJG( cf( ig, cif, ik, ispin ) ) END DO ! parallel sum of curr CALL mp_sum( curr, group ) ! the factor 4.0d0 accounts for gamma symmetry currt = 4.0d0 * (fi(if)-fi(ie)) * ( curr(1)**2 + curr(2)**2 + curr(3)**2 ) currt = currt * tpiba2 / wef ! update dielectric tensor diet(idie) = diet(idie) + CMPLX(0.0d0, currt) / wef sigma(idie) = sigma(idie) + currt ndiet(idie) = ndiet(idie) + 1 END IF END IF END DO END DO ! DO if = 1, nf ! DO ie = 1, ne ! ! frequencies in atomic units ! wef = ei_emp(ie,ik,ispin) - ei(if,ik,ispin) ! ! discretize the frequency ! idie = wef / ddie + 1 ! IF( (wef .GT. small_freq) .AND. (idie .LT. nfreq) ) THEN ! IF( gamma_symmetry ) THEN ! curr = 0.0d0 ! DO ig = 1, ngw ! curr(1) = curr(1) + gx(1,ig) * & ! AIMAG( ce(ik,ispin)%w(ig, ie) * CONJG( cf(ik,ispin)%w(ig, if) ) ) ! curr(2) = curr(2) + gx(2,ig) * & ! AIMAG( ce(ik,ispin)%w(ig, ie) * CONJG( cf(ik,ispin)%w(ig, if) ) ) ! curr(3) = curr(3) + gx(3,ig) * & ! AIMAG( ce(ik,ispin)%w(ig, ie) * CONJG( cf(ik,ispin)%w(ig, if) ) ) ! END DO ! ! parallel sum of curr ! CALL mp_sum( curr, group ) ! ! the factor 4.0d0 accounts for gamma symmetry ! currt = 4.0d0 * ( curr(1)**2 + curr(2)**2 + curr(3)**2 ) ! currt = currt * tpiba2 ! / wef ! ! update dielectric tensor ! diet(idie) = diet(idie) + CMPLX(0.0d0, currt) ! / wef ! sigma(idie) = sigma(idie) + currt ! ndiet(idie) = ndiet(idie) + 1 ! END IF ! END IF ! END DO ! END DO END DO DEALLOCATE( fi, eig ) END DO #else WRITE( dielecunit, * ) 'STEP: ',nfi DO ispin = 1, nspin nf = wfill%nbl( ispin ) ne = wempt%nbl( ispin ) ngw = wfill%ngwl nk = kp%nkpt DO ik = 1, nk DO ie = 1, ne DO if = 1, nf wef = ei_emp(ie,ik,ispin) - ei(if,ik,ispin) IF( gamma_symmetry ) THEN curr = 0.0d0 DO ig = 1, ngw curr(1) = curr(1) + gx(1,ig) * & AIMAG( ce( ig, ie, ik, ispin ) * CONJG( cf( ig, if, ik, ispin ) ) ) curr(2) = curr(2) + gx(2,ig) * & AIMAG( ce( ig, ie, ik, ispin ) * CONJG( cf( ig, if, ik, ispin ) ) ) curr(3) = curr(3) + gx(3,ig) * & AIMAG( ce( ig, ie, ik, ispin ) * CONJG( cf( ig, if, ik, ispin ) ) ) END DO CALL mp_sum( curr, group ) currt = 2.0d0 * ( curr(1)**2 + curr(2)**2 + curr(3)**2 ) ELSE ccurr = 0.0d0 DO ig = 1, ngw ccurr(1) = ccurr(1) + gkx_l(1, ig, ik) * & ce( ig, ie, ik, ispin ) * CONJG( cf( ig, if, ik, ispin ) ) ccurr(2) = ccurr(2) + gkx_l(2, ig, ik) * & ce( ig, ie, ik, ispin ) * CONJG( cf( ig, if, ik, ispin ) ) ccurr(3) = ccurr(3) + gkx_l(3, ig, ik) * & ce( ig, ie, ik, ispin ) * CONJG( cf( ig, if, ik, ispin ) ) END DO CALL mp_sum( ccurr, group ) ccurrt = ccurr(1)*CONJG(ccurr(1)) + ccurr(2)*CONJG(ccurr(2)) + ccurr(3)*CONJG(ccurr(3)) WRITE( dielecunit ,100 ) ispin, ik, ie, if, wef, ccurrt 100 FORMAT(4I5,1D14.6,3X,2D14.6) END IF END DO END DO END DO END DO #endif ierr = 0 IF( ionode ) THEN CLOSE(UNIT=dielecunit, IOSTAT=ierr) END IF CALL mp_sum( ierr ) IF( ierr /= 0 ) & CALL errore(' opticalp ', ' opening file '//TRIM(dielecfile), 1 ) ! accumulate statistical values WHERE( ndiet > 0 ) dielec_total = fact * diet sigma_total = fact * sigma n_total = ndiet END WHERE DEALLOCATE( diet, ndiet, sigma ) DEALLOCATE( cf ) RETURN END SUBROUTINE opticalp SUBROUTINE write_dielec (nfi, tm) USE constants, ONLY: au, au_to_ohmcmm1 USE io_files, ONLY: dielecunit, dielecfile USE io_global, ONLY: ionode USE mp, ONLY: mp_sum INTEGER, INTENT(IN) :: nfi REAL(dbl), INTENT(IN) :: tm REAL(dbl) :: w INTEGER :: i, ierr #if defined __CONDUCTIVITY ierr = 0 IF( ionode ) THEN OPEN(UNIT=dielecunit, FILE=dielecfile, STATUS='unknown', POSITION='append', IOSTAT=ierr) END IF CALL mp_sum( ierr ) IF( ierr /= 0 ) & CALL errore(' write_dielec ', ' opening file '//TRIM(dielecfile), 1 ) WRITE( dielecunit, 30 ) nfi, tm DO I = 1, SIZE(dielec_total) w = (REAL(i)-0.5d0) * ddie ! WRITE(dielecunit,100) & ! w * au, dielec_total(i) / w / w, sigma_total(i) * au_to_ohmcmm1 / w, n_total(i) WRITE(dielecunit,100) & w * au, dielec_total(i), sigma_total(i) * au_to_ohmcmm1, n_total(i) END DO ierr = 0 IF( ionode ) THEN CLOSE(UNIT=dielecunit, IOSTAT=ierr) END IF CALL mp_sum( ierr ) IF( ierr /= 0 ) & CALL errore(' write_dielec ', ' closing file '//TRIM(dielecfile), 1 ) ! ... write to stdout WRITE( stdout,40) WRITE( stdout,50) DO I = 1, SIZE(dielec_total) w = (REAL(i)-0.5d0) * ddie ! WRITE( stdout,110) w * au, sigma_total(i) * au_to_ohmcmm1 / w, n_total(i) WRITE( stdout,110) w * au, sigma_total(i) * au_to_ohmcmm1 / ddie, n_total(i) END DO #endif 30 FORMAT(2X,'STEP:',I7,1X,F10.2) 40 FORMAT(/,3X,'Frequency dependent electronic conductivity',/) 50 FORMAT(3X,'frequency (eV) conductivity ( Ohm^-1 cm^-1 )') 90 FORMAT(3X,'Dielectric function') 100 FORMAT(3X,F12.6,3D16.8,I5) 110 FORMAT(3X,F12.6,D16.8,I5) RETURN END SUBROUTINE write_dielec END MODULE optical_properties