diff --git a/src/QuAcK/ADC.f90 b/src/QuAcK/ADC.f90 new file mode 100644 index 0000000..fb04c21 --- /dev/null +++ b/src/QuAcK/ADC.f90 @@ -0,0 +1,48 @@ +subroutine ADC(singlet_manifold,triplet_manifold,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + +! ADC main routine + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: ispin + + +! Hello world + + write(*,*) + write(*,*)'**********************' + write(*,*)'| ADC(n) module |' + write(*,*)'**********************' + write(*,*) + +! ADC(2) calculation for singlet manifold + + if(singlet_manifold) then + + ispin = 1 + call ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + + endif + +! ADC(2) calculation for triplet manifold + + if(triplet_manifold) then + + ispin = 2 + call ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + + endif + +end subroutine ADC diff --git a/src/QuAcK/ADC2.f90 b/src/QuAcK/ADC2.f90 new file mode 100644 index 0000000..85d5469 --- /dev/null +++ b/src/QuAcK/ADC2.f90 @@ -0,0 +1,359 @@ +subroutine ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) + +! Compute ADC(2) excitation energies: see Schirmer, Cederbaum & Walter, PRA, 28 (1983) 1237 + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: ispin + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nH,nP,nHH,nPP,nSCF,n_diis + double precision :: Conv + double precision,external :: Kronecker_delta + double precision,allocatable :: B_ADC(:,:),X_ADC(:,:),e_ADC(:),SigInf(:,:),G_ADC(:,:) + double precision,allocatable :: db_ERI(:,:,:,:),eOld(:),error_diis(:,:),e_diis(:,:) + + integer :: i,j,k,l + integer :: a,b,c,d + integer :: p,q,r,s + integer :: nADC,iADC,jADC + + +! Hello world + + write(*,*) + write(*,*)'***********************************' + write(*,*)'| 2nd-order ADC calculation |' + write(*,*)'***********************************' + write(*,*) + +! Number of holes + + nH = nO - nC + nHH = nH*(nH+1)/2 + +! Number of particles + + nP = nV - nR + nPP = nP*(nP+1)/2 + + write(*,*) 'Total states: ',nH+nP + write(*,*) 'Hole states: ',nH + write(*,*) 'Particle states: ',nP + +! Size of ADC(2) matrices + + nADC = nH + nP + nH*nPP + nHH*nP + write(*,'(1X,A25,I3,A6,I6)') 'Size of ADC(2) matrices: ',nADC,' x ',nADC + +! Memory allocation + + allocate(db_ERI(nBas,nBas,nBas,nBas),error_diis(nBas,max_diis),e_diis(nBas,max_diis),eOld(nADC), & + B_ADC(nADC,nADC),X_ADC(nADC,nADC),e_ADC(nADC),G_ADC(nADC,nADC),SigInf(nADC,nADC)) + +! Create double-bar MO integrals + + call antisymmetrize_ERI(ispin,nBas,ERI,db_ERI) + +! Initialization + + Conv = 1d0 + nSCF = 0 + n_diis = 0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + SigInf(:,:) = 0d0 + eOld(:) = 0d0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ +! +! | e + SigInf (U^I)^t (U^II)^t | +! | | +! B = | U^I K^I + C^I 0 | +! | | +! | U^II 0 K^II + C^II | +! +! + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! + ! Build ADC(2) B matrix -- Eq. (38b) -- + ! + + write(*,'(1X,A7,1X,I4)') 'Cycle: ',nSCF + + ! + ! Diagonal part: static self-energy and epsilon + ! + + B_ADC(:,:) = 0d0 + B_ADC(nC+1:nV,nC+1:nV) = SigInf(nC+1:nV,nC+1:nV) + + jADC = 0 + + do p=nC+1,nV + + jADC = jADC + 1 + B_ADC(jADC,jADC) = e(p) + + enddo + + ! + ! U matrices -- Eq. (40a) -- + ! + + do p=nC+1,nV + + iADC = p - nC + jADC = nH + nP + + ! U^I: 2p-1h -- Eqs. (40a) and (41a) -- + + do i=nC+1,nO + do a=nO+1,nV-nR + do b=a,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = db_ERI(p,i,a,b) + + enddo + enddo + enddo + + ! U^II: 2h-1p -- Eqs. (40a) and (41b) -- + + do i=nC+1,nO + do j=i,nO + do a=nO+1,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = db_ERI(p,a,i,j) + + enddo + enddo + enddo + + enddo + + ! + ! K matrices -- Eq. (40b) -- + ! + + ! K^I: 2p-1h -- Eqs. (40b) and (41a) -- + + jADC = nH + nP + + do i=nC+1,nO + do a=nO+1,nV-nR + do b=a,nV-nR + + jADC = jADC + 1 + B_ADC(jADC,jADC) = e(a) + e(b) - e(i) + + enddo + enddo + enddo + + ! K^II: 2h-1p -- Eqs. (40b) and (41b) -- + + do i=nC+1,nO + do j=i,nO + do a=nO+1,nV + + jADC = jADC + 1 + B_ADC(jADC,jADC) = e(i) + e(j) - e(a) + + enddo + enddo + enddo + + ! + ! C matrices -- Eq. (42c) + ! + + ! C^I: 2p-1h-TDA -- Eqs. (42a) and (42c) -- + + iADC = nH + nP + + do i=nC+1,nO + do a=nO+1,nV-nR + do b=a,nV-nR + + iADC = iADC + 1 + jADC = nH + nP + + do j=nC+1,nO + do c=nO+1,nV + do d=c,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = B_ADC(iADC,jADC) & + + db_ERI(a,b,c,d)*Kronecker_delta(i,j) & + - db_ERI(j,b,i,d)*Kronecker_delta(a,c) & + - db_ERI(j,a,i,c)*Kronecker_delta(b,d) & + + db_ERI(b,a,c,d)*Kronecker_delta(i,j) & + - db_ERI(j,a,i,d)*Kronecker_delta(b,c) & + - db_ERI(j,b,i,c)*Kronecker_delta(a,d) + + enddo + enddo + enddo + + enddo + enddo + enddo + + ! C^II: 2p-1h-TDA -- Eqs. (42b) and (42c) -- + + iADC = nH + nP + nH * nPP + + do i=nC+1,nO + do j=i,nO + do a=nO+1,nV-nR + + iADC = iADC + 1 + jADC = nH + nP + nH*nPP + + do k=nC+1,nO + do l=k,nO + do b=nO+1,nV-nR + + jADC = jADC + 1 + B_ADC(iADC,jADC) = B_ADC(iADC,jADC) & + - db_ERI(i,j,k,l)*Kronecker_delta(a,b) & + + db_ERI(b,j,a,l)*Kronecker_delta(i,k) & + + db_ERI(b,i,a,k)*Kronecker_delta(j,l) & + - db_ERI(j,i,k,l)*Kronecker_delta(a,b) & + + db_ERI(b,i,a,l)*Kronecker_delta(j,k) & + + db_ERI(b,j,a,k)*Kronecker_delta(i,l) + + enddo + enddo + enddo + + enddo + enddo + enddo + + ! Fold B onto itself + + do iADC=1,nADC + do jADC=iADC+1,nADC + + B_ADC(jADC,iADC) = B_ADC(iADC,jADC) + + enddo + enddo + + ! Diagonalize B to obtain X and E -- Eq. (38a) -- + + X_ADC(:,:) = B_ADC(:,:) + call diagonalize_matrix(nADC,X_ADC,e_ADC) + + ! print results + + + write(*,*) '=================================' + write(*,*) 'ADC(2) excitation energies (eV)' + + do iADC=1,nADC + + if(NORM2(X_ADC(1:nH+nP,iADC)) > 0.1d0 ) & + write(*,'(2(2X,F12.6))') e_ADC(iADC)*HaToeV,NORM2(X_ADC(1:nH+nP,iADC)) + + enddo + + write(*,*) '=================================' + + ! Convergence criteria + + Conv = maxval(abs(e_ADC - eOld)) + + ! Store result for next iteration + + eOld(:) = e_ADC(:) + + ! Compute W -- Eq (11) -- + + SigInf(:,:) = 0d0 + + do i=nC+1,nO + do p=nC+1,nV-nR + do q=nC+1,nV-nR + + SigInf(p,q) = SigInf(p,q) - db_ERI(p,i,q,i) + + enddo + enddo + enddo + + ! Compute the one-particle Greeen function -- Eq. (28) -- + + G_ADC(:,:) = 0d0 + + do iADC=1,nADC + + if(e_ADC(iADC) > 0d0 ) cycle + + do p=nC+1,nV-nR + do q=nC+1,nV-nR + + G_ADC(p,q) = G_ADC(p,q) + X_ADC(p,iADC)*X_ADC(q,iADC) + + enddo + enddo + + enddo + + ! Compute static self-energy for next iteration -- Eq. (25) -- + + do p=nC+1,nV-nR + do q=nC+1,nV-nR + do r=nC+1,nV-nR + do s=nC+1,nV-nR + + SigInf(p,q) = SigInf(p,q) + db_ERI(p,r,q,s)*G_ADC(r,s) + + enddo + enddo + enddo + enddo + + ! Print results + +! call print_ADC2(nBas,nO,nSCF,Conv,e,eADC) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine ADC2 diff --git a/src/QuAcK/AO_values.f90 b/src/QuAcK/AO_values.f90 new file mode 100644 index 0000000..f57124d --- /dev/null +++ b/src/QuAcK/AO_values.f90 @@ -0,0 +1,108 @@ +subroutine AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,r,AO,dAO) + +! Compute values of the AOs and their derivatives (if required) + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: doDrift + integer,intent(in) :: nBas,nShell,nWalk + double precision,intent(in) :: CenterShell(maxShell,3) + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + double precision,intent(in) :: r(nWalk,2,3) + +! Local variables + + integer :: atot,nShellFunction,a(3) + integer,allocatable :: ShellFunction(:,:) + double precision :: rASq,xA,yA,zA,NormCoeff,prim + + integer :: iSh,iShF,iK,iW,iEl,iBas,ixyz + +! Output variables + + double precision,intent(out) :: AO(nWalk,2,nBas),dAO(nWalk,2,3,nBas) + +! Initialization + + AO = 0d0 + if(doDrift) dAO = 0d0 + iBas = 0 + +!------------------------------------------------------------------------ +! Loops over shells +!------------------------------------------------------------------------ + do iSh=1,nShell + + atot = TotAngMomShell(iSh) + nShellFunction = (atot*atot + 3*atot + 2)/2 + allocate(ShellFunction(1:nShellFunction,1:3)) + call generate_shell(atot,nShellFunction,ShellFunction) + + do iShF=1,nShellFunction + + iBas = iBas + 1 + a(1) = ShellFunction(iShF,1) + a(2) = ShellFunction(iShF,2) + a(3) = ShellFunction(iShF,3) + + do iW=1,nWalk + do iEl=1,2 + + xA = r(iW,iEl,1) - CenterShell(iSh,1) + yA = r(iW,iEl,2) - CenterShell(iSh,2) + zA = r(iW,iEl,3) - CenterShell(iSh,3) + +! Calculate distance for exponential + + rASq = xA**2 + yA**2 + zA**2 + +!------------------------------------------------------------------------ +! Loops over contraction degrees +!------------------------------------------------------------------------- + do iK=1,KShell(iSh) + +! Calculate the exponential part + prim = DShell(iSh,iK)*NormCoeff(ExpShell(iSh,iK),a)*exp(-ExpShell(iSh,iK)*rASq) + AO(iW,iEl,iBas) = AO(iW,iEl,iBas) + prim + + if(doDrift) then + prim = -2d0*ExpShell(iSh,iK)*prim + do ixyz=1,3 + dAO(iW,iEl,ixyz,iBas) = dAO(iW,iEl,ixyz,iBas) + prim + enddo + endif + + enddo + + if(doDrift) then + + dAO(iW,iEl,1,iBas) = xA**(a(1)+1)*yA**a(2)*zA**a(3)*dAO(iW,iEl,1,iBas) + if(a(1) > 0) dAO(iW,iEl,1,iBas) = dAO(iW,iEl,1,iBas) + dble(a(1))*xA**(a(1)-1)*yA**a(2)*zA**a(3)*AO(iW,iEl,iBas) + + dAO(iW,iEl,2,iBas) = xA**a(1)*yA**(a(2)+1)*zA**a(3)*dAO(iW,iEl,2,iBas) + if(a(2) > 0) dAO(iW,iEl,2,iBas) = dAO(iW,iEl,2,iBas) + dble(a(2))*xA**a(1)*yA**(a(2)-1)*zA**a(3)*AO(iW,iEl,iBas) + + dAO(iW,iEl,3,iBas) = xA**a(1)*yA**a(2)*zA**(a(3)+1)*dAO(iW,iEl,3,iBas) + if(a(3) > 0) dAO(iW,iEl,3,iBas) = dAO(iW,iEl,3,iBas) + dble(a(3))*xA**a(1)*yA**a(2)*zA**(a(3)-1)*AO(iW,iEl,iBas) + + endif + +! Calculate polynmial part + + AO(iW,iEl,iBas) = xA**a(1)*yA**a(2)*zA**a(3)*AO(iW,iEl,iBas) + + enddo + enddo + + enddo + deallocate(ShellFunction) + enddo +!------------------------------------------------------------------------ +! End loops over shells +!------------------------------------------------------------------------ + +end subroutine AO_values diff --git a/src/QuAcK/AOtoMO_integral_transform.f90 b/src/QuAcK/AOtoMO_integral_transform.f90 new file mode 100644 index 0000000..1320df9 --- /dev/null +++ b/src/QuAcK/AOtoMO_integral_transform.f90 @@ -0,0 +1,81 @@ +subroutine AOtoMO_integral_transform(nBas,c,ERI_AO_basis,ERI_MO_basis) + +! AO to MO transformation of two-electron integrals +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas),c(nBas,nBas) + +! Local variables + + double precision,allocatable :: scr(:,:,:,:) + integer :: mu,nu,la,si,i,j,k,l + +! Output variables + + double precision,intent(out) :: ERI_MO_basis(nBas,nBas,nBas,nBas) + +! Memory allocation + allocate(scr(nBas,nBas,nBas,nBas)) + + scr(:,:,:,:) = 0d0 + + do l=1,nBas + do si=1,nBas + do la=1,nBas + do nu=1,nBas + do mu=1,nBas + scr(mu,nu,la,l) = scr(mu,nu,la,l) + ERI_AO_basis(mu,nu,la,si)*c(si,l) + enddo + enddo + enddo + enddo + enddo + + ERI_MO_basis(:,:,:,:) = 0d0 + + do l=1,nBas + do la=1,nBas + do nu=1,nBas + do i=1,nBas + do mu=1,nBas + ERI_MO_basis(i,nu,la,l) = ERI_MO_basis(i,nu,la,l) + c(mu,i)*scr(mu,nu,la,l) + enddo + enddo + enddo + enddo + enddo + + scr(:,:,:,:) = 0d0 + + do l=1,nBas + do k=1,nBas + do la=1,nBas + do nu=1,nBas + do i=1,nBas + scr(i,nu,k,l) = scr(i,nu,k,l) + ERI_MO_basis(i,nu,la,l)*c(la,k) + enddo + enddo + enddo + enddo + enddo + + ERI_MO_basis(:,:,:,:) = 0d0 + + do l=1,nBas + do k=1,nBas + do j=1,nBas + do i=1,nBas + do nu=1,nBas + ERI_MO_basis(i,j,k,l) = ERI_MO_basis(i,j,k,l) + c(nu,j)*scr(i,nu,k,l) + enddo + enddo + enddo + enddo + enddo + +end subroutine AOtoMO_integral_transform diff --git a/src/QuAcK/AOtoMO_oooa.f90 b/src/QuAcK/AOtoMO_oooa.f90 new file mode 100644 index 0000000..fc474e0 --- /dev/null +++ b/src/QuAcK/AOtoMO_oooa.f90 @@ -0,0 +1,85 @@ +subroutine AOtoMO_oooa(nBas,nO,nA,cO,cA,O,ooOoa) + +! AO to MO transformation of two-electron integrals for the block oooa +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO,nA + double precision,intent(in) :: cO(nBas,nO),cA(nBas,nA),O(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:),scr2(:,:,:,:) + integer :: mu,nu,la,si,i,j,k,x + +! Output variables + + double precision,intent(out) :: ooOoa(nO,nO,nO,nA) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas)) + + write(*,*) + write(*,'(A42)') '----------------------------------------' + write(*,'(A42)') ' AO to MO transformation for oooa block ' + write(*,'(A42)') '----------------------------------------' + write(*,*) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do x=1,nA + scr1(mu,nu,la,x) = scr1(mu,nu,la,x) + O(mu,nu,la,si)*cA(si,x) + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do i=1,nO + do x=1,nA + scr2(i,nu,la,x) = scr2(i,nu,la,x) + cO(mu,i)*scr1(mu,nu,la,x) + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do i=1,nO + do k=1,nO + do x=1,nA + scr1(i,nu,k,x) = scr1(i,nu,k,x) + scr2(i,nu,la,x)*cO(la,k) + enddo + enddo + enddo + enddo + enddo + + ooOoa = 0d0 + do nu=1,nBas + do i=1,nO + do j=1,nO + do k=1,nO + do x=1,nA + ooOoa(i,j,k,x) = ooOoa(i,j,k,x) + cO(nu,j)*scr1(i,nu,k,x) + enddo + enddo + enddo + enddo + enddo + + deallocate(scr1,scr2) + +end subroutine AOtoMO_oooa diff --git a/src/QuAcK/AOtoMO_oooo.f90 b/src/QuAcK/AOtoMO_oooo.f90 new file mode 100644 index 0000000..d9ebe47 --- /dev/null +++ b/src/QuAcK/AOtoMO_oooo.f90 @@ -0,0 +1,85 @@ +subroutine AOtoMO_oooo(nBas,nO,cO,O,ooOoo) + +! AO to MO transformation of two-electron integrals for the block oooo +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: cO(nBas,nO),O(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:),scr2(:,:,:,:) + integer :: mu,nu,la,si,i,j,k,l + +! Output variables + + double precision,intent(out) :: ooOoo(nO,nO,nO,nO) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas)) + + write(*,*) + write(*,'(A42)') '----------------------------------------' + write(*,'(A42)') ' AO to MO transformation for oooo block ' + write(*,'(A42)') '----------------------------------------' + write(*,*) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do l=1,nO + scr1(mu,nu,la,l) = scr1(mu,nu,la,l) + O(mu,nu,la,si)*cO(si,l) + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do i=1,nO + do l=1,nO + scr2(i,nu,la,l) = scr2(i,nu,la,l) + cO(mu,i)*scr1(mu,nu,la,l) + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do i=1,nO + do k=1,nO + do l=1,nO + scr1(i,nu,k,l) = scr1(i,nu,k,l) + scr2(i,nu,la,l)*cO(la,k) + enddo + enddo + enddo + enddo + enddo + + ooOoo = 0d0 + do nu=1,nBas + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + ooOoo(i,j,k,l) = ooOoo(i,j,k,l) + cO(nu,j)*scr1(i,nu,k,l) + enddo + enddo + enddo + enddo + enddo + + deallocate(scr1,scr2) + +end subroutine AOtoMO_oooo diff --git a/src/QuAcK/AOtoMO_oooooo.f90 b/src/QuAcK/AOtoMO_oooooo.f90 new file mode 100644 index 0000000..e8bba04 --- /dev/null +++ b/src/QuAcK/AOtoMO_oooooo.f90 @@ -0,0 +1,135 @@ +subroutine AOtoMO_oooooo(nBas,nO,cO,O,oooOooo) + +! AO to MO transformation of three-electron integrals for the block oooooo +! Semi-direct O(N^7) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: cO(nBas,nO),O(nBas,nBas,nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:,:,:),scr2(:,:,:,:,:,:) + integer :: mu,nu,la,si,ka,ta,i,j,k,l,m,n + +! Output variables + + double precision,intent(out) :: oooOooo(nO,nO,nO,nO,nO,nO) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas,nBas,nBas)) + + write(*,*) + write(*,'(A42)') '------------------------------------------' + write(*,'(A42)') ' AO to MO transformation for oooooo block ' + write(*,'(A42)') '------------------------------------------' + write(*,*) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do ka=1,nBas + do ta=1,nBas + do n=1,nO + scr1(mu,nu,la,si,ka,n) = scr1(mu,nu,la,si,ka,n) + O(mu,nu,la,si,ka,ta)*cO(ta,n) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do ka=1,nBas + do i=1,nO + do n=1,nO + scr2(i,nu,la,si,ka,n) = scr2(i,nu,la,si,ka,n) + cO(mu,i)*scr1(mu,nu,la,si,ka,n) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do ka=1,nBas + do i=1,nO + do m=1,nO + do n=1,nO + scr1(i,nu,la,si,m,n) = scr1(i,nu,la,si,m,n) + scr2(i,nu,la,si,m,n)*cO(ka,m) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do i=1,nO + do j=1,nO + do m=1,nO + do n=1,nO + scr2(i,j,la,si,m,n) = scr2(i,j,la,si,m,n) + cO(nu,j)*scr1(i,nu,la,si,m,n) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do la=1,nBas + do si=1,nBas + do i=1,nO + do j=1,nO + do l=1,nO + do m=1,nO + do n=1,nO + scr1(i,j,la,l,m,n) = scr1(i,j,la,l,m,n) + scr2(i,j,la,si,m,n)*cO(si,l) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + oooOooo = 0d0 + do si=1,nBas + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + do m=1,nO + do n=1,nO + oooOooo(i,j,k,l,m,n) = oooOooo(i,j,k,l,m,n) + cO(la,k)*scr1(i,j,la,k,m,n) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + deallocate(scr1,scr2) + +end subroutine AOtoMO_oooooo diff --git a/src/QuAcK/AOtoMO_oovv.f90 b/src/QuAcK/AOtoMO_oovv.f90 new file mode 100644 index 0000000..05365c1 --- /dev/null +++ b/src/QuAcK/AOtoMO_oovv.f90 @@ -0,0 +1,77 @@ +subroutine AOtoMO_oovv(nBas,nO,nV,cO,cV,O,ooOvv) + +! AO to MO transformation of two-electron integrals for the block oovv +! Semi-direct O(N^5) algorithm + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO,nV + double precision,intent(in) :: cO(nBas,nO),cV(nBas,nV),O(nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: scr1(:,:,:,:),scr2(:,:,:,:) + integer :: mu,nu,la,si,i,j,a,b + +! Output variables + + double precision,intent(out) :: ooOvv(nO,nO,nV,nV) + +! Memory allocation + allocate(scr1(nBas,nBas,nBas,nBas),scr2(nBas,nBas,nBas,nBas)) + + scr1 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + do b=1,nV + scr1(mu,nu,la,b) = scr1(mu,nu,la,b) + O(mu,nu,la,si)*cV(si,b) + enddo + enddo + enddo + enddo + enddo + + scr2 = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do i=1,nO + do b=1,nV + scr2(i,nu,la,b) = scr2(i,nu,la,b) + cO(mu,i)*scr1(mu,nu,la,b) + enddo + enddo + enddo + enddo + enddo + + scr1 = 0d0 + do nu=1,nBas + do la=1,nBas + do i=1,nO + do a=1,nV + do b=1,nV + scr1(i,nu,a,b) = scr1(i,nu,a,b) + scr2(i,nu,la,b)*cV(la,a) + enddo + enddo + enddo + enddo + enddo + + ooOvv = 0d0 + do nu=1,nBas + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + ooOvv(i,j,a,b) = ooOvv(i,j,a,b) + cO(nu,j)*scr1(i,nu,a,b) + enddo + enddo + enddo + enddo + enddo + +end subroutine AOtoMO_oovv diff --git a/src/QuAcK/AOtoMO_transform.f90 b/src/QuAcK/AOtoMO_transform.f90 new file mode 100644 index 0000000..7919084 --- /dev/null +++ b/src/QuAcK/AOtoMO_transform.f90 @@ -0,0 +1,18 @@ +subroutine AOtoMO_transform(nBas,c,A) + +! Perform AO to MO transformation of a matrix A for given coefficients c + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas) + +! Output variables + + double precision,intent(inout):: A(nBas,nBas) + + A = matmul(transpose(c),matmul(A,c)) + +end subroutine AOtoMO_transform diff --git a/src/QuAcK/Bethe_Salpeter_A_matrix.f90 b/src/QuAcK/Bethe_Salpeter_A_matrix.f90 new file mode 100644 index 0000000..26f02d7 --- /dev/null +++ b/src/QuAcK/Bethe_Salpeter_A_matrix.f90 @@ -0,0 +1,44 @@ +subroutine Bethe_Salpeter_A_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,A_lr) + +! Compute the extra term for Bethe-Salpeter equation for linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Omega(nS),rho(nBas,nBas,nS) + +! Local variables + + double precision :: chi + integer :: i,j,a,b,ia,jb,kc + +! Output variables + + double precision,intent(out) :: A_lr(nS,nS) + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + chi = 0d0 + do kc=1,nS + chi = chi + rho(i,j,kc)*rho(a,b,kc)/Omega(kc) + enddo + + A_lr(ia,jb) = A_lr(ia,jb) - ERI(i,a,j,b) + 4d0*chi + + enddo + enddo + enddo + enddo + +end subroutine Bethe_Salpeter_A_matrix diff --git a/src/QuAcK/Bethe_Salpeter_B_matrix.f90 b/src/QuAcK/Bethe_Salpeter_B_matrix.f90 new file mode 100644 index 0000000..903e974 --- /dev/null +++ b/src/QuAcK/Bethe_Salpeter_B_matrix.f90 @@ -0,0 +1,44 @@ +subroutine Bethe_Salpeter_B_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,B_lr) + +! Compute the extra term for Bethe-Salpeter equation for linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Omega(nS),rho(nBas,nBas,nS) + +! Local variables + + double precision :: chi + integer :: i,j,a,b,ia,jb,kc + +! Output variables + + double precision,intent(out) :: B_lr(nS,nS) + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + chi = 0d0 + do kc=1,nS + chi = chi + rho(i,b,kc)*rho(a,j,kc)/Omega(kc) + enddo + + B_lr(ia,jb) = B_lr(ia,jb) - ERI(i,a,b,j) + 4d0*chi + + enddo + enddo + enddo + enddo + +end subroutine Bethe_Salpeter_B_matrix diff --git a/src/QuAcK/CCD.f90 b/src/QuAcK/CCD.f90 new file mode 100644 index 0000000..9caf576 --- /dev/null +++ b/src/QuAcK/CCD.f90 @@ -0,0 +1,203 @@ +subroutine CCD(maxSCF,thresh,max_diis,nBas,nEl,ERI,ENuc,ERHF,eHF) + +! CCD module + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF + integer,intent(in) :: max_diis + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nEl + double precision,intent(in) :: ENuc,ERHF + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nBas2 + integer :: nO + integer :: nV + integer :: nSCF + double precision :: Conv + double precision :: EcMP2,EcMP3,EcMP4 + double precision :: ECCD,EcCCD + double precision,allocatable :: seHF(:) + double precision,allocatable :: sERI(:,:,:,:) + double precision,allocatable :: dbERI(:,:,:,:) + + double precision,allocatable :: eO(:) + double precision,allocatable :: eV(:) + double precision,allocatable :: delta_OOVV(:,:,:,:) + + double precision,allocatable :: OOOO(:,:,:,:) + double precision,allocatable :: OOVV(:,:,:,:) + double precision,allocatable :: OVOV(:,:,:,:) + double precision,allocatable :: VVVV(:,:,:,:) + + double precision,allocatable :: X1(:,:,:,:) + double precision,allocatable :: X2(:,:) + double precision,allocatable :: X3(:,:) + double precision,allocatable :: X4(:,:,:,:) + + double precision,allocatable :: u(:,:,:,:) + double precision,allocatable :: v(:,:,:,:) + + double precision,allocatable :: r2(:,:,:,:) + double precision,allocatable :: t2(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'**************************************' + write(*,*)'| CCD calculation |' + write(*,*)'**************************************' + write(*,*) + +! Spatial to spin orbitals + + nBas2 = 2*nBas + + allocate(seHF(nBas2),sERI(nBas2,nBas2,nBas2,nBas2)) + + call spatial_to_spin_MO_energy(nBas,eHF,nBas2,seHF) + call spatial_to_spin_ERI(nBas,ERI,nBas2,sERI) + +! Antysymmetrize ERIs + + allocate(dbERI(nBas2,nBas2,nBas2,nBas2)) + + call antisymmetrize_ERI(2,nBas2,sERI,dbERI) + + deallocate(sERI) + +! Define occupied and virtual spaces + + nO = nEl + nV = nBas2 - nO + +! Form energy denominator + + allocate(eO(nO),eV(nV)) + allocate(delta_OOVV(nO,nO,nV,nV)) + + eO(:) = seHF(1:nO) + eV(:) = seHF(nO+1:nBas2) + + call form_delta_OOVV(nO,nV,eO,eV,delta_OOVV) + + deallocate(seHF) + +! Create integral batches + + allocate(OOOO(nO,nO,nO,nO),OOVV(nO,nO,nV,nV),OVOV(nO,nV,nO,nV),VVVV(nV,nV,nV,nV)) + + OOOO(:,:,:,:) = dbERI( 1:nO , 1:nO , 1:nO , 1:nO ) + OOVV(:,:,:,:) = dbERI( 1:nO , 1:nO ,nO+1:nBas2,nO+1:nBas2) + OVOV(:,:,:,:) = dbERI( 1:nO ,nO+1:nBas2, 1:nO ,nO+1:nBas2) + VVVV(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2,nO+1:nBas2,nO+1:nBas2) + + deallocate(dbERI) + +! MP2 guess amplitudes + + allocate(t2(nO,nO,nV,nV)) + + t2(:,:,:,:) = -OOVV(:,:,:,:)/delta_OOVV(:,:,:,:) + + EcMP2 = 0.25d0*dot_product(pack(OOVV,.true.),pack(t2,.true.)) + EcMP4 = 0d0 + +! Initialization + + allocate(r2(nO,nO,nV,nV),u(nO,nO,nV,nV),v(nO,nO,nV,nV)) + allocate(X1(nO,nO,nO,nO),X2(nV,nV),X3(nO,nO),X4(nO,nO,nV,nV)) + + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| CCD calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','E(CCD)','|','Ec(CCD)','|','Conv','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Form linear array + + call form_u(nO,nV,OOOO,VVVV,OVOV,t2,u) + +! Form interemediate arrays + + call form_X(nO,nV,OOVV,t2,X1,X2,X3,X4) + +! Form quadratic array + + call form_v(nO,nV,X1,X2,X3,X4,t2,v) + +! Compute residual + + r2(:,:,:,:) = OOVV(:,:,:,:) + delta_OOVV(:,:,:,:)*t2(:,:,:,:) + u(:,:,:,:) + v(:,:,:,:) + +! Check convergence + + Conv = maxval(abs(r2(:,:,:,:))) + +! Update amplitudes + + t2(:,:,:,:) = t2(:,:,:,:) - r2(:,:,:,:)/delta_OOVV(:,:,:,:) + +! Compute correlation energy + + EcCCD = 0.25d0*dot_product(pack(OOVV,.true.),pack(t2,.true.)) + + if(nSCF == 1) EcMP3 = 0.25d0*dot_product(pack(OOVV,.true.),pack(t2 + v/delta_OOVV,.true.)) + +! Dump results + + ECCD = ERHF + EcCCD + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ECCD+ENuc,'|',EcCCD,'|',Conv,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Moller-Plesset energies + + write(*,*) + write(*,'(1X,A15,1X,F10.6)') 'Ec(MP2) = ',EcMP2 + write(*,'(1X,A15,1X,F10.6)') 'Ec(MP3) = ',EcMP3 + write(*,'(1X,A15,1X,F10.6)') 'Ec(MP4-SDQ) = ',EcMP4 + write(*,*) + +end subroutine CCD diff --git a/src/QuAcK/CCSD.f90 b/src/QuAcK/CCSD.f90 new file mode 100644 index 0000000..124b2d9 --- /dev/null +++ b/src/QuAcK/CCSD.f90 @@ -0,0 +1,259 @@ +subroutine CCSD(maxSCF,thresh,max_diis,doCCSDT,nBas,nEl,ERI,ENuc,ERHF,eHF) + +! CCSD module + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF + integer,intent(in) :: max_diis + double precision,intent(in) :: thresh + + logical,intent(in) :: doCCSDT + integer,intent(in) :: nBas,nEl + double precision,intent(in) :: ENuc,ERHF + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: start_CCSDT,end_CCSDT,t_CCSDT + integer :: nBas2 + integer :: nO + integer :: nV + integer :: nSCF + double precision :: Conv + double precision :: EcMP2 + double precision :: ECCSD,EcCCSD + double precision :: EcCCT + + double precision,allocatable :: seHF(:) + double precision,allocatable :: sERI(:,:,:,:) + double precision,allocatable :: dbERI(:,:,:,:) + double precision,allocatable :: delta_OV(:,:) + double precision,allocatable :: delta_OOVV(:,:,:,:) + + double precision,allocatable :: OOOO(:,:,:,:) + double precision,allocatable :: OOOV(:,:,:,:) + double precision,allocatable :: OVOO(:,:,:,:) + double precision,allocatable :: VOOO(:,:,:,:) + double precision,allocatable :: OOVV(:,:,:,:) + double precision,allocatable :: OVVO(:,:,:,:) + double precision,allocatable :: OVVV(:,:,:,:) + double precision,allocatable :: VOVV(:,:,:,:) + double precision,allocatable :: VVVO(:,:,:,:) + double precision,allocatable :: VVVV(:,:,:,:) + + double precision,allocatable :: eO(:) + double precision,allocatable :: eV(:) + double precision,allocatable :: hvv(:,:) + double precision,allocatable :: hoo(:,:) + double precision,allocatable :: hvo(:,:) + double precision,allocatable :: gvv(:,:) + double precision,allocatable :: goo(:,:) + double precision,allocatable :: aoooo(:,:,:,:) + double precision,allocatable :: bvvvv(:,:,:,:) + double precision,allocatable :: hovvo(:,:,:,:) + + double precision,allocatable :: r1(:,:) + double precision,allocatable :: r2(:,:,:,:) + + double precision,allocatable :: t1(:,:) + double precision,allocatable :: t2(:,:,:,:) + double precision,allocatable :: tau(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'**************************************' + write(*,*)'| CCSD calculation |' + write(*,*)'**************************************' + write(*,*) + +! Spatial to spin orbitals + + nBas2 = 2*nBas + + allocate(seHF(nBas2),sERI(nBas2,nBas2,nBas2,nBas2)) + + call spatial_to_spin_MO_energy(nBas,eHF,nBas2,seHF) + call spatial_to_spin_ERI(nBas,ERI,nBas2,sERI) + +! Antysymmetrize ERIs + + allocate(dbERI(nBas2,nBas2,nBas2,nBas2)) + + call antisymmetrize_ERI(2,nBas2,sERI,dbERI) + + deallocate(sERI) + +! Define occupied and virtual spaces + + nO = nEl + nV = nBas2 - nO + +! Form energy denominator + + allocate(eO(nO),eV(nV)) + allocate(delta_OV(nO,nV),delta_OOVV(nO,nO,nV,nV)) + + eO(:) = seHF(1:nO) + eV(:) = seHF(nO+1:nBas2) + + call form_delta_OV(nO,nV,eO,eV,delta_OV) + call form_delta_OOVV(nO,nV,eO,eV,delta_OOVV) + + deallocate(seHF) + +! Create integral batches + + allocate(OOOO(nO,nO,nO,nO), & + OOOV(nO,nO,nO,nV),OVOO(nO,nV,nO,nO),VOOO(nV,nO,nO,nO), & + OOVV(nO,nO,nV,nV),OVVO(nO,nV,nV,nO), & + OVVV(nO,nV,nV,nV),VOVV(nV,nO,nV,nV),VVVO(nV,nV,nV,nO), & + VVVV(nV,nV,nV,nV)) + + OOOO(:,:,:,:) = dbERI( 1:nO , 1:nO , 1:nO , 1:nO ) + OOOV(:,:,:,:) = dbERI( 1:nO , 1:nO , 1:nO ,nO+1:nBas2) + OVOO(:,:,:,:) = dbERI( 1:nO ,nO+1:nBas2, 1:nO , 1:nO ) + VOOO(:,:,:,:) = dbERI(nO+1:nBas2, 1:nO , 1:nO , 1:nO ) + OOVV(:,:,:,:) = dbERI( 1:nO , 1:nO ,nO+1:nBas2,nO+1:nBas2) + OVVO(:,:,:,:) = dbERI( 1:nO ,nO+1:nBas2,nO+1:nBas2, 1:nO ) + OVVV(:,:,:,:) = dbERI( 1:nO ,nO+1:nBas2,nO+1:nBas2,nO+1:nBas2) + VOVV(:,:,:,:) = dbERI(nO+1:nBas2, 1:nO ,nO+1:nBas2,nO+1:nBas2) + VVVO(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2,nO+1:nBas2, 1:nO ) + VVVV(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2,nO+1:nBas2,nO+1:nBas2) + + deallocate(dbERI) + +! MP2 guess amplitudes + + allocate(t1(nO,nV),t2(nO,nO,nV,nV),tau(nO,nO,nV,nV)) + + t1(:,:) = 0d0 + t2(:,:,:,:) = -OOVV(:,:,:,:)/delta_OOVV(:,:,:,:) + call form_tau(nO,nV,t1,t2,tau) + + EcMP2 = 0.5d0*dot_product(pack(OOVV,.true.),pack(tau,.true.)) + write(*,'(1X,A10,1X,F10.6)') 'Ec(MP2) = ',EcMP2 + +! Initialization + + allocate(hvv(nV,nV),hoo(nO,nO),hvo(nV,nO), & + gvv(nV,nV),goo(nO,nO), & + aoooo(nO,nO,nO,nO),bvvvv(nV,nV,nV,nV),hovvo(nO,nV,nV,nO), & + r1(nO,nV),r2(nO,nO,nV,nV)) + + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| CCSD calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','E(CCSD)','|','Ec(CCSD)','|','Conv','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Scuseria Eqs. (5), (6) and (7) + + call form_h(nO,nV,eO,eV,OOVV,t1,tau,hvv,hoo,hvo) + +! Scuseria Eqs. (9), (10), (11), (12) and (13) + + call form_g(nO,nV,hvv,hoo,VOVV,OOOV,t1,gvv,goo) + + call form_abh(nO,nV,OOOO,OVOO,OOVV,VVVV,VOVV,OVVO,OVVV,t1,tau,aoooo,bvvvv,hovvo) + +! Compute residuals + + call form_r1(nO,nV,OVVO,OVVV,OOOV,hvv,hoo,hvo,t1,t2,tau,r1) + + call form_r2(nO,nV,OOVV,OVOO,OVVV,OVVO,gvv,goo,aoooo,bvvvv,hovvo,t1,t2,tau,r2) + +! Check convergence + + Conv = max(maxval(abs(r1(:,:))),maxval(abs(r2(:,:,:,:)))) + +! Update + + t1(:,:) = t1(:,:) - r1(:,:) /delta_OV (:,:) + t2(:,:,:,:) = t2(:,:,:,:) - r2(:,:,:,:)/delta_OOVV(:,:,:,:) + + call form_tau(nO,nV,t1,t2,tau) + +! Compute correlation energy + + EcCCSD = 0.5d0*dot_product(pack(OOVV,.true.),pack(tau,.true.)) + +! Dump results + + ECCSD = ERHF + EcCCSD + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ECCSD+ENuc,'|',EcCCSD,'|',Conv,'|' + + end do + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + end if + +! Deallocate memory + + deallocate(hvv,hoo,hvo, & + delta_OV,delta_OOVV, & + gvv,goo, & + aoooo,bvvvv,hovvo, & + tau, & + r1,r2) + +!------------------------------------------------------------------------ +! (T) correction +!------------------------------------------------------------------------ + if(doCCSDT) then + + call cpu_time(start_CCSDT) + call CCSDT(nO,nV,eO,eV,OOVV,VVVO,VOOO,t1,t2,EcCCT) + call cpu_time(end_CCSDT) + + t_CCSDT = end_CCSDT - start_CCSDT + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for (T) = ',t_CCSDT,' seconds' + write(*,*) + + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)' CCSDT(T) energy ' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A20,1X,F15.10)')' E(CCSD(T)) = ',ECCSD + EcCCT + write(*,'(1X,A20,1X,F10.6)') ' Ec(CCSD(T)) = ',EcCCSD + EcCCT + write(*,*)'----------------------------------------------------' + write(*,*) + + end if + +end subroutine CCSD diff --git a/src/QuAcK/CCSDT.f90 b/src/QuAcK/CCSDT.f90 new file mode 100644 index 0000000..2af9b3b --- /dev/null +++ b/src/QuAcK/CCSDT.f90 @@ -0,0 +1,45 @@ +subroutine CCSDT(nO,nV,eO,eV,OOVV,VVVO,VOOO,t1,t2,EcCCT) + +! Compute the (T) correction of the CCSD(T) energy + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: eO(nO) + double precision,intent(in) :: eV(nV) + + double precision,intent(in) :: OOVV(nO,nO,nV,nV) + double precision,intent(in) :: VVVO(nV,nV,nV,nO) + double precision,intent(in) :: VOOO(nV,nO,nO,nO) + + double precision,intent(in) :: t1(nO,nV) + double precision,intent(in) :: t2(nO,nO,nV,nV) + +! Local variables + + double precision,allocatable :: delta_OOOVVV(:,:,:,:,:,:) + double precision,allocatable :: ub(:,:,:,:,:,:) + double precision,allocatable :: ubb(:,:,:,:,:,:) + +! Output variables + + double precision,intent(out) :: EcCCT + +! Memory allocation + + allocate(delta_OOOVVV(nO,nO,nO,nV,nV,nV),ub(nO,nO,nO,nV,nV,nV),ubb(nO,nO,nO,nV,nV,nV)) + +! Form CCSD(T) quantities + + call form_delta_OOOVVV(nO,nV,eO,eV,delta_OOOVVV) + + call form_ub(nO,nV,OOVV,t1,ub) + + call form_ubb(nO,nV,VVVO,VOOO,t2,ubb) + + call form_T(nO,nV,delta_OOOVVV,ub,ubb,EcCCT) + +end subroutine CCSDT diff --git a/src/QuAcK/CIS.f90 b/src/QuAcK/CIS.f90 new file mode 100644 index 0000000..66142f5 --- /dev/null +++ b/src/QuAcK/CIS.f90 @@ -0,0 +1,85 @@ +subroutine CIS(singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ERI,eHF) + +! Perform configuration interaction single calculation` + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),eHF(nBas) + +! Local variables + + logical :: dRPA + logical :: dump_matrix = .false. + logical :: dump_trans = .false. + integer :: ispin + double precision,allocatable :: A(:,:),Omega(:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Configuration Interaction Singles |' + write(*,*)'************************************************' + write(*,*) + +! Switch on exchange for CIS + + dRPA = .false. + +! Memory allocation + + allocate(A(nS,nS),Omega(nS)) + +! Compute CIS matrix + + if(singlet_manifold) then + + ispin = 1 + call linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,eHF,ERI,A) + + if(dump_matrix) then + print*,'CIS matrix (singlet state)' + call matout(nS,nS,A) + write(*,*) + endif + + call diagonalize_matrix(nS,A,Omega) + call print_excitation('CIS ',ispin,nS,Omega) + + if(dump_trans) then + print*,'Singlet CIS transition vectors' + call matout(nS,nS,A) + write(*,*) + endif + + endif + + if(triplet_manifold) then + + ispin = 2 + call linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,eHF,ERI,A) + + if(dump_matrix) then + print*,'CIS matrix (triplet state)' + call matout(nS,nS,A) + write(*,*) + endif + + call diagonalize_matrix(nS,A,Omega) + call print_excitation('CIS ',ispin,nS,Omega) + + if(dump_trans) then + print*,'Triplet CIS transition vectors' + call matout(nS,nS,A) + write(*,*) + endif + + endif + +end subroutine CIS diff --git a/src/QuAcK/Coulomb_matrix_AO_basis.f90 b/src/QuAcK/Coulomb_matrix_AO_basis.f90 new file mode 100644 index 0000000..eaf6a3e --- /dev/null +++ b/src/QuAcK/Coulomb_matrix_AO_basis.f90 @@ -0,0 +1,34 @@ +subroutine Coulomb_matrix_AO_basis(nBas,P,G,J) + +! Compute Coulomb matrix in the AO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: J(nBas,nBas) + + J = 0d0 + do si=1,nBas + do nu=1,nBas + do la=1,nBas + do mu=1,nBas + J(mu,nu) = J(mu,nu) + P(la,si)*G(mu,la,nu,si) + enddo + enddo + enddo + enddo + + +end subroutine Coulomb_matrix_AO_basis diff --git a/src/QuAcK/Coulomb_matrix_MO_basis.f90 b/src/QuAcK/Coulomb_matrix_MO_basis.f90 new file mode 100644 index 0000000..1fea11e --- /dev/null +++ b/src/QuAcK/Coulomb_matrix_MO_basis.f90 @@ -0,0 +1,26 @@ +subroutine Coulomb_matrix_MO_basis(nBas,c,P,G,J) + +! Compute Coulomb matrix in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: J(nBas,nBas) + +! Compute Hartree Hamiltonian in the AO basis + + call Coulomb_matrix_AO_basis(nBas,P,G,J) + +! Transform Coulomb matrix in the MO basis + + J = matmul(transpose(c),matmul(J,c)) + +end subroutine Coulomb_matrix_MO_basis diff --git a/src/QuAcK/DIIS_extrapolation.f90 b/src/QuAcK/DIIS_extrapolation.f90 new file mode 100644 index 0000000..4fb89dc --- /dev/null +++ b/src/QuAcK/DIIS_extrapolation.f90 @@ -0,0 +1,61 @@ +subroutine DIIS_extrapolation(n_err,n_e,n_diis,error,e,error_in,e_inout) + +! Perform DIIS extrapolation + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: n_err,n_e + double precision,intent(in) :: error_in(n_err),error(n_err,n_diis),e(n_e,n_diis) + +! Local variables + + double precision :: rcond + double precision,allocatable :: A(:,:),b(:),w(:) + +! Output variables + + integer,intent(inout) :: n_diis + double precision,intent(inout):: e_inout(n_e) + +! Memory allocaiton + + allocate(A(n_diis+1,n_diis+1),b(n_diis+1),w(n_diis+1)) + +! Update DIIS "history" + + call prepend(n_err,n_diis,error,error_in) + call prepend(n_e,n_diis,e,e_inout) + +! Build A matrix + + A(1:n_diis,1:n_diis) = matmul(transpose(error),error) + + A(1:n_diis,n_diis+1) = -1d0 + A(n_diis+1,1:n_diis) = -1d0 + A(n_diis+1,n_diis+1) = +0d0 + +! Build x matrix + + b(1:n_diis) = +0d0 + b(n_diis+1) = -1d0 + +! Solve linear system + + call linear_solve(n_diis+1,A,b,w,rcond) + +! Extrapolate + + if(rcond > 1d-14) then + + e_inout(:) = matmul(w(1:n_diis),transpose(e(:,1:n_diis))) + + else + + n_diis = 0 + + endif +end subroutine DIIS_extrapolation diff --git a/src/QuAcK/G0W0.f90 b/src/QuAcK/G0W0.f90 new file mode 100644 index 0000000..aa122b9 --- /dev/null +++ b/src/QuAcK/G0W0.f90 @@ -0,0 +1,132 @@ +subroutine G0W0(COHSEX,SOSEX,BSE,TDA,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,P,ERI_AO_basis,ERI_MO_basis,cHF,eHF,eG0W0) + +! Perform G0W0 calculation + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: COHSEX,SOSEX,BSE,TDA,singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ENuc,ERHF + double precision,intent(in) :: cHF(nBas,nBas),eHF(nBas),Hc(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas),ERI_MO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA + integer :: ispin + double precision :: EcRPA,EcGM + double precision,allocatable :: H(:,:),SigmaC(:),Z(:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:),rhox(:,:,:,:) + +! Output variables + + double precision :: eG0W0(nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| One-shot G0W0 calculation |' + write(*,*)'************************************************' + write(*,*) + +! SOSEX correction + + if(SOSEX) write(*,*) 'SOSEX correction activated!' + write(*,*) + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Spin manifold + + ispin = 1 + +! Memory allocation + + allocate(H(nBas,nBas),SigmaC(nBas),Z(nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin), & + rho(nBas,nBas,nS,nspin),rhox(nBas,nBas,nS,nspin)) + +! Compute Hartree Hamiltonian in the MO basis + + call Hartree_matrix_MO_basis(nBas,cHF,P,Hc,ERI_AO_basis,H) + +! Compute linear response + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eHF,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + +! Compute correlation part of the self-energy + + call excitation_density_from_MO(nBas,nC,nO,nR,nS,ERI_MO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + if(SOSEX) call excitation_density_SOSEX_from_MO(nBas,nC,nO,nR,nS,ERI_MO_basis,XpY(:,:,ispin),rhox(:,:,:,ispin)) + + call self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eHF, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),EcGM,SigmaC) + +! COHSEX static approximation + + if(COHSEX) then + + Z(:) = 1d0 + + else + + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + endif + +! Solve the quasi-particle equation + + eG0W0(:) = eHF(:) + Z(:)*SigmaC(:) + +! Dump results + + call print_excitation('RPA ',ispin,nS,Omega(:,ispin)) + call print_G0W0(nBas,nO,eHF,ENuc,ERHF,SigmaC,Z,eG0W0,EcRPA,EcGM) + +! Plot stuff + + call plot_GW(nBas,nC,nO,nV,nR,nS,eHF,eG0W0,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin)) + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eG0W0,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eHF,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eG0W0,ERI_MO_basis, & + rho(:,:,:,1),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + + +end subroutine G0W0 diff --git a/src/QuAcK/GF2.f90 b/src/QuAcK/GF2.f90 new file mode 100644 index 0000000..6eab83c --- /dev/null +++ b/src/QuAcK/GF2.f90 @@ -0,0 +1,131 @@ +subroutine GF2(maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,V,e0) + +! Perform second-order Green function calculation in diagonal approximation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e0(nBas),V(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nSCF,n_diis + double precision :: eps,Conv + double precision,allocatable :: eGF2(:),eOld(:),Bpp(:,:,:),error_diis(:,:),e_diis(:,:) + + integer :: i,j,a,b,p,q + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Second-order Green function calculation |' + write(*,*)'************************************************' + write(*,*) + +! Memory allocation + + allocate(Bpp(nBas,nBas,2),eGF2(nBas),eOld(nBas), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +! Initialization + + Conv = 1d0 + nSCF = 0 + n_diis = 0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGF2(:) = e0(:) + eOld(:) = e0(:) + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Frequency-dependent second-order contribution + + Bpp(:,:,:) = 0d0 + + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF2(p) + e0(a) - e0(i) - e0(j) + + Bpp(p,q,1) = Bpp(p,q,1) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(q,a,i,j)/eps + + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF2(p) + e0(i) - e0(a) - e0(b) + + Bpp(p,q,2) = Bpp(p,q,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(q,i,a,b)/eps + + enddo + enddo + enddo + enddo + enddo + + print*,'Sig2 in GF2' + call matout(nBas,nBas,Bpp(:,:,1) + Bpp(:,:,2)) + +! eGF2(:) = e0(:) & +! + Bpp(:,1) + Bpp(:,2) + + Conv = maxval(abs(eGF2 - eOld)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGF2-eOld,eGF2) + + eOld = eGF2 + + ! Print results + + call print_GF2(nBas,nO,nSCF,Conv,e0,eGF2) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine GF2 diff --git a/src/QuAcK/GF2_diag.f90 b/src/QuAcK/GF2_diag.f90 new file mode 100644 index 0000000..219a38c --- /dev/null +++ b/src/QuAcK/GF2_diag.f90 @@ -0,0 +1,124 @@ +subroutine GF2_diag(maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,V,e0) + +! Perform second-order Green function calculation in diagonal approximation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + double precision,intent(in) :: thresh + integer,intent(in) :: max_diis + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e0(nBas),V(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nSCF,n_diis + double precision :: eps,Conv + double precision,allocatable :: eGF2(:),eOld(:),Bpp(:,:),error_diis(:,:),e_diis(:,:) + + integer :: i,j,a,b,p + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Second-order Green function calculation |' + write(*,*)'************************************************' + write(*,*) + +! Memory allocation + + allocate(Bpp(nBas,2),eGF2(nBas),eOld(nBas), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +! Initialization + + Conv = 1d0 + nSCF = 0 + n_diis = 0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGF2(:) = e0(:) + eOld(:) = e0(:) + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Frequency-dependent second-order contribution + + Bpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF2(p) + e0(a) - e0(i) - e0(j) + + Bpp(p,1) = Bpp(p,1) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(p,a,i,j)/eps + + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF2(p) + e0(i) - e0(a) - e0(b) + + Bpp(p,2) = Bpp(p,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(p,i,a,b)/eps + + enddo + enddo + enddo + enddo + + eGF2(:) = e0(:) & + + Bpp(:,1) + Bpp(:,2) + + Conv = maxval(abs(eGF2 - eOld)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGF2-eOld,eGF2) + + eOld = eGF2 + + ! Print results + + call print_GF2(nBas,nO,nSCF,Conv,e0,eGF2) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine GF2_diag diff --git a/src/QuAcK/GF3_diag.f90 b/src/QuAcK/GF3_diag.f90 new file mode 100644 index 0000000..b6fbfd6 --- /dev/null +++ b/src/QuAcK/GF3_diag.f90 @@ -0,0 +1,488 @@ + subroutine GF3_diag(maxSCF,thresh,max_diis,renormalization,nBas,nC,nO,nV,nR,V,e0) + +! Perform third-order Green function calculation in diagonal approximation + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: thresh + integer,intent(in) :: maxSCF,max_diis,renormalization + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e0(nBas),V(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: nSCF,n_diis + double precision :: eps,eps1,eps2,Conv + double precision,allocatable :: Sig2(:),SigInf(:),Sig3(:),eGF3(:),eOld(:) + double precision,allocatable :: App(:,:),Bpp(:,:),Cpp(:,:),Dpp(:,:) + double precision,allocatable :: Z(:),X2h1p(:),X1h2p(:),Sig2h1p(:),Sig1h2p(:) + double precision,allocatable :: error_diis(:,:),e_diis(:,:) + + integer :: i,j,k,l,a,b,c,d,p + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Third-order Green function calculation |' + write(*,*)'************************************************' + write(*,*) + +! Memory allocation + + allocate(eGF3(nBas),eOld(nBas), & + Sig2(nBas),SigInf(nBas),Sig3(nBas), & + App(nBas,6),Bpp(nBas,2),Cpp(nBas,6),Dpp(nBas,6), & + Z(nBas),X2h1p(nBas),X1h2p(nBas),Sig2h1p(nBas),Sig1h2p(nBas), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +!------------------------------------------------------------------------ +! Compute third-order frequency-independent contribution +!------------------------------------------------------------------------ + + App(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(k) + e0(i) - e0(a) - e0(b) + + App(p,1) = App(p,1) & + - (2d0*V(p,k,p,j) - V(p,k,j,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(a,b,k,i)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(j) + e0(i) - e0(a) - e0(c) + + App(p,2) = App(p,2) & + + (2d0*V(p,c,p,b) - V(p,c,b,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(j,i,c,a)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(j) - e0(c) + + App(p,3) = App(p,3) & + + (2d0*V(p,c,p,j) - V(p,c,j,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(a,b,c,i)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + App(:,4) = App(:,3) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = e0(j) + e0(i) - e0(a) - e0(b) + eps2 = e0(k) - e0(b) + + App(p,5) = App(p,5) & + - (2d0*V(p,b,p,k) - V(p,b,k,p))*(2d0*V(j,i,a,b) - V(j,i,b,a))*V(i,j,k,a)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + App(:,6) = App(:,5) + +! Frequency-independent part of the third-order self-energy + + SigInf(:) = App(:,1) + App(:,2) + App(:,3) + App(:,4) + App(:,5) + App(:,6) + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + nSCF = 0 + n_diis = 0 + Conv = 1d0 + Sig2(:) = 0d0 + Sig3(:) = 0d0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGF3(:) = e0(:) + eOld(:) = e0(:) + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Frequency-dependent second-order contribution + + Bpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF3(p) + e0(a) - e0(i) - e0(j) + + Bpp(p,1) = Bpp(p,1) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(p,a,i,j)/eps + + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF3(p) + e0(i) - e0(a) - e0(b) + + Bpp(p,2) = Bpp(p,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(p,i,a,b)/eps + + enddo + enddo + enddo + enddo + + ! Total second-order Green function + + Sig2(:) = Bpp(:,1) + Bpp(:,2) + + ! Frequency-dependent third-order contribution: "C" terms + + Cpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + do d=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(b) + eps2 = eGF3(p) + e0(i) - e0(c) - e0(d) + + Cpp(p,1) = Cpp(p,1) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(a,b,c,d)*V(p,i,c,d)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(b) + eps2 = e0(j) + e0(k) - e0(a) - e0(b) + + Cpp(p,2) = Cpp(p,2) & + + (2d0*V(p,i,a,b) - V(p,i,b,a))*V(a,b,j,k)*V(p,i,j,k)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + Cpp(:,3) = Cpp(:,2) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(i) - e0(j) + eps2 = e0(i) + e0(j) - e0(b) - e0(c) + + Cpp(p,4) = Cpp(p,4) & + + (2d0*V(p,a,i,j) - V(p,a,j,i))*V(i,j,b,c)*V(p,a,b,c)/(eps1*eps2) + enddo + enddo + enddo + enddo + enddo + enddo + + Cpp(:,5) = Cpp(:,4) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do l=nC+1,nO + do a=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(i) - e0(j) + eps2 = eGF3(p) + e0(a) - e0(k) - e0(l) + + Cpp(p,6) = Cpp(p,6) & + - (2d0*V(p,a,k,l) - V(p,a,l,k))*V(k,l,i,j)*V(p,a,i,j)/(eps1*eps2) + enddo + enddo + enddo + enddo + enddo + enddo + + ! Frequency-dependent third-order contribution: "D" terms + + Dpp(:,:) = 0d0 + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(b) + eps2 = eGF3(p) + e0(j) - e0(b) - e0(c) + + Dpp(p,1) = Dpp(p,1) & + + V(p,i,a,b)*(V(a,j,i,c)*( V(p,j,c,b) - 2d0*V(p,j,b,c)) & + + V(a,j,c,i)*( V(p,j,b,c) - 2d0*V(p,j,c,b)))/(eps1*eps2) + + Dpp(p,1) = Dpp(p,1) & + + V(p,i,b,a)*(V(a,j,i,c)*(4d0*V(p,j,b,c) - 2d0*V(p,j,c,b)) & + + V(a,j,c,i)*( V(p,j,c,b) - 2d0*V(p,j,b,c)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do c=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(i) - e0(a) - e0(c) + eps2 = e0(i) + e0(j) - e0(a) - e0(b) + + Dpp(p,2) = Dpp(p,2) & + + V(p,i,c,a)*(V(a,b,i,j)*(4d0*V(p,b,c,j) - 2d0*V(p,b,j,c)) & + + V(a,b,j,i)*( V(p,b,j,c) - 2d0*V(p,b,c,j)))/(eps1*eps2) + + Dpp(p,2) = Dpp(p,2) & + + V(p,i,a,c)*(V(a,b,i,j)*( V(p,b,j,c) - 2d0*V(p,b,c,j)) & + + V(a,b,j,i)*( V(p,b,c,j) - 2d0*V(p,b,j,c)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + Dpp(:,3) = Dpp(:,2) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(j) - e0(k) + eps2 = e0(i) + e0(j) - e0(a) - e0(b) + + Dpp(p,4) = Dpp(p,4) & + + V(p,a,k,j)*(V(j,i,a,b)*(4d0*V(p,i,k,b) - 2d0*V(p,i,b,k)) & + + V(j,i,b,a)*( V(p,i,b,k) - 2d0*V(p,i,k,b)))/(eps1*eps2) + + Dpp(p,4) = Dpp(p,4) & + + V(p,a,j,k)*(V(j,i,a,b)*( V(p,i,b,k) - 2d0*V(p,i,k,b)) & + + V(j,i,b,a)*( V(p,i,k,b) - 2d0*V(p,i,b,k)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + Dpp(:,5) = Dpp(:,4) + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do k=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps1 = eGF3(p) + e0(a) - e0(i) - e0(k) + eps2 = eGF3(p) + e0(b) - e0(j) - e0(k) + + Dpp(p,6) = Dpp(p,6) & + - V(p,a,k,i)*(V(i,b,a,j)*(4d0*V(p,b,k,j) - 2d0*V(p,b,j,k)) & + + V(i,b,j,a)*( V(p,b,j,k) - 2d0*V(p,b,k,j)))/(eps1*eps2) + + Dpp(p,6) = Dpp(p,6) & + - V(p,a,i,k)*(V(i,b,a,j)*( V(p,b,j,k) - 2d0*V(p,b,k,j)) & + + V(i,b,j,a)*( V(p,b,k,j) - 2d0*V(p,b,j,k)))/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + +! Compute renormalization factor (if required) + + Z(:) = 1d0 + + if(renormalization == 0) then + + Sig3(:) = SigInf(:) & + + Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) + Cpp(:,6) & + + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + + elseif(renormalization == 1) then + + Sig3(:) = SigInf(:) & + + Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) + Cpp(:,6) & + + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + + Z(:) = Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) & + + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + + Z(nC+1:nBas-nR) = Z(nC+1:nBas-nR)/Sig2(nC+1:nBas-nR) + Z(:) = 1d0/(1d0 - Z(:)) + + Sig3(:) = Z(:)*Sig3(:) + + elseif(renormalization == 2) then + + Sig2h1p(:) = Cpp(:,4) + Cpp(:,5) + Cpp(:,6) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + Sig1h2p(:) = Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + + X2h1p(:) = Cpp(:,4) + Cpp(:,5) + Dpp(:,4) + Dpp(:,5) + X1h2p(:) = Cpp(:,2) + Cpp(:,3) + Dpp(:,2) + Dpp(:,3) + + X2h1p(nC+1:nBas-nR) = X2h1p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,1) + X1h2p(nC+1:nBas-nR) = X1h2p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,2) + + Sig3(:) = SigInf(:) + & + + 1d0/(1d0 - X2h1p(:))*Sig2h1p(:) & + + 1d0/(1d0 - X1h2p(:))*Sig1h2p(:) + + elseif(renormalization == 3) then + + Sig3(:) = SigInf(:) & + + Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Cpp(:,4) + Cpp(:,5) + Cpp(:,6) & + + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + + Sig2h1p(:) = Cpp(:,4) + Cpp(:,5) + Cpp(:,6) + Dpp(:,4) + Dpp(:,5) + Dpp(:,6) + Sig1h2p(:) = Cpp(:,1) + Cpp(:,2) + Cpp(:,3) + Dpp(:,1) + Dpp(:,2) + Dpp(:,3) + + X2h1p(:) = Cpp(:,4) + Cpp(:,5) + Dpp(:,4) + Dpp(:,5) + X1h2p(:) = Cpp(:,2) + Cpp(:,3) + Dpp(:,2) + Dpp(:,3) + + X2h1p(nC+1:nBas-nR) = X2h1p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,1) + X1h2p(nC+1:nBas-nR) = X1h2p(nC+1:nBas-nR)/Bpp(nC+1:nBas-nR,2) + + Z(:) = X2h1p(:)*Sig2h1p(:) + X1h2p(:)*Sig1h2p(:) + Z(nC+1:nBas-nR) = Z(nC+1:nBas-nR)/(Sig3(nC+1:nBas-nR) - SigInf(nC+1:nBas-nR)) + Z(:) = 1d0/(1d0 - Z(:)) + + Sig3(:) = Z(:)*Sig3(:) + + endif + + ! Total third-order Green function + + eGF3(:) = e0(:) + Sig2(:) + Sig3(:) + + ! Convergence criteria + + Conv = maxval(abs(eGF3 - eOld)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGF3-eOld,eGF3) + + ! Store result for next iteration + + eOld(:) = eGF3(:) + + ! Print results + + call print_GF3(nBas,nO,nSCF,Conv,e0,Z,eGF3) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + endif + +end subroutine GF3_diag diff --git a/src/QuAcK/Green_function.f90 b/src/QuAcK/Green_function.f90 new file mode 100644 index 0000000..9feb5a3 --- /dev/null +++ b/src/QuAcK/Green_function.f90 @@ -0,0 +1,65 @@ +subroutine Green_function(nBas,nO,nV,nWalk,nWP,cO,cV,eO_Quad,eV_Quad,AO, & + o1MO,o2MO,v1MO,v2MO,o11,o12,o21,o22,v11,v12,v21,v22) + +! Calculate the Green functions + + implicit none + + include 'parameters.h' + include 'quadrature.h' + +! Input variables + + integer,intent(in) :: nBas,nO,nV,nWalk,nWP + double precision,intent(in) :: AO(nWalk,2,nBas),cO(nBas,nO),cV(nBas,nV), & + eO_Quad(nQuad,nO),eV_Quad(nQuad,nV) + +! Local variables + + integer :: kW,lW,klW,i,a,q + double precision :: o1MO(nWalk,nO),o2MO(nWalk,nO),v1MO(nWalk,nV),v2MO(nWalk,nV) + +! Output variables + + double precision,intent(out) :: o11(nQuad,nWP),o12(nQuad,nWP),o21(nQuad,nWP),o22(nQuad,nWP) + double precision,intent(out) :: v11(nQuad,nWP),v12(nQuad,nWP),v21(nQuad,nWP),v22(nQuad,nWP) + +! Calculate occupied and virtual MOs + + o1MO = matmul(AO(:,1,:),cO) + o2MO = matmul(AO(:,2,:),cO) + v1MO = matmul(AO(:,1,:),cV) + v2MO = matmul(AO(:,2,:),cV) + +! Compute occupied Green functions + o11 = 0d0 + o12 = 0d0 + o21 = 0d0 + o22 = 0d0 + v11 = 0d0 + v12 = 0d0 + v21 = 0d0 + v22 = 0d0 + + do q=1,nQuad + klW = 0 + do kW=1,nWalk-1 + do lW=kW+1,nWalk + klW = klW + 1 + do i=1,nO + o11(q,klW) = o11(q,klW) + o1MO(kW,i)*o1MO(lW,i)*eO_Quad(q,i) + o12(q,klW) = o12(q,klW) + o1MO(kW,i)*o2MO(lW,i)*eO_Quad(q,i) + o21(q,klW) = o21(q,klW) + o2MO(kW,i)*o1MO(lW,i)*eO_Quad(q,i) + o22(q,klW) = o22(q,klW) + o2MO(kW,i)*o2MO(lW,i)*eO_Quad(q,i) + enddo + do a=1,nV + v11(q,klW) = v11(q,klW) + v1MO(kW,a)*v1MO(lW,a)*eV_Quad(q,a) + v12(q,klW) = v12(q,klW) + v1MO(kW,a)*v2MO(lW,a)*eV_Quad(q,a) + v21(q,klW) = v21(q,klW) + v2MO(kW,a)*v1MO(lW,a)*eV_Quad(q,a) + v22(q,klW) = v22(q,klW) + v2MO(kW,a)*v2MO(lW,a)*eV_Quad(q,a) + enddo + enddo + enddo + enddo + +end subroutine Green_function diff --git a/src/QuAcK/Hartree_matrix_AO_basis.f90 b/src/QuAcK/Hartree_matrix_AO_basis.f90 new file mode 100644 index 0000000..3ee7368 --- /dev/null +++ b/src/QuAcK/Hartree_matrix_AO_basis.f90 @@ -0,0 +1,33 @@ +subroutine Hartree_matrix_AO_basis(nBas,P,Hc,G,H) + +! Compute Hartree matrix in the AO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: H(nBas,nBas) + + H = Hc + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + H(mu,nu) = H(mu,nu) + P(la,si)*G(mu,la,nu,si) + enddo + enddo + enddo + enddo + +end subroutine Hartree_matrix_AO_basis diff --git a/src/QuAcK/Hartree_matrix_MO_basis.f90 b/src/QuAcK/Hartree_matrix_MO_basis.f90 new file mode 100644 index 0000000..6cf85bd --- /dev/null +++ b/src/QuAcK/Hartree_matrix_MO_basis.f90 @@ -0,0 +1,26 @@ +subroutine Hartree_matrix_MO_basis(nBas,c,P,Hc,G,H) + +! Compute Hartree matrix in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: H(nBas,nBas) + +! Compute Hartree matrix in the AO basis + + call Hartree_matrix_AO_basis(nBas,P,Hc,G,H) + +! Transform Hartree matrix in the MO basis + + H = matmul(transpose(c),matmul(H,c)) + +end subroutine Hartree_matrix_MO_basis diff --git a/src/QuAcK/MCMP2.f90 b/src/QuAcK/MCMP2.f90 new file mode 100644 index 0000000..3851d25 --- /dev/null +++ b/src/QuAcK/MCMP2.f90 @@ -0,0 +1,344 @@ + subroutine MCMP2(doDrift,nBas,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + Norm, & + EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + +! Perform Monte Carlo MP2 calculation + + implicit none + + include 'parameters.h' + include 'quadrature.h' + +! Input variables + + logical,intent(in) :: doDrift + integer,intent(in) :: nBas,nC,nO,nV,nMC,nEq,nWalk,nPrint + double precision,intent(inout):: dt + double precision,intent(in) :: EcMP2(3) + double precision,intent(in) :: c(nBas,nBas),e(nBas) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + logical :: AcPh,EqPh,Accept,dump + double precision :: start_Eq,end_Eq,t_Eq,start_Ac,end_Ac,t_Ac + integer :: nWP + double precision :: Norm,NormSq,nData,tau + double precision,allocatable :: chi1(:,:,:),chi2(:,:,:),eta(:) + + double precision,allocatable :: cO(:,:),cV(:,:),eO(:),eV(:),P(:,:),eO_Quad(:,:),eV_Quad(:,:) + double precision,allocatable :: r(:,:,:), r12(:), gAO(:,:,:), g(:,:), w(:) + double precision,allocatable :: rp(:,:,:),r12p(:),gAOp(:,:,:), gp(:,:),wp(:) + double precision,allocatable :: o1MO(:,:),o2MO(:,:),v1MO(:,:),v2MO(:,:) + double precision,allocatable :: o11(:,:),o12(:,:),o21(:,:),o22(:,:) + double precision,allocatable :: v11(:,:),v12(:,:),v21(:,:),v22(:,:) + double precision,allocatable :: fd_Quad(:,:),fx_Quad(:,:),fd(:),fx(:),fdx(:) + + double precision,allocatable :: dgAO(:,:,:,:),dg(:,:,:),dgAOp(:,:,:,:),dgp(:,:,:) + double precision,allocatable :: F(:,:,:),Fp(:,:,:),T(:),Tp(:) + + double precision :: acceptance,D + double precision :: eloc_MP2(3),mean_MP2(3),variance_MP2(3) + + integer :: iW,kW,lW,klW,iMC,q + +! Output variables + + double precision,intent(out) :: EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + +! Number of distinct walker pairs + + nWP = nWalk*(nWalk-1)/2 + +! Diffusion coefficient + + D = 0.5d0 + +! Do diffusion-drift moves? + + if(doDrift) then + + write(*,*) + write(*,*) '*** Diffusion-drift algorithm ***' + write(*,*) + + else + + write(*,*) + write(*,*) '*** Diffusion-only algorithm ***' + write(*,*) + + endif + +! Print results + + dump = .true. + if(dump) open(unit=13,file='results/data') + +!------------------------------------------------------------------------ +! Memory allocation +!------------------------------------------------------------------------ + allocate(cO(nBas,nO),cV(nBas,nV),eO(nO),eV(nV), & + eO_Quad(nQuad,nO),eV_Quad(nQuad,nV), & + P(nBas,nBas),r(nWalk,2,3),rp(nWalk,2,3), & + chi1(nWalk,2,3),chi2(nWalk,2,3),eta(nWalk), & + r12(nWalk),r12p(nWalk),w(nWalk),wp(nWalk), & + g(nWalk,2),gp(nWalk,2),gAO(nWalk,2,nBas),gAOp(nWalk,2,nBas), & + dg(nWalk,2,3),dgp(nWalk,2,3),dgAO(nWalk,2,3,nBas),dgAOp(nWalk,2,3,nBas), & + o1MO(nWalk,nO),v1MO(nWalk,nV),o2MO(nWalk,nO),v2MO(nWalk,nV), & + o11(nQuad,nWP),v11(nQuad,nWP),o12(nQuad,nWP),v12(nQuad,nWP), & + o21(nQuad,nWP),v21(nQuad,nWP),o22(nQuad,nWP),v22(nQuad,nWP), & + fd_Quad(nQuad,nWP),fd(nWP),fx_Quad(nQuad,nWP),fx(nWP),fdx(nWP), & + T(nWalk),Tp(nWalk),F(nWalk,2,3),Fp(nWalk,2,3)) + +! Split MOs into occupied and virtual sets + + eO(1:nO) = e(nC+1:nC+nO) + eV(1:nV) = e(nC+nO+1:nBas) + + do q=1,nQuad + tau = 1d0/rQuad(q) + eO_Quad(q,1:nO) = exp(+eO(1:nO)*(tau-1d0))*sqrt(tau) + eV_Quad(q,1:nV) = exp(-eV(1:nV)*(tau-1d0))*sqrt(tau) + enddo + + cO(1:nBas,1:nO) = c(1:nBas,nC+1:nC+nO) + cV(1:nBas,1:nV) = c(1:nBas,nC+nO+1:nBas) + +! Compute norm of the trial wave function + + call norm_trial(nBas,nO,cO,P,Norm,NormSq) + +!------------------------------------------------------------------------ +! Initialize MC-MP2 calculation +!------------------------------------------------------------------------ + +! Initialize electron coordinates + + call random_number(r) + r = 2d0*r - 1d0 + +! Compute initial interelectronic distances + + call rij(nWalk,r,r12) + +! Compute initial AO values and their derivatives (if required) + + call AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,r,gAO,dgAO) + +! Compute initial weight function + + call density(doDrift,nBas,nWalk,P,gAO,dgAO,g,dg) + +! Compute initial weights + + w(1:nWalk) = g(1:nWalk,1)*g(1:nWalk,2)/r12(1:nWalk) + +! Compute initial quantum force + + if(doDrift) call drift(nWalk,r,r12,g,dg,F) + +! Equilibration or Accumulation? + + AcPh = .false. + EqPh = .true. + +! Initialization + + nData = 0d0 + acceptance = 0d0 + + mean_MP2 = 0d0 + variance_MP2 = 0d0 + + T = 1d0 + Tp = 1d0 + +!------------------------------------------------------------------------ +! Start main Monte Carlo loop +!------------------------------------------------------------------------ + call cpu_time(start_Eq) + + do iMC=1,nEq+nMC + +! Timings + + if(iMC == nEq + 1) then + AcPh = .true. + EqPh = .false. + write(*,*) 'Time step value at the end of equilibration: dt = ',dt + write(*,*) + call cpu_time(end_Eq) + t_Eq = end_Eq - start_Eq + write(*,*) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for equilibration = ',t_Eq,' seconds' + write(*,*) + call cpu_time(start_Ac) + endif + +! Optimize time step to reach 50% acceptance + + if(EqPh .and. mod(iMC,100) == 0) call optimize_timestep(nWalk,iMC,acceptance,dt) + +! Move electrons + + call random_number(chi1) + call random_number(chi2) + +! Diffusion + + rp(:,:,:) = r(:,:,:) + sqrt(2d0*D*dt)*sqrt(-2d0*log(chi1(:,:,:)))*cos(2d0*pi*chi2(:,:,:)) + +! Drift + + if(doDrift) rp(:,:,:) = rp(:,:,:) + D*dt*F(:,:,:) + +! Compute new interelectronic distances + + call rij(nWalk,rp,r12p) + +! Compute new AO values and their derivatives (if required) + + call AO_values(doDrift,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rp,gAOp,dgAOp) + + call Density(doDrift,nBas,nWalk,P,gAOp,dgAOp,gp,dgp) + +! Compute new weights + + wp(1:nWalk) = gp(1:nWalk,1)*gp(1:nWalk,2)/r12p(1:nWalk) + +! Compute new quantum force and transition probability + + if(doDrift) then + + call Drift(nWalk,rp,r12p,gp,dgp,Fp) + call transition_probability(nWalk,dt,D,r,rp,F,Fp,T,Tp) + + endif + +! Move for walkers + + call random_number(eta) + + do iW=1,nWalk + + Accept = (wp(iW)*Tp(iW))/(w(iW)*T(iW)) > eta(iW) + + if(Accept) then + + acceptance = acceptance + 1d0 + + r(iW,1:2,1:3) = rp(iW,1:2,1:3) + gAO(iW,1:2,1:nBas) = gAOp(iW,1:2,1:nBas) + r12(iW) = r12p(iW) + w(iW) = wp(iW) + + if(doDrift) F(iW,1:2,1:3) = Fp(iW,1:2,1:3) + + endif + + enddo + +! Accumulation phase + + if(AcPh) then + + nData = nData + 1d0 + +! Calculate Green functions + + call Green_function(nBas,nO,nV,nWalk,nWP,cO,cV,eO_Quad,eV_Quad,gAO, & + o1MO,o2MO,v1MO,v2MO,o11,o12,o21,o22,v11,v12,v21,v22) + +! Compute local energy + + fd_Quad = o11*o22*v11*v22 + o12*o21*v12*v21 + fx_Quad = o11*o22*v12*v21 + o12*o21*v11*v22 + + fd = matmul(wQuad,fd_Quad) + fx = matmul(wQuad,fx_Quad) + + eloc_MP2 = 0d0 + klW = 0 + do kW=1,nWalk-1 + do lW=kW+1,nWalk + klW = klW + 1 + eloc_MP2(2) = eloc_MP2(2) + fd(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + eloc_MP2(3) = eloc_MP2(3) + fx(klW)/(r12(kW)*r12(lW)*w(kW)*w(lW)) + enddo + enddo + + eloc_MP2(2) = -2d0*eloc_MP2(2)/dble(2*nWP) + eloc_MP2(3) = eloc_MP2(3)/dble(2*nWP) + + fdx = -2d0*fd + fx + eloc_MP2(1) = eloc_MP2(2) + eloc_MP2(3) + +! Accumulate results + + mean_MP2 = mean_MP2 + eloc_MP2 + variance_MP2 = variance_MP2 + eloc_MP2*eloc_MP2 + +! Print results + + if(mod(iMC,nPrint) == 0) then + + call compute_error(nData,mean_MP2,variance_MP2,Err_EcMCMP2) + EcMCMP2 = mean_MP2/nData + Var_EcMCMP2 = variance_MP2/nData + EcMCMP2 = Norm*EcMCMP2 + Var_EcMCMP2 = Norm*Var_EcMCMP2 + Err_EcMCMP2 = Norm*Err_EcMCMP2 + + write(*,*) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,I15)') 'Number of data points ','|',int(nData) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10I15)') 'acceptance ','|',int(100*acceptance/dble(nWalk*iMC)) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'MP2 correlation energy Total ','|',EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Statistical error Total ','|',Err_EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',Err_EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',Err_EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Variance Total ','|',Var_EcMCMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',Var_EcMCMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',Var_EcMCMP2(3) + write(*,*)'-------------------------------------------------------' + write(*,'(1X,A36,1X,A1,1X,10F15.8)') 'Dev. wrt deterministic Total ','|',EcMCMP2(1) - EcMP2(1) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Direct ','|',EcMCMP2(2) - EcMP2(2) + write(*,'(1X,A36,1X,A1,1X,10F15.8)') ' Exchange ','|',EcMCMP2(3) - EcMP2(3) + write(*,*)'-------------------------------------------------------' + + if(dump) write(13,*) int(nData),EcMCMP2(1),Err_EcMCMP2(1) + + endif + + endif + +!------------------------------------------------------------------------ +! End main Monte Carlo loop +!------------------------------------------------------------------------ + enddo + +! Timing + + call cpu_time(end_Ac) + t_Ac = end_Ac - start_Ac + write(*,*) + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for accumulation = ',t_Ac,' seconds' + write(*,*) + +! Close files + + if(dump) close(unit=13) + +end subroutine MCMP2 diff --git a/src/QuAcK/MOM.f90 b/src/QuAcK/MOM.f90 new file mode 100644 index 0000000..fda126c --- /dev/null +++ b/src/QuAcK/MOM.f90 @@ -0,0 +1,190 @@ +subroutine MOM(maxSCF,thresh,max_diis,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Maximum overlap method + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: iBas,jBas + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + double precision,allocatable :: cG(:,:),ON(:) + +! Output variables + + double precision,intent(inout):: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Maximum overlap method |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + cG(nBas,nBas),ON(nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Set up guess orbitals + + cG(:,:) = c(:,:) + +! Set up occupation numbers + + ON(1:nO) = 1d0 + ON(nO+1:nBas) = 0d0 + +! HOMO-LUMO transition + + ON(nO) = 0d0 + ON(nO+1) = 1d0 + + write(*,*) + write(*,*) ' --- Initial MO occupations --- ' + write(*,*) + call matout(nBas,1,ON) + write(*,*) + +! Compute density matrix + + call density_matrix(nBas,ON,c,P) + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| MOM calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! MOM overlap + + call MOM_overlap(nBas,nO,S,cG,c,ON) + +! Density matrix + + call density_matrix(nBas,ON,c,P) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + 0.5d0*trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + + write(*,*) + write(*,*) ' --- Final MO occupations --- ' + write(*,*) + call matout(nBas,1,ON) + write(*,*) + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = 0.5d0*trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,c,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine MOM diff --git a/src/QuAcK/MOM_overlap.f90 b/src/QuAcK/MOM_overlap.f90 new file mode 100644 index 0000000..f4f4c61 --- /dev/null +++ b/src/QuAcK/MOM_overlap.f90 @@ -0,0 +1,51 @@ +subroutine MOM_overlap(nBas,nO,S,cG,c,ON) + +! Compute overlap between old and new MO coefficients + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: S(nBas,nBas),cG(nBas,nBas),c(nBas,nBas) + +! Local variables + + integer :: i,j,ploc + double precision,allocatable :: Ov(:,:),pOv(:) + +! Output variables + + double precision,intent(inout):: ON(nBas) + + allocate(Ov(nBas,nBas),pOv(nBas)) + + Ov = matmul(transpose(cG),matmul(S,c)) + + pOv(:) = 0d0 + + do i=1,nBas + do j=1,nBas + pOv(j) = pOv(j) + ON(i)*Ov(i,j)**2 + enddo + enddo + + pOv(:) = sqrt(pOV(:)) + +! print*,'--- MOM overlap ---' +! call matout(nBas,1,pOv) + + ON(:) = 0d0 + + do i=1,nO + ploc = maxloc(pOv,nBas) + ON(ploc) = 1d0 + pOv(ploc) = 0d0 + enddo + +! print*,'--- Occupation numbers ---' +! call matout(nBas,1,ON) + + + +end subroutine MOM_overlap diff --git a/src/QuAcK/MOtoAO_transform.f90 b/src/QuAcK/MOtoAO_transform.f90 new file mode 100644 index 0000000..b4a8b4f --- /dev/null +++ b/src/QuAcK/MOtoAO_transform.f90 @@ -0,0 +1,27 @@ +subroutine MOtoAO_transform(nBas,S,c,A) + +! Perform MO to AO transformation of a matrix A for a given metric S +! and coefficients c + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: S(nBas,nBas),c(nBas,nBas) + +! Local variables + + double precision,allocatable :: Sc(:,:) + +! Output variables + + double precision,intent(inout):: A(nBas,nBas) + +! Memory allocation + allocate(Sc(nBas,nBas)) + + Sc = matmul(S,c) + A = matmul(Sc,matmul(A,transpose(Sc))) + +end subroutine MOtoAO_transform diff --git a/src/QuAcK/MP2.f90 b/src/QuAcK/MP2.f90 new file mode 100644 index 0000000..3e38149 --- /dev/null +++ b/src/QuAcK/MP2.f90 @@ -0,0 +1,71 @@ +subroutine MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) + +! Perform third-order Moller-Plesset calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: ENuc,EHF + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + integer :: i,j,a,b + double precision :: eps,E2a,E2b + +! Output variables + + double precision,intent(out) :: EcMP2(3) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Moller-Plesset second-order calculation |' + write(*,*)'************************************************' + write(*,*) + +! Compute MP2 energy + + E2a = 0d0 + E2b = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = e(i) + e(j) - e(a) - e(b) + +! Second-order ring diagram + + E2a = E2a + ERI(i,j,a,b)*ERI(i,j,a,b)/eps + +! Second-order exchange diagram + + E2b = E2b + ERI(i,j,a,b)*ERI(i,j,b,a)/eps + + enddo + enddo + enddo + enddo + + EcMP2(2) = 2d0*E2a + EcMP2(3) = -E2b + EcMP2(1) = EcMP2(2) + EcMP2(3) + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP2 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 correlation energy',EcMP2(1) + write(*,'(A32,1X,F16.10)') ' Direct part ',EcMP2(2) + write(*,'(A32,1X,F16.10)') ' Exchange part ',EcMP2(3) + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 electronic energy',EHF + EcMP2(1) + write(*,'(A32,1X,F16.10)') ' MP2 total energy',ENuc + EHF + EcMP2(1) + write(*,'(A32)') '-----------------------' + write(*,*) + +end subroutine MP2 diff --git a/src/QuAcK/MP2F12.f90 b/src/QuAcK/MP2F12.f90 new file mode 100644 index 0000000..a549e6a --- /dev/null +++ b/src/QuAcK/MP2F12.f90 @@ -0,0 +1,167 @@ +subroutine MP2F12(nBas,nC,nO,nV,ERI,F12,Yuk,FC,EHF,e,c) + +! Perform MP2-F12 calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV + double precision,intent(in) :: EHF + double precision,intent(in) :: e(nBas) + double precision,intent(in) :: c(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: F12(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Yuk(nBas,nBas,nBas,nBas) + double precision,intent(in) :: FC(nBas,nBas,nBas,nBas,nBas,nBas) + +! Local variables + + double precision,allocatable :: ooCoo(:,:,:,:) + double precision,allocatable :: ooFoo(:,:,:,:) + double precision,allocatable :: ooYoo(:,:,:,:) + double precision,allocatable :: ooCvv(:,:,:,:) + double precision,allocatable :: ooFvv(:,:,:,:) + double precision,allocatable :: oooFCooo(:,:,:,:,:,:) + double precision,allocatable :: eO(:),eV(:) + double precision,allocatable :: cO(:,:),cV(:,:) + double precision :: E2a,E2b,E3a,E3b,E4a,E4b,E4c,E4d + integer :: i,j,k,l,a,b + double precision :: EcMP2F12(4) + + double precision :: EcMP2a + double precision :: EcMP2b + double precision :: EcMP2 + double precision :: eps + + +! Split MOs into occupied and virtual sets + + allocate(eO(nO),eV(nV)) + + eO(1:nO) = e(nC+1:nC+nO) + eV(1:nV) = e(nC+nO+1:nBas) + + allocate(cO(nBas,nO),cV(nBas,nV)) + + cO(1:nBas,1:nO) = c(1:nBas,nC+1:nC+nO) + cV(1:nBas,1:nV) = c(1:nBas,nC+nO+1:nBas) + +! Compute conventional MP2 energy + + allocate(ooCvv(nO,nO,nV,nV)) + call AOtoMO_oovv(nBas,nO,nV,cO,cV,ERI,ooCvv) + + EcMP2a = 0d0 + EcMP2b = 0d0 + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + eps = eO(i) + eO(j) - eV(a) - eV(b) + EcMP2a = EcMP2a + ooCoo(i,j,a,b)/eps + EcMP2b = EcMP2b + ooCoo(i,j,b,a)/eps + enddo + enddo + enddo + enddo + + EcMP2 = EcMP2a + EcMP2b + +! Compute the two-electron part of the MP2-F12 energy + + allocate(ooYoo(nO,nO,nO,nO)) + call AOtoMO_oooo(nBas,nO,cO,Yuk,ooYoo) + + E2a = 0d0 + E2b = 0d0 + do i=1,nO + do j=1,nO + E2a = E2a + ooYoo(i,j,i,j) + E2b = E2b + ooYoo(i,j,j,i) + enddo + enddo + + deallocate(ooYoo) + +! Compute the three-electron part of the MP2-F12 energy + + allocate(oooFCooo(nO,nO,nO,nO,nO,nO)) + call AOtoMO_oooooo(nBas,nO,cO,FC,oooFCooo) + + E3a = 0d0 + E3b = 0d0 + do i=1,nO + do j=1,nO + do k=1,nO + E3a = E3a + oooFCooo(i,j,k,k,j,i) + E3b = E3b + oooFCooo(i,j,k,k,i,j) + enddo + enddo + enddo + + deallocate(oooFCooo) + +! Compute the four-electron part of the MP2-F12 energy + + allocate(ooCoo(nO,nO,nO,nO),ooFoo(nO,nO,nO,nO)) + call AOtoMO_oooo(nBas,nO,cO,ERI,ooCoo) + call AOtoMO_oooo(nBas,nO,cO,F12,ooFoo) + + E4a = 0d0 + E4b = 0d0 + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + E4a = E4a + ooCoo(i,j,k,l)*ooFoo(i,j,k,l) + E4b = E4b + ooCoo(i,j,k,l)*ooFoo(j,i,k,l) + enddo + enddo + enddo + enddo + + deallocate(ooCoo,ooFoo) + + allocate(ooCvv(nO,nO,nV,nV),ooFvv(nO,nO,nV,nV)) + call AOtoMO_oovv(nBas,nO,nV,cO,cV,ERI,ooCvv) + call AOtoMO_oovv(nBas,nO,nV,cO,cV,F12,ooFvv) + + E4c = 0d0 + E4d = 0d0 + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + E4c = E4c + ooCvv(i,j,a,b)*ooFvv(i,j,a,b) + E4d = E4d + ooCvv(i,j,a,b)*ooFvv(j,i,a,b) + enddo + enddo + enddo + enddo + + deallocate(ooCvv,ooFvv) + +! Final scaling of the various components + + EcMP2F12(1) = +0.625d0*E2a - 0.125d0*E2b + EcMP2F12(2) = -1.250d0*E3a + 0.250d0*E3b + EcMP2F12(3) = +0.625d0*E4a - 0.125d0*E4b - 0.625d0*E4c + 0.125d0*E4d + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP2-F12 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 ',+EcMP2 + write(*,'(A32,1X,F16.10)') ' MP2-F12 E(2) ',-EcMP2F12(1) + write(*,'(A32,1X,F16.10)') ' MP2-F12 E(3) ',-EcMP2F12(2) + write(*,'(A32,1X,F16.10)') ' MP2-F12 E(4) ',-EcMP2F12(3) + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' Total ',EcMP2-EcMP2F12(1)-EcMP2F12(2)-EcMP2F12(3) + write(*,'(A32)') '-----------------------' + write(*,*) + + deallocate(cO,cV) + +end subroutine MP2F12 diff --git a/src/QuAcK/MP3.f90 b/src/QuAcK/MP3.f90 new file mode 100644 index 0000000..0539d31 --- /dev/null +++ b/src/QuAcK/MP3.f90 @@ -0,0 +1,187 @@ +subroutine MP3(nBas,nEl,ERI,e,ENuc,EHF) + +! Perform third-order Moller-Plesset calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nEl + double precision,intent(in) :: ENuc,EHF + double precision,intent(in) :: e(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: eps,E2,EcMP2 + double precision :: eps1,eps2,E3a,E3b,E3c + double precision :: EcMP3 + + integer :: nBas2,nO,nV + integer :: i,j,k,l,a,b,c,d + + double precision,allocatable :: se(:) + double precision,allocatable :: eO(:) + double precision,allocatable :: eV(:) + + double precision,allocatable :: sERI(:,:,:,:) + double precision,allocatable :: dbERI(:,:,:,:) + + double precision,allocatable :: OOOO(:,:,:,:) + double precision,allocatable :: OOVV(:,:,:,:) + double precision,allocatable :: OVVO(:,:,:,:) + double precision,allocatable :: VVOO(:,:,:,:) + double precision,allocatable :: VVVV(:,:,:,:) + + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Moller-Plesset third-order calculation |' + write(*,*)'************************************************' + write(*,*) + +! Spatial to spin orbitals + + nBas2 = 2*nBas + + allocate(se(nBas2),sERI(nBas2,nBas2,nBas2,nBas2)) + + call spatial_to_spin_MO_energy(nBas,e,nBas2,se) + call spatial_to_spin_ERI(nBas,ERI,nBas2,sERI) + +! Antysymmetrize ERIs + + allocate(dbERI(nBas2,nBas2,nBas2,nBas2)) + + call antisymmetrize_ERI(2,nBas2,sERI,dbERI) + + deallocate(sERI) + +! Define occupied and virtual spaces + + nO = nEl + nV = nBas2 - nO + +! Form energy denominator + + allocate(eO(nO),eV(nV)) + + eO(:) = se(1:nO) + eV(:) = se(nO+1:nBas2) + + deallocate(se) + +! Create integral batches + + allocate(OOOO(nO,nO,nO,nO),OOVV(nO,nO,nV,nV),OVVO(nO,nV,nV,nO),VVOO(nV,nV,nO,nO),VVVV(nV,nV,nV,nV)) + + OOOO(:,:,:,:) = dbERI( 1:nO , 1:nO , 1:nO , 1:nO ) + OOVV(:,:,:,:) = dbERI( 1:nO , 1:nO ,nO+1:nBas2,nO+1:nBas2) + OVVO(:,:,:,:) = dbERI( 1:nO ,nO+1:nBas2,nO+1:nBas2, 1:nO ) + VVOO(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2, 1:nO , 1:nO ) + VVVV(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2,nO+1:nBas2,nO+1:nBas2) + + deallocate(dbERI) + +! Compute MP2 energy + + E2 = 0d0 + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + + eps = eO(i) + eO(j) - eV(a) - eV(b) + + E2 = E2 + OOVV(i,j,a,b)*OOVV(i,j,a,b)/eps + + enddo + enddo + enddo + enddo + + EcMP2 = 0.25d0*E2 + +! Compute MP3 energy + + E3a = 0d0 + + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + do a=1,nV + do b=1,nV + + eps1 = eO(i) + eO(j) - eV(a) - eV(b) + eps2 = eO(k) + eO(l) - eV(a) - eV(b) + + E3a = E3a + OOVV(i,j,a,b)*OOOO(k,l,i,j)*VVOO(a,b,k,l)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + E3b = 0d0 + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + do d=1,nV + + eps1 = eO(i) + eO(j) - eV(a) - eV(b) + eps2 = eO(i) + eO(j) - eV(c) - eV(d) + + E3b = E3b + OOVV(i,j,a,b)*VVVV(a,b,c,d)*VVOO(c,d,i,j)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + E3c = 0d0 + + do i=1,nO + do j=1,nO + do k=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + + eps1 = eO(i) + eO(j) - eV(a) - eV(b) + eps2 = eO(i) + eO(k) - eV(a) - eV(c) + + E3c = E3c + OOVV(i,j,a,b)*OVVO(k,b,c,j)*VVOO(a,c,i,k)/(eps1*eps2) + + enddo + enddo + enddo + enddo + enddo + enddo + + EcMP3 = 0.125d0*E3a + 0.125d0*E3b + E3c + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP3 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 contribution ',EcMP2 + write(*,'(A32,1X,F16.10)') ' MP3 contribution ',EcMP3 + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP3 correlation energy', EcMP2 + EcMP3 + write(*,'(A32,1X,F16.10)') ' MP3 total energy',ENuc + EHF + EcMP2 + EcMP3 + write(*,'(A32)') '-----------------------' + write(*,*) + +end subroutine MP3 diff --git a/src/QuAcK/MinMCMP2.f90 b/src/QuAcK/MinMCMP2.f90 new file mode 100644 index 0000000..13c7c59 --- /dev/null +++ b/src/QuAcK/MinMCMP2.f90 @@ -0,0 +1,121 @@ +subroutine MinMCMP2(nBas,nEl,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + TrialType,Norm,cTrial,gradient,hessian) + +! Minimize the variance of MC-MP2 + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nEl,nC,nO,nV,nMC,nEq,nWalk,nPrint + double precision,intent(in) :: EcMP2(3),dt + double precision,intent(in) :: c(nBas,nBas),e(nBas) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + logical :: debug,varmin,mincvg + double precision :: thresh + double precision,allocatable :: max_gradient(:),energy_MCMP2(:),variance_MCMP2(:),error_MCMP2(:),NormTr(:) + + double precision :: EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + + integer :: it,nIt,i + +! Output variables + + integer,intent(in) :: TrialType + double precision,intent(inout):: Norm,cTrial(nBas),gradient(nBas),hessian(nBas,nBas) + +! Debuging mode + +! debug = .true. + debug = .false. + +! Minimization parameters + + varmin = .true. + mincvg = .false. + nIt = 10 + thresh = 1d-5 + allocate(max_gradient(nIt),energy_MCMP2(nIt),variance_MCMP2(nIt),error_MCMP2(nIt),normTr(nIt)) + + if(TrialType == 1) then + +! Use HOMO as guess + cTrial(1:nBas) = c(1:nBas,nEl/2) +! Normalization factor will be computed later + + endif + +!------------------------------------------------------------------------ +! Start MC-MP2 variance minimization +!------------------------------------------------------------------------ + it = 0 + do while (it < nIt .and. .not.(mincvg)) + + it = it + 1 + + write(*,*) '**********************************************************************' + write(*,*) ' Variance minimization of MC-MP2 energy ' + write(*,*) '**********************************************************************' + write(*,*) ' Iteration n.',it + write(*,*) '**********************************************************************' + + write(*,*) + write(*,*) ' Trial wave function coefficients at iteration n.',it + call matout(nBas,1,cTrial) + write(*,*) + + call MCMP2(varmin,nBas,nEl,nC,nO,nV,c,e,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + TrialType,Norm,cTrial,gradient,hessian, & + EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + +! Newton update of the coefficients + + call Newton(nBas,gradient,hessian,cTrial) + +! Check for convergence + + max_gradient(it) = maxval(abs(gradient)) + energy_MCMP2(it) = EcMCMP2(1) + variance_MCMP2(it) = Var_EcMCMP2(1) + error_MCMP2(it) = Err_EcMCMP2(1) + NormTr(it) = Norm + + write(*,*) + write(*,*) 'Maximum gradient at iteration n.',it,':',max_gradient(it) + write(*,*) + + if(max_gradient(it) < thresh) then + write(*,*) ' Miracle! Variance minimization of MC-MP2 has converged!' + mincvg = .true. + endif + + enddo + + write(*,*) + write(*,*) '********************************' + write(*,*) 'Summary of variance minimization' + write(*,*) '********************************' + write(*,*) + + write(*,'(A3,A20,A20,A20,A20,A20,A20)') & + 'It.','Gradient','Ec(MC-MPC2)','Variance','Error','Ec(MC-MP2)-Ec(MP2)','Norm' + write(*,'(I3,4X,F16.10,4X,F16.10,4X,F16.10,4X,F16.10,4X,F16.10,4X,F16.10)') & + (i,max_gradient(i),energy_MCMP2(i),variance_MCMP2(i),error_MCMP2(i),energy_MCMP2(i)-EcMP2(1),NormTr(i),i=1,it) + write(*,*) + +!------------------------------------------------------------------------ +! End MC-MP2 variance minimization +!------------------------------------------------------------------------ + +end subroutine MinMCMP2 diff --git a/src/QuAcK/NDrift.f90 b/src/QuAcK/NDrift.f90 new file mode 100644 index 0000000..13cc5f3 --- /dev/null +++ b/src/QuAcK/NDrift.f90 @@ -0,0 +1,67 @@ +subroutine NDrift(nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,P,r,w,F) + +! Compute quantum force numerically + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nWalk,nBas + double precision,intent(in) :: P(nBas,nBas),r(nWalk,2,3),w(nWalk) + + integer,intent(in) :: nShell + integer,intent(in) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(in) :: CenterShell(maxShell,3),DShell(maxShell,maxK),ExpShell(maxShell,maxK) + +! Local variables + + integer :: iW,iEl,ixyz + double precision :: delta + double precision :: wp,wm + double precision,allocatable :: rp(:,:,:),rm(:,:,:),r12p(:),r12m(:) + double precision,allocatable :: gAOp(:,:,:),dgAOp(:,:,:,:),gAOm(:,:,:),dgAOm(:,:,:,:) + double precision,allocatable :: gp(:,:),dgp(:,:,:),gm(:,:),dgm(:,:,:) + + +! Output variables + + double precision,intent(out) :: F(nWalk,2,3) + + allocate(rp(nWalk,2,3),rm(nWalk,2,3),r12p(nWalk),r12m(nWalk), & + gAOp(nWalk,2,nBas),dgAOp(nWalk,2,3,nBas),gAOm(nWalk,2,nBas),dgAOm(nWalk,2,3,nBas), & + gp(nWalk,2),dgp(nWalk,2,3),gm(nWalk,2),dgm(nWalk,2,3)) + + do iW=1,nWalk + do iEl=1,2 + do ixyz=1,3 + + delta = 1d-6 + + rp = r + rm = r + + rp(iW,iEl,ixyz) = r(iW,iEl,ixyz) + delta + rm(iW,iEl,ixyz) = r(iW,iEl,ixyz) - delta + + call AO_values(.false.,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rp,gAOp,dgAOp) + call AO_values(.false.,nBas,nShell,nWalk,CenterShell,TotAngMomShell,KShell,DShell,ExpShell,rm,gAOm,dgAOm) + + call Density(.false.,nBas,nWalk,P,gAOp,dgAOp,gp,dgp) + call Density(.false.,nBas,nWalk,P,gAOm,dgAOm,gm,dgm) + + call rij(nWalk,rp,r12p) + call rij(nWalk,rm,r12m) + + wp = gp(iW,1)*gp(iW,2)/r12p(iW) + wm = gm(iW,1)*gm(iW,2)/r12m(iW) + + F(iW,iEl,ixyz) = (wp - wm)/(2d0*delta*w(iw)) + enddo + enddo + enddo + +! print*,'NF',F + + +end subroutine NDrift diff --git a/src/QuAcK/Newton.f90 b/src/QuAcK/Newton.f90 new file mode 100644 index 0000000..f074035 --- /dev/null +++ b/src/QuAcK/Newton.f90 @@ -0,0 +1,67 @@ +subroutine Newton(nWSq,gradient,hessian,cWeight) + +! Calculate the Green functions + + implicit none + +! Input variables + + integer,intent(in) :: nWSq + double precision,intent(in) :: gradient(nWSq),hessian(nWSq,nWSq) + +! Local variables + + integer :: info + integer,allocatable :: ipiv(:) + double precision,allocatable :: scr(:),eigval(:),eigvec(:,:) + +! Output variables + + double precision,intent(inout):: cWeight(nWSq) + +! Memory allocation + + allocate(ipiv(nWSq),scr(3*nWsq),eigval(nWSq),eigvec(nWSq,nWSq)) + +! Compute eigenvectors and eigenvalues + + eigvec = hessian + call dsyev('V','U',nWSq,eigvec,nWSq,eigval,scr,3*nWSq,info) + + if(info /= 0)then + write(*,*) ' Problem with dsyev!' + stop + endif + + write(*,*) + write(*,*) 'Eigenvalues of hessian' + call matout(nWSq,1,eigval) + write(*,*) +! write(*,*) 'Eigenvectors of hessian' +! call matout(nWSq,1,eigval) +! write(*,*) + +! Compute inverse of the hessian + + call dgetrf(nWSq,nWSq,hessian,nWSq,ipiv,info) + + if(info /= 0) then + write(*,*) ' Problem in dgetrf!' + stop + endif + + call dgetri(nWSq,hessian,nWSq,ipiv,scr,nWSq,info) + + if(info /= 0) then + write(*,*) ' Problem in dgetri!' + stop + endif + + print*,'inverse hessian' + call matout(nWSq,nWSq,hessian) + +! Compute new coefficients + + cWeight = cWeight - matmul(hessian,gradient) + +end subroutine Newton diff --git a/src/QuAcK/NormCoeff.f90 b/src/QuAcK/NormCoeff.f90 new file mode 100644 index 0000000..9e6cabf --- /dev/null +++ b/src/QuAcK/NormCoeff.f90 @@ -0,0 +1,29 @@ +function NormCoeff(alpha,a) + + implicit none + +! Input variables + + double precision,intent(in) :: alpha + integer,intent(in) :: a(3) + +! local variable + double precision :: pi,dfa(3),dfac + integer :: atot + +! Output variable + double precision NormCoeff + + pi = 4d0*atan(1d0) + atot = a(1) + a(2) + a(3) + + dfa(1) = dfac(2*a(1))/(2d0**a(1)*dfac(a(1))) + dfa(2) = dfac(2*a(2))/(2d0**a(2)*dfac(a(2))) + dfa(3) = dfac(2*a(3))/(2d0**a(3)*dfac(a(3))) + + + NormCoeff = (2d0*alpha/pi)**(3d0/2d0)*(4d0*alpha)**atot + NormCoeff = NormCoeff/(dfa(1)*dfa(2)*dfa(3)) + NormCoeff = sqrt(NormCoeff) + +end function NormCoeff diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 new file mode 100644 index 0000000..55c8f82 --- /dev/null +++ b/src/QuAcK/QuAcK.f90 @@ -0,0 +1,552 @@ +program QuAcK + + implicit none + include 'parameters.h' + + logical :: doRHF,doUHF,doMOM + logical :: doMP2,doMP3,doMP2F12 + logical :: doCCD,doCCSD,doCCSDT + logical :: doCIS,doTDHF,doADC + logical :: doGF2,doGF3 + logical :: doG0W0,doevGW,doqsGW + logical :: doMCMP2,doMinMCMP2 + logical :: doeNcusp + integer :: nNuc,nBas,nBasCABS + integer :: nEl(nspin),nC(nspin),nO(nspin),nV(nspin),nR(nspin),nS(nspin) + double precision :: ENuc,ERHF,EUHF,Norm + double precision :: EcMP2(3),EcMP3,EcMP2F12(3),EcMCMP2(3),Err_EcMCMP2(3),Var_EcMCMP2(3) + + double precision,allocatable :: ZNuc(:),rNuc(:,:) + double precision,allocatable :: cHF(:,:,:),eHF(:,:),PHF(:,:,:) + double precision,allocatable :: eG0W0(:) + + integer :: nShell + integer,allocatable :: TotAngMomShell(:),KShell(:) + double precision,allocatable :: CenterShell(:,:),DShell(:,:),ExpShell(:,:) + + integer :: TrialType + double precision,allocatable :: cTrial(:),gradient(:),hessian(:,:) + + double precision,allocatable :: S(:,:),T(:,:),V(:,:),Hc(:,:),X(:,:) + double precision,allocatable :: ERI_AO_basis(:,:,:,:),ERI_MO_basis(:,:,:,:) + double precision,allocatable :: F12(:,:,:,:),Yuk(:,:,:,:),FC(:,:,:,:,:,:) + + double precision :: start_HF ,end_HF ,t_HF + double precision :: start_MOM ,end_MOM ,t_MOM + double precision :: start_CCD ,end_CCD ,t_CCD + double precision :: start_CCSD ,end_CCSD ,t_CCSD + double precision :: start_CIS ,end_CIS ,t_CIS + double precision :: start_TDHF ,end_TDHF ,t_TDHF + double precision :: start_ADC ,end_ADC ,t_ADC + double precision :: start_GF2 ,end_GF2 ,t_GF2 + double precision :: start_GF3 ,end_GF3 ,t_GF3 + double precision :: start_G0W0 ,end_G0W0 ,t_G0W0 + double precision :: start_evGW ,end_evGW ,t_evGW + double precision :: start_qsGW ,end_qsGW ,t_qsGW + double precision :: start_eNcusp ,end_eNcusp ,t_eNcusp + double precision :: start_MP2 ,end_MP2 ,t_MP2 + double precision :: start_MP3 ,end_MP3 ,t_MP3 + double precision :: start_MP2F12 ,end_MP2F12 ,t_MP2F12 + double precision :: start_MCMP2 ,end_MCMP2 ,t_MCMP2 + double precision :: start_MinMCMP2,end_MinMCMP2,t_MinMCMP2 + + integer :: maxSCF_HF,n_diis_HF + double precision :: thresh_HF + logical :: DIIS_HF,guess_type,ortho_type + + integer :: maxSCF_CC,n_diis_CC + double precision :: thresh_CC + logical :: DIIS_CC + + logical :: singlet_manifold,triplet_manifold + + integer :: maxSCF_GF,n_diis_GF,renormalization + double precision :: thresh_GF + logical :: DIIS_GF + + integer :: maxSCF_GW,n_diis_GW + double precision :: thresh_GW + logical :: DIIS_GW,COHSEX,SOSEX,BSE,TDA,G0W,GW0,linearize + + integer :: nMC,nEq,nWalk,nPrint,iSeed + double precision :: dt + logical :: doDrift + +! Hello World + + write(*,*) + write(*,*) '******************************************************************************************' + write(*,*) '* QuAcK QuAcK QuAcK *' + write(*,*) '* __ __ __ __ __ __ __ __ __ *' + write(*,*) '* <(o )___ <(o )___ <(o )___ <(o )___ <(o )___ <(o )___ <(o )___ <(o )___ <(o )___ *' + write(*,*) '* ( ._> / ( ._> / ( ._> / ( ._> / ( ._> / ( ._> / ( ._> / ( ._> / ( ._> / *' + write(*,*) '*|--------------------------------------------------------------------------------------|*' + write(*,*) '******************************************************************************************' + write(*,*) + +! Which calculations do you want to do? + + call read_methods(doRHF,doUHF,doMOM, & + doMP2,doMP3,doMP2F12, & + doCCD,doCCSD,doCCSDT, & + doCIS,doTDHF,doADC, & + doGF2,doGF3, & + doG0W0,doevGW,doqsGW, & + doMCMP2) + +! Read options for methods + + call read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type, & + maxSCF_CC,thresh_CC,DIIS_CC,n_diis_CC, & + singlet_manifold,triplet_manifold, & + maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,renormalization, & + maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,COHSEX,SOSEX,BSE,TDA,G0W,GW0,linearize, & + nMC,nEq,nWalk,dt,nPrint,iSeed,doDrift) + +! Weird stuff + + doeNCusp = .false. + doMinMCMP2 = .false. + +!------------------------------------------------------------------------ +! Read input information +!------------------------------------------------------------------------ + +! Read number of atoms, number of electrons of the system +! nC = number of core orbitals +! nO = number of occupied orbitals +! nV = number of virtual orbitals (see below) +! nR = number of Rydberg orbitals +! nBas = number of basis functions (see below) +! = nO + nV +! nS = number of single excitation +! = nO*nV + + call read_molecule(nNuc,nEl,nO,nC,nR) + allocate(ZNuc(nNuc),rNuc(nNuc,3)) + +! Read geometry + + call read_geometry(nNuc,ZNuc,rNuc,ENuc) + + allocate(CenterShell(maxShell,3),TotAngMomShell(maxShell),KShell(maxShell), & + DShell(maxShell,maxK),ExpShell(maxShell,maxK)) + +!------------------------------------------------------------------------ +! Read basis set information +!------------------------------------------------------------------------ + + call read_basis(nNuc,rNuc,nBas,nO,nV,nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell) + nS(:) = nO(:)*nV(:) + +!------------------------------------------------------------------------ +! Read auxiliary basis set information +!------------------------------------------------------------------------ + +! call ReadAuxBasis(nNuc,rNuc,nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell) + +! Compute the number of basis functions + +! call CalcNBasis(nShell,TotAngMomShell,nA) + +! Number of virtual orbitals in complete space + +! nBasCABS = nA - nBas + +!------------------------------------------------------------------------ +! Read one- and two-electron integrals +!------------------------------------------------------------------------ + +! Memory allocation for one- and two-electron integrals + + allocate(cHF(nBas,nBas,nspin),eHF(nBas,nspin),eG0W0(nBas),PHF(nBas,nBas,nspin), & + S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas), & + ERI_AO_basis(nBas,nBas,nBas,nBas),ERI_MO_basis(nBas,nBas,nBas,nBas)) + +! Read integrals + + call read_integrals(nBas,S,T,V,Hc,ERI_AO_basis) + +! Compute orthogonalization matrix + + call orthogonalization_matrix(ortho_type,nBas,S,X) + +!------------------------------------------------------------------------ +! Compute RHF energy +!------------------------------------------------------------------------ + + if(doRHF) then + + call cpu_time(start_HF) +! call SPHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type, & +! nBas,nEl,S,T,V,Hc,ERI_AO_basis,X,ENuc,ERHF,cHF,eHF,PHF) + call RHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type, & + nBas,nO,S,T,V,Hc,ERI_AO_basis,X,ENuc,ERHF,cHF,eHF,PHF) + call cpu_time(end_HF) + + t_HF = end_HF - start_HF + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for HF = ',t_HF,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute RHF energy +!------------------------------------------------------------------------ + + if(doUHF) then + + nO(2) = nO(1) + + call cpu_time(start_HF) + call UHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type, & + nBas,nO,S,T,V,Hc,ERI_AO_basis,X,ENuc,EUHF) + call cpu_time(end_HF) + + t_HF = end_HF - start_HF + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for HF = ',t_HF,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Maximum overlap method +!------------------------------------------------------------------------ + + if(doMOM) then + + call cpu_time(start_MOM) + call MOM(maxSCF_HF,thresh_HF,n_diis_HF, & + nBas,nO,S,T,V,Hc,ERI_AO_basis,X,ENuc,ERHF,cHF,eHF,PHF) + call cpu_time(end_MOM) + + t_MOM = end_MOM - start_MOM + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MOM = ',t_MOM,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! AO to MO integral transform for post-HF methods +!------------------------------------------------------------------------ + + call AOtoMO_integral_transform(nBas,cHF,ERI_AO_basis,ERI_MO_basis) + +!------------------------------------------------------------------------ +! Compute MP2 energy +!------------------------------------------------------------------------ + + if(doMP2) then + + call cpu_time(start_MP2) +! call SPMP2(nBas,nC,nEl,nBas-nEl,nR,ERI_MO_basis,ENuc,ERHF,eHF,EcMP2) + call MP2(nBas,nC,nO,nV,nR,ERI_MO_basis,ENuc,ERHF,eHF,EcMP2) + call cpu_time(end_MP2) + + t_MP2 = end_MP2 - start_MP2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2 = ',t_MP2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute MP3 energy +!------------------------------------------------------------------------ + + if(doMP3) then + + call cpu_time(start_MP3) + call MP3(nBas,nEl,ERI_MO_basis,eHF,ENuc,ERHF) + call cpu_time(end_MP3) + + t_MP3 = end_MP3 - start_MP3 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP3 = ',t_MP3,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute MP2-F12 energy +!------------------------------------------------------------------------ + + if(doMP2F12) then + + call cpu_time(start_MP2F12) +! Memory allocation for one- and two-electron integrals + allocate(F12(nBas,nBas,nBas,nBas),Yuk(nBas,nBas,nBas,nBas),FC(nBas,nBas,nBas,nBas,nBas,nBas)) +! Read integrals + call read_F12_integrals(nBas,S,ERI_AO_basis,F12,Yuk,FC) + call MP2F12(nBas,nC,nO,nV,ERI_AO_basis,F12,Yuk,FC,ERHF,eHF,cHF) + call cpu_time(end_MP2F12) + + t_MP2F12 = end_MP2F12 - start_MP2F12 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2-F12 = ',t_MP2F12,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform CCD calculation +!------------------------------------------------------------------------ + + if(doCCD) then + + call cpu_time(start_CCD) + call CCD(maxSCF_CC,thresh_CC,n_diis_CC,nBas,nEl,ERI_MO_basis,ENuc,ERHF,eHF) + call cpu_time(end_CCD) + + t_CCD = end_CCD - start_CCD + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CCD = ',t_CCD,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform CCSD or CCSD(T) calculation +!------------------------------------------------------------------------ + + if(doCCSD) then + + call cpu_time(start_CCSD) + call CCSD(maxSCF_CC,thresh_CC,n_diis_CC,doCCSDT,nBas,nEl,ERI_MO_basis,ENuc,ERHF,eHF) + call cpu_time(end_CCSD) + + t_CCSD = end_CCSD - start_CCSD + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CCSD or CCSD(T)= ',t_CCSD,' seconds' + write(*,*) + + end if + +!------------------------------------------------------------------------ +! Compute CIS excitations +!------------------------------------------------------------------------ + + if(doCIS) then + + call cpu_time(start_CIS) + call CIS(singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ERI_MO_basis,eHF) + call cpu_time(end_CIS) + + t_CIS = end_CIS - start_CIS + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CIS = ',t_CIS,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute TDHF excitations +!------------------------------------------------------------------------ + + if(doTDHF) then + + call cpu_time(start_TDHF) + call TDHF(singlet_manifold,triplet_manifold,nBas,nC,nO,nV,nR,nS,ERI_MO_basis,eHF) +! call SPTDHF(singlet_manifold,triplet_manifold,nBas,nC,nEl,nBas-nEl,nR,nEl*(nBas-nEl),ERI_MO_basis,eHF) + call cpu_time(end_TDHF) + + t_TDHF = end_TDHF - start_TDHF + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for TDHF = ',t_TDHF,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute ADC excitations +!------------------------------------------------------------------------ + + if(doADC) then + + call cpu_time(start_ADC) + call ADC(singlet_manifold,triplet_manifold,maxSCF_GF,thresh_GF,n_diis_GF,nBas,nC,nO,nV,nR,eHF,ERI_MO_basis) + call cpu_time(end_ADC) + + t_ADC = end_ADC - start_ADC + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ADC = ',t_ADC,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute GF2 electronic binding energies +!------------------------------------------------------------------------ + + if(doGF2) then + + call cpu_time(start_GF2) +! call GF2(maxSCF_GF,thresh_GF,n_diis_GF,nBas,nC,nO,nV,nR,ERI_MO_basis,eHF) + call GF2_diag(maxSCF_GF,thresh_GF,n_diis_GF,nBas,nC,nO,nV,nR,ERI_MO_basis,eHF) + call cpu_time(end_GF2) + + t_GF2 = end_GF2 - start_GF2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute GF3 electronic binding energies +!------------------------------------------------------------------------ + + if(doGF3) then + + call cpu_time(start_GF3) + call GF3_diag(maxSCF_GF,thresh_GF,n_diis_GF,renormalization,nBas,nC,nO,nV,nR,ERI_MO_basis,eHF) + call cpu_time(end_GF3) + + t_GF3 = end_GF3 - start_GF3 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF3 = ',t_GF3,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform G0W0 calculatiom +!------------------------------------------------------------------------ + + eG0W0(:) = eHF(:,1) + + if(doG0W0) then + + call cpu_time(start_G0W0) + call G0W0(COHSEX,SOSEX,BSE,TDA,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,PHF,ERI_AO_basis,ERI_MO_basis,cHF,eHF,eG0W0) + call cpu_time(end_G0W0) + + t_G0W0 = end_G0W0 - start_G0W0 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0W0 = ',t_G0W0,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform evGW calculation +!------------------------------------------------------------------------ + + if(doevGW) then + + call cpu_time(start_evGW) + call evGW(maxSCF_GW,thresh_GW,n_diis_GW, & + COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold,linearize, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,ERI_AO_basis,ERI_MO_basis,PHF,cHF,eHF,eHF) + call cpu_time(end_evGW) + + t_evGW = end_evGW - start_evGW + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGW = ',t_evGW,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Perform qsGW calculation +!------------------------------------------------------------------------ + + if(doqsGW) then + + call cpu_time(start_qsGW) + call qsGW(maxSCF_GW,thresh_GW,n_diis_GW, & + COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,S,X,T,V,Hc,ERI_AO_basis,PHF,cHF,eHF) + call cpu_time(end_qsGW) + + t_qsGW = end_qsGW - start_qsGW + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGW = ',t_qsGW,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Compute e-N cusp dressing +!------------------------------------------------------------------------ + if(doeNcusp) then + + call cpu_time(start_eNcusp) +! call eNcusp() + call cpu_time(end_eNcusp) + + t_eNcusp = end_eNcusp - start_eNcusp + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for e-N cusp dressing = ',t_eNcusp,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Information for Monte Carlo calculations +!------------------------------------------------------------------------ + + if(doMCMP2 .or. doMinMCMP2) then + +! Print simulation details + + write(*,'(A32)') '----------------------' + write(*,'(A32,1X,I16)') 'Number of Monte Carlo steps',nMC + write(*,'(A32,1X,I16)') 'Number of equilibration steps',nEq + write(*,'(A32,1X,I16)') 'Number of walkers',nWalk + write(*,'(A32,1X,F16.10)') 'Initial time step',dt + write(*,'(A32,1X,I16)') 'Frequency of ouput',nPrint + write(*,'(A32,1X,I16)') 'Seed for random number generator',iSeed + write(*,'(A32)') '----------------------' + write(*,*) + +! Initialize random number generator + + call initialize_random_generator(iSeed) + +!------------------------------------------------------------------------ +! Type of weight function +!------------------------------------------------------------------------ +! TrialType = 0 => HF density +! TrialType = 1 => Custom one-electron function +!------------------------------------------------------------------------ + + TrialType = 0 + allocate(cTrial(nBas),gradient(nBas),hessian(nBas,nBas)) + + endif +!------------------------------------------------------------------------ +! Compute MC-MP2 energy +!------------------------------------------------------------------------ + + if(doMCMP2) then + + call cpu_time(start_MCMP2) + call MCMP2(doDrift,nBas,nC,nO,nV,cHF,eHF,EcMP2, & + nMC,nEq,nWalk,dt,nPrint, & + nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & + Norm,EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) +! call MCMP2(.false.,doDrift,nBas,nEl,nC,nO,nV,cHF,eHF,EcMP2, & +! nMC,nEq,nWalk,dt,nPrint, & +! nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! TrialType,Norm,cTrial,gradient,hessian, & +! EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) + call cpu_time(end_MCMP2) + + t_MCMP2 = end_MCMP2 - start_MCMP2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MC-MP2 = ',t_MCMP2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! Minimize MC-MP2 variance +!------------------------------------------------------------------------ + + if(doMinMCMP2) then + + call cpu_time(start_MinMCMP2) +! call MinMCMP2(nBas,nEl,nC,nO,nV,cHF,eHF,EcMP2, & +! nMC,nEq,nWalk,dt,nPrint, & +! nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! TrialType,Norm,cTrial,gradient,hessian) + call cpu_time(end_MinMCMP2) + + t_MinMCMP2 = end_MinMCMP2 - start_MinMCMP2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MC-MP2 variance minimization = ',t_MinMCMP2,' seconds' + write(*,*) + + endif + +!------------------------------------------------------------------------ +! End of QuAcK +!------------------------------------------------------------------------ +end program QuAcK diff --git a/src/QuAcK/RHF.f90 b/src/QuAcK/RHF.f90 new file mode 100644 index 0000000..25621d0 --- /dev/null +++ b/src/QuAcK/RHF.f90 @@ -0,0 +1,171 @@ +subroutine RHF(maxSCF,thresh,max_diis,guess_type,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis,guess_type + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + +! Output variables + + double precision,intent(out) :: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Restricted Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Guess coefficients and eigenvalues + + if(guess_type == 1) then + + Fp = matmul(transpose(X),matmul(Hc,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + elseif(guess_type == 2) then + + call random_number(c) + + endif + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| RHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! Density matrix + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + 0.5d0*trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = 0.5d0*trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine RHF diff --git a/src/QuAcK/SPHF.f90 b/src/QuAcK/SPHF.f90 new file mode 100644 index 0000000..e6cd623 --- /dev/null +++ b/src/QuAcK/SPHF.f90 @@ -0,0 +1,170 @@ +subroutine SPHF(maxSCF,thresh,max_diis,guess_type,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) + +! Perform restricted Hartree-Fock calculation + + implicit none + +! Input variables + + integer,intent(in) :: maxSCF,max_diis,guess_type + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),X(nBas,nBas) + +! Local variables + + integer :: nSCF,nBasSq,n_diis + double precision :: ET,EV,EJ,EK,Conv,Gap + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:),error_diis(:,:),F_diis(:,:) + double precision,allocatable :: J(:,:),K(:,:),cp(:,:),F(:,:),Fp(:,:) + +! Output variables + + double precision,intent(out) :: ERHF,c(nBas,nBas),e(nBas),P(nBas,nBas) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Restricted Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Guess coefficients and eigenvalues + + if(guess_type == 1) then + + Fp = matmul(transpose(X),matmul(Hc,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + elseif(guess_type == 2) then + + call random_number(c) + + endif + + P(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| SPHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + 2d0*K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! Density matrix + + P(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + + call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF) + +end subroutine SPHF diff --git a/src/QuAcK/SPMP2.f90 b/src/QuAcK/SPMP2.f90 new file mode 100644 index 0000000..d91d803 --- /dev/null +++ b/src/QuAcK/SPMP2.f90 @@ -0,0 +1,71 @@ +subroutine SPMP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) + +! Perform third-order Moller-Plesset calculation + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: ENuc,EHF + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + integer :: i,j,a,b + double precision :: eps,E2a,E2b + +! Output variables + + double precision,intent(out) :: EcMP2(3) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Moller-Plesset second-order calculation |' + write(*,*)'************************************************' + write(*,*) + +! Compute MP2 energy + + E2a = 0d0 + E2b = 0d0 + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = e(i) + e(j) - e(a) - e(b) + +! Secon-order ring diagram + + E2a = E2a + ERI(i,j,a,b)*ERI(i,j,a,b)/eps + +! Second-order exchange + + E2b = E2b + ERI(i,j,a,b)*ERI(i,j,b,a)/eps + + enddo + enddo + enddo + enddo + + EcMP2(2) = E2a + EcMP2(3) = -E2b + EcMP2(1) = EcMP2(2) + EcMP2(3) + + write(*,*) + write(*,'(A32)') '-----------------------' + write(*,'(A32)') ' MP2 calculation ' + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 correlation energy',EcMP2(1) + write(*,'(A32,1X,F16.10)') ' Direct part ',EcMP2(2) + write(*,'(A32,1X,F16.10)') ' Exchange part ',EcMP2(3) + write(*,'(A32)') '-----------------------' + write(*,'(A32,1X,F16.10)') ' MP2 electronic energy',EHF + EcMP2(1) + write(*,'(A32,1X,F16.10)') ' MP2 total energy',ENuc + EHF + EcMP2(1) + write(*,'(A32)') '-----------------------' + write(*,*) + +end subroutine SPMP2 diff --git a/src/QuAcK/SPTDHF.f90 b/src/QuAcK/SPTDHF.f90 new file mode 100644 index 0000000..6409607 --- /dev/null +++ b/src/QuAcK/SPTDHF.f90 @@ -0,0 +1,77 @@ +subroutine SPTDHF(singlet_manifold,triplet_manifold,nBas,nC,nO,nV,nR,nS,ERI,e) + +! Perform random phase approximation calculation + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + logical :: dRPA,TDA,BSE + integer :: ispin + double precision,allocatable :: Omega(:,:),XpY(:,:,:) + + double precision :: rho + double precision :: EcRPA + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Time-dependent Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Switch on exchange for TDHF + + dRPA = .false. + +! Switch off Tamm-Dancoff approximation for TDHF + + TDA = .false. + +! Switch off Bethe-Salpeter equation for TDHF + + BSE = .false. + +! Memory allocation + + allocate(Omega(nS,nspin),XpY(nS,nS,nspin)) + +! Singlet manifold + + if(singlet_manifold) then + + ispin = 1 + + call SP_linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + + +! Triplet manifold + + if(triplet_manifold) then + + ispin = 2 + + call SP_linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + +end subroutine SPTDHF diff --git a/src/QuAcK/SP_linear_response.f90 b/src/QuAcK/SP_linear_response.f90 new file mode 100644 index 0000000..e087397 --- /dev/null +++ b/src/QuAcK/SP_linear_response.f90 @@ -0,0 +1,81 @@ +subroutine SP_linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI,rho,EcRPA,Omega,XpY) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA,TDA,BSE + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas),rho(nBas,nBas,nS) + +! Local variables + + double precision :: trace_matrix + double precision,allocatable :: A(:,:),B(:,:),ApB(:,:),AmB(:,:),AmBSq(:,:),Z(:,:) + +! Output variables + + double precision,intent(out) :: EcRPA + double precision,intent(out) :: Omega(nS),XpY(nS,nS) + + +! Memory allocation + + allocate(A(nS,nS),B(nS,nS),ApB(nS,nS),AmB(nS,nS),AmBSq(nS,nS),Z(nS,nS)) + +! Build A and B matrices + + call SP_linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A) + if(BSE) call Bethe_Salpeter_A_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,A) + +! Tamm-Dancoff approximation + + B = 0d0 + if(.not. TDA) then + + call SP_linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B) + if(BSE) call Bethe_Salpeter_B_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,B) + + endif + +! Build A + B and A - B matrices + + AmB = A - B + ApB = A + B + +! print*,'A+B' +! call matout(nS,nS,ApB) + +! print*,'A-B' +! call matout(nS,nS,AmB) + +! Diagonalize TD-HF matrix + + call diagonalize_matrix(nS,AmB,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + call ADAt(nS,AmB,sqrt(Omega),AmBSq) + Z = matmul(AmBSq,matmul(ApB,AmBSq)) + + call diagonalize_matrix(nS,Z,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + Omega = sqrt(Omega) + XpY = matmul(transpose(Z),AmBSq) + call DA(nS,1d0/sqrt(Omega),XpY) + +! print*,'RPA excitations' +! call matout(nS,1,Omega) + +! Compute the RPA correlation energy + + EcRPA = 0.5d0*(sum(Omega) - trace_matrix(nS,A)) + +end subroutine SP_linear_response diff --git a/src/QuAcK/SP_linear_response_A_matrix.f90 b/src/QuAcK/SP_linear_response_A_matrix.f90 new file mode 100644 index 0000000..d95ebf4 --- /dev/null +++ b/src/QuAcK/SP_linear_response_A_matrix.f90 @@ -0,0 +1,56 @@ +subroutine SP_linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + double precision :: Kronecker_delta + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: A_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + A_lr(ia,jb) = (e(a) - e(i))*Kronecker_delta(i,j)*Kronecker_delta(a,b) & + + 0.5d0*(1d0 + delta_spin)*ERI(i,b,a,j) & + - (1d0 - delta_dRPA)*ERI(i,b,j,a) + + enddo + enddo + enddo + enddo + +end subroutine SP_linear_response_A_matrix diff --git a/src/QuAcK/SP_linear_response_B_matrix.f90 b/src/QuAcK/SP_linear_response_B_matrix.f90 new file mode 100644 index 0000000..6e60338 --- /dev/null +++ b/src/QuAcK/SP_linear_response_B_matrix.f90 @@ -0,0 +1,54 @@ +subroutine SP_linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: B_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + B_lr(ia,jb) = 0.5d0*(1d0 + delta_spin)*ERI(i,j,a,b) & + - (1d0 - delta_dRPA)*ERI(i,j,b,a) + + enddo + enddo + enddo + enddo + +end subroutine SP_linear_response_B_matrix diff --git a/src/QuAcK/TDHF.f90 b/src/QuAcK/TDHF.f90 new file mode 100644 index 0000000..1999792 --- /dev/null +++ b/src/QuAcK/TDHF.f90 @@ -0,0 +1,77 @@ +subroutine TDHF(singlet_manifold,triplet_manifold,nBas,nC,nO,nV,nR,nS,ERI,e) + +! Perform random phase approximation calculation + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + +! Local variables + + logical :: dRPA,TDA,BSE + integer :: ispin + double precision,allocatable :: Omega(:,:),XpY(:,:,:) + + double precision :: rho + double precision :: EcRPA + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Time-dependent Hartree-Fock calculation |' + write(*,*)'************************************************' + write(*,*) + +! Switch on exchange for TDHF + + dRPA = .false. + +! Switch off Tamm-Dancoff approximation for TDHF + + TDA = .false. + +! Switch off Bethe-Salpeter equation for TDHF + + BSE = .false. + +! Memory allocation + + allocate(Omega(nS,nspin),XpY(nS,nS,nspin)) + +! Singlet manifold + + if(singlet_manifold) then + + ispin = 1 + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + + +! Triplet manifold + + if(triplet_manifold) then + + ispin = 2 + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI, & + rho,EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('TDHF ',ispin,nS,Omega(:,ispin)) + + endif + +end subroutine TDHF diff --git a/src/QuAcK/UHF.f90 b/src/QuAcK/UHF.f90 new file mode 100644 index 0000000..dc230eb --- /dev/null +++ b/src/QuAcK/UHF.f90 @@ -0,0 +1,237 @@ +subroutine UHF(maxSCF,thresh,max_diis,guess_type,nBas,nO,S,T,V,Hc,ERI,X,ENuc,EUHF) + +! Perform unrestricted Hartree-Fock calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + integer,intent(in) :: max_diis + integer,intent(in) :: guess_type + double precision,intent(in) :: thresh + integer,intent(in) :: nBas + + integer,intent(in) :: nO(nspin) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas) + double precision,intent(in) :: V(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ENuc + +! Local variables + + integer :: nSCF + integer :: nBasSq + integer :: n_diis + double precision :: conv + double precision :: rcond(nspin) + double precision :: ET(nspin) + double precision :: EV(nspin) + double precision :: EJ(nsp) + double precision :: Ex(nspin) + double precision :: Ec(nsp) + double precision :: EUHF + + double precision,allocatable :: eps(:,:) + double precision,allocatable :: c(:,:,:) + double precision,allocatable :: cp(:,:,:) + double precision,allocatable :: J(:,:,:) + double precision,allocatable :: F(:,:,:) + double precision,allocatable :: Fp(:,:,:) + double precision,allocatable :: Fx(:,:,:) + double precision,allocatable :: err(:,:,:) + double precision,allocatable :: err_diis(:,:,:) + double precision,allocatable :: F_diis(:,:,:) + double precision,external :: trace_matrix + + double precision,allocatable :: P(:,:,:) + + integer :: ispin + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'* Unrestricted Hartree-Fock calculation *' + write(*,*)'************************************************' + write(*,*) + +! Useful stuff + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(eps(nBas,nspin),c(nBas,nBas,nspin),cp(nBas,nBas,nspin), & + J(nBas,nBas,nspin),F(nBas,nBas,nspin),Fp(nBas,nBas,nspin), & + Fx(nBas,nBas,nspin),err(nBas,nBas,nspin),P(nBas,nBas,nspin), & + err_diis(nBasSq,max_diis,nspin),F_diis(nBasSq,max_diis,nspin)) + +! Guess coefficients and eigenvalues + + if(guess_type == 1) then + + do ispin=1,nspin + F(:,:,ispin) = Hc(:,:) + end do + + else if(guess_type == 2) then + + do ispin=1,nspin + call random_number(F(:,:,ispin)) + end do + + end if + +! Initialization + + nSCF = 0 + conv = 1d0 + + n_diis = 0 + F_diis(:,:,:) = 0d0 + err_diis(:,:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + + write(*,*) + write(*,*)'------------------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A16,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','E(KS)','|','Ex(KS)','|','Ec(KS)','|','Conv','|' + write(*,*)'------------------------------------------------------------------------------------------' + + do while(conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Transform Fock matrix in orthogonal basis + + do ispin=1,nspin + Fp(:,:,ispin) = matmul(transpose(X(:,:)),matmul(F(:,:,ispin),X(:,:))) + end do + +! Diagonalize Fock matrix to get eigenvectors and eigenvalues + + cp(:,:,:) = Fp(:,:,:) + do ispin=1,nspin + call diagonalize_matrix(nBas,cp(:,:,ispin),eps(:,ispin)) + end do + +! Back-transform eigenvectors in non-orthogonal basis + + do ispin=1,nspin + c(:,:,ispin) = matmul(X(:,:),cp(:,:,ispin)) + end do + +! Compute density matrix + + do ispin=1,nspin + P(:,:,ispin) = matmul(c(:,1:nO(ispin),ispin),transpose(c(:,1:nO(ispin),ispin))) + end do + +! Build Coulomb repulsion + + do ispin=1,nspin + call Coulomb_matrix_AO_basis(nBas,P(:,:,ispin),ERI(:,:,:,:),J(:,:,ispin)) + end do + +! Compute exchange potential + + do ispin=1,nspin + call exchange_matrix_AO_basis(nBas,P(:,:,ispin),ERI(:,:,:,:),Fx(:,:,ispin)) + end do + +! Build Fock operator + do ispin=1,nspin + F(:,:,ispin) = Hc(:,:) + J(:,:,ispin) + J(:,:,mod(ispin,2)+1) + Fx(:,:,ispin) + end do + +! Check convergence + + do ispin=1,nspin + err(:,:,ispin) = matmul(F(:,:,ispin),matmul(P(:,:,ispin),S(:,:))) - matmul(matmul(S(:,:),P(:,:,ispin)),F(:,:,ispin)) + end do + + conv = maxval(abs(err(:,:,:))) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + do ispin=1,nspin + call DIIS_extrapolation(rcond(ispin),nBasSq,nBasSq,n_diis,err_diis(:,:,ispin),F_diis(:,:,ispin),err(:,:,ispin),F(:,:,ispin)) + end do + +! Reset DIIS if required + + if(minval(rcond(:)) < 1d-15) n_diis = 0 + +!------------------------------------------------------------------------ +! Compute UHF energy +!------------------------------------------------------------------------ + +! Kinetic energy + + do ispin=1,nspin + ET(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),T(:,:))) + end do + +! Potential energy + + do ispin=1,nspin + EV(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),V(:,:))) + end do + +! Coulomb energy + + EJ(1) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,1))) + EJ(2) = trace_matrix(nBas,matmul(P(:,:,1),J(:,:,2))) + EJ(3) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,2),J(:,:,2))) + +! Exchange energy + + do ispin=1,nspin + Ex(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),Fx(:,:,ispin))) + end do + +! Total energy + + EUHF = sum(ET(:)) + sum(EV(:)) + sum(EJ(:)) + sum(Ex(:)) + sum(Ec(:)) + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F16.10,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',EUHF + ENuc,'|',sum(Ex(:)),'|',sum(Ec(:)),'|',conv,'|' + + end do + write(*,*)'------------------------------------------------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + end if + +! Compute final UHF energy + + call print_UHF(nBas,nO(:),eps(:,:),c(:,:,:),ENuc,ET(:),EV(:),EJ(:),Ex(:),Ec(:),EUHF) + +end subroutine UHF diff --git a/src/QuAcK/antisymmetrize_ERI.f90 b/src/QuAcK/antisymmetrize_ERI.f90 new file mode 100644 index 0000000..034c94a --- /dev/null +++ b/src/QuAcK/antisymmetrize_ERI.f90 @@ -0,0 +1,46 @@ +subroutine antisymmetrize_ERI(ispin,nBas,ERI,db_ERI) + +! Antisymmetrize ERIs + + implicit none + +! Input variables + + integer,intent(in) :: ispin,nBas + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: i,j,k,l + +! Output variables + + double precision,intent(out) :: db_ERI(nBas,nBas,nBas,nBas) + + if(ispin == 1) then + + do i=1,nBas + do j=1,nBas + do k=1,nBas + do l=1,nBas + db_ERI(i,j,k,l) = 2d0*ERI(i,j,k,l) - ERI(i,j,l,k) + enddo + enddo + enddo + enddo + + elseif(ispin == 2) then + + do i=1,nBas + do j=1,nBas + do k=1,nBas + do l=1,nBas + db_ERI(i,j,k,l) = ERI(i,j,k,l) - ERI(i,j,l,k) + enddo + enddo + enddo + enddo + + endif + +end subroutine antisymmetrize_ERI diff --git a/src/QuAcK/chem_to_phys_ERI.f90 b/src/QuAcK/chem_to_phys_ERI.f90 new file mode 100644 index 0000000..9764bcb --- /dev/null +++ b/src/QuAcK/chem_to_phys_ERI.f90 @@ -0,0 +1,33 @@ +subroutine chem_to_phys_ERI(nBas,ERI) + +! Antisymmetrize ERIs + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(inout):: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: p,q,r,s + double precision,allocatable :: pERI(:,:,:,:) + + allocate(pERI(nBas,nBas,nBas,nBas)) + + do p=1,nBas + do q=1,nBas + do r=1,nBas + do s=1,nBas + + pERI(p,q,r,s) = ERI(p,r,q,s) + + enddo + enddo + enddo + enddo + + ERI(:,:,:,:) = pERI(:,:,:,:) + +end subroutine chem_to_phys_ERI diff --git a/src/QuAcK/dcgw.f90 b/src/QuAcK/dcgw.f90 new file mode 100644 index 0000000..e67ff3b --- /dev/null +++ b/src/QuAcK/dcgw.f90 @@ -0,0 +1,84 @@ +function SigC_dcgw(x,y) result(SigC) + +! Degeneracy-corrected GW + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: x,y + +! Local variables + + double precision,parameter :: eta = 0.1d0 + double precision :: r + +! Output variables + + double precision :: SigC + +! Compute the divergence-free term + + r = y/x + +! Bare style + + SigC = y*r + +! DCPT style + +! SigC = -0.5d0*x*(1d0-sqrt(1d0+4d0*r*r)) + +! QDPT style + +! SigC = y*r/sqrt(1d0+4d0*r*r) + +! Infinitesimal + +! SigC = y*y*x/(x*x+eta*eta) + +end function SigC_dcgw + +function Z_dcgw(x,y) result(Z) + + +! Derivative of the degeneracy-corrected GW + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: x,y + +! Local variables + + double precision,parameter :: eta = 1d0 + double precision :: r + +! Output variables + + double precision :: Z + +! Compute the divergence-free term + + r = y/x + +! Bare style + + Z = r*r + +! DCPT style + +! Z = 0.5d0*(1d0-1d0/sqrt(1d0+4d0*r*r)) + +! QDPT style + +! Z = r/sqrt(1d0+4d0*r*r)/(1d0+4d0*r*r) + +! Infinitesimal + +! Z = y*y*(x*x-eta*eta)/(x*x+eta*eta)**2 + +end function Z_dcgw diff --git a/src/QuAcK/density.f90 b/src/QuAcK/density.f90 new file mode 100644 index 0000000..90a17c1 --- /dev/null +++ b/src/QuAcK/density.f90 @@ -0,0 +1,51 @@ +subroutine density(doDrift,nBas,nWalk,P,gAO,dgAO,g,dg) + +! Calculate the Green functions + + implicit none + +! Input variables + + logical,intent(in) :: doDrift + integer,intent(in) :: nBas,nWalk + double precision,intent(in) :: P(nBas,nBas),gAO(nWalk,2,nBas),dgAO(nWalk,2,3,nBas) + +! Local variables + + integer :: iW,iEl,ixyz,mu,nu + +! Output variables + + double precision,intent(out) :: g(nWalk,2),dg(nWalk,2,3) + + g = 0d0 + do iW=1,nWalk + do iEl=1,2 + do mu=1,nBas + do nu=1,nBas + g(iW,iEl) = g(iW,iEl) + gAO(iW,iEl,mu)*P(mu,nu)*gAO(iW,iEl,nu) + enddo + enddo + enddo + enddo + + if(doDrift) then + + dg = 0d0 + do iW=1,nWalk + do iEl=1,2 + do ixyz=1,3 + do mu=1,nBas + do nu=1,nBas + dg(iW,iEl,ixyz) = dg(iW,iEl,ixyz) & + + P(mu,nu)*(dgAO(iW,iEl,ixyz,mu)*gAO(iW,iEl,nu) & + + gAO(iW,iEl,mu)*dgAO(iW,iEl,ixyz,nu)) + enddo + enddo + enddo + enddo + enddo + + endif + +end subroutine density diff --git a/src/QuAcK/density_matrix.f90 b/src/QuAcK/density_matrix.f90 new file mode 100644 index 0000000..3556388 --- /dev/null +++ b/src/QuAcK/density_matrix.f90 @@ -0,0 +1,30 @@ +subroutine density_matrix(nBas,ON,c,P) + +! Compute density matrix based on the occupation numbers + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: ON(nBas),c(nBas,nBas) + +! Local variables + + integer :: mu,nu,i + +! Output variables + + double precision,intent(out) :: P(nBas,nBas) + + P(:,:) = 0d0 + + do mu=1,nBas + do nu=1,nBas + do i=1,nBas + P(mu,nu) = P(mu,nu) + 2d0*ON(i)*c(mu,i)*c(nu,i) + enddo + enddo + enddo + +end subroutine density_matrix diff --git a/src/QuAcK/drift.f90 b/src/QuAcK/drift.f90 new file mode 100644 index 0000000..0a002e0 --- /dev/null +++ b/src/QuAcK/drift.f90 @@ -0,0 +1,50 @@ +subroutine drift(nWalk,r,r12,g,dg,F) + +! Compute quantum force + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nWalk + double precision,intent(in) :: r(nWalk,2,3),r12(nWalk),g(nWalk,2),dg(nWalk,2,3) + +! Local variables + + logical :: smoothDrift + double precision :: rij,rijSq,w,wSq,damp + integer :: iW + +! Output variables + + double precision,intent(out) :: F(nWalk,2,3) + +! Compute + + smoothDrift = .false. + w = 0.1d0 + wSq = w*w + + do iW=1,nWalk + + rij = r12(iW) + rijSq = rij*rij + + F(iW,1,1:3) = dg(iW,1,1:3)/g(iW,1) + F(iW,2,1:3) = dg(iW,2,1:3)/g(iW,2) + + if(smoothDrift) then + damp = 1d0 + 2d0*w/sqrt(pi)*rij*exp(-wSq*rijSq)/erfc(w*rij) + else + damp = 1d0 + endif + + F(iW,1,1:3) = F(iW,1,1:3) - damp*(r(iW,2,1:3) - r(iW,1,1:3))/rijSq + F(iW,2,1:3) = F(iW,2,1:3) - damp*(r(iW,2,1:3) - r(iW,1,1:3))/rijSq + + enddo + +! print*,' F',F + +end subroutine drift diff --git a/src/QuAcK/elements.f90 b/src/QuAcK/elements.f90 new file mode 100644 index 0000000..22953dc --- /dev/null +++ b/src/QuAcK/elements.f90 @@ -0,0 +1,170 @@ +function element_number(element_name) + + implicit none + + integer,parameter :: nelement_max = 103 + character(len=2),intent(in) :: element_name + integer :: element_number + character(len=2),parameter :: element_list(nelement_max) = & + (/' H', 'He', & ! 2 + 'Li','Be', ' B',' C',' N',' O',' F','Ne', & ! 10 + 'Na','Mg', 'Al','Si',' P',' S','Cl','Ar', & ! 18 + ' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr', & ! 36 + 'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te',' I','Xe', & ! 54 + 'Cs','Ba', & ! 56 + 'La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', & ! 70 + 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn', & ! 86 + 'Fr','Ra', & ! 88 + 'Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md','No', & ! 102 + 'Lr' & ! 103 + /) + +!===== + integer :: ielement +!===== + + ielement=1 + do while( ADJUSTL(element_name) /= ADJUSTL(element_list(ielement)) ) + if( ielement == nelement_max ) then + write(*,'(a,a)') ' Input symbol ',element_name + write(*,'(a,i3,a)') ' Element symbol is not one of first ',nelement_max,' elements' + write(*,*) '!!! element symbol not understood !!!' + stop + endif + ielement = ielement + 1 + enddo + + element_number = ielement + +end function element_number + +function element_core(zval,zatom) + implicit none + double precision,intent(in) :: zval + double precision,intent(in) :: zatom + integer :: element_core +!===== + + ! + ! If zval /= zatom, this is certainly an effective core potential + ! and no core states should be frozen. + if( ABS(zval - zatom) > 1d0-3 ) then + element_core = 0 + else + + if( zval <= 4.00001d0 ) then ! up to Be + element_core = 0 + else if( zval <= 12.00001d0 ) then ! up to Mg + element_core = 1 + else if( zval <= 30.00001d0 ) then ! up to Ca + element_core = 5 + else if( zval <= 48.00001d0 ) then ! up to Sr + element_core = 9 + else + write(*,*) '!!! not imlemented in element_core !!!' + stop + endif + + endif + + +end function element_core + +function element_covalent_radius(zatom) + +! Return covalent radius of an atom + + implicit none + include 'parameters.h' + + integer,intent(in) :: zatom + double precision :: element_covalent_radius + + ! + ! Data from Cambridge Structural Database + ! http://en.wikipedia.org/wiki/Covalent_radius + ! + ! Values are first given in picometer + ! They will be converted in bohr later on + select case(zatom) + case( 1) + element_covalent_radius = 31. + case( 2) + element_covalent_radius = 28. + case( 3) + element_covalent_radius = 128. + case( 4) + element_covalent_radius = 96. + case( 5) + element_covalent_radius = 84. + case( 6) + element_covalent_radius = 73. + case( 7) + element_covalent_radius = 71. + case( 8) + element_covalent_radius = 66. + case( 9) + element_covalent_radius = 57. + case(10) ! Ne. + element_covalent_radius = 58. + case(11) + element_covalent_radius = 166. + case(12) + element_covalent_radius = 141. + case(13) + element_covalent_radius = 121. + case(14) + element_covalent_radius = 111. + case(15) + element_covalent_radius = 107. + case(16) + element_covalent_radius = 105. + case(17) + element_covalent_radius = 102. + case(18) ! Ar. + element_covalent_radius = 106. + case(19) + element_covalent_radius = 203. + case(20) + element_covalent_radius = 176. + case(21) + element_covalent_radius = 170. + case(22) + element_covalent_radius = 160. + case(23) + element_covalent_radius = 153. + case(24) + element_covalent_radius = 139. + case(25) + element_covalent_radius = 145. + case(26) + element_covalent_radius = 145. + case(27) + element_covalent_radius = 140. + case(28) + element_covalent_radius = 124. + case(29) + element_covalent_radius = 132. + case(30) + element_covalent_radius = 122. + case(31) + element_covalent_radius = 120. + case(32) + element_covalent_radius = 119. + case(34) + element_covalent_radius = 120. + case(35) + element_covalent_radius = 120. + case(36) ! Kr. + element_covalent_radius = 116. + case default + write(*,*) '!!! covalent radius not available !!!' + stop + end select + + ! pm to bohr conversion + element_covalent_radius = element_covalent_radius*pmtoau + + +end function element_covalent_radius + diff --git a/src/QuAcK/evGW.f90 b/src/QuAcK/evGW.f90 new file mode 100644 index 0000000..12bfb51 --- /dev/null +++ b/src/QuAcK/evGW.f90 @@ -0,0 +1,207 @@ +subroutine evGW(maxSCF,thresh,max_diis,COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold,linearize, & + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,Hc,ERI_AO_basis,ERI_MO_basis,PHF,cHF,eHF,eG0W0) + +! Perform self-consistent eigenvalue-only GW calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh,ENuc,ERHF + logical,intent(in) :: COHSEX,SOSEX,BSE,TDA,G0W,GW0 + logical,intent(in) :: singlet_manifold,triplet_manifold,linearize + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: cHF(nBas,nBas),eHF(nBas),eG0W0(nBas),Hc(nBas,nBas),PHF(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas),ERI_MO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA,linear_mixing + integer :: ispin,nSCF,n_diis + double precision :: Conv,EcRPA,lambda + double precision,allocatable :: error_diis(:,:),e_diis(:,:) + double precision,allocatable :: eGW(:),eOld(:),Z(:) + double precision,allocatable :: H(:,:),SigmaC(:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:),rhox(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent evGW calculation |' + write(*,*)'************************************************' + write(*,*) + +! SOSEX correction + + if(SOSEX) write(*,*) 'SOSEX correction activated!' + write(*,*) + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Linear mixing + + linear_mixing = .false. + lambda = 0.2d0 + +! Memory allocation + + allocate(eGW(nBas),eOld(nBas),Z(nBas), & + H(nBas,nBas),SigmaC(nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin), & + rho(nBas,nBas,nS,nspin),rhox(nBas,nBas,nS,nspin), & + error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + +! Initialization + + nSCF = 0 + ispin = 1 + n_diis = 0 + Conv = 1d0 + e_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + eGW(:) = eG0W0(:) + eOld(:) = eGW(:) + Z(:) = 1d0 + +! Compute Hartree Hamiltonian in the MO basis + + call Hartree_matrix_MO_basis(nBas,cHF,PHF,Hc,ERI_AO_basis,H) + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Compute linear response + + if(.not. GW0 .or. nSCF == 0) then + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + + endif + +! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + if(SOSEX) call excitation_density_SOSEX(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rhox(:,:,:,ispin)) + + ! Correlation self-energy + + if(G0W) then + + call self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eHF, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigmaC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + else + + call self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eGW, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),SigmaC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eGW,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + endif + + ! Solve the quasi-particle equation (linearized or not) + + if(linearize) then + + eGW(:) = eHF(:) + Z(:)*SigmaC(:) + + else + + eGW(:) = eHF(:) + SigmaC(:) + + endif + + ! Convergence criteria + + Conv = maxval(abs(eGW - eOld)) + + ! Print results + + call print_excitation('RPA ',ispin,nS,Omega(:,ispin)) + call print_evGW(nBas,nO,nSCF,Conv,eHF,ENuc,ERHF,SigmaC,Z,eGW,EcRPA) + + ! Linear mixing or DIIS extrapolation + + if(linear_mixing) then + + eGW(:) = lambda*eGW(:) + (1d0 - lambda)*eOld(:) + + else + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBas,nBas,n_diis,error_diis,e_diis,eGW-eOld,eGW) + + endif + + ! Save quasiparticles energy for next cycle + + eOld(:) = eGW(:) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Plot stuff + + call plot_GW(nBas,nC,nO,nV,nR,nS,eHF,eGW,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin)) + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + if(BSE) stop + + endif + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,cHF,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,eGW,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + +end subroutine evGW diff --git a/src/QuAcK/exchange_matrix_AO_basis.f90 b/src/QuAcK/exchange_matrix_AO_basis.f90 new file mode 100644 index 0000000..b60a59a --- /dev/null +++ b/src/QuAcK/exchange_matrix_AO_basis.f90 @@ -0,0 +1,35 @@ +subroutine exchange_matrix_AO_basis(nBas,P,G,K) + +! Compute exchange matrix in the AO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(out) :: K(nBas,nBas) + + K = 0d0 + do nu=1,nBas + do si=1,nBas + do la=1,nBas + do mu=1,nBas + K(mu,nu) = K(mu,nu) + P(la,si)*G(mu,la,si,nu) + enddo + enddo + enddo + enddo + + K = -0.5d0*K + +end subroutine exchange_matrix_AO_basis diff --git a/src/QuAcK/exchange_matrix_MO_basis.f90 b/src/QuAcK/exchange_matrix_MO_basis.f90 new file mode 100644 index 0000000..5cb13b1 --- /dev/null +++ b/src/QuAcK/exchange_matrix_MO_basis.f90 @@ -0,0 +1,26 @@ +subroutine exchange_matrix_MO_basis(nBas,c,P,G,K) + +! Compute exchange matrix in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas) + double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: K(nBas,nBas) + +! Compute Hartree Hamiltonian in the AO basis + + call exchange_matrix_AO_basis(nBas,P,G,K) + +! Transform Coulomb matrix in the MO basis + + K = matmul(transpose(c),matmul(K,c)) + +end subroutine exchange_matrix_MO_basis diff --git a/src/QuAcK/excitation_density.f90 b/src/QuAcK/excitation_density.f90 new file mode 100644 index 0000000..db8f222 --- /dev/null +++ b/src/QuAcK/excitation_density.f90 @@ -0,0 +1,65 @@ +subroutine excitation_density(nBas,nC,nO,nR,nS,c,G,XpY,rho) + +! Compute excitation densities + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nR,nS + double precision,intent(in) :: c(nBas,nBas),G(nBas,nBas,nBas,nBas),XpY(nS,nS) + +! Local variables + + double precision,allocatable :: scr(:,:,:) + integer :: mu,nu,la,si,ia,jb,x,y,j,b + +! Output variables + + double precision,intent(out) :: rho(nBas,nBas,nS) + +! Memory allocation + allocate(scr(nBas,nBas,nS)) + + rho(:,:,:) = 0d0 + do nu=1,nBas + do si=1,nBas + do ia=1,nS + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + rho(nu,si,ia) = rho(nu,si,ia) + c(nu,j)*XpY(ia,jb)*c(si,b) + enddo + enddo + enddo + enddo + enddo + + scr(:,:,:) = 0d0 + do mu=1,nBas + do la=1,nBas + do ia=1,nS + do nu=1,nBas + do si=1,nBas + scr(mu,la,ia) = scr(mu,la,ia) + G(mu,nu,la,si)*rho(nu,si,ia) + enddo + enddo + enddo + enddo + enddo + + rho(:,:,:) = 0d0 + do ia=1,nS + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do mu=1,nBas + do la=1,nBas + rho(x,y,ia) = rho(x,y,ia) + c(mu,x)*scr(mu,la,ia)*c(la,y) + enddo + enddo + enddo + enddo + enddo + +end subroutine excitation_density diff --git a/src/QuAcK/excitation_density_SOSEX.f90 b/src/QuAcK/excitation_density_SOSEX.f90 new file mode 100644 index 0000000..53c9a66 --- /dev/null +++ b/src/QuAcK/excitation_density_SOSEX.f90 @@ -0,0 +1,65 @@ +subroutine excitation_density_SOSEX(nBas,nC,nO,nR,nS,c,G,XpY,rho) + +! Compute excitation densities + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nR,nS + double precision,intent(in) :: c(nBas,nBas),G(nBas,nBas,nBas,nBas),XpY(nS,nS) + +! Local variables + + double precision,allocatable :: scr(:,:,:) + integer :: mu,nu,la,si,ia,jb,x,y,j,b + +! Output variables + + double precision,intent(out) :: rho(nBas,nBas,nS) + +! Memory allocation + allocate(scr(nBas,nBas,nS)) + + rho(:,:,:) = 0d0 + do nu=1,nBas + do si=1,nBas + do ia=1,nS + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + rho(nu,si,ia) = rho(nu,si,ia) + c(nu,j)*XpY(ia,jb)*c(si,b) + enddo + enddo + enddo + enddo + enddo + + scr(:,:,:) = 0d0 + do mu=1,nBas + do la=1,nBas + do ia=1,nS + do nu=1,nBas + do si=1,nBas + scr(mu,la,ia) = scr(mu,la,ia) + G(mu,nu,la,si)*rho(nu,si,ia) + enddo + enddo + enddo + enddo + enddo + + rho(:,:,:) = 0d0 + do ia=1,nS + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do mu=1,nBas + do la=1,nBas + rho(x,y,ia) = rho(x,y,ia) + c(mu,x)*scr(mu,la,ia)*c(la,y) + enddo + enddo + enddo + enddo + enddo + +end subroutine excitation_density_SOSEX diff --git a/src/QuAcK/excitation_density_SOSEX_from_MO.f90 b/src/QuAcK/excitation_density_SOSEX_from_MO.f90 new file mode 100644 index 0000000..0127887 --- /dev/null +++ b/src/QuAcK/excitation_density_SOSEX_from_MO.f90 @@ -0,0 +1,35 @@ +subroutine excitation_density_SOSEX_from_MO(nBas,nC,nO,nR,nS,G,XpY,rho) + +! Compute excitation densities + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nR,nS + double precision,intent(in) :: G(nBas,nBas,nBas,nBas),XpY(nS,nS) + +! Local variables + + integer :: ia,jb,x,y,j,b + +! Output variables + + double precision,intent(out) :: rho(nBas,nBas,nS) + + rho(:,:,:) = 0d0 + do ia=1,nS + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + rho(x,y,ia) = rho(x,y,ia) + G(x,y,b,j)*XpY(ia,jb) + enddo + enddo + enddo + enddo + enddo + +end subroutine excitation_density_SOSEX_from_MO diff --git a/src/QuAcK/excitation_density_from_MO.f90 b/src/QuAcK/excitation_density_from_MO.f90 new file mode 100644 index 0000000..ec5d854 --- /dev/null +++ b/src/QuAcK/excitation_density_from_MO.f90 @@ -0,0 +1,35 @@ +subroutine excitation_density_from_MO(nBas,nC,nO,nR,nS,G,XpY,rho) + +! Compute excitation densities + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nR,nS + double precision,intent(in) :: G(nBas,nBas,nBas,nBas),XpY(nS,nS) + +! Local variables + + integer :: ia,jb,x,y,j,b + +! Output variables + + double precision,intent(out) :: rho(nBas,nBas,nS) + + rho(:,:,:) = 0d0 + do ia=1,nS + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + rho(x,y,ia) = rho(x,y,ia) + G(x,j,y,b)*XpY(ia,jb) + enddo + enddo + enddo + enddo + enddo + +end subroutine excitation_density_from_MO diff --git a/src/QuAcK/form_T.f90 b/src/QuAcK/form_T.f90 new file mode 100644 index 0000000..dc66b63 --- /dev/null +++ b/src/QuAcK/form_T.f90 @@ -0,0 +1,46 @@ +subroutine form_T(nO,nV,delta_OOOVVV,ub,ubb,EcCCT) + +! Compute (T) correction + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: delta_OOOVVV(nO,nO,nO,nV,nV,nV) + double precision,intent(in) :: ub(nO,nO,nO,nV,nV,nV) + double precision,intent(in) :: ubb(nO,nO,nO,nV,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: EcCCT + + EcCCT = 0d0 + + do i=1,nO + do j=1,nO + do k=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + + EcCCT = EcCCT & + + (ub(i,j,k,a,b,c) + ubb(i,j,k,a,b,c)) & + * ubb(i,j,k,a,b,c)/delta_OOOVVV(i,j,k,a,b,c) + + end do + end do + end do + end do + end do + end do + + EcCCT = - EcCCT/36d0 + +end subroutine form_T diff --git a/src/QuAcK/form_X.f90 b/src/QuAcK/form_X.f90 new file mode 100644 index 0000000..9f2eeb5 --- /dev/null +++ b/src/QuAcK/form_X.f90 @@ -0,0 +1,92 @@ +subroutine form_X(nO,nV,OOVV,t2,X1,X2,X3,X4) + +! Form intermediate arrays X's in CCD + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: t2(nO,nO,nV,nV) + double precision,intent(in) :: OOVV(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: X1(nO,nO,nO,nO) + double precision,intent(out) :: X2(nV,nV) + double precision,intent(out) :: X3(nO,nO) + double precision,intent(out) :: X4(nO,nO,nV,nV) + +! Initialization + + X1(:,:,:,:) = 0d0 + X2(:,:) = 0d0 + X3(:,:) = 0d0 + X4(:,:,:,:) = 0d0 + +! Build X1 + + do k=1,nO + do l=1,nO + do i=1,nO + do j=1,nO + do c=1,nV + do d=1,nV + X1(k,l,i,j) = X1(k,l,i,j) + OOVV(k,l,c,d)*t2(i,j,c,d) + enddo + enddo + enddo + enddo + enddo + enddo + +! Build X2 + + do b=1,nV + do c=1,nV + do k=1,nO + do l=1,nO + do d=1,nV + X2(b,c) = X2(b,c) + OOVV(k,l,c,d)*t2(k,l,b,d) + enddo + enddo + enddo + enddo + enddo + +! Build X3 + + do k=1,nO + do j=1,nO + do l=1,nO + do c=1,nV + do d=1,nV + X3(k,j) = X3(k,j) + OOVV(k,l,c,d)*t2(j,l,c,d) + enddo + enddo + enddo + enddo + enddo + +! Build X4 + + do i=1,nO + do l=1,nO + do a=1,nV + do d=1,nV + do k=1,nO + do c=1,nV + X4(i,l,a,d) = X4(i,l,a,d) + OOVV(k,l,c,d)*t2(i,k,a,c) + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine form_X diff --git a/src/QuAcK/form_abh.f90 b/src/QuAcK/form_abh.f90 new file mode 100644 index 0000000..4b0efcc --- /dev/null +++ b/src/QuAcK/form_abh.f90 @@ -0,0 +1,105 @@ +subroutine form_abh(nO,nV,OOOO,OVOO,OOVV,VVVV,VOVV,OVVO,OVVV,t1,tau,aoooo,bvvvv,hovvo) + +! Scuseria Eqs. (11),(12) and (13) + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: OOOO(nO,nO,nO,nO) + double precision,intent(in) :: OVOO(nO,nV,nO,nO) + double precision,intent(in) :: OOVV(nO,nO,nV,nV) + double precision,intent(in) :: OVVO(nO,nV,nV,nO) + double precision,intent(in) :: OVVV(nO,nV,nV,nV) + double precision,intent(in) :: VOVV(nV,nO,nV,nV) + double precision,intent(in) :: VVVV(nV,nV,nV,nV) + + double precision,intent(in) :: t1(nO,nV) + double precision,intent(in) :: tau(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: aoooo(nO,nO,nO,nO) + double precision,intent(out) :: bvvvv(nV,nV,nV,nV) + double precision,intent(out) :: hovvo(nO,nV,nV,nO) + + aoooo(:,:,:,:) = OOOO(:,:,:,:) + + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + + do c=1,nV + aoooo(i,j,k,l) = aoooo(i,j,k,l) + OVOO(i,c,k,l)*t1(j,c) + end do + + do c=1,nV + aoooo(i,j,k,l) = aoooo(i,j,k,l) - OVOO(j,c,k,l)*t1(i,c) + end do + + do c=1,nV + do d=1,nV + aoooo(i,j,k,l) = aoooo(i,j,k,l) + OOVV(k,l,c,d)*tau(i,j,c,d) + end do + end do + + end do + end do + end do + end do + + bvvvv(:,:,:,:) = VVVV(:,:,:,:) + + do c=1,nV + do d=1,nV + do a=1,nV + do b=1,nV + + do k=1,nO + bvvvv(c,d,a,b) = bvvvv(c,d,a,b) - VOVV(a,k,c,d)*t1(k,b) + end do + + do k=1,nO + bvvvv(c,d,a,b) = bvvvv(c,d,a,b) + VOVV(b,k,c,d)*t1(k,a) + end do + + end do + end do + end do + end do + + hovvo(:,:,:,:) = OVVO(:,:,:,:) + + do i=1,nO + do c=1,nV + do a=1,nV + do k=1,nO + + do l=1,nO + hovvo(i,c,a,k) = hovvo(i,c,a,k) - OVOO(i,c,l,k)*t1(l,a) + end do + + do d=1,nV + hovvo(i,c,a,k) = hovvo(i,c,a,k) + OVVV(k,a,c,d)*t1(i,d) + end do + + do l=1,nO + do d=1,nV + hovvo(i,c,a,k) = hovvo(i,c,a,k) - OOVV(k,l,c,d)*tau(i,l,d,a) + end do + end do + + end do + end do + end do + end do + +end subroutine form_abh diff --git a/src/QuAcK/form_delta_OOOVVV.f90 b/src/QuAcK/form_delta_OOOVVV.f90 new file mode 100644 index 0000000..973b579 --- /dev/null +++ b/src/QuAcK/form_delta_OOOVVV.f90 @@ -0,0 +1,37 @@ +subroutine form_delta_OOOVVV(nO,nV,eO,eV,delta) + +! Form energy denominator for CC + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: eO(nO) + double precision,intent(in) :: eV(nV) + +! Local variables + + integer :: i,j,k,a,b,c + +! Output variables + + double precision,intent(out) :: delta(nO,nO,nO,nV,nV,nV) + + do i=1,nO + do j=1,nO + do k=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + + delta(i,j,k,a,b,c) = eV(a) + eV(b) + eV(c) - eO(i) - eO(j) - eO(k) + + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine form_delta_OOOVVV diff --git a/src/QuAcK/form_delta_OOVV.f90 b/src/QuAcK/form_delta_OOVV.f90 new file mode 100644 index 0000000..15bb6d9 --- /dev/null +++ b/src/QuAcK/form_delta_OOVV.f90 @@ -0,0 +1,33 @@ +subroutine form_delta_OOVV(nO,nV,eO,eV,delta) + +! Form energy denominator for CC + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: eO(nO) + double precision,intent(in) :: eV(nV) + +! Local variables + + integer :: i,j,a,b + +! Output variables + + double precision,intent(out) :: delta(nO,nO,nV,nV) + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + + delta(i,j,a,b) = eV(a) + eV(b) - eO(i) - eO(j) + + enddo + enddo + enddo + enddo + +end subroutine form_delta_OOVV diff --git a/src/QuAcK/form_delta_OV.f90 b/src/QuAcK/form_delta_OV.f90 new file mode 100644 index 0000000..e785a0c --- /dev/null +++ b/src/QuAcK/form_delta_OV.f90 @@ -0,0 +1,27 @@ +subroutine form_delta_OV(nO,nV,eO,eV,delta) + +! Form energy denominator for CC + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: eO(nO) + double precision,intent(in) :: eV(nV) + +! Local variables + + integer :: i,a + +! Output variables + + double precision,intent(out) :: delta(nO,nV) + + do i=1,nO + do a=1,nV + delta(i,a) = eV(a) - eO(i) + enddo + enddo + +end subroutine form_delta_OV diff --git a/src/QuAcK/form_g.f90 b/src/QuAcK/form_g.f90 new file mode 100644 index 0000000..ebb8427 --- /dev/null +++ b/src/QuAcK/form_g.f90 @@ -0,0 +1,53 @@ +subroutine form_g(nO,nV,hvv,hoo,VOVV,OOOV,t1,gvv,goo) + +! Scuseria Eqs. (9), (10) + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: hvv(nV,nV) + double precision,intent(in) :: hoo(nO,nO) + + double precision,intent(in) :: VOVV(nV,nO,nV,nV) + double precision,intent(in) :: OOOV(nO,nO,nO,nV) + + double precision,intent(in) :: t1(nO,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: gvv(nV,nV) + double precision,intent(out) :: goo(nO,nO) + + gvv(:,:) = hvv(:,:) + + do c=1,nV + do a=1,nV + do k=1,nO + do d=1,nV + gvv(c,a) = gvv(c,a) + VOVV(a,k,c,d)*t1(k,d) + end do + end do + end do + end do + + goo(:,:) = hoo(:,:) + + do i=1,nO + do k=1,nO + do l=1,nO + do c=1,nV + goo(i,k) = goo(i,k) + OOOV(k,l,i,c)*t1(l,c) + end do + end do + end do + end do + +end subroutine form_g diff --git a/src/QuAcK/form_h.f90 b/src/QuAcK/form_h.f90 new file mode 100644 index 0000000..4bc16f1 --- /dev/null +++ b/src/QuAcK/form_h.f90 @@ -0,0 +1,79 @@ +subroutine form_h(nO,nV,eO,eV,OOVV,t1,tau,hvv,hoo,hvo) + +! Scuseria Eqs. (5), (6) and (7) + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: eO(nO) + double precision,intent(in) :: eV(nV) + double precision,intent(in) :: OOVV(nO,nO,nV,nV) + + double precision,intent(in) :: t1(nO,nV) + double precision,intent(in) :: tau(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: hvv(nV,nV) + double precision,intent(out) :: hoo(nO,nO) + double precision,intent(out) :: hvo(nV,nO) + + hvv(:,:) = 0d0 + + do b=1,nV + hvv(b,b) = eV(b) + do a=1,nV + do j=1,nO + do k=1,nO + do c=1,nV + + hvv(b,a) = hvv(b,a) - OOVV(j,k,b,c)*tau(j,k,a,c) + + end do + end do + end do + end do + end do + + hoo(:,:) = 0d0 + + do i=1,nO + hoo(i,i) = eO(i) + do j=1,nO + do k=1,nO + do b=1,nV + do c=1,nV + + hoo(i,j) = hoo(i,j) + OOVV(j,k,b,c)*tau(i,k,b,c) + + end do + end do + end do + end do + end do + + hvo(:,:) = 0d0 + + do b=1,nV + do j=1,nO + do k=1,nO + do c=1,nV + + hvo(b,j) = hvo(b,j) + OOVV(j,k,b,c)*t1(k,c) + + end do + end do + end do + end do + +! print*,'hvv',hvv + +end subroutine form_h diff --git a/src/QuAcK/form_r1.f90 b/src/QuAcK/form_r1.f90 new file mode 100644 index 0000000..ab1bd57 --- /dev/null +++ b/src/QuAcK/form_r1.f90 @@ -0,0 +1,77 @@ +subroutine form_r1(nO,nV,OVVO,OVVV,OOOV,hvv,hoo,hvo,t1,t2,tau,r1) + +! Form tau in CCSD + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: OVVO(nO,nV,nV,nO) + double precision,intent(in) :: OVVV(nO,nV,nV,nV) + double precision,intent(in) :: OOOV(nO,nO,nO,nV) + + + double precision,intent(in) :: hvv(nV,nV) + double precision,intent(in) :: hoo(nO,nO) + double precision,intent(in) :: hvo(nV,nO) + + double precision,intent(in) :: t1(nO,nV) + double precision,intent(in) :: t2(nO,nO,nV,nV) + double precision,intent(in) :: tau(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: r1(nO,nV) + + r1(:,:) = 0d0 + + do i=1,nO + do a=1,nV + + do b=1,nV + r1(i,a) = r1(i,a) + hvv(b,a)*t1(i,b) + end do + + do j=1,nO + r1(i,a) = r1(i,a) - hoo(i,j)*t1(j,a) + end do + + do j=1,nO + do b=1,nV + r1(i,a) = r1(i,a) + hvo(b,j)*(t2(i,j,a,b) + t1(i,b)*t1(j,a)) + end do + end do + + do j=1,nO + do b=1,nV + r1(i,a) = r1(i,a) + OVVO(i,b,a,j)*t1(j,b) + end do + end do + + do j=1,nO + do b=1,nV + do c=1,nV + r1(i,a) = r1(i,a) - OVVV(j,a,b,c)*tau(i,j,b,c) + end do + end do + end do + + do j=1,nO + do k=1,nO + do b=1,nV + r1(i,a) = r1(i,a) - OOOV(j,k,i,b)*tau(j,k,a,b) + end do + end do + end do + + end do + end do + +end subroutine form_r1 diff --git a/src/QuAcK/form_r2.f90 b/src/QuAcK/form_r2.f90 new file mode 100644 index 0000000..c57b8a8 --- /dev/null +++ b/src/QuAcK/form_r2.f90 @@ -0,0 +1,139 @@ +subroutine form_r2(nO,nV,OOVV,OVOO,OVVV,OVVO,gvv,goo,aoooo,bvvvv,hovvo,t1,t2,tau,r2) + +! Form tau in CCSD + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: OOVV(nO,nO,nV,nV) + double precision,intent(in) :: OVOO(nO,nV,nO,nO) + double precision,intent(in) :: OVVV(nO,nV,nV,nV) + double precision,intent(in) :: OVVO(nO,nV,nV,nO) + + double precision,intent(in) :: gvv(nV,nV) + double precision,intent(in) :: goo(nO,nO) + double precision,intent(in) :: aoooo(nO,nO,nO,nO) + double precision,intent(in) :: bvvvv(nV,nV,nV,nV) + double precision,intent(in) :: hovvo(nO,nV,nV,nO) + + double precision,intent(in) :: t1(nO,nV) + double precision,intent(in) :: t2(nO,nO,nV,nV) + double precision,intent(in) :: tau(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: r2(nO,nO,nV,nV) + + r2(:,:,:,:) = OOVV(:,:,:,:) + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + + do k=1,nO + do l=1,nO + r2(i,j,a,b) = r2(i,j,a,b) + aoooo(i,j,k,l)*tau(k,l,a,b) + end do + end do + + do c=1,nV + do d=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + bvvvv(c,d,a,b)*tau(i,j,c,d) + end do + end do + + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + gvv(c,a)*t2(i,j,c,b) + end do + + do k=1,nO + r2(i,j,a,b) = r2(i,j,a,b) + OVOO(k,a,i,j)*t1(k,b) + end do + + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) - gvv(c,b)*t2(i,j,c,a) + end do + + do k=1,nO + r2(i,j,a,b) = r2(i,j,a,b) - OVOO(k,b,i,j)*t1(k,a) + end do + + do k=1,nO + r2(i,j,a,b) = r2(i,j,a,b) - goo(i,k)*t2(k,j,a,b) + end do + + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + OVVV(j,c,b,a)*t1(i,c) + end do + + do k=1,nO + r2(i,j,a,b) = r2(i,j,a,b) + goo(j,k)*t2(k,i,a,b) + end do + + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) - OVVV(i,c,b,a)*t1(j,c) + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + hovvo(i,c,a,k)*t2(j,k,b,c) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) - OVVO(i,c,a,k)*t1(j,c)*t1(k,b) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) - hovvo(j,c,a,k)*t2(i,k,b,c) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + OVVO(j,c,a,k)*t1(i,c)*t1(k,b) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) - hovvo(i,c,b,k)*t2(j,k,a,c) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + OVVO(i,c,b,k)*t1(j,c)*t1(k,a) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) + hovvo(j,c,b,k)*t2(i,k,a,c) + end do + end do + + do k=1,nO + do c=1,nV + r2(i,j,a,b) = r2(i,j,a,b) - OVVO(j,c,b,k)*t1(i,c)*t1(k,a) + end do + end do + + end do + end do + end do + end do + +end subroutine form_r2 diff --git a/src/QuAcK/form_tau.f90 b/src/QuAcK/form_tau.f90 new file mode 100644 index 0000000..d666383 --- /dev/null +++ b/src/QuAcK/form_tau.f90 @@ -0,0 +1,34 @@ +subroutine form_tau(nO,nV,t1,t2,tau) + +! Form tau in CCSD + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: t1(nO,nV) + double precision,intent(in) :: t2(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: tau(nO,nO,nV,nV) + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + + tau(i,j,a,b) = 0.5d0*t2(i,j,a,b) + t1(i,a)*t1(j,b) + + enddo + enddo + enddo + enddo + +end subroutine form_tau diff --git a/src/QuAcK/form_u.f90 b/src/QuAcK/form_u.f90 new file mode 100644 index 0000000..c8fc76d --- /dev/null +++ b/src/QuAcK/form_u.f90 @@ -0,0 +1,71 @@ +subroutine form_u(nO,nV,OOOO,VVVV,OVOV,t2,u) + +! Form linear array in CCD + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: t2(nO,nO,nV,nV) + double precision,intent(in) :: OOOO(nO,nO,nO,nO) + double precision,intent(in) :: VVVV(nV,nV,nV,nV) + double precision,intent(in) :: OVOV(nO,nV,nO,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: u(nO,nO,nV,nV) + + u(:,:,:,:) = 0d0 + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + do d=1,nV + u(i,j,a,b) = u(i,j,a,b) + 0.5d0*VVVV(a,b,c,d)*t2(i,j,c,d) + enddo + enddo + enddo + enddo + enddo + enddo + + do i=1,nO + do j=1,nO + do k=1,nO + do l=1,nO + do a=1,nV + do b=1,nV + u(i,j,a,b) = u(i,j,a,b) + 0.5d0*OOOO(k,l,i,j)*t2(k,l,a,b) + enddo + enddo + enddo + enddo + enddo + enddo + + do i=1,nO + do j=1,nO + do k=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + u(i,j,a,b) = u(i,j,a,b) - OVOV(k,b,j,c)*t2(i,k,a,c) & + + OVOV(k,a,j,c)*t2(i,k,b,c) & + - OVOV(k,a,i,c)*t2(j,k,b,c) & + + OVOV(k,b,i,c)*t2(j,k,a,c) + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine form_u diff --git a/src/QuAcK/form_ub.f90 b/src/QuAcK/form_ub.f90 new file mode 100644 index 0000000..14f8d9c --- /dev/null +++ b/src/QuAcK/form_ub.f90 @@ -0,0 +1,48 @@ +subroutine form_ub(nO,nV,OOVV,t1,ub) + +! Form 1st term in (T) correction + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: OOVV(nO,nO,nV,nV) + + double precision,intent(in) :: t1(nO,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: ub(nO,nO,nO,nV,nV,nV) + + do i=1,nO + do j=1,nO + do k=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + + ub(i,j,k,a,b,c) = t1(i,a)*OOVV(j,k,b,c) & + + t1(i,b)*OOVV(j,k,c,a) & + + t1(i,c)*OOVV(j,k,a,b) & + + t1(j,a)*OOVV(k,i,b,c) & + + t1(j,b)*OOVV(k,i,c,a) & + + t1(j,c)*OOVV(k,i,a,b) & + + t1(k,a)*OOVV(i,j,b,c) & + + t1(k,b)*OOVV(i,j,c,a) & + + t1(k,c)*OOVV(i,j,a,b) + + end do + end do + end do + end do + end do + end do + +end subroutine form_ub diff --git a/src/QuAcK/form_ubb.f90 b/src/QuAcK/form_ubb.f90 new file mode 100644 index 0000000..5beaa6e --- /dev/null +++ b/src/QuAcK/form_ubb.f90 @@ -0,0 +1,67 @@ +subroutine form_ubb(nO,nV,VVVO,VOOO,t2,ubb) + +! Form 2nd term in (T) correction + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + + double precision,intent(in) :: VVVO(nV,nV,nV,nO) + double precision,intent(in) :: VOOO(nV,nO,nO,nO) + + double precision,intent(in) :: t2(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l,m + integer :: a,b,c,d,e + +! Output variables + + double precision,intent(out) :: ubb(nO,nO,nO,nV,nV,nV) + + ubb(:,:,:,:,:,:) = 0d0 + + do i=1,nO + do j=1,nO + do k=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + + do e=1,nV + ubb(i,j,k,a,b,c) = ubb(i,j,k,a,b,c) & + + t2(i,j,a,e)*VVVO(b,c,e,k) & + + t2(i,j,b,e)*VVVO(c,a,e,k) & + + t2(i,j,c,e)*VVVO(a,b,e,k) & + + t2(k,i,a,e)*VVVO(b,c,e,j) & + + t2(k,i,b,e)*VVVO(c,a,e,j) & + + t2(k,i,c,e)*VVVO(a,b,e,j) & + + t2(j,k,a,e)*VVVO(b,c,e,i) & + + t2(j,k,b,e)*VVVO(c,a,e,i) & + + t2(j,k,c,e)*VVVO(a,b,e,i) + end do + + do m=1,nO + ubb(i,j,k,a,b,c) = ubb(i,j,k,a,b,c) & + + t2(i,m,a,b)*VOOO(c,m,j,k) & + + t2(i,m,b,c)*VOOO(a,m,j,k) & + + t2(i,m,c,a)*VOOO(b,m,j,k) & + + t2(j,m,a,b)*VOOO(c,m,k,i) & + + t2(j,m,b,c)*VOOO(a,m,k,i) & + + t2(j,m,c,a)*VOOO(b,m,k,i) & + + t2(k,m,a,b)*VOOO(c,m,i,j) & + + t2(k,m,b,c)*VOOO(a,m,i,j) & + + t2(k,m,c,a)*VOOO(b,m,i,j) + end do + + end do + end do + end do + end do + end do + end do + +end subroutine form_ubb diff --git a/src/QuAcK/form_v.f90 b/src/QuAcK/form_v.f90 new file mode 100644 index 0000000..f589d31 --- /dev/null +++ b/src/QuAcK/form_v.f90 @@ -0,0 +1,79 @@ +subroutine form_v(nO,nV,X1,X2,X3,X4,t2,v) + +! Form quadratic array in CCD + + implicit none + +! Input variables + + integer,intent(in) :: nO,nV + double precision,intent(in) :: t2(nO,nO,nV,nV) + double precision,intent(in) :: X1(nO,nO,nO,nO) + double precision,intent(in) :: X2(nV,nV) + double precision,intent(in) :: X3(nO,nO) + double precision,intent(in) :: X4(nO,nO,nV,nV) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + +! Output variables + + double precision,intent(out) :: v(nO,nO,nV,nV) + + v(:,:,:,:) = 0d0 + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + do k=1,nO + do l=1,nO + v(i,j,a,b) = v(i,j,a,b) + 0.25d0*X1(k,l,i,j)*t2(k,l,a,b) + enddo + enddo + enddo + enddo + enddo + enddo + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + do c=1,nV + v(i,j,a,b) = v(i,j,a,b) - 0.5d0*(X2(b,c)*t2(i,j,a,c) + X2(a,c)*t2(i,j,c,b)) + enddo + enddo + enddo + enddo + enddo + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + do k=1,nO + v(i,j,a,b) = v(i,j,a,b) - 0.5d0*(X3(k,j)*t2(i,k,a,b) + X3(k,i)*t2(k,j,a,b)) + enddo + enddo + enddo + enddo + enddo + + do i=1,nO + do j=1,nO + do a=1,nV + do b=1,nV + do k=1,nO + do c=1,nV + v(i,j,a,b) = v(i,j,a,b) + (X4(i,k,a,c)*t2(j,k,b,c) + X4(i,k,b,c)*t2(k,j,a,c)) + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine form_v diff --git a/src/QuAcK/generate_shell.f90 b/src/QuAcK/generate_shell.f90 new file mode 100644 index 0000000..0a13b8f --- /dev/null +++ b/src/QuAcK/generate_shell.f90 @@ -0,0 +1,30 @@ +subroutine generate_shell(atot,nShellFunction,ShellFunction) + + implicit none + +! Input variables + + integer,intent(in) :: atot,nShellFunction + +! Local variables + + integer :: ax,ay,az,ia + +! Output variables + + integer,intent(out) :: ShellFunction(nShellFunction,3) + + ia = 0 + do ax=atot,0,-1 + do az=0,atot + ay = atot - ax - az + if(ay >= 0) then + ia = ia + 1 + ShellFunction(ia,1) = ax + ShellFunction(ia,2) = ay + ShellFunction(ia,3) = az + endif + enddo + enddo + +end subroutine generate_shell diff --git a/src/QuAcK/initialize_random_generator.f90 b/src/QuAcK/initialize_random_generator.f90 new file mode 100644 index 0000000..189c36b --- /dev/null +++ b/src/QuAcK/initialize_random_generator.f90 @@ -0,0 +1,25 @@ +subroutine initialize_random_generator(iSeed) + +! Initialize random number generator + + implicit none + +! Input variables + + integer,intent(in) :: iSeed + +! Local variables + + integer,allocatable :: Seed(:) + integer :: nSeed + + call random_seed(size = nSeed) + allocate(Seed(nSeed)) + call random_seed(get=Seed) + if(iSeed /= 0) then + Seed = 0 + Seed(1) = iSeed + endif + call random_seed(put=Seed) + +end subroutine initialize_random_generator diff --git a/src/QuAcK/linear_response.f90 b/src/QuAcK/linear_response.f90 new file mode 100644 index 0000000..7a21e58 --- /dev/null +++ b/src/QuAcK/linear_response.f90 @@ -0,0 +1,81 @@ +subroutine linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI,rho,EcRPA,Omega,XpY) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA,TDA,BSE + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas),rho(nBas,nBas,nS) + +! Local variables + + double precision :: trace_matrix + double precision,allocatable :: A(:,:),B(:,:),ApB(:,:),AmB(:,:),AmBSq(:,:),Z(:,:) + +! Output variables + + double precision,intent(out) :: EcRPA + double precision,intent(out) :: Omega(nS),XpY(nS,nS) + + +! Memory allocation + + allocate(A(nS,nS),B(nS,nS),ApB(nS,nS),AmB(nS,nS),AmBSq(nS,nS),Z(nS,nS)) + +! Build A and B matrices + + call linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A) + if(BSE) call Bethe_Salpeter_A_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,A) + +! Tamm-Dancoff approximation + + B = 0d0 + if(.not. TDA) then + + call linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B) + if(BSE) call Bethe_Salpeter_B_matrix(nBas,nC,nO,nV,nR,nS,ERI,Omega,rho,B) + + endif + +! Build A + B and A - B matrices + + AmB = A - B + ApB = A + B + +! print*,'A+B' +! call matout(nS,nS,ApB) + +! print*,'A-B' +! call matout(nS,nS,AmB) + +! Diagonalize TD-HF matrix + + call diagonalize_matrix(nS,AmB,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + call ADAt(nS,AmB,sqrt(Omega),AmBSq) + Z = matmul(AmBSq,matmul(ApB,AmBSq)) + + call diagonalize_matrix(nS,Z,Omega) + + if(minval(Omega) < 0d0) & + call print_warning('You may have instabilities in linear response!!') + + Omega = sqrt(Omega) + XpY = matmul(transpose(Z),AmBSq) + call DA(nS,1d0/sqrt(Omega),XpY) + +! print*,'RPA excitations' +! call matout(nS,1,Omega) + +! Compute the RPA correlation energy + + EcRPA = 0.5d0*(sum(Omega) - trace_matrix(nS,A)) + +end subroutine linear_response diff --git a/src/QuAcK/linear_response_A_matrix.f90 b/src/QuAcK/linear_response_A_matrix.f90 new file mode 100644 index 0000000..c61ffd9 --- /dev/null +++ b/src/QuAcK/linear_response_A_matrix.f90 @@ -0,0 +1,56 @@ +subroutine linear_response_A_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,e,ERI,A_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + double precision :: Kronecker_delta + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: A_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + A_lr(ia,jb) = (e(a) - e(i))*Kronecker_delta(i,j)*Kronecker_delta(a,b) & + + (1d0 + delta_spin)*ERI(i,b,a,j) & + - (1d0 - delta_dRPA)*ERI(i,b,j,a) + + enddo + enddo + enddo + enddo + +end subroutine linear_response_A_matrix diff --git a/src/QuAcK/linear_response_B_matrix.f90 b/src/QuAcK/linear_response_B_matrix.f90 new file mode 100644 index 0000000..17e5a85 --- /dev/null +++ b/src/QuAcK/linear_response_B_matrix.f90 @@ -0,0 +1,54 @@ +subroutine linear_response_B_matrix(ispin,dRPA,nBas,nC,nO,nV,nR,nS,ERI,B_lr) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: dRPA + integer,intent(in) :: ispin,nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + double precision :: delta_spin,delta_dRPA + + integer :: i,j,a,b,ia,jb + +! Output variables + + double precision,intent(out) :: B_lr(nS,nS) + +! Singlet or triplet manifold? + + delta_spin = 0d0 + if(ispin == 1) delta_spin = +1d0 + if(ispin == 2) delta_spin = -1d0 + +! Direct RPA + + delta_dRPA = 0d0 + if(dRPA) delta_dRPA = 1d0 + +! Build A matrix + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + B_lr(ia,jb) = (1d0 + delta_spin)*ERI(i,j,a,b) & + - (1d0 - delta_dRPA)*ERI(i,j,b,a) + + enddo + enddo + enddo + enddo + +end subroutine linear_response_B_matrix diff --git a/src/QuAcK/natural_orbital.f90 b/src/QuAcK/natural_orbital.f90 new file mode 100644 index 0000000..14717a9 --- /dev/null +++ b/src/QuAcK/natural_orbital.f90 @@ -0,0 +1,57 @@ +subroutine natural_orbital(nBas,nO,cHF,c) + +! Compute natural orbitals and natural occupancies + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: cHF(nBas,nBas),c(nBas,nBas) + +! Local variables + + integer :: i,j,k + double precision,allocatable :: eNO(:),cNO(:,:),P(:,:) + +! Allocate + + allocate(eNO(nBas),cNO(nBas,nBas),P(nBas,nBas)) + +! Compute density matrix + + P = matmul(transpose(cHF),cHF) + + call matout(nBas,nBas,P) + + cNO = 0d0 + + do i=1,nBas + do j=1,nBas + do k=1,1 + cNO(i,j) = cNO(i,j) + 2d0*P(i,k)*P(j,k) + enddo + enddo + enddo + +! cNO(:,:) = matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! cNO = matmul(transpose(cHF),matmul(cNO,cHF)) + + call diagonalize_matrix(nBas,cNO,eNO) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Natural orbitals ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,cNO) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Natural occupancies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eNO) + write(*,*) + +end subroutine natural_orbital diff --git a/src/QuAcK/norm_trial.f90 b/src/QuAcK/norm_trial.f90 new file mode 100644 index 0000000..4ca9e9c --- /dev/null +++ b/src/QuAcK/norm_trial.f90 @@ -0,0 +1,53 @@ +subroutine norm_trial(nBas,nO,c,P,Norm,NormSq) + +! Initialize weight function + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nO + double precision,intent(inout):: c(nBas,nO),P(nBas,nBas) + +! Local variables + + double precision,allocatable :: S(:,:),T(:,:),V(:,:),Hc(:,:),G(:,:,:,:) + + integer :: mu,nu,la,si + +! Output variables + + double precision,intent(inout):: Norm,NormSq + +! Memory allocation for one- and two-electron integrals + + allocate(S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),G(nBas,nBas,nBas,nBas)) + +! Read integrals + + call read_integrals(nBas,S,T,V,Hc,G) + +! Compute normalization factor + + P = 2d0*matmul(c,transpose(c)) + + Norm = 0d0 + do mu=1,nBas + do nu=1,nBas + do la=1,nBas + do si=1,nBas + Norm = Norm + P(mu,nu)*P(la,si)*G(mu,la,nu,si) + enddo + enddo + enddo + enddo + + Norm = Norm*Norm + NormSq = Norm*Norm + + write(*,*) + write(*,*) 'Normalization of trial wave function: ',Norm + write(*,*) + +end subroutine norm_trial diff --git a/src/QuAcK/optimize_timestep.f90 b/src/QuAcK/optimize_timestep.f90 new file mode 100644 index 0000000..916854a --- /dev/null +++ b/src/QuAcK/optimize_timestep.f90 @@ -0,0 +1,28 @@ +subroutine optimize_timestep(nWalk,iMC,Acc,dt) + +! Optimize dt to get 50% of accepted moves + + implicit none + +! Input variables + + integer,intent(in) :: nWalk,iMC + double precision,intent(inout):: Acc,dt + +! Local variables + + double precision :: TotAcc,Current_Acc,Target_Acc,delta + + TotAcc = Acc/dble(nWalk) + Current_Acc = 100d0*TotAcc/dble(iMC) + + Target_Acc = 50.0d0 + + delta = dt*abs(Target_Acc - Current_Acc)/100.d0 + if(Current_Acc > Target_Acc + 0.5d0)then + dt = dt + delta + elseif(Current_Acc < Target_Acc - 0.5d0)then + dt = dt - delta + endif + +end subroutine optimize_timestep diff --git a/src/QuAcK/orthogonalization_matrix.f90 b/src/QuAcK/orthogonalization_matrix.f90 new file mode 100644 index 0000000..15ea4ac --- /dev/null +++ b/src/QuAcK/orthogonalization_matrix.f90 @@ -0,0 +1,120 @@ +subroutine orthogonalization_matrix(ortho_type,nBas,S,X) + +! Compute the orthogonalization matrix X + + implicit none + +! Input variables + + integer,intent(in) :: nBas,ortho_type + double precision,intent(in) :: S(nBas,nBas) + +! Local variables + + logical :: debug + double precision,allocatable :: UVec(:,:),Uval(:) + double precision,parameter :: thresh = 1d-6 + + integer :: i + +! Output variables + + double precision,intent(out) :: X(nBas,nBas) + + debug = .false. + +! Type of orthogonalization ortho_type +! +! 1 = Lowdin +! 2 = Canonical +! 3 = SVD +! + + allocate(Uvec(nBas,nBas),Uval(nBas)) + + if(ortho_type == 1) then + + write(*,*) + write(*,*) ' Lowdin orthogonalization' + write(*,*) + + Uvec = S + call diagonalize_matrix(nBas,Uvec,Uval) + + do i=1,nBas + + if(Uval(i) > thresh) then + + Uval(i) = 1d0/sqrt(Uval(i)) + + else + + write(*,*) 'Eigenvalue',i,'too small for Lowdin orthogonalization' + + endif + + enddo + + call ADAt(nBas,Uvec,Uval,X) + + elseif(ortho_type == 2) then + + write(*,*) + write(*,*) 'Canonical orthogonalization' + write(*,*) + + Uvec = S + call diagonalize_matrix(nBas,Uvec,Uval) + + do i=1,nBas + + if(Uval(i) > thresh) then + + Uval(i) = 1d0/sqrt(Uval(i)) + + else + + write(*,*) ' Eigenvalue',i,'too small for canonical orthogonalization' + + endif + + enddo + + call AD(nBas,Uvec,Uval) + X = Uvec + + elseif(ortho_type == 3) then + + write(*,*) + write(*,*) ' SVD-based orthogonalization NYI' + write(*,*) + +! Uvec = S +! call diagonalize_matrix(nBas,Uvec,Uval) + +! do i=1,nBas +! if(Uval(i) > thresh) then +! Uval(i) = 1d0/sqrt(Uval(i)) +! else +! write(*,*) 'Eigenvalue',i,'too small for canonical orthogonalization' +! endif +! enddo +! +! call AD(nBas,Uvec,Uval) +! X = Uvec + + endif + +! Print results + + if(debug) then + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Orthogonalization matrix' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,X) + write(*,*) + + endif + +end subroutine orthogonalization_matrix diff --git a/src/QuAcK/overlap.f90 b/src/QuAcK/overlap.f90 new file mode 100644 index 0000000..bb38800 --- /dev/null +++ b/src/QuAcK/overlap.f90 @@ -0,0 +1,40 @@ +subroutine overlap(nBas,bra,ket) + +! Compute the overlap between two sets of coefficients + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: bra(nBas,nBas),ket(nBas,nBas) + +! Local variables + + double precision,allocatable :: s(:),Ov(:,:) + +! Allocate + + allocate(s(nBas),Ov(nBas,nBas)) + +! Compute overlap + + Ov = matmul(transpose(bra),ket) + + call diagonalize_matrix(nBas,Ov,s) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' Overlap ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,Ov) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' Eigenvalues of overlap matrix' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,s) + write(*,*) + +end subroutine overlap diff --git a/src/QuAcK/plot_GW.f90 b/src/QuAcK/plot_GW.f90 new file mode 100644 index 0000000..11c7f0c --- /dev/null +++ b/src/QuAcK/plot_GW.f90 @@ -0,0 +1,113 @@ +subroutine plot_GW(nBas,nC,nO,nV,nR,nS,eHF,eGW,Omega,rho,rhox) + +! Dump several GW quantities for external plotting + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: eHF(nBas),eGW(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,jb,g + integer :: nGrid + double precision :: eps,eta,wmin,wmax,dw + double precision,allocatable :: w(:),SigC(:,:),Z(:,:),S(:,:) + +! Infinitesimal + + eta = 1d-3 + +! Construct grid + + nGrid = 1000 + allocate(w(nGrid),SigC(nBas,nGrid),Z(nBas,nGrid),S(nBas,nGrid)) + +! Initialize + + SigC(:,:) = 0d0 + Z(:,:) = 0d0 + +! Minimum and maximum frequency values + + wmin = -5d0 + wmax = +5d0 + dw = (wmax - wmin)/dble(ngrid) + + do g=1,nGrid + w(g) = wmin + dble(g)*dw + enddo + +! Occupied part of the self-energy and renormalization factor + + do g=1,nGrid + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = w(g) - eHF(i) + Omega(jb) + SigC(x,g) = SigC(x,g) + 2d0*rho(x,i,jb)**2*eps/(eps**2 + eta**2) + Z(x,g) = Z(x,g) + 2d0*rho(x,i,jb)**2/eps**2 + enddo + enddo + enddo + enddo + enddo + +! Virtual part of the self-energy and renormalization factor + + do g=1,nGrid + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = w(g) - eHF(a) - Omega(jb) + SigC(x,g) = SigC(x,g) + 2d0*rho(x,a,jb)**2*eps/(eps**2 + eta**2) + Z(x,g) = Z(x,g) + 2d0*rho(x,a,jb)**2/eps**2 + enddo + enddo + enddo + enddo + enddo + + Z(:,:) = 1d0/(1d0 + Z(:,:)) + +! Compute spectral function + + do g=1,nGrid + do x=nC+1,nBas-nR + S(x,g) = eta/((w(g) - eHF(x) - SigC(x,g))**2 + eta**2) + enddo + enddo + + S(:,:) = S(:,:)/pi + +! Dump quantities in files as a function of w + + open(unit=8 ,file='plot/grid.dat') + open(unit=9 ,file='plot/SigC.dat') + open(unit=10 ,file='plot/Z.dat') + open(unit=11 ,file='plot/A.dat') + + do g=1,nGrid + write(8 ,*) w(g)*HaToeV,(SigC(x,g)*HaToeV,x=1,nBas) + write(9 ,*) w(g)*HaToeV,((w(g)-eHF(x))*HaToeV,x=1,nBas) + write(10,*) w(g)*HaToeV,(Z(x,g),x=1,nBas) + write(11,*) w(g)*HaToeV,(S(x,g),x=1,nBas) + enddo + +! Closing files + + close(unit=8) + close(unit=9) + close(unit=10) + close(unit=11) + +end subroutine plot_GW diff --git a/src/QuAcK/print_G0W0.f90 b/src/QuAcK/print_G0W0.f90 new file mode 100644 index 0000000..e069f4c --- /dev/null +++ b/src/QuAcK/print_G0W0.f90 @@ -0,0 +1,49 @@ +subroutine print_G0W0(nBas,nO,e,ENuc,EHF,SigmaC,Z,eGW,EcRPA,EcGM) + +! Print one-electron energies and other stuff for G0W0 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: ENuc,EHF,EcRPA,EcGM + double precision,intent(in) :: e(nBas),SigmaC(nBas),Z(nBas),eGW(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGW(LUMO)-eGW(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + write(*,*)' One-shot G0W0 calculation' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sigma_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',e(x)*HaToeV,'|',SigmaC(x)*HaToeV,'|',Z(x),'|',eGW(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'G0W0 HOMO energy (eV):',eGW(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'G0W0 LUMO energy (eV):',eGW(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'G0W0 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'G0W0 RPA total energy =',ENuc + EHF + EcRPA + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,'(2X,A27,F15.6)') 'G0W0 GM total energy =',ENuc + EHF + EcGM + write(*,'(2X,A27,F15.6)') 'GM correlation energy =',EcGM + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine print_G0W0 + + diff --git a/src/QuAcK/print_GF2.f90 b/src/QuAcK/print_GF2.f90 new file mode 100644 index 0000000..98a3933 --- /dev/null +++ b/src/QuAcK/print_GF2.f90 @@ -0,0 +1,44 @@ +subroutine print_GF2(nBas,nO,nSCF,Conv,eHF,eGF2) + +! Print one-electron energies and other stuff for GF2 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: Conv,eHF(nBas),eGF2(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGF2(LUMO)-eGF2(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------' + write(*,*)' Frequency-dependent diagonal GF2 calculation' + write(*,*)'-------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','e_GF2 (eV)','|' + write(*,*)'-------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',eHF(x)*HaToeV,'|',eGF2(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------' + write(*,'(2X,A27,F15.6)') 'GF2 HOMO energy (eV):',eGF2(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF2 LUMO energy (eV):',eGF2(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF2 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------' + write(*,*) + +end subroutine print_GF2 diff --git a/src/QuAcK/print_GF3.f90 b/src/QuAcK/print_GF3.f90 new file mode 100644 index 0000000..cf0634b --- /dev/null +++ b/src/QuAcK/print_GF3.f90 @@ -0,0 +1,44 @@ +subroutine print_GF3(nBas,nO,nSCF,Conv,eHF,Z,eGF3) + +! Print one-electron energies and other stuff for GF3 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: Conv,eHF(nBas),eGF3(nBas),Z(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGF3(LUMO)-eGF3(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------' + write(*,*)' Frequency-dependent diagonal GF3 calculation' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Z','|','e_GF3 (eV)','|' + write(*,*)'-------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',eHF(x)*HaToeV,'|',Z(x),'|',eGF3(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'GF3 HOMO energy (eV):',eGF3(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF3 LUMO energy (eV):',eGF3(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'GF3 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------------------------' + write(*,*) + +end subroutine print_GF3 diff --git a/src/QuAcK/print_RHF.f90 b/src/QuAcK/print_RHF.f90 new file mode 100644 index 0000000..eef7055 --- /dev/null +++ b/src/QuAcK/print_RHF.f90 @@ -0,0 +1,60 @@ +subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF) + +! Print one-electron energies and other stuff for G0W0 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO + double precision,intent(in) :: eHF(nBas),cHF(nBas,nBas),ENuc,ET,EV,EJ,EK,ERHF + + integer :: HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eHF(LUMO)-eHF(HOMO) + +! Dump results + + + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Summary ' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' One-electron energy ',ET + EV + write(*,'(A32,1X,F16.10)') ' Kinetic energy ',ET + write(*,'(A32,1X,F16.10)') ' Potential energy ',EV + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Two-electron energy ',EJ + EK + write(*,'(A32,1X,F16.10)') ' Coulomb energy ',EJ + write(*,'(A32,1X,F16.10)') ' Exchange energy ',EK + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Electronic energy ',ERHF + write(*,'(A32,1X,F16.10)') ' Nuclear repulsion ',ENuc + write(*,'(A32,1X,F16.10)') ' Hartree-Fock energy ',ERHF + ENuc + write(*,'(A50)') '---------------------------------------' + write(*,'(A36,F13.6)') ' HF HOMO energy (eV):',eHF(HOMO)*HaToeV + write(*,'(A36,F13.6)') ' HF LUMO energy (eV):',eHF(LUMO)*HaToeV + write(*,'(A36,F13.6)') ' HF HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,'(A50)') '---------------------------------------' + write(*,*) + +! Print results + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') 'MO coefficients' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,cHF) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') 'MO energies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eHF) + write(*,*) + +end subroutine print_RHF + + diff --git a/src/QuAcK/print_UHF.f90 b/src/QuAcK/print_UHF.f90 new file mode 100644 index 0000000..d0a16c1 --- /dev/null +++ b/src/QuAcK/print_UHF.f90 @@ -0,0 +1,102 @@ +subroutine print_UHF(nBas,nO,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew) + +! Print one- and two-electron energies and other stuff for UHF calculation + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas + integer,intent(in) :: nO(nspin) + double precision,intent(in) :: eps(nBas,nspin) + double precision,intent(in) :: c(nBas,nBas,nspin) + double precision,intent(in) :: ENuc + double precision,intent(in) :: ET(nspin) + double precision,intent(in) :: EV(nspin) + double precision,intent(in) :: EJ(nsp) + double precision,intent(in) :: Ex(nspin) + double precision,intent(in) :: Ec(nsp) + double precision,intent(in) :: Ew + + integer :: HOMO(nspin) + integer :: LUMO(nspin) + double precision :: Gap(nspin) + +! HOMO and LUMO + + HOMO(:) = nO(:) + + LUMO(:) = HOMO(:) + 1 + + Gap(1) = eps(LUMO(1),1) - eps(HOMO(1),1) + Gap(2) = eps(LUMO(2),2) - eps(HOMO(2),2) + +! Dump results + + + write(*,*) + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40)') ' Summary ' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.10,A3)') ' One-electron energy: ',sum(ET(:)) + sum(EV(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' One-electron a energy: ',ET(1) + EV(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' One-electron b energy: ',ET(2) + EV(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Kinetic energy: ',sum(ET(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Kinetic a energy: ',ET(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Kinetic b energy: ',ET(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Potential energy: ',sum(EV(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Potential a energy: ',EV(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Potential b energy: ',EV(2),' au' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron a energy: ',sum(EJ(:)) + sum(Ex(:)) + sum(Ec(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron aa energy: ',EJ(1) + Ex(1) + Ec(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron ab energy: ',EJ(2) + Ec(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron bb energy: ',EJ(3) + Ex(2) + Ec(3),' au' + write(*,'(A40,1X,F16.10,A3)') ' Coulomb energy: ',sum(EJ(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Coulomb aa energy: ',EJ(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Coulomb ab energy: ',EJ(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Coulomb bb energy: ',EJ(3),' au' + write(*,'(A40,1X,F16.10,A3)') ' Exchange energy: ',sum(Ex(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Exchange a energy: ',Ex(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Exchange b energy: ',Ex(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation energy: ',sum(Ec(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation aa energy: ',Ec(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation ab energy: ',Ec(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation bb energy: ',Ec(3),' au' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.10,A3)') ' Electronic energy: ',Ew,' au' + write(*,'(A40,1X,F16.10,A3)') ' Nuclear repulsion: ',ENuc,' au' + write(*,'(A40,1X,F16.10,A3)') ' UHF energy: ',Ew + ENuc,' au' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,F13.6,A3)') ' UHF HOMO a energy:',eps(HOMO(1),1)*HatoeV,' eV' + write(*,'(A40,F13.6,A3)') ' UHF LUMO a energy:',eps(LUMO(1),1)*HatoeV,' eV' + write(*,'(A40,F13.6,A3)') ' UHF HOMOa-LUMOa gap:',Gap(1)*HatoeV,' eV' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,F13.6,A3)') ' UHF HOMO b energy:',eps(HOMO(2),2)*HatoeV,' eV' + write(*,'(A40,F13.6,A3)') ' UHF LUMO b energy:',eps(LUMO(2),2)*HatoeV,' eV' + write(*,'(A40,F13.6,A3)') ' UHF HOMOb-LUMOb gap :',Gap(2)*HatoeV,' eV' + write(*,'(A60)') '-------------------------------------------------' + write(*,*) + +! Print results + + write(*,'(A50)') '-----------------------------------------' + write(*,'(A50)') 'UHF spin-up orbital coefficients ' + write(*,'(A50)') '-----------------------------------------' + call matout(nBas,nBas,c(:,:,1)) + write(*,'(A50)') '-----------------------------------------' + write(*,'(A50)') 'UHF spin-down orbital coefficients ' + write(*,'(A50)') '-----------------------------------------' + call matout(nBas,nBas,c(:,:,2)) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' UHF spin-up orbital energies ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eps(:,1)) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A50)') ' UHF spin-down orbital energies ' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eps(:,2)) + write(*,*) + +end subroutine print_UHF diff --git a/src/QuAcK/print_evGW.f90 b/src/QuAcK/print_evGW.f90 new file mode 100644 index 0000000..54acbcb --- /dev/null +++ b/src/QuAcK/print_evGW.f90 @@ -0,0 +1,54 @@ +subroutine print_evGW(nBas,nO,nSCF,Conv,e,ENuc,EHF,SigmaC,Z,eGW,EcRPA,EcGM) + +! Print one-electron energies and other stuff for evGW + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: ENuc,EHF,EcRPA,EcGM + double precision,intent(in) :: Conv,e(nBas),SigmaC(nBas),Z(nBas),eGW(nBas) + + integer :: x,HOMO,LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGW(LUMO)-eGW(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A1,I1,A12)')' Self-consistent evG',nSCF,'W',nSCF,' calculation' + else + write(*,'(1X,A21,I2,A1,I2,A12)')' Self-consistent evG',nSCF,'W',nSCF,' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sigma_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',e(x)*HaToeV,'|',SigmaC(x)*HaToeV,'|',Z(x),'|',eGW(x)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'evGW HOMO energy (eV):',eGW(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'evGW LUMO energy (eV):',eGW(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'evGW HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A27,F15.6)') 'evGW RPA total energy =',ENuc + EHF + EcRPA + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,'(2X,A27,F15.6)') 'evGW GM total energy =',ENuc + EHF + EcGM + write(*,'(2X,A27,F15.6)') 'GM correlation energy =',EcGM + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine print_evGW diff --git a/src/QuAcK/print_excitation.f90 b/src/QuAcK/print_excitation.f90 new file mode 100644 index 0000000..dbf90ef --- /dev/null +++ b/src/QuAcK/print_excitation.f90 @@ -0,0 +1,36 @@ +subroutine print_excitation(method,ispin,nS,Omega) + +! Print excitation energies for a given spin manifold + + implicit none + include 'parameters.h' + + character*5,intent(in) :: method + integer,intent(in) :: ispin,nS + double precision,intent(in) :: Omega(nS) + + character*7 :: spin_manifold + integer :: ia + + if(ispin == 1) spin_manifold = 'singlet' + if(ispin == 2) spin_manifold = 'triplet' + + write(*,*) + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A4,A14,A7,A9,A25)')'|',method,' calculation: ',spin_manifold,' manifold',' |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + + do ia=1,nS + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Omega(ia),'|',Omega(ia)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------' + write(*,*) + +end subroutine print_excitation + + diff --git a/src/QuAcK/print_qsGW.f90 b/src/QuAcK/print_qsGW.f90 new file mode 100644 index 0000000..f92be3d --- /dev/null +++ b/src/QuAcK/print_qsGW.f90 @@ -0,0 +1,112 @@ +subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,Hc,J,K,F,SigmaC,Z,EcRPA,EcGM) + + +! Print one-electron energies and other stuff for qsGW + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nO,nSCF + double precision,intent(in) :: ENuc,EcRPA,EcGM,Conv,thresh + double precision,intent(in) :: eHF(nBas),eGW(nBas),c(nBas),P(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas) + double precision,intent(in) :: J(nBas,nBas),K(nBas,nBas),F(nBas,nBas) + double precision,intent(in) :: Z(nBas),SigmaC(nBas,nBas) + +! Local variables + + integer :: x,HOMO,LUMO + double precision :: Gap,ET,EV,EJ,Ex,Ec,EqsGW + double precision,external :: trace_matrix + + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGW(LUMO)-eGW(HOMO) + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + Ex = 0.5d0*trace_matrix(nBas,matmul(P,K)) + EqsGW = ET + EV + EJ + Ex + Ec = 0d0 + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A1,I1,A12)')' Self-consistent qsG',nSCF,'W',nSCF,' calculation' + else + write(*,'(1X,A21,I2,A1,I2,A12)')' Self-consistent qsG',nSCF,'W',nSCF,' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','e_QP-e_HF (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do x=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',x,'|',eHF(x)*HaToeV,'|',(eGW(x)-eHF(x))*HaToeV,'|',Z(x),'|',eGW(x)*HaToeV,'|' + enddo + + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A19,F15.5)')'max(|FPS - SPF|) = ',Conv + write(*,*)'-------------------------------------------' + write(*,'(2X,A27,F15.6)') 'qsGW HOMO energy (eV):',eGW(HOMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'qsGW LUMO energy (eV):',eGW(LUMO)*HaToeV + write(*,'(2X,A27,F15.6)') 'qsGW HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,*)'-------------------------------------------' + write(*,'(2X,A27,F15.6)') 'qsGW total energy =',EqsGW + ENuc + write(*,'(2X,A27,F15.6)') 'qsGW GM total energy =',EqsGW + ENuc + EcGM + write(*,'(2X,A27,F15.6)') 'qsGW exchange energy =',Ex + write(*,'(2X,A27,F15.6)') 'qsGW correlation energy =',Ec + write(*,'(2X,A27,F15.6)') 'RPA correlation energy =',EcRPA + write(*,'(2X,A27,F15.6)') 'GM correlation energy =',EcGM + write(*,*)'-------------------------------------------' + write(*,*) + +! Dump results for final iteration + + if(Conv < thresh) then + + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Summary ' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' One-electron energy ',ET + EV + write(*,'(A32,1X,F16.10)') ' Kinetic energy ',ET + write(*,'(A32,1X,F16.10)') ' Potential energy ',EV + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Two-electron energy ',EJ + Ex + write(*,'(A32,1X,F16.10)') ' Coulomb energy ',EJ + write(*,'(A32,1X,F16.10)') ' Exchange energy ',Ex + write(*,'(A32,1X,F16.10)') ' Correlation energy ',Ec + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10)') ' Electronic energy ',EqsGW + write(*,'(A32,1X,F16.10)') ' Nuclear repulsion ',ENuc + write(*,'(A32,1X,F16.10)') ' qsGW energy ',ENuc + EqsGW + write(*,'(A32,1X,F16.10)') ' RPA corr. energy ',EcRPA + write(*,'(A50)') '---------------------------------------' + write(*,*) + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' qsGW MO coefficients' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,c) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' qsGW MO energies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eGW) + write(*,*) + + endif + + +end subroutine print_qsGW diff --git a/src/QuAcK/qsGW.f90 b/src/QuAcK/qsGW.f90 new file mode 100644 index 0000000..1b34714 --- /dev/null +++ b/src/QuAcK/qsGW.f90 @@ -0,0 +1,222 @@ +subroutine qsGW(maxSCF,thresh,max_diis,COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold, & + nBas,nC,nO,nV,nR,nS,ENuc,S,X,T,V,Hc,ERI_AO_basis,PHF,cHF,eHF) + +! Compute linear response + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis + double precision,intent(in) :: thresh + logical,intent(in) :: COHSEX,SOSEX,BSE,TDA,G0W,GW0,singlet_manifold,triplet_manifold + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ENuc + double precision,intent(in) :: PHF(nBas,nBas),cHF(nBas,nBas),eHF(nBas) + double precision,intent(in) :: S(nBas,nBas),T(nBas,nBAs),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas) + double precision,intent(in) :: ERI_AO_basis(nBas,nBas,nBas,nBas) + +! Local variables + + logical :: dRPA + integer :: nSCF,nBasSq,ispin,n_diis + double precision :: EcRPA,EcGM,Conv + double precision,external :: trace_matrix + double precision,allocatable :: error_diis(:,:),F_diis(:,:) + double precision,allocatable :: Omega(:,:),XpY(:,:,:),rho(:,:,:,:),rhox(:,:,:,:) + double precision,allocatable :: c(:,:),cp(:,:),e(:),P(:,:) + double precision,allocatable :: F(:,:),Fp(:,:),J(:,:),K(:,:) + double precision,allocatable :: SigC(:,:),SigCp(:,:),SigCm(:,:),Z(:) + double precision,allocatable :: error(:,:),ERI_MO_basis(:,:,:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent qsGW calculation |' + write(*,*)'************************************************' + write(*,*) + +! Stuff + + nBasSq = nBas*nBas + +! SOSEX correction + + if(SOSEX) write(*,*) 'SOSEX correction activated!' + write(*,*) + +! Switch off exchange for G0W0 + + dRPA = .true. + +! Memory allocation + + allocate(e(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & + J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),SigCm(nBas,nBas),Z(nBas), & + ERI_MO_basis(nBas,nBas,nBas,nBas),error(nBas,nBas), & + Omega(nS,nspin),XpY(nS,nS,nspin),rho(nBas,nBas,nS,nspin),rhox(nBas,nBas,nS,nspin), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Initialization + + nSCF = 0 + n_diis = 0 + ispin = 1 + Conv = 1d0 + P(:,:) = PHF(:,:) + e(:) = eHF(:) + c(:,:) = cHF(:,:) + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Buid Coulomb matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI_AO_basis,J) + + ! Compute exchange part of the self-energy + + call exchange_matrix_AO_basis(nBas,P,ERI_AO_basis,K) + + ! AO to MO transformation of two-electron integrals + + call AOtoMO_integral_transform(nBas,c,ERI_AO_basis,ERI_MO_basis) + + ! Compute linear response + + if(.not. GW0 .or. nSCF == 0) then + + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + + endif + + ! Compute correlation part of the self-energy + + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + if(SOSEX) call excitation_density_SOSEX(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rhox(:,:,:,ispin)) + + if(G0W) then + + call self_energy_correlation(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,eHF, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),EcGM,SigC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,eHF,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + else + + call self_energy_correlation(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,e, & + Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),EcGM,SigC) + call renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega(:,ispin),rho(:,:,:,ispin),rhox(:,:,:,ispin),Z) + + endif + + ! Make correlation self-energy Hermitian and transform it back to AO basis + + SigCp = 0.5d0*(SigC + transpose(SigC)) + SigCm = 0.5d0*(SigC - transpose(SigC)) + + call MOtoAO_transform(nBas,S,c,SigCp) + + ! Solve the quasi-particle equation + + F(:,:) = Hc(:,:) + J(:,:) + K(:,:) + SigCp(:,:) + + ! Compute commutator and convergence criteria + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + + ! Diagonalize Hamiltonian in AO basis + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + + ! Compute new density matrix in the AO basis + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + ! Print results + + call print_excitation('RPA ',ispin,nS,Omega(:,ispin)) + call print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,e,c,ENuc,P,T,V,Hc,J,K,F,SigCp,Z,EcRPA,EcGM) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Compute second-order correction of the Hermitization error + + call qsGW_PT(nBas,nC,nO,nV,nR,nS,e,SigCm) + +! Compute the overlap between HF and GW orbitals + +! call overlap(nBas,cHF,c) + +! Compute natural orbitals and occupancies + +! call natural_orbital(nBas,nO,cHF,c) + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + if(BSE) stop + + endif + +! Perform BSE calculation + + if(BSE) then + + ! Singlet manifold + if(singlet_manifold) then + + ispin = 1 + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + ! Triplet manifold + if(triplet_manifold) then + + ispin = 2 + call linear_response(ispin,dRPA,TDA,.false.,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call excitation_density(nBas,nC,nO,nR,nS,c,ERI_AO_basis,XpY(:,:,ispin),rho(:,:,:,ispin)) + + call linear_response(ispin,dRPA,TDA,BSE,nBas,nC,nO,nV,nR,nS,e,ERI_MO_basis, & + rho(:,:,:,ispin),EcRPA,Omega(:,ispin),XpY(:,:,ispin)) + call print_excitation('BSE ',ispin,nS,Omega(:,ispin)) + + endif + + endif + +end subroutine qsGW diff --git a/src/QuAcK/qsGW_PT.f90 b/src/QuAcK/qsGW_PT.f90 new file mode 100644 index 0000000..adb2239 --- /dev/null +++ b/src/QuAcK/qsGW_PT.f90 @@ -0,0 +1,119 @@ +subroutine qsGW_PT(nBas,nC,nO,nV,nR,nS,e0,SigCm) + +! Compute the 1st-, 2nd-, 3rd- and 4th-order correction on the qsGW quasiparticle energies + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e0(nBas),SigCm(nBas,nBas) + +! Local variables + + integer :: x,y,z,t + double precision :: eps + double precision,allocatable :: e1(:),e2(:),e3(:),e4(:) + +! Allocation + + allocate(e1(nBas),e2(nBas),e3(nBas),e4(nBas)) + +! Initalization + + e1(:) = 0d0 + e2(:) = 0d0 + e3(:) = 0d0 + e4(:) = 0d0 + +! Print zeroth-order qsGW QP energies + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 0th-order values of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e0(:)*HaToeV) + +! Compute 1st-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + + e1(x) = SigCm(x,x) + + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 1st-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e1(:)*HaToeV) + +! Compute 2nd-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + + eps = e0(x) - e0(y) + if(abs(eps) > threshold) e2(x) = e2(x) + SigCm(x,y)**2/eps + + end do + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 2nd-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e2(:)*HaToeV) + +! Compute 3nd-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do z=nC+1,nBas-nR + + eps = (e0(x) - e0(y))*(e0(x) - e0(z)) + if(abs(eps) > threshold) e3(x) = e3(x) + SigCm(x,y)*SigCm(y,z)*SigCm(z,x)/eps + + end do + end do + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 3rd-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e3(:)*HaToeV) + +! Compute 4nd-order correction of qsGW QP energies + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do z=nC+1,nBas-nR + do t=nC+1,nBas-nR + + eps = (e0(x) - e0(y))*(e0(x) - e0(z))*(e0(x) - e0(t)) + if(abs(eps) > threshold) e4(x) = e4(x) + SigCm(x,y)*SigCm(y,z)*SigCm(z,t)*SigCm(t,x)/eps + + end do + end do + end do + end do + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + + eps = (e0(x) - e0(y))**2 + if(abs(eps) > threshold) e4(x) = e4(x) - e2(x)*SigCm(x,y)**2/eps + + end do + end do + + write(*,*) + write(*,'(A50)') '-----------------------------------------------' + write(*,'(A50)') ' 4th-order correction of qsGW QP energies (eV) ' + write(*,'(A50)') '-----------------------------------------------' + call matout(nBas,1,e4(:)*HaToeV) + +end subroutine qsGW_PT diff --git a/src/QuAcK/read_F12_integrals.f90 b/src/QuAcK/read_F12_integrals.f90 new file mode 100644 index 0000000..93fe2e5 --- /dev/null +++ b/src/QuAcK/read_F12_integrals.f90 @@ -0,0 +1,169 @@ +subroutine read_F12_integrals(nBas,S,C,F,Y,FC) + +! Read one- and two-electron integrals from files + + implicit none + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: S(nBas,nBas) + +! Local variables + + logical :: debug + integer :: mu,nu,la,si,ka,ta + double precision :: ERI,F12,Yuk,F13C12,ExpS + +! Output variables + + double precision,intent(out) :: C(nBas,nBas,nBas,nBas) + double precision,intent(out) :: F(nBas,nBas,nBas,nBas) + double precision,intent(out) :: Y(nBas,nBas,nBas,nBas) + double precision,intent(out) :: FC(nBas,nBas,nBas,nBas,nBas,nBas) + + debug = .false. + +! Open file with integrals + + open(unit=21,file='int/ERI.dat') + open(unit=22,file='int/F12.dat') + open(unit=23,file='int/Yuk.dat') + open(unit=31,file='int/3eInt_Type1.dat') + +! Read 1/r12 integrals + + C = 0d0 + do + read(21,*,end=21) mu,nu,la,si,ERI +! <12|34> + C(mu,nu,la,si) = ERI +! <32|14> + C(la,nu,mu,si) = ERI +! <14|32> + C(mu,si,la,nu) = ERI +! <34|12> + C(la,si,mu,nu) = ERI +! <41|23> + C(si,mu,nu,la) = ERI +! <23|41> + C(nu,la,si,mu) = ERI +! <21|43> + C(nu,mu,si,la) = ERI +! <43|21> + C(si,la,nu,mu) = ERI + enddo + 21 close(unit=21) + +! Read f12 integrals + + F = 0d0 + do + read(22,*,end=22) mu,nu,la,si,F12 +! <12|34> + F(mu,nu,la,si) = F12 +! <32|14> + F(la,nu,mu,si) = F12 +! <14|32> + F(mu,si,la,nu) = F12 +! <34|12> + F(la,si,mu,nu) = F12 +! <41|23> + F(si,mu,nu,la) = F12 +! <23|41> + F(nu,la,si,mu) = F12 +! <21|43> + F(nu,mu,si,la) = F12 +! <43|21> + F(si,la,nu,mu) = F12 + enddo + 22 close(unit=22) + +! Read f12/r12 integrals + + Y = 0d0 + do + read(23,*,end=23) mu,nu,la,si,Yuk +! <12|34> + Y(mu,nu,la,si) = Yuk +! <32|14> + Y(la,nu,mu,si) = Yuk +! <14|32> + Y(mu,si,la,nu) = Yuk +! <34|12> + Y(la,si,mu,nu) = Yuk +! <41|23> + Y(si,mu,nu,la) = Yuk +! <23|41> + Y(nu,la,si,mu) = Yuk +! <21|43> + Y(nu,mu,si,la) = Yuk +! <43|21> + Y(si,la,nu,mu) = Yuk + enddo + 23 close(unit=23) + +! Read f13/r12 integrals + + FC = 0d0 + do + read(31,*,end=31) mu,nu,la,si,ka,ta,F13C12 + FC(mu,nu,la,si,ka,ta) = F13C12 + enddo + 31 close(unit=31) + +! Print results + + if(debug) then + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Electron repulsion integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,C(1,1,la,si)) + enddo + enddo + write(*,*) + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'F12 integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,F(1,1,la,si)) + enddo + enddo + write(*,*) + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Yukawa integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,Y(1,1,la,si)) + enddo + enddo + write(*,*) + + endif + +! Read exponent of Slater geminal + open(unit=4,file='input/geminal') + read(4,*) ExpS + close(unit=4) + +! Transform two-electron integrals + +! do mu=1,nBas +! do nu=1,nBas +! do la=1,nBas +! do si=1,nBas +! F(mu,nu,la,si) = (S(mu,la)*S(nu,si) - F(mu,nu,la,si))/ExpS +! Y(mu,nu,la,si) = (C(mu,nu,la,si) - Y(mu,nu,la,si))/ExpS +! enddo +! enddo +! enddo +! enddo + +end subroutine read_F12_integrals diff --git a/src/QuAcK/read_MOs.f90 b/src/QuAcK/read_MOs.f90 new file mode 100644 index 0000000..d775fb9 --- /dev/null +++ b/src/QuAcK/read_MOs.f90 @@ -0,0 +1,58 @@ +subroutine read_MOs(nBas,C,e,EJ) + +! Read normalization factor and MOs (coefficients and eigenvalues) + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + +! Local variables + + integer :: i,j + +! Output variables + + double precision,intent(out) :: EJ + double precision,intent(out) :: C(nBas,nBas),e(nBas) + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=3,file='input/MOs') + +! Read MO information + + read(3,*) EJ + + do i=1,nBas + read(3,*) (C(i,j),j=1,nBas) + enddo + + do i=1,nBas + read(3,*) e(i) + enddo + +! Print results + + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'MO coefficients' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,C) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'MO energies' + write(*,'(A28)') '----------------------' + call matout(nBas,1,e) + write(*,*) + +! Close file + + close(unit=3) + +end subroutine read_MOs diff --git a/src/QuAcK/read_basis.f90 b/src/QuAcK/read_basis.f90 new file mode 100644 index 0000000..2f3768c --- /dev/null +++ b/src/QuAcK/read_basis.f90 @@ -0,0 +1,118 @@ +subroutine read_basis(nAt,rAt,nBas,nO,nV,nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell) + +! Read basis set information + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nAt,nO + double precision,intent(in) :: rAt(nAt,ncart) + +! Local variables + + integer :: nShAt,iAt,iShell + integer :: i,j,k + character :: shelltype + +! Output variables + + integer,intent(out) :: nShell,nBas + double precision,intent(out) :: CenterShell(maxShell,ncart) + integer,intent(out) :: TotAngMomShell(maxShell),KShell(maxShell) + double precision,intent(out) :: DShell(maxShell,maxK),ExpShell(maxShell,maxK) + integer,intent(out) :: nV + +!------------------------------------------------------------------------ +! Primary basis set information +!------------------------------------------------------------------------ + +! Open file with basis set specification + + open(unit=2,file='input/basis') + +! Read basis information + + write(*,'(A28)') 'Gaussian basis set' + write(*,'(A28)') '------------------' + + nShell = 0 + do i=1,nAt + read(2,*) iAt,nShAt + write(*,'(A28,1X,I16)') 'Atom n. ',iAt + write(*,'(A28,1X,I16)') 'number of shells ',nShAt + write(*,'(A28)') '------------------' + +! Basis function centers + + do j=1,nShAt + nShell = nShell + 1 + do k=1,ncart + CenterShell(nShell,k) = rAt(iAt,k) + enddo + +! Shell type and contraction degree + + read(2,*) shelltype,KShell(nShell) + if(shelltype == "S") then + TotAngMomShell(nShell) = 0 + write(*,'(A28,1X,I16)') 's-type shell with K = ',KShell(nShell) + elseif(shelltype == "P") then + TotAngMomShell(nShell) = 1 + write(*,'(A28,1X,I16)') 'p-type shell with K = ',KShell(nShell) + elseif(shelltype == "D") then + TotAngMomShell(nShell) = 2 + write(*,'(A28,1X,I16)') 'd-type shell with K = ',KShell(nShell) + elseif(shelltype == "F") then + TotAngMomShell(nShell) = 3 + write(*,'(A28,1X,I16)') 'f-type shell with K = ',KShell(nShell) + elseif(shelltype == "G") then + TotAngMomShell(nShell) = 4 + write(*,'(A28,1X,I16)') 'g-type shell with K = ',KShell(nShell) + elseif(shelltype == "H") then + TotAngMomShell(nShell) = 5 + write(*,'(A28,1X,I16)') 'h-type shell with K = ',KShell(nShell) + elseif(shelltype == "I") then + TotAngMomShell(nShell) = 6 + write(*,'(A28,1X,I16)') 'i-type shell with K = ',KShell(nShell) + endif + +! Read exponents and contraction coefficients + + write(*,'(A28,1X,A16,A16)') '','Exponents','Contraction' + do k=1,Kshell(nShell) + read(2,*) ExpShell(nShell,k),DShell(nShell,k) + write(*,'(A28,1X,F16.10,F16.10)') '',ExpShell(nShell,k),DShell(nShell,k) + enddo + enddo + write(*,'(A28)') '------------------' + enddo + +! Total number of shells + + write(*,'(A28,1X,I16)') 'Number of shells',nShell + write(*,'(A28)') '------------------' + write(*,*) + +! Close file with basis set specification + + close(unit=2) + +! Calculate number of basis functions + + nBas = 0 + do iShell=1,nShell + nBas = nBas + (TotAngMomShell(iShell)*TotAngMomShell(iShell) + 3*TotAngMomShell(iShell) + 2)/2 + enddo + + write(*,'(A28)') '------------------' + write(*,'(A28,1X,I16)') 'Number of basis functions',NBas + write(*,'(A28)') '------------------' + write(*,*) + +! Number of virtual orbitals + + nV = nBas - nO + +end subroutine read_basis diff --git a/src/QuAcK/read_geometry.f90 b/src/QuAcK/read_geometry.f90 new file mode 100644 index 0000000..a3a4cf9 --- /dev/null +++ b/src/QuAcK/read_geometry.f90 @@ -0,0 +1,68 @@ +subroutine read_geometry(nNuc,ZNuc,rNuc,ENuc) + +! Read molecular geometry + + implicit none + + include 'parameters.h' + +! Ouput variables + + integer,intent(in) :: nNuc + +! Local variables + + integer :: i,j + double precision :: RAB + character(len=2) :: El + integer,external :: element_number + +! Ouput variables + + double precision,intent(out) :: ZNuc(nNuc),rNuc(nNuc,ncart),ENuc + +! Open file with geometry specification + + open(unit=1,file='input/molecule') + +! Read geometry + + read(1,*) + read(1,*) + read(1,*) + + do i=1,nNuc + read(1,*) El,rNuc(i,1),rNuc(i,2),rNuc(i,3) + ZNuc(i) = element_number(El) + enddo + +! Compute nuclear repulsion energy + + ENuc = 0 + + do i=1,nNuc-1 + do j=i+1,nNuc + RAB = (rNuc(i,1)-rNuc(j,1))**2 + (rNuc(i,2)-rNuc(j,2))**2 + (rNuc(i,3)-rNuc(j,3))**2 + ENuc = ENuc + ZNuc(i)*ZNuc(j)/sqrt(RAB) + enddo + enddo + +! Close file with geometry specification + close(unit=1) + +! Print geometry + write(*,'(A28)') '------------------' + write(*,'(A28)') 'Molecular geometry' + write(*,'(A28)') '------------------' + do i=1,nNuc + write(*,'(A28,1X,I16)') 'Atom n. ',i + write(*,'(A28,1X,F16.10)') 'Z = ',ZNuc(i) + write(*,'(A28,1X,F16.10,F16.10,F16.10)') 'Atom coordinates:',(rNuc(i,j),j=1,ncart) + enddo + write(*,*) + write(*,'(A28)') '------------------' + write(*,'(A28,1X,F16.10)') 'Nuclear repulsion energy = ',ENuc + write(*,'(A28)') '------------------' + write(*,*) + +end subroutine read_geometry diff --git a/src/QuAcK/read_integrals.f90 b/src/QuAcK/read_integrals.f90 new file mode 100644 index 0000000..e6f9dd6 --- /dev/null +++ b/src/QuAcK/read_integrals.f90 @@ -0,0 +1,119 @@ +subroutine read_integrals(nBas,S,T,V,Hc,G) + +! Read one- and two-electron integrals from files + + implicit none + +! Input variables + + integer,intent(in) :: nBas + +! Local variables + + logical :: debug + integer :: mu,nu,la,si + double precision :: Ov,Kin,Nuc,ERI + double precision :: scale + +! Output variables + + double precision,intent(out) :: S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Open file with integrals + + debug = .false. + + scale = 1d0 + + open(unit=8 ,file='int/Ov.dat') + open(unit=9 ,file='int/Kin.dat') + open(unit=10,file='int/Nuc.dat') + open(unit=11,file='int/ERI.dat') + +! Read overlap integrals + + S = 0d0 + do + read(8,*,end=8) mu,nu,Ov + S(mu,nu) = Ov + enddo + 8 close(unit=8) + +! Read kinetic integrals + + T = 0d0 + do + read(9,*,end=9) mu,nu,Kin + T(mu,nu) = Kin/scale**2 + enddo + 9 close(unit=9) + +! Read nuclear integrals + + V = 0d0 + do + read(10,*,end=10) mu,nu,Nuc + V(mu,nu) = Nuc + enddo + 10 close(unit=10) + +! Define core Hamiltonian + + Hc = T + V + +! Read nuclear integrals + + G = 0d0 + do + read(11,*,end=11) mu,nu,la,si,ERI + + ERI = ERI/scale +! <12|34> + G(mu,nu,la,si) = ERI +! <32|14> + G(la,nu,mu,si) = ERI +! <14|32> + G(mu,si,la,nu) = ERI +! <34|12> + G(la,si,mu,nu) = ERI +! <41|23> + G(si,mu,nu,la) = ERI +! <23|41> + G(nu,la,si,mu) = ERI +! <21|43> + G(nu,mu,si,la) = ERI +! <43|21> + G(si,la,nu,mu) = ERI + enddo + 11 close(unit=11) + + +! Print results + if(debug) then + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Overlap integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,S) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Kinetic integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,T) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Nuclear integrals' + write(*,'(A28)') '----------------------' + call matout(nBas,nBas,V) + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28)') 'Electron repulsion integrals' + write(*,'(A28)') '----------------------' + do la=1,nBas + do si=1,nBas + call matout(nBas,nBas,G(1,1,la,si)) + enddo + enddo + write(*,*) + endif + +end subroutine read_integrals diff --git a/src/QuAcK/read_methods.f90 b/src/QuAcK/read_methods.f90 new file mode 100644 index 0000000..b9978c2 --- /dev/null +++ b/src/QuAcK/read_methods.f90 @@ -0,0 +1,115 @@ +subroutine read_methods(doRHF,doUHF,doMOM, & + doMP2,doMP3,doMP2F12, & + doCCD,doCCSD,doCCSDT, & + doCIS,doTDHF,doADC, & + doGF2,doGF3, & + doG0W0,doevGW,doqsGW, & + doMCMP2) + +! Read desired methods + + implicit none + +! Input variables + + logical,intent(out) :: doRHF,doUHF,doMOM + logical,intent(out) :: doMP2,doMP3,doMP2F12 + logical,intent(out) :: doCCD,doCCSD,doCCSDT + logical,intent(out) :: doCIS,doTDHF,doADC + logical,intent(out) :: doGF2,doGF3 + logical,intent(out) :: doG0W0,doevGW,doqsGW + logical,intent(out) :: doMCMP2 + +! Local variables + + character(len=1) :: answer1,answer2,answer3 + +! Open file with method specification + + open(unit=1,file='input/methods') + +! Set all the booleans to false + + doRHF = .false. + doUHF = .false. + doMOM = .false. + + doMP2 = .false. + doMP3 = .false. + doMP2F12 = .false. + + doCCD = .false. + doCCSD = .false. + doCCSDT = .false. + + doCIS = .false. + doTDHF = .false. + doADC = .false. + + doGF2 = .false. + doGF3 = .false. + + doG0W0 = .false. + doevGW = .false. + doqsGW = .false. + + doMCMP2 = .false. + +! Read mean-field methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doRHF = .true. + if(answer2 == 'T') doUHF = .true. + if(answer3 == 'T') doMOM = .true. + +! Read MPn methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doMP2 = .true. + if(answer2 == 'T') doMP3 = .true. + if(answer3 == 'T') doMP2F12 = .true. + +! Read CC methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doCCD = .true. + if(answer2 == 'T') doCCSD = .true. + if(answer3 == 'T') doCCSDT = .true. + +! Read excited state methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doCIS = .true. + if(answer2 == 'T') doTDHF = .true. + if(answer3 == 'T') doADC = .true. + +! Read Green function methods + + read(1,*) + read(1,*) answer1,answer2 + if(answer1 == 'T') doGF2 = .true. + if(answer2 == 'T') doGF3 = .true. + +! Read GW methods + + read(1,*) + read(1,*) answer1,answer2,answer3 + if(answer1 == 'T') doG0W0 = .true. + if(answer2 == 'T') doevGW = .true. + if(answer3 == 'T') doqsGW = .true. + +! Read stochastic methods + + read(1,*) + read(1,*) answer1 + if(answer1 == 'T') doMCMP2 = .true. + +! Close file with geometry specification + + close(unit=1) + +end subroutine read_methods diff --git a/src/QuAcK/read_molecule.f90 b/src/QuAcK/read_molecule.f90 new file mode 100644 index 0000000..4625d03 --- /dev/null +++ b/src/QuAcK/read_molecule.f90 @@ -0,0 +1,39 @@ +subroutine read_molecule(nNuc,nEl,nO,nC,nR) + +! Read number of atoms and number of electrons + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(out) :: nNuc,nEl,nO,nC,nR + +! Open file with geometry specification + + open(unit=1,file='input/molecule') + +! Read number of atoms and number of electrons + + read(1,*) + read(1,*) nNuc,nEl,nC,nR + + nO = nEl/2 + +! Print results + + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of atoms',nNuc + write(*,'(A28)') '----------------------' + write(*,*) + write(*,'(A28)') '----------------------' + write(*,'(A28,1X,I16)') 'Number of electrons',nEl + write(*,'(A28)') '----------------------' + write(*,*) + +! Close file with geometry specification + + close(unit=1) + +end subroutine read_molecule diff --git a/src/QuAcK/read_options.f90 b/src/QuAcK/read_options.f90 new file mode 100644 index 0000000..5afc2a8 --- /dev/null +++ b/src/QuAcK/read_options.f90 @@ -0,0 +1,171 @@ +subroutine read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type, & + maxSCF_CC,thresh_CC,DIIS_CC,n_diis_CC, & + singlet_manifold,triplet_manifold, & + maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,renormalization, & + maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,COHSEX,SOSEX,BSE,TDA,G0W,GW0,linearize, & + nMC,nEq,nWalk,dt,nPrint,iSeed,doDrift) + +! Read desired methods + + implicit none + +! Input variables + + integer,intent(out) :: maxSCF_HF + double precision,intent(out) :: thresh_HF + logical,intent(out) :: DIIS_HF + integer,intent(out) :: n_diis_HF + integer,intent(out) :: guess_type + integer,intent(out) :: ortho_type + + integer,intent(out) :: maxSCF_CC + double precision,intent(out) :: thresh_CC + logical,intent(out) :: DIIS_CC + integer,intent(out) :: n_diis_CC + + logical,intent(out) :: singlet_manifold + logical,intent(out) :: triplet_manifold + + integer,intent(out) :: maxSCF_GF + double precision,intent(out) :: thresh_GF + logical,intent(out) :: DIIS_GF + integer,intent(out) :: n_diis_GF + integer,intent(out) :: renormalization + + integer,intent(out) :: maxSCF_GW + double precision,intent(out) :: thresh_GW + logical,intent(out) :: DIIS_GW + integer,intent(out) :: n_diis_GW + logical,intent(out) :: COHSEX + logical,intent(out) :: SOSEX + logical,intent(out) :: BSE + logical,intent(out) :: TDA + logical,intent(out) :: G0W + logical,intent(out) :: GW0 + logical,intent(out) :: linearize + + integer,intent(out) :: nMC + integer,intent(out) :: nEq + integer,intent(out) :: nWalk + double precision,intent(out) :: dt + integer,intent(out) :: nPrint + integer,intent(out) :: iSeed + logical,intent(out) :: doDrift + +! Local variables + + character(len=1) :: answer1,answer2,answer3,answer4,answer5,answer6,answer7,answer8 + +! Open file with method specification + + open(unit=1,file='input/options') + +! Read HF options + + maxSCF_HF = 64 + thresh_HF = 1d-6 + DIIS_HF = .false. + n_diis_HF = 5 + guess_type = 1 + ortho_type = 1 + + read(1,*) + read(1,*) maxSCF_HF,thresh_HF,answer1,n_diis_HF,guess_type,ortho_type + + if(answer1 == 'T') DIIS_HF = .true. + + if(.not.DIIS_HF) n_diis_HF = 1 + +! Read MPn options + + read(1,*) + read(1,*) + +! Read CC options + + maxSCF_CC = 64 + thresh_CC = 1d-5 + DIIS_CC = .false. + n_diis_CC = 5 + + read(1,*) + read(1,*) maxSCF_CC,thresh_CC,answer1,n_diis_CC + + if(answer1 == 'T') DIIS_CC = .true. + + if(.not.DIIS_CC) n_diis_CC = 1 + +! Read excited state options + + singlet_manifold = .false. + triplet_manifold = .false. + + read(1,*) + read(1,*) answer1,answer2 + + if(answer1 == 'T') singlet_manifold = .true. + if(answer2 == 'T') triplet_manifold = .true. + +! Read Green function options + + maxSCF_GF = 64 + thresh_GF = 1d-5 + DIIS_GF = .false. + n_diis_GF = 5 + renormalization = 0 + + read(1,*) + read(1,*) maxSCF_GF,thresh_GW,answer1,n_diis_GF,renormalization + + if(answer1 == 'T') DIIS_GF = .true. + if(.not.DIIS_GF) n_diis_GF = 1 + +! Read GW options + + maxSCF_GW = 64 + thresh_GW = 1d-5 + DIIS_GW = .false. + n_diis_GW = 5 + COHSEX = .false. + SOSEX = .false. + BSE = .false. + TDA = .false. + G0W = .false. + GW0 = .false. + linearize = .false. + + read(1,*) + read(1,*) maxSCF_GW,thresh_GW,answer1,n_diis_GW,answer2, & + answer3,answer4,answer5,answer6,answer7,answer8 + + if(answer1 == 'T') DIIS_GW = .true. + if(answer2 == 'T') COHSEX = .true. + if(answer3 == 'T') SOSEX = .true. + if(answer4 == 'T') BSE = .true. + if(answer5 == 'T') TDA = .true. + if(answer6 == 'T') G0W = .true. + if(answer7 == 'T') GW0 = .true. + if(answer8 == 'T') linearize = .true. + if(.not.DIIS_GW) n_diis_GW = 1 + +! Read options for MC-MP2: Monte Carlo steps, number of equilibration steps, number of walkers, +! Monte Carlo time step, frequency of output results, and seed for random number generator + + nMC = 100000 + nEq = 10000 + nWalk = 10 + dt = 0.3d0 + nPrint = 1000 + iSeed = 0 + doDrift = .false. + + read(1,*) + read(1,*) nMC,nEq,nWalk,dt,nPrint,iSeed,answer1 + + if(answer1 == 'T') doDrift = .true. + +! Close file with options + + close(unit=1) + +end subroutine read_options diff --git a/src/QuAcK/renormalization_factor.f90 b/src/QuAcK/renormalization_factor.f90 new file mode 100644 index 0000000..b4fff31 --- /dev/null +++ b/src/QuAcK/renormalization_factor.f90 @@ -0,0 +1,112 @@ +subroutine renormalization_factor(SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega,rho,rhox,Z) + +! Compute renormalization factor for GW + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: SOSEX + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,jb + double precision :: eps + double precision,allocatable :: SigC(:),dSigC(:),d2SigC(:) + double precision,external :: Z_dcgw + +! Output variables + + double precision,intent(out) :: Z(nBas) + +! Allocate + + allocate(SigC(nBas),dSigC(nBas),d2SigC(nBas)) + + SigC(:) = 0d0 + dSigC(:) = 0d0 + d2SigC(:) = 0d0 + +! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) +! Z(x) = Z(x) + 2d0*Z_dcgw(eps,rho(x,i,jb)) +! SigC(x) = SigC(x) + 2d0*rho(x,i,jb)**2/eps + dSigC(x) = dSigC(x) - 2d0*rho(x,i,jb)**2/eps**2 +! d2SigC(x) = d2SigC(x) + 4d0*rho(x,i,jb)**2/eps**3 + enddo + enddo + enddo + enddo + +! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) +! Z(x) = Z(x) + 2d0*Z_dcgw(eps,rho(x,a,jb)) +! SigC(x) = SigC(x) + 2d0*rho(x,a,jb)**2/eps + dSigC(x) = dSigC(x) - 2d0*rho(x,a,jb)**2/eps**2 +! d2SigC(x) = d2SigC(x) + 4d0*rho(x,a,jb)**2/eps**3 + enddo + enddo + enddo + enddo + + ! SOSEX correction + + if(SOSEX) then + + ! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + dSigC(x) = dSigC(x) - (rho(x,i,jb)/eps)*(rhox(x,i,jb)/eps) + enddo + enddo + enddo + enddo + + ! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + dSigC(x) = dSigC(x) - (rho(x,a,jb)/eps)*(rhox(x,a,jb)/eps) + enddo + enddo + enddo + enddo + + endif + +! Compute renormalization factor from derivative of SigC + + Z(:) = 1d0/(1d0-dSigC(:)) + +! Z(:) = 1d0 - dSigC(:) + sqrt( (1d0 - dSigC(:))**2 - 2d0*SigC(:)*d2SigC(:) ) +! Z(:) = Z(:)/(SigC(:)*d2SigC(:)) + +end subroutine renormalization_factor diff --git a/src/QuAcK/rij.f90 b/src/QuAcK/rij.f90 new file mode 100644 index 0000000..ff9b6f8 --- /dev/null +++ b/src/QuAcK/rij.f90 @@ -0,0 +1,24 @@ +subroutine rij(nWalk,r,r12) + +! Compute the interelectronic distances + + implicit none + +! Input variables + + integer,intent(in) :: nWalk + double precision,intent(in) :: r(nWalk,1:2,1:3) + +! Output variables + + double precision,intent(out) :: r12(nWalk) + +! Compute + + r12(1:nWalk) = (r(1:nWalk,1,1)-r(1:nWalk,2,1))**2 & + + (r(1:nWalk,1,2)-r(1:nWalk,2,2))**2 & + + (r(1:nWalk,1,3)-r(1:nWalk,2,3))**2 + + r12 = sqrt(r12) + +end subroutine rij diff --git a/src/QuAcK/self_energy_correlation.f90 b/src/QuAcK/self_energy_correlation.f90 new file mode 100644 index 0000000..d1d1ad2 --- /dev/null +++ b/src/QuAcK/self_energy_correlation.f90 @@ -0,0 +1,150 @@ +subroutine self_energy_correlation(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega,rho,rhox,EcGM,SigC) + +! Compute correlation part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: COHSEX,SOSEX + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,y,jb + double precision :: eps,eta + +! Output variables + + double precision,intent(out) :: SigC(nBas,nBas) + double precision,intent(out) :: EcGM + +! Initialize + + SigC = 0d0 + +! Infinitesimal + + eta = 0.001d0 + +! COHSEX static approximation + + if(COHSEX) then + + ! COHSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 +! SigC(x,y) = SigC(x,y) + 4d0*rho(x,i,jb)*rho(y,i,jb)/Omega(jb) + SigC(x,y) = SigC(x,y) + 2d0*rho(x,i,jb)*rho(y,i,jb)/Omega(jb) + enddo + enddo + enddo + enddo + enddo + + ! COHSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + SigC(x,y) = SigC(x,y) - 2d0*rho(x,a,jb)*rho(y,a,jb)/Omega(jb) + enddo + enddo + enddo + enddo + enddo + + EcGM=0d0 + do i=nC+1,nO + EcGM = EcGM + SigC(i,i) + enddo + + else + + ! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + SigC(x,y) = SigC(x,y) + 2d0*rho(x,i,jb)*rho(y,i,jb)*eps/(eps**2 + eta**2) + enddo + enddo + enddo + enddo + enddo + + ! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + SigC(x,y) = SigC(x,y) + 2d0*rho(x,a,jb)*rho(y,a,jb)*eps/(eps**2 + eta**2) + enddo + enddo + enddo + enddo + enddo + + if(SOSEX) then + + ! SOSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + SigC(x,y) = SigC(x,y) - rho(x,i,jb)*rhox(y,i,jb)/eps + enddo + enddo + enddo + enddo + enddo + + ! SOSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do y=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + SigC(x,y) = SigC(x,y) - rho(x,a,jb)*rhox(y,a,jb)/eps + enddo + enddo + enddo + enddo + enddo + + endif + + endif + +end subroutine self_energy_correlation diff --git a/src/QuAcK/self_energy_correlation_diag.f90 b/src/QuAcK/self_energy_correlation_diag.f90 new file mode 100644 index 0000000..8427acc --- /dev/null +++ b/src/QuAcK/self_energy_correlation_diag.f90 @@ -0,0 +1,177 @@ +subroutine self_energy_correlation_diag(COHSEX,SOSEX,nBas,nC,nO,nV,nR,nS,e,Omega,rho,rhox,EcGM,SigC) + +! Compute diagonal of the correlation part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + logical,intent(in) :: COHSEX,SOSEX + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: e(nBas),Omega(nS),rho(nBas,nBas,nS),rhox(nBas,nBas,nS) + +! Local variables + + integer :: i,j,a,b,x,jb + double precision :: eps,eta + double precision,external :: SigC_dcgw + +! Output variables + + double precision,intent(out) :: SigC(nBas) + double precision,intent(out) :: EcGM + +! Initialize + + SigC = 0d0 + +! Infinitesimal + + eta = 0d0 +! eta = 0.001d0 + +! COHSEX static approximation + + if(COHSEX) then + + ! COHSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 +! SigC(x) = SigC(x) + 4d0*rho(x,i,jb)**2/Omega(jb) + SigC(x) = SigC(x) + 2d0*rho(x,i,jb)**2/Omega(jb) + enddo + enddo + enddo + enddo + + ! COHSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + SigC(x) = SigC(x) - 2d0*rho(x,a,jb)**2/Omega(jb) + enddo + enddo + enddo + enddo + + ! GM correlation energy + + EcGM=0d0 + do i=nC+1,nO + EcGM = EcGM + SigC(i) + enddo + + else + + ! Occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) +! SigC(x) = SigC(x) + 4d0*rho(x,i,jb)**2/(eps + eps*sqrt(1d0 + rho(x,i,jb)**2/eps**2)) + SigC(x) = SigC(x) + 2d0*rho(x,i,jb)**2*eps/(eps**2 + eta**2) +! SigC(x) = SigC(x) + 2d0*SigC_dcgw(eps,rho(x,i,jb)) + enddo + enddo + enddo + enddo + + ! Virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) +! SigC(x) = SigC(x) + 4d0*rho(x,a,jb)**2/(eps + eps*sqrt(1d0 + 4d0*rho(x,a,jb)**2/eps**2)) + SigC(x) = SigC(x) + 2d0*rho(x,a,jb)**2*eps/(eps**2 + eta**2) +! SigC(x) = SigC(x) + 2d0*SigC_dcgw(eps,rho(x,a,jb)) + enddo + enddo + enddo + enddo + + ! GM correlation energy + + EcGM=0d0 + do i=nC+1,nO + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(a) - e(i) + Omega(jb) + EcGM = EcGM - 4d0*rho(a,i,jb)*rho(a,i,jb)/eps + enddo + enddo + enddo + enddo + + if(SOSEX) then + + ! SOSEX: occupied part of the correlation self-energy + + do x=nC+1,nBas-nR + do i=nC+1,nO + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(i) + Omega(jb) + SigC(x) = SigC(x) - rho(x,i,jb)*rhox(x,i,jb)/eps + enddo + enddo + enddo + enddo + + ! SOSEX: virtual part of the correlation self-energy + + do x=nC+1,nBas-nR + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(x) - e(a) - Omega(jb) + SigC(x) = SigC(x) - rho(x,a,jb)*rhox(x,a,jb)/eps + enddo + enddo + enddo + enddo + + ! GM correlation energy + + do i=nC+1,nO + do a=nO+1,nBas-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + eps = e(a) - e(i) + Omega(jb) + EcGM = EcGM + 2d0*rho(a,i,jb)*rhox(a,i,jb)/eps + enddo + enddo + enddo + enddo + + endif + + endif + +end subroutine self_energy_correlation_diag diff --git a/src/QuAcK/self_energy_exchange.f90 b/src/QuAcK/self_energy_exchange.f90 new file mode 100644 index 0000000..26db034 --- /dev/null +++ b/src/QuAcK/self_energy_exchange.f90 @@ -0,0 +1,25 @@ +subroutine self_energy_exchange(nBas,c,P,G,SigmaX) + +! Compute exchange part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas),G(nBas,nBas,nBas,nBas) + +! Output variables + + double precision,intent(out) :: SigmaX(nBas,nBas) + +! Compute exchange part of the self-energy in the AO basis + + call exchange_matrix_AO_basis(nBas,P,G,SigmaX) + +! Compute exchange part of the self-energy in the MO basis + + SigmaX = matmul(transpose(c),matmul(SigmaX,c)) + +end subroutine self_energy_exchange diff --git a/src/QuAcK/spatial_to_spin_ERI.f90 b/src/QuAcK/spatial_to_spin_ERI.f90 new file mode 100644 index 0000000..bdb2919 --- /dev/null +++ b/src/QuAcK/spatial_to_spin_ERI.f90 @@ -0,0 +1,35 @@ +subroutine spatial_to_spin_ERI(nBas,ERI,nBas2,sERI) + +! Convert ERIs from spatial to spin orbitals + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nBas2 + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: p,q,r,s + double precision,external :: Kronecker_delta + +! Output variables + + double precision,intent(out) :: sERI(nBas2,nBas2,nBas2,nBas2) + + do p=1,nBas2 + do q=1,nBas2 + do r=1,nBas2 + do s=1,nBas2 + + sERI(p,q,r,s) = Kronecker_delta(mod(p,2),mod(r,2)) & + * Kronecker_delta(mod(q,2),mod(s,2)) & + * ERI((p+1)/2,(q+1)/2,(r+1)/2,(s+1)/2) + + enddo + enddo + enddo + enddo + +end subroutine spatial_to_spin_ERI diff --git a/src/QuAcK/spatial_to_spin_MO_energy.f90 b/src/QuAcK/spatial_to_spin_MO_energy.f90 new file mode 100644 index 0000000..688dc1d --- /dev/null +++ b/src/QuAcK/spatial_to_spin_MO_energy.f90 @@ -0,0 +1,29 @@ +subroutine spatial_to_spin_MO_energy(nBas,e,nBas2,se) + +! Convert ERIs from spatial to spin orbitals + + implicit none + +! Input variables + + integer,intent(in) :: nBas,nBas2 + double precision,intent(in) :: e(nBas) + +! Local variables + + integer :: p + +! Output variables + + double precision,intent(out) :: se(nBas2) + + do p=1,nBas2 + + se(p) = e((p+1)/2) + + enddo + +! print*,'MO energies in spinorbital basis' +! call matout(nBas2,1,se) + +end subroutine spatial_to_spin_MO_energy diff --git a/src/QuAcK/transition_probability.f90 b/src/QuAcK/transition_probability.f90 new file mode 100644 index 0000000..76da1d5 --- /dev/null +++ b/src/QuAcK/transition_probability.f90 @@ -0,0 +1,41 @@ +subroutine transition_probability(nWalk,dt,D,r,rp,F,Fp,T,Tp) + +! Compute transition probability + + implicit none + +! Input variables + + integer,intent(in) :: nWalk + double precision,intent(in) :: dt,D + double precision,intent(in) :: r(nWalk,1:2,1:3), F(nWalk,1:2,1:3) + double precision,intent(in) :: rp(nWalk,1:2,1:3),Fp(nWalk,1:2,1:3) + +! Local variables + + integer :: iW,iEl,ixyz + +! Output variables + + double precision,intent(out) :: T(nWalk),Tp(nWalk) + +! Initialize + + T = 0d0 + Tp = 0d0 + +! Compute + + do iW=1,nWalk + do iEl=1,2 + do ixyz=1,3 + T(iW) = T(iW) + (rp(iW,iEl,ixyz) - r(iW,iEl,ixyz) - D*dt*F(iW,iEl,ixyz))**2 + Tp(iW) = Tp(iW) + (r(iW,iEl,ixyz) - rp(iW,iEl,ixyz) - D*dt*Fp(iW,iEl,ixyz))**2 + enddo + enddo + enddo + + T(:) = exp(-0.25d0*T(:)/(D*dt)) + Tp(:) = exp(-0.25d0*Tp(:)/(D*dt)) + +end subroutine transition_probability diff --git a/src/QuAcK/utils.f90 b/src/QuAcK/utils.f90 new file mode 100644 index 0000000..8669f34 --- /dev/null +++ b/src/QuAcK/utils.f90 @@ -0,0 +1,339 @@ +!------------------------------------------------------------------------ +function Kronecker_delta(i,j) result(delta) + +! Kronecker Delta + + implicit none + +! Input variables + + integer,intent(in) :: i,j + +! Output variables + + double precision :: delta + + if(i == j) then + delta = 1d0 + else + delta = 0d0 + endif + +end function Kronecker_delta + +!------------------------------------------------------------------------ +subroutine matout(m,n,A) + +! Print the MxN array A + + implicit none + + integer,parameter :: ncol = 5 + double precision,parameter :: small = 1d-10 + integer,intent(in) :: m,n + double precision,intent(in) :: A(m,n) + double precision :: B(ncol) + integer :: ilower,iupper,num,i,j + + do ilower=1,n,ncol + iupper = min(ilower + ncol - 1,n) + num = iupper - ilower + 1 + write(*,'(3X,10(9X,I6))') (j,j=ilower,iupper) + do i=1,m + do j=ilower,iupper + B(j-ilower+1) = A(i,j) + enddo + do j=1,num + if(abs(B(j)) < small) B(j) = 0d0 + enddo + write(*,'(I7,10F15.8)') i,(B(j),j=1,num) + enddo + enddo + +end subroutine matout + +!------------------------------------------------------------------------ +subroutine trace_vector(n,v,Tr) + +! Calculate the trace of the vector v of length n +!!! Please use the intrinsic fortran sum() !!! + + implicit none + +! Input variables + + integer,intent(in) :: n + double precision,intent(in) :: v(n) + +! Local variables + + integer :: i + +! Output variables + + double precision,intent(out) :: Tr + + Tr = 0d0 + do i=1,n + Tr = Tr + v(i) + enddo + +end subroutine trace_vector + +!------------------------------------------------------------------------ +function trace_matrix(n,A) result(Tr) + +! Calculate the trace of the square matrix A + + implicit none + +! Input variables + + integer,intent(in) :: n + double precision,intent(in) :: A(n,n) + +! Local variables + + integer :: i + +! Output variables + + double precision :: Tr + + Tr = 0d0 + do i=1,n + Tr = Tr + A(i,i) + enddo + +end function trace_matrix + +!------------------------------------------------------------------------ +subroutine compute_error(nData,Mean,Var,Error) + +! Calculate the statistical error + + implicit none + +! Input variables + + double precision,intent(in) :: nData,Mean(3) + +! Output variables + + double precision,intent(out) :: Error(3) + double precision,intent(inout):: Var(3) + + Error = sqrt((Var-Mean**2/nData)/nData/(nData-1d0)) + +end subroutine compute_error + +!------------------------------------------------------------------------ +subroutine identity_matrix(N,A) + +! Set the matrix A to the identity matrix + + implicit none + +! Input variables + + integer,intent(in) :: N + +! Local viaruabkes + + integer :: i + +! Output variables + + double precision,intent(out) :: A(N,N) + + A = 0d0 + + do i=1,N + A(i,i) = 1d0 + enddo + +end subroutine identity_matrix + +!------------------------------------------------------------------------ +subroutine prepend(N,M,A,b) + +! Prepend the vector b of size N into the matrix A of size NxM + + implicit none + +! Input variables + + integer,intent(in) :: N,M + double precision,intent(in) :: b(N) + +! Local viaruabkes + + integer :: i,j + +! Output variables + + double precision,intent(out) :: A(N,M) + + +! print*,'b in append' +! call matout(N,1,b) + + do i=1,N + do j=M-1,1,-1 + A(i,j+1) = A(i,j) + enddo + A(i,1) = b(i) + enddo + +end subroutine prepend + +!------------------------------------------------------------------------ +subroutine append(N,M,A,b) + +! Append the vector b of size N into the matrix A of size NxM + + implicit none + +! Input variables + + integer,intent(in) :: N,M + double precision,intent(in) :: b(N) + +! Local viaruabkes + + integer :: i,j + +! Output variables + + double precision,intent(out) :: A(N,M) + + do i=1,N + do j=2,M + A(i,j-1) = A(i,j) + enddo + A(i,M) = b(i) + enddo + +end subroutine append + +!------------------------------------------------------------------------ +subroutine AtDA(N,A,D,B) + +! Perform B = At.D.A where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),D(N) + +! Local viaruabkes + + integer :: i,j,k + +! Output variables + + double precision,intent(out) :: B(N,N) + + B = 0d0 + + do i=1,N + do j=1,N + do k=1,N + B(i,k) = B(i,k) + A(j,i)*D(j)*A(j,k) + enddo + enddo + enddo + +end subroutine AtDA + +!------------------------------------------------------------------------ +subroutine ADAt(N,A,D,B) + +! Perform B = A.D.At where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),D(N) + +! Local viaruabkes + + integer :: i,j,k + +! Output variables + + double precision,intent(out) :: B(N,N) + + B = 0d0 + + do i=1,N + do j=1,N + do k=1,N + B(i,k) = B(i,k) + A(i,j)*D(j)*A(k,j) + enddo + enddo + enddo + +end subroutine ADAt +!------------------------------------------------------------------------ +subroutine DA(N,D,A) + +! Perform A <- D.A where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + + integer,intent(in) :: N + integer :: i,j,k + double precision,intent(in) :: D(N) + double precision,intent(inout):: A(N,N) + + do i=1,N + do j=1,N + A(i,j) = D(i)*A(i,j) + enddo + enddo + +end subroutine DA + +!------------------------------------------------------------------------ +subroutine AD(N,A,D) + +! Perform A <- A.D where A is a NxN matrix and D is a diagonal matrix given +! as a vector of length N + + implicit none + + integer,intent(in) :: N + integer :: i,j,k + double precision,intent(in) :: D(N) + double precision,intent(inout):: A(N,N) + + do i=1,N + do j=1,N + A(i,j) = A(i,j)*D(j) + enddo + enddo + +end subroutine AD + +!------------------------------------------------------------------------ +subroutine print_warning(message) + +! Print warning + + implicit none + + character(len=*),intent(in) :: message + + write(*,*) message + +end subroutine print_warning + + diff --git a/src/QuAcK/wrap_lapack.f90 b/src/QuAcK/wrap_lapack.f90 new file mode 100644 index 0000000..6c29ab7 --- /dev/null +++ b/src/QuAcK/wrap_lapack.f90 @@ -0,0 +1,207 @@ +!subroutine eigenvalues_non_symmetric_matrix(N,A,e) +! +!! Diagonalize a square matrix +! +! implicit none +! +!! Input variables +! +! integer,intent(in) :: N +! double precision,intent(inout):: A(N,N) +! double precision,intent(out) :: e(N) +! +!! Local variables +! +! integer :: lwork,info +! double precision,allocatable :: work(:) +! +!! Memory allocation +! +! allocate(eRe(N),eIm(N),work(3*N)) +! lwork = size(work) +! +! call DGEEV('N','N',N,A,N, eRe, eIm, 0d0,1, VR,LDVR, WORK, LWORK, INFO ) +! +! if(info /= 0) then +! print*,'Problem in diagonalize_matrix (dseev)!!' +! stop +! endif +! +!end subroutine eigenvalues_non_symmetric_matrix + +subroutine diagonalize_matrix(N,A,e) + +! Diagonalize a square matrix + + implicit none + +! Input variables + + integer,intent(in) :: N + double precision,intent(inout):: A(N,N) + double precision,intent(out) :: e(N) + +! Local variables + + integer :: lwork,info + double precision,allocatable :: work(:) + +! Memory allocation + + allocate(work(3*N)) + lwork = size(work) + + call dsyev('V','U',N,A,N,e,work,lwork,info) + + if(info /= 0) then + print*,'Problem in diagonalize_matrix (dsyev)!!' + endif + +end subroutine diagonalize_matrix + +subroutine svd(N,A,U,D,Vt) + + ! Compute A = U.D.Vt + ! Dimension of A is NxN + + implicit none + + integer, intent(in) :: N + double precision,intent(in) :: A(N,N) + double precision,intent(out) :: U(N,N) + double precision,intent(out) :: Vt(N,N) + double precision,intent(out) :: D(N) + double precision,allocatable :: work(:) + integer :: info,lwork + + double precision,allocatable :: scr(:,:) + + allocate (scr(N,N)) + + scr(:,:) = A(:,:) + + ! Find optimal size for temporary arrays + + allocate(work(1)) + + lwork = -1 + call dgesvd('A','A',N,N,scr,N,D,U,N,Vt,N,work,lwork,info) + lwork = int(work(1)) + + deallocate(work) + + allocate(work(lwork)) + + call dgesvd('A','A',N,N,scr,N,D,U,N,Vt,N,work,lwork,info) + + deallocate(work,scr) + + if (info /= 0) then + print *, info, ': SVD failed' + stop + endif + +end + +subroutine inverse_matrix(N,A,B) + +! Returns the inverse of the square matrix A in B + + implicit none + + integer,intent(in) :: N + double precision, intent(in) :: A(N,N) + double precision, intent(out) :: B(N,N) + + integer :: info,lwork + integer, allocatable :: ipiv(:) + double precision,allocatable :: work(:) + + allocate (ipiv(N),work(N*N)) + lwork = size(work) + + B(1:N,1:N) = A(1:N,1:N) + + call dgetrf(N,N,B,N,ipiv,info) + + if (info /= 0) then + + print*,info + stop 'error in inverse (dgetrf)!!' + + endif + + call dgetri(N,B,N,ipiv,work,lwork,info) + + if (info /= 0) then + + print *, info + stop 'error in inverse (dgetri)!!' + + endif + + deallocate(ipiv,work) + +end subroutine inverse_matrix + +subroutine linear_solve(N,A,b,x,rcond) + +! Solve the linear system A.x = b where A is a NxN matrix +! and x and x are vectors of size N + + implicit none + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),b(N),rcond + double precision,intent(out) :: x(N) + + integer :: info,lwork + double precision :: ferr,berr + integer,allocatable :: ipiv(:),iwork(:) + double precision,allocatable :: AF(:,:),work(:) + + lwork = 3*N + allocate(AF(N,N),ipiv(N),work(lwork),iwork(N)) + + call dsysvx('N','U',N,1,A,N,AF,N,ipiv,b,N,x,N,rcond,ferr,berr,work,lwork,iwork,info) + +! if (info /= 0) then + +! print *, info +! stop 'error in linear_solve (dsysvx)!!' + +! endif + +end subroutine linear_solve + +subroutine easy_linear_solve(N,A,b,x) + +! Solve the linear system A.x = b where A is a NxN matrix +! and x and x are vectors of size N + + implicit none + + integer,intent(in) :: N + double precision,intent(in) :: A(N,N),b(N) + double precision,intent(out) :: x(N) + + integer :: info,lwork + integer,allocatable :: ipiv(:) + double precision,allocatable :: work(:) + + allocate(ipiv(N),work(N*N)) + lwork = size(work) + + x = b + + call dsysv('U',N,1,A,N,ipiv,x,N,work,lwork,info) + + if (info /= 0) then + + print *, info + stop 'error in linear_solve (dsysv)!!' + + endif + +end subroutine easy_linear_solve +