LCPQ/quack
4
1
Fork 0
mirror of https://github.com/pfloos/quack synced 2024-08-31 00:23:45 +02:00
Code Releases Activity

openMP for GW

Browse Source
This commit is contained in:
Antoine Marie 2023-03-14 14:11:54 +01:00
parent 01b0a4d823
commit 3a80069009
2 changed files with 44 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/GW/self_energy_correlation.f90
View File

@ -78,29 +78,43 @@ subroutine self_energy_correlation(COHSEX,eta,nBas,nC,nO,nV,nR,nS,e,Omega,rho,Ec
! Occupied part of the correlation self-energy
do jb=1,nS
do i=nC+1,nO
do q=nC+1,nBas-nR
do p=nC+1,nBas-nR
!$OMP PARALLEL &
!$OMP SHARED(SigC,rho,eta,nS,nC,nO,nBas,nR,e,Omega) &
!$OMP PRIVATE(jb,i,q,p,eps) &
!$OMP DEFAULT(NONE)
!$OMP DO
do q=nC+1,nBas-nR
do p=nC+1,nBas-nR
do jb=1,nS
do i=nC+1,nO
eps = e(p) - e(i) + Omega(jb)
SigC(p,q) = SigC(p,q) + 2d0*rho(p,i,jb)*rho(q,i,jb)*eps/(eps**2 + eta**2)
end do
end do
end do
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
! Virtual part of the correlation self-energy
do jb=1,nS
do a=nO+1,nBas-nR
do q=nC+1,nBas-nR
do p=nC+1,nBas-nR
!$OMP PARALLEL &
!$OMP SHARED(SigC,rho,eta,nS,nC,nO,nBas,nR,e,Omega) &
!$OMP PRIVATE(jb,a,q,p,eps) &
!$OMP DEFAULT(NONE)
!$OMP DO
do q=nC+1,nBas-nR
do p=nC+1,nBas-nR
do jb=1,nS
do a=nO+1,nBas-nR
eps = e(p) - e(a) - Omega(jb)
SigC(p,q) = SigC(p,q) + 2d0*rho(p,a,jb)*rho(q,a,jb)*eps/(eps**2 + eta**2)
end do
end do
end do
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
! Galitskii-Migdal correlation energy

24
src/LR/linear_response.f90
View File

@ -21,7 +21,9 @@ subroutine linear_response(ispin,dRPA,TDA,eta,nBas,nC,nO,nV,nR,nS,lambda,e,ERI,E
double precision,intent(in) :: e(nBas)
double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas)
! Local variables
! Local variables
integer :: i,j,k
double precision :: trace_matrix
double precision,allocatable :: A(:,:)
@ -31,6 +33,7 @@ subroutine linear_response(ispin,dRPA,TDA,eta,nBas,nC,nO,nV,nR,nS,lambda,e,ERI,E
double precision,allocatable :: AmBSq(:,:)
double precision,allocatable :: AmBIv(:,:)
double precision,allocatable :: Z(:,:)
double precision,allocatable :: tmp(:,:)
! Output variables
@ -41,7 +44,7 @@ subroutine linear_response(ispin,dRPA,TDA,eta,nBas,nC,nO,nV,nR,nS,lambda,e,ERI,E
! Memory allocation
allocate(A(nS,nS),B(nS,nS),ApB(nS,nS),AmB(nS,nS),AmBSq(nS,nS),AmBIv(nS,nS),Z(nS,nS))
allocate(A(nS,nS),B(nS,nS),ApB(nS,nS),AmB(nS,nS),AmBSq(nS,nS),AmBIv(nS,nS),Z(nS,nS),tmp(nS,nS))
! Build A and B matrices
@ -77,10 +80,11 @@ subroutine linear_response(ispin,dRPA,TDA,eta,nBas,nC,nO,nV,nR,nS,lambda,e,ERI,E
! if(Omega(ia) < 0d0) Omega(ia) = 0d0
! end do
call ADAt(nS,AmB,1d0*sqrt(Omega),AmBSq)
call ADAt(nS,AmB,1d0/sqrt(Omega),AmBIv)
call ADAt(nS,AmB,1d0*dsqrt(Omega),AmBSq)
call ADAt(nS,AmB,1d0/dsqrt(Omega),AmBIv)
Z = matmul(AmBSq,matmul(ApB,AmBSq))
call dgemm('N','N',nS,nS,nS,1d0,ApB,size(ApB,1),AmBSq,size(AmBSq,1),0d0,tmp,size(tmp,1))
call dgemm('N','N',nS,nS,nS,1d0,AmBSq,size(AmBSq,1),tmp,size(tmp,1),0d0,Z,size(Z,1))
call diagonalize_matrix(nS,Z,Omega)
@ -91,13 +95,13 @@ subroutine linear_response(ispin,dRPA,TDA,eta,nBas,nC,nO,nV,nR,nS,lambda,e,ERI,E
! if(Omega(ia) < 0d0) Omega(ia) = 0d0
! end do
Omega = sqrt(Omega)
Omega = dsqrt(Omega)
XpY = matmul(transpose(Z),AmBSq)
call DA(nS,1d0/sqrt(Omega),XpY)
call dgemm('T','N',nS,nS,nS,1d0,Z,size(Z,1),AmBSq,size(AmBSq,1),0d0,XpY,size(XpY,1))
call DA(nS,1d0/dsqrt(Omega),XpY)
XmY = matmul(transpose(Z),AmBIv)
call DA(nS,1d0*sqrt(Omega),XmY)
call dgemm('T','N',nS,nS,nS,1d0,Z,size(Z,1),AmBIv,size(AmBIv,1),0d0,XmY,size(XmY,1))
call DA(nS,1d0*dsqrt(Omega),XmY)
end if