Skip to content

Commit

Permalink
Merge branch 'develop' of iffgit.fz-juelich.de:fleur/fleur into develop
Browse files Browse the repository at this point in the history
  • Loading branch information
@d-wortmann
d-wortmann committed Mar 20, 2024
2 parents d7668df + e0cb9df commit 28e038e
Show file tree
Hide file tree
Showing 5 changed files with 194 additions and 7 deletions.
8 changes: 8 additions & 0 deletions fleurinput/types_juPhon.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@ MODULE m_types_juPhon
LOGICAL :: l_dos = .FALSE. ! Calculate the phonon density of states
LOGICAL :: l_scf = .TRUE. ! Do a self-consistency run for dynmats
INTEGER :: startq = 1 ! Start the q-loop at a specific point
INTEGER :: stopq = 0 ! Stop the q-loop at a specific point
INTEGER :: qmode = 0 ! 0: Single-shot calculation for qlist
! 1: Reads q from fullsym_* input files

Expand Down Expand Up @@ -143,6 +144,7 @@ SUBROUTINE mpi_bc_juPhon(this, mpi_comm, irank)
CALL mpi_bc(this%l_dos, rank, mpi_comm)
CALL mpi_bc(this%l_scf, rank, mpi_comm)
CALL mpi_bc(this%startq, rank, mpi_comm)
CALL mpi_bc(this%stopq, rank, mpi_comm)
CALL mpi_bc(this%qmode, rank, mpi_comm)
CALL mpi_bc(this%singleQpt, rank, mpi_comm)
CALL mpi_bc(this%qvec, rank, mpi_comm)
Expand Down Expand Up @@ -300,6 +302,12 @@ SUBROUTINE read_xml_juPhon(this, xml)
this%startq = evaluateFirstIntOnly(xml%GetAttributeValue('/fleurInput/output/juPhon/@startq'))
END IF

numberNodes = xml%GetNumberOfNodes('/fleurInput/output/juPhon/@stopq')

IF (numberNodes == 1) THEN
this%stopq = evaluateFirstIntOnly(xml%GetAttributeValue('/fleurInput/output/juPhon/@stopq'))
END IF

numberNodes = xml%GetNumberOfNodes('/fleurInput/output/juPhon/@qmode')

IF (numberNodes == 1) THEN
Expand Down
1 change: 1 addition & 0 deletions io/xml/FleurInputSchema.xsd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1120,6 +1120,7 @@
<xsd:attribute name="l_dos" type="FleurBool" use="optional"/>
<xsd:attribute name="l_scf" type="FleurBool" use="optional"/>
<xsd:attribute name="startq" type="xsd:positiveInteger" use="optional"/>
<xsd:attribute name="stopq" type="xsd:nonNegativeInteger" use="optional"/>
<xsd:attribute name="qmode" type="xsd:nonNegativeInteger" use="optional"/>
</xsd:complexType>

Expand Down
42 changes: 37 additions & 5 deletions juphon/dfpt.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -102,13 +102,13 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &

COMPLEX, ALLOCATABLE :: grrhodummy(:, :, :, :, :)

COMPLEX, ALLOCATABLE :: dyn_mat(:,:,:), dyn_mat_r(:,:,:), dyn_mat_q_full(:,:,:), dyn_mat_pathq(:,:)
COMPLEX, ALLOCATABLE :: dyn_mat(:,:,:), dyn_mat_r(:,:,:), dyn_mat_q_full(:,:,:), dyn_mat_pathq(:,:), sym_dynvec(:,:,:), sym_dyn_mat(:,:,:)
REAL, ALLOCATABLE :: e2_vm(:,:,:)

INTEGER :: ngdp, iSpin, iQ, iDir, iDtype, nspins, zlim, iVac, lh, iDir2
INTEGER :: ngdp, iSpin, iQ, iDir, iDtype, nspins, zlim, iVac, lh, iDir2, sym_count
INTEGER :: iStar, xInd, yInd, zInd, q_eig_id, ikpt, ierr, qm_eig_id, iArray
INTEGER :: dfpt_eig_id, dfpt_eig_id2, dfpt_eigm_id, dfpt_eigm_id2
LOGICAL :: l_real, l_minusq, l_dfpt_scf
LOGICAL :: l_real, l_minusq, l_dfpt_scf, l_cheated

LOGICAL :: l_dfpt_band, l_dfpt_dos, l_dfpt_full

Expand All @@ -117,6 +117,7 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &
CHARACTER(len=100) :: inp_pref, trash

INTEGER, ALLOCATABLE :: q_list(:)
INTEGER, ALLOCATABLE :: sym_list(:) ! For each q: Collect, which symmetries leave q unchanged.

! Desym-tests:
INTEGER :: grid(3), iread
Expand All @@ -131,6 +132,8 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &
l_dfpt_full = fi%juPhon%l_intp
l_dfpt_dos = fi%juPhon%l_dos

l_cheated = .FALSE.

l_real = fi%sym%invs.AND.(.NOT.fi%noco%l_soc).AND.(.NOT.fi%noco%l_noco).AND.fi%atoms%n_hia==0

! l_minusq is a hard false at the moment. It can be used to ignore +-q symmetries and
Expand Down Expand Up @@ -204,6 +207,9 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &

ALLOCATE(q_list(SIZE(qpts_loc%bk,2)))
q_list = (/(iArray, iArray=1,SIZE(qpts_loc%bk,2), 1)/)

ALLOCATE(sym_list(fi_fullsym%sym%nop))
sym_list = 0
ELSE
! Read qpoints from the juPhon qlist in inp.xml
qpts_loc = qpts
Expand Down Expand Up @@ -388,12 +394,20 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &

ALLOCATE(dyn_mat(SIZE(q_list),3*fi_nosym%atoms%ntype,3*fi_nosym%atoms%ntype))
dyn_mat = cmplx(0.0,0.0)
ALLOCATE(sym_dyn_mat(SIZE(q_list),3*fi_nosym%atoms%ntype,3*fi_nosym%atoms%ntype))
sym_dyn_mat = cmplx(0.0,0.0)
IF (l_dfpt_scf) THEN
! Do the self-consistency calculations for each specified q, for all atoms and for
! all three cartesian directions.
! TODO: The effort here should be greatly reducible by symmetry considerations.
DO iQ = fi%juPhon%startq, SIZE(q_list)
! TODO: The effort here should be greatly reducible by symmetry considerations.
write(*,*) fi%juPhon%startq/=0, fi%juPhon%stopq, size(q_list)

DO iQ = fi%juPhon%startq, MERGE(fi%juPhon%stopq,SIZE(q_list),fi%juPhon%stopq/=0)
CALL timestart("q-point")
IF (.NOT.fi%juPhon%qmode==0) THEN
CALL make_sym_list(fi_fullsym%sym, qpts_loc%bk(:,q_list(iQ)),sym_count,sym_list)
ALLOCATE(sym_dynvec(3*fi_nosym%atoms%ntype,3*fi_nosym%atoms%ntype-1,sym_count))
END IF
kqpts = fi%kpts
! Modify this from kpts only in DFPT case.
DO ikpt = 1, fi%kpts%nkpt
Expand Down Expand Up @@ -475,6 +489,14 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &
CALL timestart("Typeloop")
DO iDir = 1, 3
CALL timestart("Dirloop")
IF (.NOT.fi%juPhon%qmode==0.AND.fmpi%irank==0) THEN
IF (iDtype==1.AND.iDir==2) sym_dyn_mat(iQ, 1, :) = dyn_mat(iQ, 1, :)
IF (3 *(iDtype-1)+iDir>1) THEN
CALL cheat_dynmat(fi_fullsym%atoms, fi_fullsym%sym, fi_fullsym%cell%amat, qpts_loc%bk(:,q_list(iQ)), iDtype, iDir, sym_count, sym_list(:sym_count), sym_dynvec, dyn_mat(iQ,:,:), sym_dyn_mat(iQ,:,:), l_cheated)
END IF
IF (l_cheated) WRITE(*,*) "Following row was cheated!"
IF (l_cheated) write(*,*) sym_dyn_mat(iQ,3 *(iDtype-1)+iDir,:)
END IF
dfpt_tag = ''
WRITE(dfpt_tag,'(a1,i0,a2,i0,a2,i0)') 'q', q_list(iQ), '_b', iDtype, '_j', iDir

Expand Down Expand Up @@ -538,8 +560,15 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &
END IF
CALL timestop("Dynmat")
dyn_mat(iQ,3 *(iDtype-1)+iDir,:) = dyn_mat(iQ,3 *(iDtype-1)+iDir,:) + conjg(E2ndOrdII(3 *(iDtype-1)+iDir,:))
IF (.NOT.fi%juPhon%qmode==0) THEN
CALL make_sym_dynvec(fi_fullsym%atoms, fi_fullsym%sym, fi_fullsym%cell%amat, qpts_loc%bk(:,q_list(iQ)), iDtype, iDir, sym_count, sym_list(:sym_count), dyn_mat(iQ,3 *(iDtype-1)+iDir,:), sym_dynvec)
END IF

IF (fmpi%irank==0) write(*,*) "dynmat row for ", dfpt_tag
IF (fmpi%irank==0) write(*,*) dyn_mat(iQ,3 *(iDtype-1)+iDir,:)
IF (fmpi%irank==0.AND.l_cheated) write(*,*) "The cheat:"
IF (fmpi%irank==0.AND.l_cheated) write(*,*) sym_dyn_mat(iQ,3 *(iDtype-1)+iDir,:)
l_cheated = .FALSE.
IF (fmpi%irank==0) WRITE(9339,*) dyn_mat(iQ,3 *(iDtype-1)+iDir,:)
CALL timestop("Dirloop")
END DO
Expand All @@ -564,6 +593,9 @@ SUBROUTINE dfpt(fi, sphhar, stars, nococonv, qpts, fmpi, results, enpara, &
END IF
!CALL close_eig(q_eig_id)
!IF (l_minusq) CALL close_eig(qm_eig_id)
IF (.NOT.fi%juPhon%qmode==0) THEN
DEALLOCATE(sym_dynvec)
END IF
CALL timestop("q-point")

END DO
Expand Down
149 changes: 148 additions & 1 deletion juphon/dfpt_dynmat_sym.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -207,4 +207,151 @@ SUBROUTINE ift_dyn(atoms,qpts,sym,amat,bqpt,dyn_mat_r,dyn_mat_q)
CALL ft_dyn_direct(q_lim,-1,bqpt,dyn_mat_q,dyn_mat_r)
END SUBROUTINE

END MODULE m_dfpt_dynmat_sym
SUBROUTINE make_sym_list(sym, bqpt, sym_count, sym_list)
TYPE(t_sym), INTENT(IN) :: sym
REAL, INTENT(IN) :: bqpt(3)
INTEGER, INTENT(OUT) :: sym_count
INTEGER, INTENT(INOUT) :: sym_list(:)

INTEGER :: iSym

sym_count = 0
sym_list = 0
DO iSym = 1, sym%nop
IF (norm2(bqpt-MATMUL(bqpt,sym%mrot(:,:,iSym)))<1e-8) THEN
sym_count = sym_count + 1
sym_list(sym_count) = iSym
END IF
END DO
END SUBROUTINE

SUBROUTINE make_sym_dynvec(atoms, sym, amat, bqpt, iDtype, iDir, sym_count, sym_list, dynvec, sym_dynvec)
USE m_inv3

TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sym), INTENT(IN) :: sym
REAL, INTENT(IN) :: amat(3,3), bqpt(3)
INTEGER, INTENT(IN) :: iDtype, iDir, sym_count
INTEGER, INTENT(IN) :: sym_list(sym_count)
COMPLEX, INTENT(IN) :: dynvec(:)
COMPLEX, INTENT(INOUT) :: sym_dynvec(:,:,:)

INTEGER :: iSym, iAtom, iRow, iCol
REAL :: phas, det, mrot(3,3), invmrot(3,3), invamat(3,3)
COMPLEX :: brot(3,3), temp_mat_1(3,3), temp_mat_2(3,3)
COMPLEX :: phase_fac, rotvec(3)

iRow = 3 * (iDtype-1) + iDir

DO iSym = 1, sym_count
mrot = sym%mrot(:,:,sym_list(iSym))
invmrot = sym%mrot(:,:,sym%invtab(sym_list(iSym)))
CALL inv3(amat,invamat,det)
temp_mat_1 = MATMUL(invmrot,invamat)
brot = MATMUL(amat,temp_mat_1)
DO iAtom = 1, atoms%nat
iCol = 3 * (iAtom-1)

phas = -tpi_const*(dot_product(bqpt(:),atoms%taual(:,iAtom)-atoms%taual(:,iDtype)))
phase_fac = cmplx(cos(phas),sin(phas))

rotvec = MATMUL(brot,dynvec(iCol+1:iCol+3))
sym_dynvec(iCol+1:iCol+3,iRow,iSym) = phase_fac * rotvec
END DO
END DO
END SUBROUTINE

SUBROUTINE cheat_dynmat(atoms, sym, amat, bqpt, iBetaPr, jDirPr, sym_count, sym_list, sym_dynvec, dynmat, sym_dynmat, l_cheated)
USE m_inv3

TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sym), INTENT(IN) :: sym
REAL, INTENT(IN) :: amat(3,3), bqpt(3)
INTEGER, INTENT(IN) :: iBetaPr, jDirPr, sym_count
INTEGER, INTENT(IN) :: sym_list(sym_count)
COMPLEX, INTENT(IN) :: sym_dynvec(:,:,:), dynmat(:,:)
COMPLEX, INTENT(INOUT) :: sym_dynmat(:,:)
LOGICAL, INTENT(OUT) :: l_cheated

INTEGER :: iSym, iDatom, iAtom, iRowPr, iColPr, iRow, iCol, iDir, jDir, iDirPr, kDir, iBeta, iAlpha, iAlphaPr, symsumcount, aAlpha(atoms%nat), iDone, iNeed, kNeed
REAL :: phas, det, mrot(3,3), invmrot(3,3), invamat(3,3)
COMPLEX :: brot(3,3), temp_mat_1(3,3), temp_mat_2(3,3), symsum(3,3), symvec(3)
COMPLEX :: phase_fac, rotvec(3), rhs_vecs(3,3 * (iBetaPr-1) + jDirPr - 1), rhs_vec_full(3)
LOGICAL :: l_mapped, l_done(3), l_need(3)

l_cheated = .FALSE.
iRowPr = 3 * (iBetaPr-1) + jDirPr
alphaPrloop: DO iAlphaPr = 1, atoms%nat
iColPr = 3 * (iAlphaPr-1)
DO iBeta = 1, iBetaPr
iRow = 3 * (iBeta-1)
alphaloop: DO iAlpha = 1, atoms%nat
iCol = 3 * (iAlpha-1)
symloop: DO iSym = 1, sym_count
IF (.NOT.(iBetaPr==sym%mapped_atom(sym_list(iSym),iBeta))) CYCLE
IF (.NOT.(iAlphaPr==sym%mapped_atom(sym_list(iSym),iAlpha))) CYCLE
! Get all rhs vectors that are possible
rhs_vecs = sym_dynvec(iCol+1:iCol+3,:iRowPr-1,iSym)
phas = tpi_const*(dot_product(bqpt(:),atoms%taual(:,iAlphaPr)-atoms%taual(:,iBetaPr)))
phase_fac = cmplx(cos(phas),sin(phas))

invmrot = sym%mrot(:,:,sym%invtab(sym_list(iSym)))
CALL inv3(amat,invamat,det)
temp_mat_1 = MATMUL(invmrot,invamat)
brot = MATMUL(amat,temp_mat_1)

DO jDir = 1, 3
IF (iRow+jDir>iRowPr) CYCLE symloop
rhs_vec_full = phase_fac*rhs_vecs(:, iRow + jDir)
!write(*,*) "---------------"
!write(*,*) rhs_vec_full
symvec = brot(:, jDir)
!write(*,*) symvec

l_done = .FALSE.
iDone = 0
l_need = .TRUE.
iNeed = 3
kNeed = 0
DO kDir = 1, 3
!IF (ABS(symvec(kDir))>1e-8.AND.ANY((ABS(dynmat(3 * (iBetaPr-1) + kDir,:))<1e-15)))
IF (ALL(ABS(dynmat(3 * (iBetaPr-1) + kDir,iColPr+1:iColPr+3))>1e-15)) THEN
l_done(kDir) = .TRUE.
iDone = iDone + 1
l_need(kDir) = .FALSE.
iNeed = iNeed - 1
CYCLE
END IF
IF (ABS(symvec(kDir))<1e-8) THEN
l_need(kDir) = .FALSE.
iNeed = iNeed - 1
CYCLE
END IF
kNeed = kDir
END DO
!write(*,*) iDone, l_done
!write(*,*) iNeed, l_need, kNeed
IF (iDone==0.OR.iDone==3) CYCLE
IF (iNeed/=1) CYCLE
DO kDir = 1, 3
IF (.NOT.l_need(kDir)) rhs_vec_full = rhs_vec_full - symvec(kDir)*dynmat(3 * (iBetaPr-1) + kDir,iColPr+1:iColPr+3)
END DO
IF (SQRT(REAL(DOT_PRODUCT(rhs_vec_full,rhs_vec_full)))<1e-15) CYCLE
!write(*,*) "Newrhs:", rhs_vec_full
!write(*,*) "Thesym:", symvec(kNeed)
IF (ABS(symvec(kNeed))>1e-8) THEN
sym_dynmat(iRowPr-jDirPr+kNeed,iColPr+1:iColPr+3) = rhs_vec_full/symvec(kNeed)
l_cheated = .TRUE.
ELSE
CYCLE
END IF
!write(*,*) "Cheat: ", sym_dynmat(iRowPr-jDirPr+kNeed,:)
IF (ALL(ABS(sym_dynmat(iRowPr-jDirPr+kNeed,iColPr+1:iColPr+3))>1e-15)) CYCLE alphaPrloop
END DO
END DO symloop
END DO alphaloop
END DO
END DO alphaPrloop
END SUBROUTINE

END MODULE m_dfpt_dynmat_sym
1 change: 0 additions & 1 deletion juphon/dfpt_eigen.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -185,7 +185,6 @@ SUBROUTINE dfpt_eigen(fi, sphhar, results, resultsq, results1, fmpi, enpara, noc
ALLOCATE(tempMat2(nbasfcnq))
IF (.NOT.sh_den.AND..NOT.old_and_wrong) ALLOCATE(tempMat3(nbasfcnq))

!TODO: Optimize this with (SCA)LAPACK CALLS
CALL timestart("Matrix multiplications")
DO nu = 1, noccbd
eigs1(nu) = 0.0
Expand Down

0 comments on commit 28e038e

Please sign in to comment.