From 42565f95f1c6fc6cd508cd420b95c34d8b76ecb3 Mon Sep 17 00:00:00 2001 From: pfloos Date: Fri, 16 Aug 2024 19:05:11 +0200 Subject: [PATCH 01/46] implement 1RDM and 2RDM for pCCD --- int/CAP.dat | 16 --- mol/H2.xyz | 4 +- mol/N2.xyz | 4 +- src/CC/pCCD.f90 | 367 ++++++++++++++++++++++++++++++++++++++++-------- 4 files changed, 315 insertions(+), 76 deletions(-) delete mode 100644 int/CAP.dat diff --git a/int/CAP.dat b/int/CAP.dat deleted file mode 100644 index e8a0eda..0000000 --- a/int/CAP.dat +++ /dev/null @@ -1,16 +0,0 @@ - 1 1 9.1642021581097924E-03 6.2961947849362709E-02 9.1642021581097941E-03 - 1 2 2.9798815568270971E-02 1.0031339688416364E-01 2.9798815568270971E-02 - 1 3 4.8078353659559226E-03 5.1255302523161485E-03 4.8078353659559234E-03 - 1 4 2.3003539814844435E-02 4.1290024754715535E-02 2.3003539814844435E-02 - 2 1 2.9798815568270971E-02 1.0031339688416364E-01 2.9798815568270971E-02 - 2 2 3.5629639141443131E-01 5.7428563627799001E-01 3.5629639141443131E-01 - 2 3 2.3003539814844435E-02 4.1290024754715576E-02 2.3003539814844435E-02 - 2 4 3.0301481386007040E-01 3.0301481386007040E-01 3.0301481386007040E-01 - 3 1 4.8078353659559226E-03 5.1255302523161485E-03 4.8078353659559234E-03 - 3 2 2.3003539814844435E-02 4.1290024754715576E-02 2.3003539814844435E-02 - 3 3 9.1642021581097924E-03 6.2961947849362682E-02 9.1642021581097941E-03 - 3 4 2.9798815568270971E-02 1.0031339688416376E-01 2.9798815568270971E-02 - 4 1 2.3003539814844435E-02 4.1290024754715535E-02 2.3003539814844435E-02 - 4 2 3.0301481386007040E-01 3.0301481386007040E-01 3.0301481386007040E-01 - 4 3 2.9798815568270971E-02 1.0031339688416376E-01 2.9798815568270971E-02 - 4 4 3.5629639141443131E-01 5.7428563627799034E-01 3.5629639141443131E-01 diff --git a/mol/H2.xyz b/mol/H2.xyz index 8c244ab..48f4296 100644 --- a/mol/H2.xyz +++ b/mol/H2.xyz @@ -1,4 +1,4 @@ 2 -H 0.0000 0.0000 -0.37500000 -H 0.0000 0.0000 0.37500000 +H 0.00000000 -0.37500000 0.00000000 +H 0.00000000 0.37500000 0.00000000 diff --git a/mol/N2.xyz b/mol/N2.xyz index ecc0432..fb38cec 100644 --- a/mol/N2.xyz +++ b/mol/N2.xyz @@ -1,4 +1,4 @@ 2 -N 0.0000 0.0000 0.0000 -N 0.0000 0.0000 1.1007 +N 0.0000 0.0000 -0.5475132 +N 0.0000 0.0000 0.5475132 diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index 5306944..54c3c17 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -35,15 +35,26 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF double precision,allocatable :: OVVO(:,:) double precision,allocatable :: VVVV(:,:) - double precision,allocatable :: y(:,:) + double precision,allocatable :: yO(:,:),yV(:,:) double precision,allocatable :: r(:,:) double precision,allocatable :: t(:,:) + double precision,allocatable :: z(:,:) + double precision,allocatable :: rdm1(:,:) + double precision,allocatable :: rdm2(:,:,:,:) + double precision,allocatable :: xOO(:,:) + double precision,allocatable :: xVV(:,:) + double precision,allocatable :: xOV(:,:) + double precision :: tr_1rdm + double precision :: tr_2rdm + + integer :: O,V integer :: n_diis double precision :: rcond - double precision,allocatable :: error_diis(:,:) + double precision,allocatable :: err_diis(:,:) double precision,allocatable :: t_diis(:,:) + double precision,allocatable :: z_diis(:,:) double precision,external :: trace_matrix ! Hello world @@ -54,9 +65,14 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF write(*,*)'**************************************' write(*,*) +! Useful quantities + + O = nO - nC + V = nV - NR + ! Form energy denominator - allocate(eO(nO-nC),eV(nV-nR),delta_OV(nO-nC,nV-nR)) + allocate(eO(O),eV(V),delta_OV(O,V)) eO(:) = eHF(nC+1:nO) eV(:) = eHF(nO+1:nBas-nR) @@ -65,62 +81,56 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Create integral batches - allocate(OOOO(nO-nC,nO-nC),OOVV(nO-nC,nV-nR),OVOV(nO-nC,nV-nR),OVVO(nO-nC,nV-nR),VVVV(nV-nR,nV-nR)) + allocate(OOOO(O,O),OOVV(O,V),OVOV(O,V),OVVO(O,V),VVVV(V,V)) - do i=1,nO-nC - do j=1,nO-nC + do i=1,O + do j=1,O OOOO(i,j) = ERI(nC+i,nC+i,nC+j,nC+j) end do end do - do i=1,nO-nC - do a=1,nV-nR + do i=1,O + do a=1,V OOVV(i,a) = ERI(nC+i,nC+i,nO+a,nO+a) OVOV(i,a) = ERI(nC+i,nO+a,nC+i,nO+a) OVVO(i,a) = ERI(nC+i,nO+a,nO+a,nC+i) end do end do - do a=1,nV-nR - do b=1,nV-nR + do a=1,V + do b=1,V VVVV(a,b) = ERI(nO+a,nO+a,nO+b,nO+b) end do end do -! MP2 guess amplitudes +! Initialization - allocate(t(nO-nC,nV-nR)) - - t(:,:) = -0.5d0*OOVV(:,:)/delta_OV(:,:) - - EcCC = 0d0 - do i=1,nO-nC - do a=1,nV-nR - EcCC = EcCC + OOVV(i,a)*t(i,a) - end do - end do + allocate(t(O,V),r(O,V),yO(O,O),yV(V,V)) ! Memory allocation for DIIS - allocate(error_diis((nO-nC)*(nV-nR),max_diis),t_diis((nO-nC)*(nV-nR),max_diis)) + allocate(err_diis(O*V,max_diis),t_diis(O*V,max_diis)) -! Initialization - - allocate(r(nO-nC,nV-nR),y(nO-nC,nO-nC)) +!------------------------------------------------------------------------ +! Compute t ampltiudes +!------------------------------------------------------------------------ Conv = 1d0 nSCF = 0 + ECC = ERHF + EcCC = 0d0 - n_diis = 0 - t_diis(:,:) = 0d0 - error_diis(:,:) = 0d0 + n_diis = 0 + t(:,:) = 0d0 + t_diis(:,:) = 0d0 + err_diis(:,:) = 0d0 !------------------------------------------------------------------------ ! Main SCF loop !------------------------------------------------------------------------ write(*,*) write(*,*)'----------------------------------------------------' - write(*,*)'| pair CCD calculation |' + write(*,*)'| pCCD calculation: t amplitudes |' write(*,*)'----------------------------------------------------' write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|' @@ -134,28 +144,22 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Form intermediate array - y(:,:) = 0d0 - do i=1,nO-nC - do j=1,nO-nC - do b=1,nV-nR - y(i,j) = y(i,j) + OOVV(j,b)*t(i,b) - end do - end do - end do + yO(:,:) = matmul(t,transpose(OOVV)) ! Compute residual - do i=1,nO-nC - do a=1,nV-nR - r(i,a) = OOVV(i,a) + 2d0*delta_OV(i,a)*t(i,a) & - - 2d0*(2d0*OVOV(i,a) - OVVO(i,a) - OOVV(i,a)*t(i,a))*t(i,a) + r(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*t(:,:) & + - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - OOVV(:,:)*t(:,:))*t(:,:) - do j=1,nO-nC - r(i,a) = r(i,a) - 2d0*OOVV(j,a)*t(j,a)*t(i,a) + OOOO(j,i)*t(j,a) + y(i,j)*t(j,a) + do i=1,O + do a=1,V + + do j=1,O + r(i,a) = r(i,a) - 2d0*OOVV(j,a)*t(j,a)*t(i,a) + OOOO(j,i)*t(j,a) + yO(i,j)*t(j,a) end do - do b=1,nV-nR + do b=1,V r(i,a) = r(i,a) - 2d0*OOVV(i,b)*t(i,b)*t(i,a) + VVVV(a,b)*t(i,b) end do @@ -172,25 +176,20 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Compute correlation energy - EcCC = 0d0 - do i=1,nO-nC - do a=1,nV-nR - EcCC = EcCC + OOVV(i,a)*t(i,a) - end do - end do + EcCC = trace_matrix(V,matmul(transpose(OOVV),t)) ! Dump results ECC = ERHF + EcCC - ! DIIS extrapolation + ! DIIS extrapolation -! n_diis = min(n_diis+1,max_diis) -! call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,error_diis,t_diis,-0.5d0*r/delta_OV,t) + if(max_diis > 1) then - ! Reset DIIS if required + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,err_diis,t_diis,-0.5d0*r/delta_OV,t) -! if(abs(rcond) < 1d-15) n_diis = 0 + end if write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & '|',nSCF,'|',ECC+ENuc,'|',EcCC,'|',Conv,'|' @@ -201,6 +200,116 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! End of SCF loop !------------------------------------------------------------------------ +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed for t ampitudes ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + + stop + + end if + +! Deallocate memory + + deallocate(err_diis,t_diis) + +! Memory allocation + + allocate(z(O,V)) + +! Memory allocation for DIIS + + allocate(err_diis(O*V,max_diis),z_diis(O*V,max_diis)) + +!------------------------------------------------------------------------ +! Compute z ampltiudes +!------------------------------------------------------------------------ + + Conv = 1d0 + nSCF = 0 + + n_diis = 0 + z_diis(:,:) = 0d0 + err_diis(:,:) = 0d0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| pCCD calculation: z amplitudes |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Increment + + nSCF = nSCF + 1 + + ! Form intermediate array + + yO(:,:) = matmul(OOVV,transpose(t)) + yV(:,:) = matmul(transpose(OOVV),t) + + ! Compute residual + + r(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*z(:,:) & + - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - 2d0*OOVV(:,:)*t(:,:))*z(:,:) + + do i=1,O + do a=1,V + + do j=1,O + r(i,a) = r(i,a) - 2d0*OOVV(j,a)*t(j,a)*z(i,a) & + - 2d0*OOVV(i,a)*z(j,a)*t(j,a) & + + OOOO(i,j)*z(j,a) & + + yO(i,j)*z(j,a) + end do + + do b=1,V + r(i,a) = r(i,a) - 2d0*OOVV(i,b)*t(i,b)*z(i,a) & + - 2d0*OOVV(i,a)*z(i,b)*t(i,b) & + + VVVV(b,a)*z(i,b) & + + yV(a,b)*z(i,b) + end do + + end do + end do + + ! Check convergence + + Conv = maxval(abs(r(:,:))) + + ! Update amplitudes + + z(:,:) = z(:,:) - 0.5d0*r(:,:)/delta_OV(:,:) + + ! DIIS extrapolation + + if(max_diis > 1) then + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(rcond,O*V,O*V,n_diis,err_diis,z_diis,-0.5d0*r/delta_OV,z) + + end if + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ECC+ENuc,'|',EcCC,'|',Conv,'|' + + end do + write(*,*)'----------------------------------------------------' + write(*,*) +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + ! Did it actually converge? if(nSCF == maxSCF) then @@ -211,9 +320,155 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' stop - + end if +! Deallocate memory + + deallocate(err_diis,z_diis,r) + +!--------------------------! +! Compute density matrices ! +!--------------------------! + + allocate(xOO(O,O),xVV(V,V),xOV(O,V)) + + xOO(:,:) = matmul(t,transpose(z)) + xVV(:,:) = matmul(transpose(z),t) + xOV(:,:) = matmul(t,matmul(transpose(z),t)) + +! Form 1RDM + + allocate(rdm1(O+V,O+V)) + + rdm1(:,:) = 0d0 + + do i=1,O + rdm1(i,i) = 2d0*(1d0 - xOO(i,i)) + end do + + do a=1,V + rdm1(O+a,O+a) = 2d0*xVV(a,a) + end do + +! Check 1RDM + + tr_1rdm = trace_matrix(O+V,rdm1) + write(*,*) ' --> Trace of the 1RDM = ',tr_1rdm + + if( abs(dble(2*O) - tr_1rdm) > thresh ) & + write(*,*) ' !!! Your 1RDM seems broken !!! ' + write(*,*) + +! Form 2RM + + allocate(rdm2(O+V,O+V,O+V,O+V)) + + rdm2(:,:,:,:) = 0d0 + + ! iijj + + do i=1,O + do j=1,O + rdm2(i,i,j,j) = 2d0*xOO(i,j) + end do + end do + + ! iiaa + + do i=1,O + do a=1,V + rdm2(i,i,O+a,O+a) = 2d0*(t(i,a) + xOV(i,a) - 2d0*t(i,a)*(xVV(a,a) + xOO(i,i) - t(i,a)*z(i,a))) + end do + end do + + ! aaii + + do i=1,O + do a=1,V + rdm2(O+a,O+a,i,i) = 2d0*z(a,i) + end do + end do + + ! aabb + + do a=1,V + do b=1,V + rdm2(O+a,O+a,O+b,O+b) = 2d0*xVV(a,b) + end do + end do + + ! ijij + + do i=1,O + do j=1,O + rdm2(i,j,i,j) = 4d0*(1d0 - xOO(i,i) - xOO(j,j)) + end do + end do + + ! ijji + + do i=1,O + do j=1,O + rdm2(i,j,j,i) = - 2d0*(1d0 - xOO(i,i) - xOO(j,j)) + end do + end do + + ! iiii + + do i=1,O + rdm2(i,i,i,i) = 2d0*(1d0 - xOO(i,i)) + end do + + ! iaia + + do i=1,O + do a=1,V + rdm2(i,O+a,i,O+a) = 4d0*(xVV(a,a) - t(i,a)*z(i,a)) + end do + end do + + ! iaai + + do i=1,O + do a=1,V + rdm2(i,O+a,O+a,i) = - 2d0*(xVV(a,a) - t(i,a)*z(i,a)) + end do + end do + + ! aiai + + do i=1,O + do a=1,V + rdm2(O+a,i,O+a,i) = 4d0*(xVV(a,a) - t(i,a)*z(i,a)) + end do + end do + + ! aiia + + do i=1,O + do a=1,V + rdm2(O+a,i,i,O+a) = - 2d0*(xVV(a,a) - t(i,a)*z(i,a)) + end do + end do + + ! abab + + do a=1,V + rdm2(O+a,O+a,O+a,O+a) = 2d0*xVV(a,a) + end do + +! Check 2RDM + + tr_2rdm = trace_matrix((O+V)**2,rdm2) + write(*,*) ' --> Trace of the 2RDM = ',tr_2rdm + + if( abs(dble(2*O*(2*O-1)) - tr_2rdm) > thresh ) & + write(*,*) ' !!! Your 2RDM seems broken !!! ' + write(*,*) + +! Testing zone + if(dotest) then call dump_test_value('R','pCCD correlation energy',EcCC) From 68826076cc0ef73a0f8ffb1e32e253799c51ffcc Mon Sep 17 00:00:00 2001 From: pfloos Date: Sun, 18 Aug 2024 16:00:46 +0200 Subject: [PATCH 02/46] implement energy and gradient in pCCD --- src/CC/RCC.f90 | 5 +- src/CC/pCCD.f90 | 196 ++++++++++++++++++++++++++++++------------- src/QuAcK/RQuAcK.f90 | 2 +- 3 files changed, 142 insertions(+), 61 deletions(-) diff --git a/src/CC/RCC.f90 b/src/CC/RCC.f90 index fd271cc..d60dafe 100644 --- a/src/CC/RCC.f90 +++ b/src/CC/RCC.f90 @@ -1,5 +1,5 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF) ! Coupled-cluster module @@ -32,6 +32,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: Hc(nBas,nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables @@ -160,7 +161,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dopCCD) then call wall_time(start_CC) - call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index 54c3c17..d114158 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -1,4 +1,4 @@ -subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) +subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF) ! pair CCD module @@ -15,10 +15,13 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF integer,intent(in) :: nBas,nC,nO,nV,nR double precision,intent(in) :: ENuc,ERHF double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: Hc(nBas,nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables + integer :: p,q,r,s,t,u + integer :: pq,rs integer :: i,j,a,b integer :: nSCF @@ -35,11 +38,12 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF double precision,allocatable :: OVVO(:,:) double precision,allocatable :: VVVV(:,:) - double precision,allocatable :: yO(:,:),yV(:,:) + double precision,allocatable :: yO(:,:) + double precision,allocatable :: yV(:,:) - double precision,allocatable :: r(:,:) - double precision,allocatable :: t(:,:) - double precision,allocatable :: z(:,:) + double precision,allocatable :: r2(:,:) + double precision,allocatable :: t2(:,:) + double precision,allocatable :: z2(:,:) double precision,allocatable :: rdm1(:,:) double precision,allocatable :: rdm2(:,:,:,:) @@ -49,12 +53,16 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF double precision :: tr_1rdm double precision :: tr_2rdm - integer :: O,V + double precision :: E1,E2 + double precision,allocatable :: g(:) + double precision,allocatable :: H(:,:) + + integer :: O,V,N integer :: n_diis double precision :: rcond double precision,allocatable :: err_diis(:,:) - double precision,allocatable :: t_diis(:,:) - double precision,allocatable :: z_diis(:,:) + double precision,allocatable :: t2_diis(:,:) + double precision,allocatable :: z2_diis(:,:) double precision,external :: trace_matrix ! Hello world @@ -68,7 +76,8 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Useful quantities O = nO - nC - V = nV - NR + V = nV - nR + N = O + V ! Form energy denominator @@ -105,11 +114,11 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Initialization - allocate(t(O,V),r(O,V),yO(O,O),yV(V,V)) + allocate(t2(O,V),r2(O,V),yO(O,O),yV(V,V)) ! Memory allocation for DIIS - allocate(err_diis(O*V,max_diis),t_diis(O*V,max_diis)) + allocate(err_diis(O*V,max_diis),t2_diis(O*V,max_diis)) !------------------------------------------------------------------------ ! Compute t ampltiudes @@ -121,8 +130,8 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF EcCC = 0d0 n_diis = 0 - t(:,:) = 0d0 - t_diis(:,:) = 0d0 + t2(:,:) = 0d0 + t2_diis(:,:) = 0d0 err_diis(:,:) = 0d0 !------------------------------------------------------------------------ @@ -144,23 +153,23 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Form intermediate array - yO(:,:) = matmul(t,transpose(OOVV)) + yO(:,:) = matmul(t2,transpose(OOVV)) ! Compute residual - r(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*t(:,:) & - - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - OOVV(:,:)*t(:,:))*t(:,:) + r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*t2(:,:) & + - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - OOVV(:,:)*t2(:,:))*t2(:,:) do i=1,O do a=1,V do j=1,O - r(i,a) = r(i,a) - 2d0*OOVV(j,a)*t(j,a)*t(i,a) + OOOO(j,i)*t(j,a) + yO(i,j)*t(j,a) + r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*t2(i,a) + OOOO(j,i)*t2(j,a) + yO(i,j)*t2(j,a) end do do b=1,V - r(i,a) = r(i,a) - 2d0*OOVV(i,b)*t(i,b)*t(i,a) + VVVV(a,b)*t(i,b) + r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*t2(i,a) + VVVV(a,b)*t2(i,b) end do end do @@ -168,15 +177,15 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Check convergence - Conv = maxval(abs(r(:,:))) + Conv = maxval(abs(r2(:,:))) ! Update amplitudes - t(:,:) = t(:,:) - 0.5d0*r(:,:)/delta_OV(:,:) + t2(:,:) = t2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:) ! Compute correlation energy - EcCC = trace_matrix(V,matmul(transpose(OOVV),t)) + EcCC = trace_matrix(V,matmul(transpose(OOVV),t2)) ! Dump results @@ -187,7 +196,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,err_diis,t_diis,-0.5d0*r/delta_OV,t) + call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,err_diis,t2_diis,-0.5d0*r2/delta_OV,t2) end if @@ -215,15 +224,15 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Deallocate memory - deallocate(err_diis,t_diis) + deallocate(err_diis,t2_diis) ! Memory allocation - allocate(z(O,V)) + allocate(z2(O,V)) ! Memory allocation for DIIS - allocate(err_diis(O*V,max_diis),z_diis(O*V,max_diis)) + allocate(err_diis(O*V,max_diis),z2_diis(O*V,max_diis)) !------------------------------------------------------------------------ ! Compute z ampltiudes @@ -232,8 +241,8 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF Conv = 1d0 nSCF = 0 - n_diis = 0 - z_diis(:,:) = 0d0 + n_diis = 0 + z2_diis(:,:) = 0d0 err_diis(:,:) = 0d0 !------------------------------------------------------------------------ @@ -255,29 +264,25 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Form intermediate array - yO(:,:) = matmul(OOVV,transpose(t)) - yV(:,:) = matmul(transpose(OOVV),t) + yO(:,:) = matmul(OOVV,transpose(t2)) + yV(:,:) = matmul(transpose(OOVV),t2) ! Compute residual - r(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*z(:,:) & - - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - 2d0*OOVV(:,:)*t(:,:))*z(:,:) + r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*z2(:,:) & + - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - 2d0*OOVV(:,:)*t2(:,:))*z2(:,:) do i=1,O do a=1,V do j=1,O - r(i,a) = r(i,a) - 2d0*OOVV(j,a)*t(j,a)*z(i,a) & - - 2d0*OOVV(i,a)*z(j,a)*t(j,a) & - + OOOO(i,j)*z(j,a) & - + yO(i,j)*z(j,a) + r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*z2(i,a) - 2d0*OOVV(i,a)*z2(j,a)*t2(j,a) & + + OOOO(i,j)*z2(j,a) + yO(i,j)*z2(j,a) end do do b=1,V - r(i,a) = r(i,a) - 2d0*OOVV(i,b)*t(i,b)*z(i,a) & - - 2d0*OOVV(i,a)*z(i,b)*t(i,b) & - + VVVV(b,a)*z(i,b) & - + yV(a,b)*z(i,b) + r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*z2(i,a) - 2d0*OOVV(i,a)*z2(i,b)*t2(i,b) & + + VVVV(b,a)*z2(i,b) + yV(a,b)*z2(i,b) end do end do @@ -285,18 +290,18 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Check convergence - Conv = maxval(abs(r(:,:))) + Conv = maxval(abs(r2(:,:))) ! Update amplitudes - z(:,:) = z(:,:) - 0.5d0*r(:,:)/delta_OV(:,:) + z2(:,:) = z2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:) ! DIIS extrapolation if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,O*V,O*V,n_diis,err_diis,z_diis,-0.5d0*r/delta_OV,z) + call DIIS_extrapolation(rcond,O*V,O*V,n_diis,err_diis,z2_diis,-0.5d0*r2/delta_OV,z2) end if @@ -325,7 +330,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Deallocate memory - deallocate(err_diis,z_diis,r) + deallocate(err_diis,z2_diis,r2) !--------------------------! ! Compute density matrices ! @@ -333,13 +338,13 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF allocate(xOO(O,O),xVV(V,V),xOV(O,V)) - xOO(:,:) = matmul(t,transpose(z)) - xVV(:,:) = matmul(transpose(z),t) - xOV(:,:) = matmul(t,matmul(transpose(z),t)) + xOO(:,:) = matmul(t2,transpose(z2)) + xVV(:,:) = matmul(transpose(z2),t2) + xOV(:,:) = matmul(t2,matmul(transpose(z2),t2)) ! Form 1RDM - allocate(rdm1(O+V,O+V)) + allocate(rdm1(N,N)) rdm1(:,:) = 0d0 @@ -353,8 +358,8 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Check 1RDM - tr_1rdm = trace_matrix(O+V,rdm1) - write(*,*) ' --> Trace of the 1RDM = ',tr_1rdm + tr_1rdm = trace_matrix(N,rdm1) + write(*,'(A25,F16.10)') ' --> Trace of the 1RDM = ',tr_1rdm if( abs(dble(2*O) - tr_1rdm) > thresh ) & write(*,*) ' !!! Your 1RDM seems broken !!! ' @@ -362,7 +367,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Form 2RM - allocate(rdm2(O+V,O+V,O+V,O+V)) + allocate(rdm2(N,N,N,N)) rdm2(:,:,:,:) = 0d0 @@ -378,7 +383,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF do i=1,O do a=1,V - rdm2(i,i,O+a,O+a) = 2d0*(t(i,a) + xOV(i,a) - 2d0*t(i,a)*(xVV(a,a) + xOO(i,i) - t(i,a)*z(i,a))) + rdm2(i,i,O+a,O+a) = 2d0*(t2(i,a) + xOV(i,a) - 2d0*t2(i,a)*(xVV(a,a) + xOO(i,i) - t2(i,a)*z2(i,a))) end do end do @@ -386,7 +391,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF do i=1,O do a=1,V - rdm2(O+a,O+a,i,i) = 2d0*z(a,i) + rdm2(O+a,O+a,i,i) = 2d0*z2(i,a) end do end do @@ -424,7 +429,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF do i=1,O do a=1,V - rdm2(i,O+a,i,O+a) = 4d0*(xVV(a,a) - t(i,a)*z(i,a)) + rdm2(i,O+a,i,O+a) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a)) end do end do @@ -432,7 +437,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF do i=1,O do a=1,V - rdm2(i,O+a,O+a,i) = - 2d0*(xVV(a,a) - t(i,a)*z(i,a)) + rdm2(i,O+a,O+a,i) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a)) end do end do @@ -440,7 +445,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF do i=1,O do a=1,V - rdm2(O+a,i,O+a,i) = 4d0*(xVV(a,a) - t(i,a)*z(i,a)) + rdm2(O+a,i,O+a,i) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a)) end do end do @@ -448,7 +453,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF do i=1,O do a=1,V - rdm2(O+a,i,i,O+a) = - 2d0*(xVV(a,a) - t(i,a)*z(i,a)) + rdm2(O+a,i,i,O+a) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a)) end do end do @@ -460,13 +465,88 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF ! Check 2RDM - tr_2rdm = trace_matrix((O+V)**2,rdm2) - write(*,*) ' --> Trace of the 2RDM = ',tr_2rdm + tr_2rdm = trace_matrix(N**2,rdm2) + write(*,'(A25,F16.10)') ' --> Trace of the 2RDM = ',tr_2rdm if( abs(dble(2*O*(2*O-1)) - tr_2rdm) > thresh ) & write(*,*) ' !!! Your 2RDM seems broken !!! ' write(*,*) +! Compute electronic energy + + E1 = 0d0 + E2 = 0d0 + + do p=1,N + do q=1,N + E1 = E1 + rdm1(p,q)*Hc(p,q) + do r=1,N + do s=1,N + E2 = E2 + rdm2(p,q,r,s)*ERI(p,q,r,s) + end do + end do + end do + end do + + E2 = 0.5d0*E2 + + write(*,'(A25,F16.10)') ' One-electron energy = ',E1 + write(*,'(A25,F16.10)') ' Two-electron energy = ',E2 + write(*,'(A25,F16.10)') ' Electronic energy = ',E1 + E2 + write(*,'(A25,F16.10)') ' Total energy = ',E1 + E2 + ENuc + write(*,*) + +! Compute gradient + + allocate(g(N**2)) + + g(:) = 0d0 + + pq = 0 + do p=1,N + do q=1,N + + pq = pq + 1 + + do r=1,N + g(pq) = g(pq) + Hc(r,p)*rdm1(r,q) - Hc(q,r)*rdm1(p,r) + end do + + do r=1,N + do s=1,N + do t=1,N + g(pq) = g(pq) + (ERI(r,s,p,t)*rdm2(r,s,q,t) - ERI(q,t,r,s)*rdm2(p,t,r,s)) + end do + end do + end do + + end do + end do + +! Compute Hessian + + allocate(H(N**2,N**2)) + + H(:,:) = 0d0 + + pq = 0 + do p=1,N + do q=1,N + + pq = pq + 1 + + rs = 0 + do r=1,N + do s=1,N + + rs = rs + 1 + + end do + end do + + end do + end do + ! Testing zone if(dotest) then diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 6815d9e..a667af9 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -228,7 +228,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_CC) call RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) + maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC From 7643ef3c2f1fe62431a57b72136be11b96ca6773 Mon Sep 17 00:00:00 2001 From: pfloos Date: Sun, 18 Aug 2024 22:44:58 +0200 Subject: [PATCH 03/46] debug grad and code hessian in pccd --- src/CC/RCC.f90 | 5 +- src/CC/pCCD.f90 | 107 ++++++++++++++++++++++++++++++++++++++----- src/QuAcK/RQuAcK.f90 | 2 +- 3 files changed, 100 insertions(+), 14 deletions(-) diff --git a/src/CC/RCC.f90 b/src/CC/RCC.f90 index d60dafe..21f6866 100644 --- a/src/CC/RCC.f90 +++ b/src/CC/RCC.f90 @@ -1,5 +1,5 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF) + maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) ! Coupled-cluster module @@ -32,6 +32,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: cHF(nBas,nBas) double precision,intent(in) :: Hc(nBas,nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) @@ -161,7 +162,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dopCCD) then call wall_time(start_CC) - call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF) + call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) call wall_time(end_CC) t_CC = end_CC - start_CC diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index d114158..4f8b67d 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -1,4 +1,4 @@ -subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF) +subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) ! pair CCD module @@ -15,6 +15,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, integer,intent(in) :: nBas,nC,nO,nV,nR double precision,intent(in) :: ENuc,ERHF double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: cHF(nBas,nBas) double precision,intent(in) :: Hc(nBas,nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) @@ -26,7 +27,8 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, integer :: nSCF double precision :: Conv - double precision :: ECC,EcCC + double precision :: ECC + double precision :: EcCC double precision,allocatable :: eO(:) double precision,allocatable :: eV(:) @@ -54,8 +56,11 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, double precision :: tr_2rdm double precision :: E1,E2 - double precision,allocatable :: g(:) - double precision,allocatable :: H(:,:) + double precision,allocatable :: h(:,:) + double precision,allocatable :: grad(:) + double precision,allocatable :: tmp(:,:,:,:) + double precision,allocatable :: hess(:,:) + double precision,allocatable :: eig(:) integer :: O,V,N integer :: n_diis @@ -64,6 +69,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, double precision,allocatable :: t2_diis(:,:) double precision,allocatable :: z2_diis(:,:) double precision,external :: trace_matrix + double precision,external :: Kronecker_delta ! Hello world @@ -365,6 +371,9 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, write(*,*) ' !!! Your 1RDM seems broken !!! ' write(*,*) +! write(*,*) '1RDM is diagonal at the pCCD level:' +! call matout(N,N,rdm1) + ! Form 2RM allocate(rdm2(N,N,N,N)) @@ -472,14 +481,20 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, write(*,*) ' !!! Your 2RDM seems broken !!! ' write(*,*) +! write(*,*) '2RDM is not diagonal at the pCCD level:' +! call matout(N**2,N**2,rdm2) + ! Compute electronic energy + allocate(h(N,N)) + h = matmul(transpose(cHF),matmul(Hc,cHF)) + E1 = 0d0 E2 = 0d0 do p=1,N do q=1,N - E1 = E1 + rdm1(p,q)*Hc(p,q) + E1 = E1 + rdm1(p,q)*h(p,q) do r=1,N do s=1,N E2 = E2 + rdm2(p,q,r,s)*ERI(p,q,r,s) @@ -498,9 +513,9 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, ! Compute gradient - allocate(g(N**2)) + allocate(grad(N**2)) - g(:) = 0d0 + grad(:) = 0d0 pq = 0 do p=1,N @@ -509,25 +524,83 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, pq = pq + 1 do r=1,N - g(pq) = g(pq) + Hc(r,p)*rdm1(r,q) - Hc(q,r)*rdm1(p,r) + grad(pq) = grad(pq) + h(r,p)*rdm1(r,q) - h(q,r)*rdm1(p,r) end do do r=1,N do s=1,N do t=1,N - g(pq) = g(pq) + (ERI(r,s,p,t)*rdm2(r,s,q,t) - ERI(q,t,r,s)*rdm2(p,t,r,s)) + grad(pq) = grad(pq) + (ERI(r,s,p,t)*rdm2(r,s,q,t) - ERI(q,t,r,s)*rdm2(p,t,r,s)) end do end do end do end do end do + + write(*,*) 'Orbital gradient at the pCCD level:' + call matout(N,N,grad) ! Compute Hessian - allocate(H(N**2,N**2)) + allocate(hess(N**2,N**2),tmp(N,N,N,N)) - H(:,:) = 0d0 + tmp(:,:,:,:) = 0d0 + + do p=1,N + do q=1,N + + rs = 0 + do r=1,N + do s=1,N + + tmp(p,q,r,s) = - h(s,p)*rdm1(r,q) - h(q,r)*rdm1(p,s) + + do u=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*( & + Kronecker_delta(q,r)*(h(u,p)*rdm1(u,s) + h(s,u)*rdm1(p,u)) & + + Kronecker_delta(p,s)*(h(u,r)*rdm1(u,q) + h(q,u)*rdm1(r,u)) ) + + end do + + do u=1,N + do v=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) + ERI(u,v,p,r)*rdm2(u,v,q,s) + ERI(q,s,u,v)*rdm2(p,r,u,v) + + end do + end do + + do t=1,N + do u=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) - ( & + ERI(s,t,p,u)*rdm2(r,t,q,u) + ERI(t,s,p,u)*rdm2(t,r,q,u) & + + ERI(q,u,r,t)*rdm2(p,u,s,t) + ERI(q,u,t,r)*rdm2(p,u,t,s) ) + + end do + end do + + do t=1,N + do u=1,N + do v=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*( & + Kronecker_delta(q,r)*(ERI(u,v,p,t)*rdm2(u,v,s,t) + ERI(s,t,u,v)*rdm2(p,t,u,v)) & + + Kronecker_delta(p,s)*(ERI(q,t,u,v)*rdm2(r,t,u,v) + ERI(u,v,r,t)*rdm2(u,v,q,t)) ) + + end do + end do + end do + + end do + end do + + end do + end do + +! Flatten Hessian matrix and add permutations pq = 0 do p=1,N @@ -541,12 +614,24 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, rs = rs + 1 + hess(pq,rs) = tmp(p,q,r,s) - tmp(q,p,r,s) - tmp(p,q,s,r) + tmp(q,p,s,r) + end do end do end do end do + call matout(N**2,N**2,hess) + + deallocate(tmp) + + allocate(eig(N**2)) + + call diagonalize_matrix(N**2,hess,eig) + + call vecout(N**2,eig) + ! Testing zone if(dotest) then diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index a667af9..3897f37 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -228,7 +228,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_CC) call RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF) + maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF,cHF) call wall_time(end_CC) t_CC = end_CC - start_CC From 989bd99f17b6d9371520f6e22c597c98b9564b83 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Mon, 19 Aug 2024 18:11:39 +0200 Subject: [PATCH 04/46] saving tmp --- src/GT/GTpp_excitation_density.f90 | 9 ++- src/GT/RG0T0pp.f90 | 88 ++++++++++++++++++++++++++---- 2 files changed, 84 insertions(+), 13 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index a6ed548..ba32107 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -2,6 +2,7 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 ! Compute excitation densities for T-matrix self-energy + implicit none ! Input variables @@ -44,6 +45,8 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 1) then + print*, "ispin = ", ispin + !$OMP PARALLEL & !$OMP SHARED(nC,nBas,nR,nO,nVV,nOO,rho1,rho2,ERI,X1,Y1,X2,Y2) & !$OMP PRIVATE(q,p,ab,cd,kl,ij) & @@ -123,10 +126,11 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 2 .or. ispin == 4) then + print*, "ispin = ", ispin + do q=nC+1,nBas-nR do p=nC+1,nBas-nR -! do ab=1,nVV ab = 0 do a=nO+1,nBas-nR do b=a+1,nBas-nR @@ -153,7 +157,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 end do end do -! do ij=1,nOO ij = 0 do i=nC+1,nO do j=i+1,nO @@ -190,6 +193,8 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 !---------------------------------------------- if(ispin == 3) then + + print*, "ispin = ", ispin !$OMP PARALLEL & !$OMP SHARED(nC,nBas,nR,nO,nVV,nOO,rho1,rho2,ERI,X1,Y1,X2,Y2) & diff --git a/src/GT/RG0T0pp.f90 b/src/GT/RG0T0pp.f90 index e624bca..2975934 100644 --- a/src/GT/RG0T0pp.f90 +++ b/src/GT/RG0T0pp.f90 @@ -64,6 +64,11 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d double precision,allocatable :: eGT(:) double precision,allocatable :: eGTlin(:) + double precision :: t0, t1 + double precision :: tt0, tt1 + + call wall_time(t0) + ! Output variables ! Hello world @@ -122,11 +127,25 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs)) - if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + call wall_time(tt0) + call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C = ',tt1-tt0,' seconds' + call wall_time(tt0) + call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D = ',tt1-tt0,' seconds' + + call wall_time(tt0) + if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B = ',tt1-tt0,' seconds' + + call wall_time(tt0) call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin)) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR = ',tt1-tt0,' seconds' deallocate(Bpp,Cpp,Dpp) @@ -145,11 +164,25 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) - if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + call wall_time(tt0) + call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C = ',tt1-tt0,' seconds' + call wall_time(tt0) + call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D = ',tt1-tt0,' seconds' + + call wall_time(tt0) + if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B = ',tt1-tt0,' seconds' + + call wall_time(tt0) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR = ',tt1-tt0,' seconds' deallocate(Bpp,Cpp,Dpp) @@ -162,16 +195,25 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d ! iblock = 1 iblock = 3 + + call wall_time(tt0) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GTpp_excitation_density = ',tt1-tt0,' seconds' ! iblock = 2 iblock = 4 + + call wall_time(tt0) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GTpp_excitation_density = ',tt1-tt0,' seconds' !---------------------------------------------- ! Compute T-matrix version of the self-energy !---------------------------------------------- + call wall_time(tt0) if(regularize) then call GTpp_regularization(nBas,nC,nO,nV,nR,nOOs,nVVs,eHF,Om1s,rho1s,Om2s,rho2s) call GTpp_regularization(nBas,nC,nO,nV,nR,nOOt,nVVt,eHF,Om1t,rho1t,Om2t,rho2t) @@ -179,10 +221,14 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d call GTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eHF,Om1s,rho1s,Om2s,rho2s, & Om1t,rho1t,Om2t,rho2t,EcGM,Sig,Z) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for self-energy = ',tt1-tt0,' seconds' !---------------------------------------------- ! Solve the quasi-particle equation !---------------------------------------------- + + call wall_time(tt0) eGTlin(:) = eHF(:) + Z(:)*Sig(:) @@ -203,6 +249,9 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d end if + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time to solve QP = ',tt1-tt0,' seconds' + ! call GTpp_plot_self_energy(nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eHF,eGT,Om1s,rho1s,Om2s,rho2s, & ! Om1t,rho1t,Om2t,rho2t) @@ -218,9 +267,9 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs)) + call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp) + call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp) - call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp) call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin)) @@ -232,11 +281,25 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) - if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI,Cpp) - call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI,Dpp) + call wall_time(tt0) + call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI,Cpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C = ',tt1-tt0,' seconds' + call wall_time(tt0) + call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D = ',tt1-tt0,' seconds' + + call wall_time(tt0) + if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B = ',tt1-tt0,' seconds' + + call wall_time(tt0) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR = ',tt1-tt0,' seconds' deallocate(Bpp,Cpp,Dpp) @@ -336,4 +399,7 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d end if + call wall_time(t1) + write(*,'(A65,1X,F9.3,A8)') 'Total Wall time for RG0T0pp = ',t1-t0,' seconds' + end subroutine From 50bfb261ca040712755efa6b44f40f9aee6c6917 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Mon, 19 Aug 2024 18:44:03 +0200 Subject: [PATCH 05/46] add OpenMP + Collapse --- src/GT/GTpp_excitation_density.f90 | 214 ++++++++++++++++------------- 1 file changed, 119 insertions(+), 95 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index ba32107..e86a524 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -47,11 +47,10 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 print*, "ispin = ", ispin - !$OMP PARALLEL & - !$OMP SHARED(nC,nBas,nR,nO,nVV,nOO,rho1,rho2,ERI,X1,Y1,X2,Y2) & - !$OMP PRIVATE(q,p,ab,cd,kl,ij) & - !$OMP DEFAULT(NONE) - !$OMP DO + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) do q=nC+1,nBas-nR do p=nC+1,nBas-nR @@ -116,8 +115,8 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 end do end do - !$OMP END DO - !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL end if !---------------------------------------------- @@ -128,63 +127,81 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 print*, "ispin = ", ispin - do q=nC+1,nBas-nR - do p=nC+1,nBas-nR + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) + do q = nC+1, nBas-nR + do p = nC+1, nBas-nR ab = 0 - do a=nO+1,nBas-nR - do b=a+1,nBas-nR + + do a = nO+1, nBas-nR + do b = a+1, nBas-nR + ab = ab + 1 cd = 0 - do c=nO+1,nBas-nR - do d=c+1,nBas-nR + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + cd = cd + 1 + rho1(p,q,ab) = rho1(p,q,ab) & + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) - end do - end do + end do ! d + end do ! c kl = 0 - do k=nC+1,nO - do l=k+1,nO + do k = nC+1, nO + do l = k+1, nO + kl = kl + 1 + rho1(p,q,ab) = rho1(p,q,ab) & + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) - end do - end do + end do ! l + end do ! k - end do - end do + end do ! b + end do ! a - ij = 0 - do i=nC+1,nO - do j=i+1,nO + ij = 0 + do i = nC+1, nO + do j = i+1, nO + ij = ij + 1 - + cd = 0 - do c=nO+1,nBas-nR - do d=c+1,nBas-nR + + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + cd = cd + 1 + rho2(p,q,ij) = rho2(p,q,ij) & + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) - end do - end do - + end do ! d + end do ! c + kl = 0 - do k=nC+1,nO - do l=k+1,nO + do k = nC+1, nO + do l = k+1, nO + kl = kl + 1 + rho2(p,q,ij) = rho2(p,q,ij) & + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) - end do - end do - - end do - end do + end do ! l + end do ! k - end do - end do + end do ! j + end do ! i + + end do ! p + end do ! q + !$OMP END DO + !$OMP END PARALLEL end if @@ -196,69 +213,76 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 print*, "ispin = ", ispin - !$OMP PARALLEL & - !$OMP SHARED(nC,nBas,nR,nO,nVV,nOO,rho1,rho2,ERI,X1,Y1,X2,Y2) & - !$OMP PRIVATE(q,p,ab,cd,kl,ij,c,d,k,l) & - !$OMP DEFAULT(NONE) - !$OMP DO + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) - do q=nC+1,nBas-nR - do p=nC+1,nBas-nR + do q = nC+1, nBas-nR + do p = nC+1, nBas-nR - ! do ab=1,nVV - ab = 0 - do a=nO+1,nBas-nR - do b=nO+1,nBas-nR - ab = ab + 1 - - cd = 0 - do c=nO+1,nBas-nR - do d=nO+1,nBas-nR - cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) - end do - end do - - kl = 0 - do k=nC+1,nO - do l=nC+1,nO - kl = kl + 1 - rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) - end do - end do + ab = 0 + do a = nO+1, nBas-nR + do b = nO+1, nBas-nR + + ab = ab + 1 + cd = 0 + do c = nO+1, nBas-nR + do d = nO+1, nBas-nR + + cd = cd + 1 + + rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) end do - end do - - ! do ij=1,nOO - ij = 0 - do i=nC+1,nO - do j=nC+1,nO - ij = ij + 1 - - cd = 0 - do c=nO+1,nBas-nR - do d=nO+1,nBas-nR - cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) - end do - end do - - kl = 0 - do k=nC+1,nO - do l=nC+1,nO - kl = kl + 1 - rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) - end do - end do + end do + kl = 0 + do k = nC+1, nO + do l = nC+1, nO + + kl = kl + 1 + + rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) end do - end do - + end do + + end do end do - end do - !$OMP END DO - !$OMP END PARALLEL + + ij = 0 + do i = nC+1, nO + do j = nC+1, nO + + ij = ij + 1 + + cd = 0 + do c = nO+1, nBas-nR + do d = nO+1, nBas-nR + + cd = cd + 1 + + rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) + end do + end do + + kl = 0 + do k = nC+1, nO + do l = nC+1, nO + + kl = kl + 1 + + rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) + end do + end do + + end do + end do + + end do + end do + !$OMP END DO + !$OMP END PARALLEL end if From 635e7ae457e6f2df8f90663895108e1856142b4d Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Mon, 19 Aug 2024 19:22:37 +0200 Subject: [PATCH 06/46] rho1 & rho2: use DGEMM instead of OpenMP --- src/GT/GTpp_excitation_density.f90 | 186 +++++++++++++++++++---------- 1 file changed, 122 insertions(+), 64 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index e86a524..8b4b1c2 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -34,6 +34,10 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 double precision,intent(out) :: rho1(nBas,nBas,nVV) double precision,intent(out) :: rho2(nBas,nBas,nOO) + integer :: dim_1, dim_2 + double precision, allocatable :: ERI_1(:,:,:) + double precision, allocatable :: ERI_2(:,:,:) + ! Initialization rho1(:,:,:) = 0d0 @@ -209,81 +213,135 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 ! alpha-beta block !---------------------------------------------- + ! TODO + ! debug for nC & nR + if(ispin == 3) then print*, "ispin = ", ispin - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & - !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + + dim_1 = (nBas - nO) * (nBas - nO) + dim_2 = nO * nO + + allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) + ERI_1 = 0.d0 + ERI_2 = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) !$OMP DO COLLAPSE(2) - do q = nC+1, nBas-nR do p = nC+1, nBas-nR - - ab = 0 - do a = nO+1, nBas-nR - do b = nO+1, nBas-nR - - ab = ab + 1 - - cd = 0 - do c = nO+1, nBas-nR - do d = nO+1, nBas-nR - - cd = cd + 1 - - rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) - end do - end do - - kl = 0 - do k = nC+1, nO - do l = nC+1, nO - - kl = kl + 1 - - rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) - end do - end do - + cd = 0 + do c = nO+1, nBas-nR + do d = nO+1, nBas-nR + cd = cd + 1 + ERI_1(p,q,cd) = ERI(p,q,c,d) + enddo + enddo + kl = 0 + do k = nC+1, nO + do l = nC+1, nO + kl = kl + 1 + ERI_2(p,q,kl) = ERI(p,q,k,l) end do end do - - ij = 0 - do i = nC+1, nO - do j = nC+1, nO - - ij = ij + 1 - - cd = 0 - do c = nO+1, nBas-nR - do d = nO+1, nBas-nR - - cd = cd + 1 - - rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) - end do - end do - - kl = 0 - do k = nC+1, nO - do l = nC+1, nO - - kl = kl + 1 - - rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) - end do - end do - - end do - end do - - end do - end do + enddo + enddo !$OMP END DO !$OMP END PARALLEL + call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & + 0.d0, rho1(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & + 1.d0, rho1(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & + 0.d0, rho2(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & + 1.d0, rho2(1,1,1), nBas*nBas) + + deallocate(ERI_1, ERI_2) + + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & +! !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) +! !$OMP DO COLLAPSE(2) +! +! do q = nC+1, nBas-nR +! do p = nC+1, nBas-nR +! +! ab = 0 +! do a = nO+1, nBas-nR +! do b = nO+1, nBas-nR +! +! ab = ab + 1 +! +! cd = 0 +! do c = nO+1, nBas-nR +! do d = nO+1, nBas-nR +! +! cd = cd + 1 +! +! rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) +! end do +! end do +! +! kl = 0 +! do k = nC+1, nO +! do l = nC+1, nO +! +! kl = kl + 1 +! +! rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) +! end do +! end do +! +! end do +! end do +! +! ij = 0 +! do i = nC+1, nO +! do j = nC+1, nO +! +! ij = ij + 1 +! +! cd = 0 +! do c = nO+1, nBas-nR +! do d = nO+1, nBas-nR +! +! cd = cd + 1 +! +! rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) +! end do +! end do +! +! kl = 0 +! do k = nC+1, nO +! do l = nC+1, nO +! +! kl = kl + 1 +! +! rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) +! end do +! end do +! +! end do +! end do +! +! end do +! end do +! !$OMP END DO +! !$OMP END PARALLEL + end if end subroutine From c9fa0470aaea5633056e64da1a1d77152ed515d5 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Mon, 19 Aug 2024 19:32:33 +0200 Subject: [PATCH 07/46] rm time printing --- src/GT/GTpp_excitation_density.f90 | 6 --- src/GT/RG0T0pp.f90 | 63 ------------------------------ 2 files changed, 69 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index 8b4b1c2..fe86ef3 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -49,8 +49,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 1) then - print*, "ispin = ", ispin - !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) @@ -129,8 +127,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 2 .or. ispin == 4) then - print*, "ispin = ", ispin - !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) @@ -218,8 +214,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 3) then - print*, "ispin = ", ispin - dim_1 = (nBas - nO) * (nBas - nO) dim_2 = nO * nO diff --git a/src/GT/RG0T0pp.f90 b/src/GT/RG0T0pp.f90 index 2975934..5954adf 100644 --- a/src/GT/RG0T0pp.f90 +++ b/src/GT/RG0T0pp.f90 @@ -64,10 +64,6 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d double precision,allocatable :: eGT(:) double precision,allocatable :: eGTlin(:) - double precision :: t0, t1 - double precision :: tt0, tt1 - - call wall_time(t0) ! Output variables @@ -127,25 +123,11 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs)) - call wall_time(tt0) call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C = ',tt1-tt0,' seconds' - - call wall_time(tt0) call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D = ',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B = ',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin)) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR = ',tt1-tt0,' seconds' deallocate(Bpp,Cpp,Dpp) @@ -164,25 +146,11 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) - call wall_time(tt0) call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C = ',tt1-tt0,' seconds' - - call wall_time(tt0) call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D = ',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B = ',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR = ',tt1-tt0,' seconds' deallocate(Bpp,Cpp,Dpp) @@ -196,24 +164,17 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d ! iblock = 1 iblock = 3 - call wall_time(tt0) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GTpp_excitation_density = ',tt1-tt0,' seconds' ! iblock = 2 iblock = 4 - call wall_time(tt0) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GTpp_excitation_density = ',tt1-tt0,' seconds' !---------------------------------------------- ! Compute T-matrix version of the self-energy !---------------------------------------------- - call wall_time(tt0) if(regularize) then call GTpp_regularization(nBas,nC,nO,nV,nR,nOOs,nVVs,eHF,Om1s,rho1s,Om2s,rho2s) call GTpp_regularization(nBas,nC,nO,nV,nR,nOOt,nVVt,eHF,Om1t,rho1t,Om2t,rho2t) @@ -221,15 +182,11 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d call GTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eHF,Om1s,rho1s,Om2s,rho2s, & Om1t,rho1t,Om2t,rho2t,EcGM,Sig,Z) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for self-energy = ',tt1-tt0,' seconds' !---------------------------------------------- ! Solve the quasi-particle equation !---------------------------------------------- - call wall_time(tt0) - eGTlin(:) = eHF(:) + Z(:)*Sig(:) if(linearize) then @@ -249,9 +206,6 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d end if - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time to solve QP = ',tt1-tt0,' seconds' - ! call GTpp_plot_self_energy(nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eHF,eGT,Om1s,rho1s,Om2s,rho2s, & ! Om1t,rho1t,Om2t,rho2t) @@ -281,25 +235,11 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) - call wall_time(tt0) call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI,Cpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C = ',tt1-tt0,' seconds' - - call wall_time(tt0) call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI,Dpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D = ',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B = ',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR = ',tt1-tt0,' seconds' deallocate(Bpp,Cpp,Dpp) @@ -399,7 +339,4 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d end if - call wall_time(t1) - write(*,'(A65,1X,F9.3,A8)') 'Total Wall time for RG0T0pp = ',t1-t0,' seconds' - end subroutine From 4fadf5c1bb98c060a17c8d8fec2ca5bf0ce5de2c Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 21 Aug 2024 09:03:40 +0200 Subject: [PATCH 08/46] OpenMP -> DGEMM for ispin=2,4 in GTpp_excitation_density --- src/GT/GTpp_excitation_density.f90 | 195 +++++++++++++++++++---------- 1 file changed, 127 insertions(+), 68 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index fe86ef3..d793d5c 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -2,6 +2,11 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 ! Compute excitation densities for T-matrix self-energy + ! TODO + ! debug DGEMM for nC != 0 + ! and nR != 0 + + implicit none @@ -49,6 +54,8 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 1) then + print*, "ispin = ", ispin + !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) @@ -127,81 +134,134 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 2 .or. ispin == 4) then - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & - !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + print*, "ispin = ", ispin + + dim_1 = (nBas - nO) * (nBas - nO - 1) / 2 + dim_2 = nO * (nO - 1) / 2 + + allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) + ERI_1 = 0.d0 + ERI_2 = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) !$OMP DO COLLAPSE(2) do q = nC+1, nBas-nR do p = nC+1, nBas-nR - - ab = 0 + cd = 0 + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + cd = cd + 1 + ERI_1(p,q,cd) = ERI(p,q,c,d) - ERI(p,q,d,c) + enddo + enddo + kl = 0 + do k = nC+1, nO + do l = k+1, nO + kl = kl + 1 + ERI_2(p,q,kl) = ERI(p,q,k,l) - ERI(p,q,l,k) + end do + end do + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL - do a = nO+1, nBas-nR - do b = a+1, nBas-nR + call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & + 0.d0, rho1(1,1,1), nBas*nBas) - ab = ab + 1 - - cd = 0 - do c = nO+1, nBas-nR - do d = c+1, nBas-nR + call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & + 1.d0, rho1(1,1,1), nBas*nBas) - cd = cd + 1 + call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & + 0.d0, rho2(1,1,1), nBas*nBas) - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) - end do ! d - end do ! c - - kl = 0 - do k = nC+1, nO - do l = k+1, nO + call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & + 1.d0, rho2(1,1,1), nBas*nBas) - kl = kl + 1 + deallocate(ERI_1, ERI_2) - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) - end do ! l - end do ! k - - end do ! b - end do ! a - - ij = 0 - do i = nC+1, nO - do j = i+1, nO - ij = ij + 1 - - cd = 0 - - do c = nO+1, nBas-nR - do d = c+1, nBas-nR - - cd = cd + 1 - - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) - end do ! d - end do ! c - - kl = 0 - do k = nC+1, nO - do l = k+1, nO - - kl = kl + 1 - - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) - end do ! l - end do ! k - - end do ! j - end do ! i - - end do ! p - end do ! q - !$OMP END DO - !$OMP END PARALLEL +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & +! !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) +! !$OMP DO COLLAPSE(2) +! do q = nC+1, nBas-nR +! do p = nC+1, nBas-nR +! +! ab = 0 +! +! do a = nO+1, nBas-nR +! do b = a+1, nBas-nR +! +! ab = ab + 1 +! +! cd = 0 +! do c = nO+1, nBas-nR +! do d = c+1, nBas-nR +! +! cd = cd + 1 +! +! rho1(p,q,ab) = rho1(p,q,ab) & +! + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) +! end do ! d +! end do ! c +! +! kl = 0 +! do k = nC+1, nO +! do l = k+1, nO +! +! kl = kl + 1 +! +! rho1(p,q,ab) = rho1(p,q,ab) & +! + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) +! end do ! l +! end do ! k +! +! end do ! b +! end do ! a +! +! ij = 0 +! do i = nC+1, nO +! do j = i+1, nO +! +! ij = ij + 1 +! +! cd = 0 +! +! do c = nO+1, nBas-nR +! do d = c+1, nBas-nR +! +! cd = cd + 1 +! +! rho2(p,q,ij) = rho2(p,q,ij) & +! + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) +! end do ! d +! end do ! c +! +! kl = 0 +! do k = nC+1, nO +! do l = k+1, nO +! +! kl = kl + 1 +! +! rho2(p,q,ij) = rho2(p,q,ij) & +! + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) +! end do ! l +! end do ! k +! +! end do ! j +! end do ! i +! +! end do ! p +! end do ! q +! !$OMP END DO +! !$OMP END PARALLEL end if @@ -209,11 +269,10 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 ! alpha-beta block !---------------------------------------------- - ! TODO - ! debug for nC & nR - if(ispin == 3) then + print*, "ispin = ", ispin + dim_1 = (nBas - nO) * (nBas - nO) dim_2 = nO * nO From 5a738f00b94d3e6aa53fe7c7eeb606093ae79665 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 21 Aug 2024 09:03:40 +0200 Subject: [PATCH 09/46] OpenMP -> DGEMM for ispin=2,4 in GTpp_excitation_density --- src/GT/GTpp_excitation_density.f90 | 189 ++++++++++++++++++----------- 1 file changed, 121 insertions(+), 68 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index fe86ef3..05f9c2d 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -2,6 +2,11 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 ! Compute excitation densities for T-matrix self-energy + ! TODO + ! debug DGEMM for nC != 0 + ! and nR != 0 + + implicit none @@ -127,81 +132,132 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 2 .or. ispin == 4) then - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & - !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + dim_1 = (nBas - nO) * (nBas - nO - 1) / 2 + dim_2 = nO * (nO - 1) / 2 + + allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) + ERI_1 = 0.d0 + ERI_2 = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) !$OMP DO COLLAPSE(2) do q = nC+1, nBas-nR do p = nC+1, nBas-nR - - ab = 0 + cd = 0 + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + cd = cd + 1 + ERI_1(p,q,cd) = ERI(p,q,c,d) - ERI(p,q,d,c) + enddo + enddo + kl = 0 + do k = nC+1, nO + do l = k+1, nO + kl = kl + 1 + ERI_2(p,q,kl) = ERI(p,q,k,l) - ERI(p,q,l,k) + end do + end do + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL - do a = nO+1, nBas-nR - do b = a+1, nBas-nR + call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & + 0.d0, rho1(1,1,1), nBas*nBas) - ab = ab + 1 - - cd = 0 - do c = nO+1, nBas-nR - do d = c+1, nBas-nR + call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & + 1.d0, rho1(1,1,1), nBas*nBas) - cd = cd + 1 + call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & + 0.d0, rho2(1,1,1), nBas*nBas) - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) - end do ! d - end do ! c - - kl = 0 - do k = nC+1, nO - do l = k+1, nO + call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & + 1.d0, rho2(1,1,1), nBas*nBas) - kl = kl + 1 + deallocate(ERI_1, ERI_2) - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) - end do ! l - end do ! k - - end do ! b - end do ! a - - ij = 0 - do i = nC+1, nO - do j = i+1, nO - ij = ij + 1 - - cd = 0 - - do c = nO+1, nBas-nR - do d = c+1, nBas-nR - - cd = cd + 1 - - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) - end do ! d - end do ! c - - kl = 0 - do k = nC+1, nO - do l = k+1, nO - - kl = kl + 1 - - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) - end do ! l - end do ! k - - end do ! j - end do ! i - - end do ! p - end do ! q - !$OMP END DO - !$OMP END PARALLEL +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & +! !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) +! !$OMP DO COLLAPSE(2) +! do q = nC+1, nBas-nR +! do p = nC+1, nBas-nR +! +! ab = 0 +! +! do a = nO+1, nBas-nR +! do b = a+1, nBas-nR +! +! ab = ab + 1 +! +! cd = 0 +! do c = nO+1, nBas-nR +! do d = c+1, nBas-nR +! +! cd = cd + 1 +! +! rho1(p,q,ab) = rho1(p,q,ab) & +! + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) +! end do ! d +! end do ! c +! +! kl = 0 +! do k = nC+1, nO +! do l = k+1, nO +! +! kl = kl + 1 +! +! rho1(p,q,ab) = rho1(p,q,ab) & +! + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) +! end do ! l +! end do ! k +! +! end do ! b +! end do ! a +! +! ij = 0 +! do i = nC+1, nO +! do j = i+1, nO +! +! ij = ij + 1 +! +! cd = 0 +! +! do c = nO+1, nBas-nR +! do d = c+1, nBas-nR +! +! cd = cd + 1 +! +! rho2(p,q,ij) = rho2(p,q,ij) & +! + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) +! end do ! d +! end do ! c +! +! kl = 0 +! do k = nC+1, nO +! do l = k+1, nO +! +! kl = kl + 1 +! +! rho2(p,q,ij) = rho2(p,q,ij) & +! + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) +! end do ! l +! end do ! k +! +! end do ! j +! end do ! i +! +! end do ! p +! end do ! q +! !$OMP END DO +! !$OMP END PARALLEL end if @@ -209,9 +265,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 ! alpha-beta block !---------------------------------------------- - ! TODO - ! debug for nC & nR - if(ispin == 3) then dim_1 = (nBas - nO) * (nBas - nO) From a1786b2ade0cb07f023dfa44e12230bed952a786 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 21 Aug 2024 09:13:25 +0200 Subject: [PATCH 10/46] rm print ispin --- src/GT/GTpp_excitation_density.f90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index a3be531..05f9c2d 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -54,8 +54,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 1) then - print*, "ispin = ", ispin - !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) @@ -269,8 +267,6 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 if(ispin == 3) then - print*, "ispin = ", ispin - dim_1 = (nBas - nO) * (nBas - nO) dim_2 = nO * nO From 992e3dff4b98142130638f597d8cad240e21ba25 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 21 Aug 2024 13:51:12 +0200 Subject: [PATCH 11/46] optim in AdAt --- src/RPA/sort_ppRPA.f90 | 9 ++++---- src/utils/orthogonalization_matrix.f90 | 2 +- src/utils/utils.f90 | 30 +++++++++++++++++++------- src/utils/wrap_lapack.f90 | 4 ++++ 4 files changed, 32 insertions(+), 13 deletions(-) diff --git a/src/RPA/sort_ppRPA.f90 b/src/RPA/sort_ppRPA.f90 index e7037ad..8518ecb 100644 --- a/src/RPA/sort_ppRPA.f90 +++ b/src/RPA/sort_ppRPA.f90 @@ -39,9 +39,10 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2) double precision,intent(out) :: X2(nVV,nOO) double precision,intent(out) :: Y2(nOO,nOO) + ! Memory allocation - allocate(M(nOO+nVV,nOO+nVV),Z1(nOO+nVV,nVV),Z2(nOO+nVV,nOO),order1(nVV),order2(nOO)) + allocate(M(nOO+nVV,nOO+nVV),Z1(nOO+nVV,nVV),Z2(nOO+nVV,nOO),order1(nVV),order2(nOO)) ! Initializatiom @@ -86,7 +87,7 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2) end if - end do + end do if(minval(Om1) < 0d0 .or. ab /= nVV) call print_warning('You may have instabilities in pp-RPA!!') if(maxval(Om2) > 0d0 .or. ij /= nOO) call print_warning('You may have instabilities in pp-RPA!!') @@ -111,7 +112,8 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2) call quick_sort(Om2,order2,nOO) call set_order(Z2,order2,nOO+nVV,nOO) - end if + end if + ! Orthogonalize eigenvectors @@ -202,7 +204,6 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2) if(nVV > 0) call dgemm ('N', 'N', nOO+nVV, nVV, nOO+nVV, 1d0, M, nOO+nVV, Z1, nOO+nVV, 0d0, tmp1, nOO+nVV) if(nVV > 0) call dgemm ('T', 'N', nVV , nVV, nOO+nVV, 1d0, Z1, nOO+nVV, tmp1, nOO+nVV, 0d0, S1, nVV) - if(nOO > 0) call dgemm ('N', 'N', nOO+nVV, nOO, nOO+nVV, 1d0, M, nOO+nVV, -1d0*Z2, nOO+nVV, 0d0, tmp2, nOO+nVV) if(nOO > 0) call dgemm ('T', 'N', nOO , nOO, nOO+nVV, 1d0, Z2, nOO+nVV, tmp2, nOO+nVV, 0d0, S2, nOO) diff --git a/src/utils/orthogonalization_matrix.f90 b/src/utils/orthogonalization_matrix.f90 index 176862a..d7e0089 100644 --- a/src/utils/orthogonalization_matrix.f90 +++ b/src/utils/orthogonalization_matrix.f90 @@ -54,7 +54,7 @@ subroutine orthogonalization_matrix(nBas,S,X) end do - call ADAt(nBas,Uvec,Uval,X) + call ADAt(nBas, Uvec(1,1), Uval(1), X(1,1)) elseif(ortho_type == 2) then diff --git a/src/utils/utils.f90 b/src/utils/utils.f90 index efd3087..80b8322 100644 --- a/src/utils/utils.f90 +++ b/src/utils/utils.f90 @@ -375,15 +375,29 @@ subroutine ADAt(N,A,D,B) double precision,intent(out) :: B(N,N) - B = 0d0 + double precision, allocatable :: tmp(:,:) - 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) - end do - end do - end do + allocate(tmp(N,N)) + !$OMP PARALLEL DEFAULT(NONE) PRIVATE(i, j) SHARED(N, A, D, tmp) + !$OMP DO + do i = 1, N + do j = 1, N + tmp(i,j) = D(i) * A(j,i) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call dgemm("N", "N", N, N, N, 1.d0, A(1,1), N, tmp(1,1), N, 0.d0, B(1,1), N) + deallocate(tmp) + +! 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) +! end do +! end do +! end do end subroutine !------------------------------------------------------------------------ diff --git a/src/utils/wrap_lapack.f90 b/src/utils/wrap_lapack.f90 index d63b722..86280fe 100644 --- a/src/utils/wrap_lapack.f90 +++ b/src/utils/wrap_lapack.f90 @@ -31,6 +31,8 @@ subroutine diagonalize_general_matrix(N,A,WR,VR) call dgeev('V','V',N,A,N,WR,WI,VL,N,VR,N,work,lwork,info) + deallocate(work, WI, VL) + if(info /= 0) then print*,'Problem in diagonalize_general_matrix (dgeev)!!' end if @@ -67,6 +69,8 @@ subroutine diagonalize_matrix(N,A,e) allocate(work(lwork)) call dsyev('V','U',N,A,N,e,work,lwork,info) + + deallocate(work) if(info /= 0) then print*,'Problem in diagonalize_matrix (dsyev)!!' From bb4729192ef9dbc6175826129fd9d990bfa26261 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 15:23:08 +0200 Subject: [PATCH 12/46] GW_ppBSE_static_kernel_C for ispin = 1 --- src/GW/GW_ppBSE.f90 | 109 ++++++++++++++++++++++++---- src/GW/GW_ppBSE_static_kernel_C.f90 | 92 +++++++++++++++++------ src/GW/RG0W0.f90 | 56 +++++++++++++- 3 files changed, 221 insertions(+), 36 deletions(-) diff --git a/src/GW/GW_ppBSE.f90 b/src/GW/GW_ppBSE.f90 index c1d6daa..e26b2e1 100644 --- a/src/GW/GW_ppBSE.f90 +++ b/src/GW/GW_ppBSE.f90 @@ -66,6 +66,11 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, double precision,intent(out) :: EcBSE(nspin) + double precision :: t0, t1 + double precision :: tt0, tt1 + + call wall_time(t0) + !--------------------------------- ! Compute (singlet) RPA screening !--------------------------------- @@ -76,11 +81,25 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, allocate(OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS), & Aph(nS,nS),Bph(nS,nS)) - call phLR_A(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,eW,ERI,Aph) - if(.not.TDA_W) call phLR_B(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call wall_time(tt0) + call phLR_A(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,eW,ERI,Aph) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_A =',tt1-tt0,' seconds' + call wall_time(tt0) + if(.not.TDA_W) call phLR_B(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_B =',tt1-tt0,' seconds' + + call wall_time(tt0) call phLR(TDA_W,nS,Aph,Bph,EcRPA,OmRPA,XpY_RPA,XmY_RPA) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR =',tt1-tt0,' seconds' + + call wall_time(tt0) call GW_excitation_density(nBas,nC,nO,nR,nS,ERI,XpY_RPA,rho_RPA) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_excitation_density =',tt1-tt0,' seconds' deallocate(XpY_RPA,XmY_RPA,Aph,Bph) @@ -108,32 +127,63 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, ! Compute BSE excitation energies - if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta) - call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta) - call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta) + call wall_time(tt0) + call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_C =',tt1-tt0,' seconds' + call wall_time(tt0) + call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_D =',tt1-tt0,' seconds' + + call wall_time(tt0) + if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_B =',tt1-tt0,' seconds' + + call wall_time(tt0) + call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C =',tt1-tt0,' seconds' + + call wall_time(tt0) + call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D =',tt1-tt0,' seconds' + + call wall_time(tt0) if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) - call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp) - call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B =',tt1-tt0,' seconds' Bpp(:,:) = Bpp(:,:) + KB_sta(:,:) Cpp(:,:) = Cpp(:,:) + KC_sta(:,:) Dpp(:,:) = Dpp(:,:) + KD_sta(:,:) + call wall_time(tt0) call ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin)) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR =',tt1-tt0,' seconds' + call wall_time(tt0) call ppLR_transition_vectors(.true.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_transition_vectors =',tt1-tt0,' seconds' !----------------------------------------------------! ! Compute the dynamical screening at the ppBSE level ! !----------------------------------------------------! + call wall_time(tt0) if(dBSE) & call GW_ppBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,eW,eGW,ERI,dipole_int,OmRPA,rho_RPA, & Om1,X1,Y1,Om2,X2,Y2,KB_sta,KC_sta,KD_sta) - write(*,*) "Deallocate not done" + + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_dynamic_perturbation =',tt1-tt0,' seconds' + deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,KB_sta,KC_sta,KD_sta) - write(*,*) "Deallocate done" end if !------------------- @@ -160,33 +210,66 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, ! Compute BSE excitation energies + call wall_time(tt0) + call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_C =',tt1-tt0,' seconds' + + call wall_time(tt0) + call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_D =',tt1-tt0,' seconds' + + call wall_time(tt0) if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta) - call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta) - call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_B =',tt1-tt0,' seconds' + call wall_time(tt0) + call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C =',tt1-tt0,' seconds' + call wall_time(tt0) + call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D =',tt1-tt0,' seconds' + + call wall_time(tt0) if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) - call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp) - call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B =',tt1-tt0,' seconds' Bpp(:,:) = Bpp(:,:) + KB_sta(:,:) Cpp(:,:) = Cpp(:,:) + KC_sta(:,:) Dpp(:,:) = Dpp(:,:) + KD_sta(:,:) + call wall_time(tt0) call ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin)) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR =',tt1-tt0,' seconds' + call wall_time(tt0) call ppLR_transition_vectors(.false.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_transition_vectors =',tt1-tt0,' seconds' !----------------------------------------------------! ! Compute the dynamical screening at the ppBSE level ! !----------------------------------------------------! + call wall_time(tt0) if(dBSE) & call GW_ppBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,eW,eGW,ERI,dipole_int,OmRPA,rho_RPA, & Om1,X1,Y1,Om2,X2,Y2,KB_sta,KC_sta,KD_sta) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_dynamic_perturbation =',tt1-tt0,' seconds' deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,KB_sta,KC_sta,KD_sta) end if + call wall_time(t1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE =',t1-t0,' seconds' + end subroutine diff --git a/src/GW/GW_ppBSE_static_kernel_C.f90 b/src/GW/GW_ppBSE_static_kernel_C.f90 index ef21825..dfc9c75 100644 --- a/src/GW/GW_ppBSE_static_kernel_C.f90 +++ b/src/GW/GW_ppBSE_static_kernel_C.f90 @@ -26,44 +26,94 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI double precision,external :: Kronecker_delta double precision :: chi double precision :: eps + double precision :: tmp_ab, lambda4, eta2 integer :: a,b,c,d,ab,cd,m + integer :: a0, aa + + double precision, allocatable :: Om_tmp(:) ! Output variables double precision,intent(out) :: KC(nVV,nVV) -! Initialization - - KC(:,:) = 0d0 - !---------------! ! Singlet block ! !---------------! if(ispin == 1) then - ab = 0 - do a=nO+1,nBas-nR - do b=a,nBas-nR - ab = ab + 1 + a0 = nBas - nR - nO + lambda4 = 4.d0 * lambda + eta2 = eta * eta + + allocate(Om_tmp(nS)) + + !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp) + !$OMP DO + do m = 1, nS + Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2) + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, tmp_ab) & + !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC) + !$OMP DO + do a = nO+1, nBas-nR + aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO + do b = a, nBas-nR + ab = aa + b + + tmp_ab = lambda4 + if(a .eq. b) then + tmp_ab = 0.7071067811865475d0 * lambda4 + endif + cd = 0 - do c=nO+1,nBas-nR - do d=c,nBas-nR + do c = nO + 1, nBas-nR + do d = c, nBas-nR cd = cd + 1 - chi = 0d0 - do m=1,nS - eps = Om(m)**2 + eta**2 - chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps & - - rho(a,d,m)*rho(b,c,m)*Om(m)/eps - end do + KC(ab,cd) = 0d0 + do m = 1, nS + KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) & + - rho(a,d,m) * rho(b,c,m) * Om_tmp(m) + end do - KC(ab,cd) = 4d0*lambda*chi/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) + KC(ab,cd) = tmp_ab * KC(ab,cd) + if(c .eq. d) then + KC(ab,cd) = 0.7071067811865475d0 * KC(ab,cd) + endif + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL - end do - end do - end do - end do +! ab = 0 +! do a=nO+1,nBas-nR +! do b=a,nBas-nR +! ab = ab + 1 +! cd = 0 +! do c=nO+1,nBas-nR +! do d=c,nBas-nR +! cd = cd + 1 +! +! chi = 0d0 +! do m=1,nS +! eps = Om(m)**2 + eta**2 +! chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps & +! - rho(a,d,m)*rho(b,c,m)*Om(m)/eps +! end do +! +! KC(ab,cd) = 4d0*lambda*chi/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) +! +! end do +! end do +! end do +! end do end if diff --git a/src/GW/RG0W0.f90 b/src/GW/RG0W0.f90 index fc30b5d..1bd18e0 100644 --- a/src/GW/RG0W0.f90 +++ b/src/GW/RG0W0.f90 @@ -59,6 +59,11 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA double precision,allocatable :: eGWlin(:) double precision,allocatable :: eGW(:) + double precision :: t0, t1 + double precision :: tt0, tt1 + + call wall_time(t0) + ! Output variables ! Hello world @@ -101,26 +106,48 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Compute screening ! !-------------------! - call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call wall_time(tt0) + call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_A =',tt1-tt0,' seconds' + + call wall_time(tt0) if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_B =',tt1-tt0,' seconds' + call wall_time(tt0) call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR =',tt1-tt0,' seconds' + call wall_time(tt0) if(print_W) call print_excitation_energies('phRPA@RHF','singlet',nS,Om) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for print_excitation_energies =',tt1-tt0,' seconds' !--------------------------! ! Compute spectral weights ! !--------------------------! + call wall_time(tt0) call GW_excitation_density(nBas,nC,nO,nR,nS,ERI,XpY,rho) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_excitation_density =',tt1-tt0,' seconds' !------------------------! ! Compute GW self-energy ! !------------------------! + call wall_time(tt0) if(regularize) call GW_regularization(nBas,nC,nO,nV,nR,nS,eHF,Om,rho) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_regularization =',tt1-tt0,' seconds' + call wall_time(tt0) call GW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,EcGM,SigC,Z) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_self_energy_diag =',tt1-tt0,' seconds' !-----------------------------------! ! Solve the quasi-particle equation ! @@ -128,6 +155,7 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Linearized or graphical solution? + call wall_time(tt0) eGWlin(:) = eHF(:) + Z(:)*SigC(:) if(linearize) then @@ -145,6 +173,8 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA call GW_QP_graph(eta,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,eGWlin,eHF,eGW,Z) end if + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for QP =',tt1-tt0,' seconds' ! Plot self-energy, renormalization factor, and spectral function @@ -158,19 +188,33 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Compute the RPA correlation energy + call wall_time(tt0) call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI,Aph) - if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_A =',tt1-tt0,' seconds' + call wall_time(tt0) + if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_B =',tt1-tt0,' seconds' + + call wall_time(tt0) call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR =',tt1-tt0,' seconds' !--------------! ! Dump results ! !--------------! + call wall_time(tt0) call print_RG0W0(nBas,nO,eHF,ENuc,ERHF,SigC,Z,eGW,EcRPA,EcGM) + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for print_RG0W0 =',tt1-tt0,' seconds' ! Perform BSE calculation + call wall_time(tt0) if(dophBSE) then call GW_phBSE(dophBSE2,TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGW,EcBSE) @@ -221,7 +265,10 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA end if end if + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for phBSE =',tt1-tt0,' seconds' + call wall_time(tt0) if(doppBSE) then call GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGW,EcBSE) @@ -238,6 +285,8 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA write(*,*) end if + call wall_time(tt1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppBSE =',tt1-tt0,' seconds' ! end if @@ -251,4 +300,7 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA end if + call wall_time(t1) + write(*,'(A65,1X,F9.3,A8)') 'Wall time for RG0W0 =',t1-t0,' seconds' + end subroutine From af65a4d69c4d4198177dbb84f363bafdd7471fc5 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 16:44:16 +0200 Subject: [PATCH 13/46] GW_ppBSE_static_kernel_C for ispin = 2 --- src/GW/GW_ppBSE_static_kernel_C.f90 | 82 ++++++++++++++++++++++------- 1 file changed, 64 insertions(+), 18 deletions(-) diff --git a/src/GW/GW_ppBSE_static_kernel_C.f90 b/src/GW/GW_ppBSE_static_kernel_C.f90 index dfc9c75..534654c 100644 --- a/src/GW/GW_ppBSE_static_kernel_C.f90 +++ b/src/GW/GW_ppBSE_static_kernel_C.f90 @@ -71,7 +71,7 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI endif cd = 0 - do c = nO + 1, nBas-nR + do c = nO+1, nBas-nR do d = c, nBas-nR cd = cd + 1 @@ -92,6 +92,8 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI !$OMP END DO !$OMP END PARALLEL + deallocate(Om_tmp) + ! ab = 0 ! do a=nO+1,nBas-nR ! do b=a,nBas-nR @@ -123,28 +125,72 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI if(ispin == 2) then - ab = 0 - do a=nO+1,nBas-nR - do b=a+1,nBas-nR - ab = ab + 1 + a0 = nBas - nR - nO - 1 + lambda4 = 4.d0 * lambda + eta2 = eta * eta + + allocate(Om_tmp(nS)) + + !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp) + !$OMP DO + do m = 1, nS + Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2) + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m) & + !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC) + !$OMP DO + do a = nO+1, nBas-nR + aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1 + do b = a+1, nBas-nR + ab = aa + b + cd = 0 - do c=nO+1,nBas-nR - do d=c+1,nBas-nR + do c = nO+1, nBas-nR + do d = c+1, nBas-nR cd = cd + 1 - chi = 0d0 - do m=1,nS - eps = Om(m)**2 + eta**2 - chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps & - + rho(a,d,m)*rho(b,c,m)*Om(m)/eps + KC(ab,cd) = 0d0 + do m = 1, nS + KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) & + + rho(a,d,m) * rho(b,c,m) * Om_tmp(m) end do - - KC(ab,cd) = 4d0*lambda*chi - end do - end do - end do - end do + KC(ab,cd) = lambda4 * KC(ab,cd) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(Om_tmp) + +! ab = 0 +! do a=nO+1,nBas-nR +! do b=a+1,nBas-nR +! ab = ab + 1 +! cd = 0 +! do c=nO+1,nBas-nR +! do d=c+1,nBas-nR +! cd = cd + 1 +! +! chi = 0d0 +! do m=1,nS +! eps = Om(m)**2 + eta**2 +! chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps & +! + rho(a,d,m)*rho(b,c,m)*Om(m)/eps +! end do +! +! KC(ab,cd) = 4d0*lambda*chi +! +! end do +! end do +! end do +! end do end if From 8e26c3582622d2cfb7c9b093ce85dccd19ca2fd3 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 16:48:15 +0200 Subject: [PATCH 14/46] added Olympe comf --- src/make_ninja.py | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/make_ninja.py b/src/make_ninja.py index 1ac16ed..1e72639 100755 --- a/src/make_ninja.py +++ b/src/make_ninja.py @@ -76,10 +76,21 @@ STDCXX=-lstdc++ FIX_ORDER_OF_LIBS=-Wl,--start-group """ +compile_olympe = """ +FC = ifort -mkl=parallel -qopenmp +AR = ar crs +FFLAGS = -I$IDIR -Ofast -traceback -xCORE-AVX512 +CC = icc +CXX = icpc +LAPACK= +STDCXX=-lstdc++ +FIX_ORDER_OF_LIBS=-Wl,--start-group +""" if sys.platform in ["linux", "linux2"]: - compiler = compile_gfortran_linux +# compiler = compile_gfortran_linux # compiler = compile_ifort_linux + compiler = compile_olympe elif sys.platform == "darwin": compiler = compile_gfortran_mac else: From 14e95287f62b204412cadd98f83fae15da5ad34a Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 18:15:11 +0200 Subject: [PATCH 15/46] OpenMP in ppLR_C for ispin = 1 --- src/LR/ppLR_C.f90 | 76 +++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 63 insertions(+), 13 deletions(-) diff --git a/src/LR/ppLR_C.f90 b/src/LR/ppLR_C.f90 index c74b2dd..72f15f0 100644 --- a/src/LR/ppLR_C.f90 +++ b/src/LR/ppLR_C.f90 @@ -23,6 +23,8 @@ subroutine ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,lambda,e,ERI,Cpp) double precision,external :: Kronecker_delta integer :: a,b,c,d,ab,cd + integer :: a0, aa + double precision :: e_ab, tmp_ab, delta_ac, tmp_cd ! Output variables @@ -37,22 +39,70 @@ subroutine ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,lambda,e,ERI,Cpp) if(ispin == 1) then - ab = 0 - do a=nO+1,nBas-nR - do b=a,nBas-nR - ab = ab + 1 + a0 = nBas - nR - nO + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(a, b, aa, ab, c, d, cd, e_ab, tmp_ab, delta_ac, tmp_cd) & + !$OMP SHARED(nO, nBas, nR, a0, eF, lambda, e, ERI, Cpp) + !$OMP DO + do a = nO+1, nBas-nR + aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO + do b = a, nBas-nR + ab = aa + b + + e_ab = e(a) + e(b) - eF + + tmp_ab = lambda + if(a .eq. b) then + tmp_ab = 0.7071067811865475d0 * lambda + endif + cd = 0 - do c=nO+1,nBas-nR - do d=c,nBas-nR + do c = nO+1, nBas-nR + + delta_ac = 0.d0 + if(a .eq. c) then + delta_ac = 1.d0 + endif + + do d = c, nBas-nR cd = cd + 1 + + tmp_cd = tmp_ab + if(c .eq. d) then + tmp_cd = 0.7071067811865475d0 * tmp_ab + endif + + Cpp(ab,cd) = 0.d0 + if(b .eq. d) then + Cpp(ab,cd) = e_ab * delta_ac + endif - Cpp(ab,cd) = + (e(a) + e(b) - eF)*Kronecker_delta(a,c)*Kronecker_delta(b,d) & - + lambda*(ERI(a,b,c,d) + ERI(a,b,d,c))/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) - - end do - end do - end do - end do + Cpp(ab,cd) = Cpp(ab,cd) + tmp_cd * (ERI(a,b,c,d) + ERI(a,b,d,c)) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + +! ab = 0 +! do a=nO+1,nBas-nR +! do b=a,nBas-nR +! ab = ab + 1 +! cd = 0 +! do c=nO+1,nBas-nR +! do d=c,nBas-nR +! cd = cd + 1 +! +! Cpp(ab,cd) = + (e(a) + e(b) - eF)*Kronecker_delta(a,c)*Kronecker_delta(b,d) & +! + lambda*(ERI(a,b,c,d) + ERI(a,b,d,c))/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) +! +! end do +! end do +! end do +! end do end if From adf05c13eef8434fa375a8cb0cf5595d9f1edd51 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 18:15:47 +0200 Subject: [PATCH 16/46] OpenMP -> DGEMM in GW_ppBSE_static_kernel_C, ispin=1,2 --- src/GW/GW_ppBSE_static_kernel_C.f90 | 210 +++++++++++++++++++++++----- 1 file changed, 176 insertions(+), 34 deletions(-) diff --git a/src/GW/GW_ppBSE_static_kernel_C.f90 b/src/GW/GW_ppBSE_static_kernel_C.f90 index 534654c..2df0025 100644 --- a/src/GW/GW_ppBSE_static_kernel_C.f90 +++ b/src/GW/GW_ppBSE_static_kernel_C.f90 @@ -31,6 +31,8 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI integer :: a0, aa double precision, allocatable :: Om_tmp(:) + double precision, allocatable :: tmp_m(:,:,:) + double precision, allocatable :: tmp(:,:,:,:) ! Output variables @@ -46,19 +48,27 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI lambda4 = 4.d0 * lambda eta2 = eta * eta - allocate(Om_tmp(nS)) + allocate(tmp_m(nBas,nBas,nS)) + allocate(tmp(nBas,nBas,nBas,nBas)) - !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp) - !$OMP DO do m = 1, nS - Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2) + eps = Om(m) / (Om(m)*Om(m) + eta2) + do c = 1, nBas + do a = 1, nBas + tmp_m(a,c,m) = eps * rho(a,c,m) + enddo + enddo enddo - !$OMP END DO - !$OMP END PARALLEL - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, tmp_ab) & - !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC) + call dgemm("N", "T", nBas*nBas, nBas*nBas, nS, 1.d0, & + tmp_m(1,1,1), nBas*nBas, rho(1,1,1), nBas*nBas, & + 0.d0, tmp(1,1,1,1), nBas*nBas) + + deallocate(tmp_m) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(a, b, aa, ab, c, d, cd, tmp_ab) & + !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, tmp, KC) !$OMP DO do a = nO+1, nBas-nR aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO @@ -75,13 +85,7 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI do d = c, nBas-nR cd = cd + 1 - KC(ab,cd) = 0d0 - do m = 1, nS - KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) & - - rho(a,d,m) * rho(b,c,m) * Om_tmp(m) - end do - - KC(ab,cd) = tmp_ab * KC(ab,cd) + KC(ab,cd) = -tmp_ab * (tmp(a,c,b,d) + tmp(a,d,b,c)) if(c .eq. d) then KC(ab,cd) = 0.7071067811865475d0 * KC(ab,cd) endif @@ -92,8 +96,87 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI !$OMP END DO !$OMP END PARALLEL - deallocate(Om_tmp) + deallocate(tmp) + +! do a=nO+1,nBas-nR +! do b=a,nBas-nR +! ab = ab + 1 +! cd = 0 +! do c=nO+1,nBas-nR +! do d=c,nBas-nR +! cd = cd + 1 +! +! chi = 0d0 +! do m=1,nS +! eps = Om(m)**2 + eta**2 +! chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps & +! - rho(a,d,m)*rho(b,c,m)*Om(m)/eps +! end do + + +! --- --- --- +! OpenMP implementation +! --- --- --- +! +! a0 = nBas - nR - nO +! lambda4 = 4.d0 * lambda +! eta2 = eta * eta +! +! allocate(Om_tmp(nS)) +! +! !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp) +! !$OMP DO +! do m = 1, nS +! Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2) +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, tmp_ab) & +! !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC) +! !$OMP DO +! do a = nO+1, nBas-nR +! aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO +! do b = a, nBas-nR +! ab = aa + b +! +! tmp_ab = lambda4 +! if(a .eq. b) then +! tmp_ab = 0.7071067811865475d0 * lambda4 +! endif +! +! cd = 0 +! do c = nO+1, nBas-nR +! do d = c, nBas-nR +! cd = cd + 1 +! +! KC(ab,cd) = 0d0 +! do m = 1, nS +! KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) & +! - rho(a,d,m) * rho(b,c,m) * Om_tmp(m) +! end do +! +! KC(ab,cd) = tmp_ab * KC(ab,cd) +! if(c .eq. d) then +! KC(ab,cd) = 0.7071067811865475d0 * KC(ab,cd) +! endif +! enddo +! enddo +! enddo +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +! deallocate(Om_tmp) +! --- --- --- + + +! --- --- --- +! Naive implementation +! --- --- --- +! ! ab = 0 ! do a=nO+1,nBas-nR ! do b=a,nBas-nR @@ -116,6 +199,7 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI ! end do ! end do ! end do +! --- --- --- end if @@ -129,19 +213,27 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI lambda4 = 4.d0 * lambda eta2 = eta * eta - allocate(Om_tmp(nS)) + allocate(tmp_m(nBas,nBas,nS)) + allocate(tmp(nBas,nBas,nBas,nBas)) - !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp) - !$OMP DO do m = 1, nS - Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2) + eps = Om(m) / (Om(m)*Om(m) + eta2) + do c = 1, nBas + do a = 1, nBas + tmp_m(a,c,m) = eps * rho(a,c,m) + enddo + enddo enddo - !$OMP END DO - !$OMP END PARALLEL - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m) & - !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC) + call dgemm("N", "T", nBas*nBas, nBas*nBas, nS, 1.d0, & + tmp_m(1,1,1), nBas*nBas, rho(1,1,1), nBas*nBas, & + 0.d0, tmp(1,1,1,1), nBas*nBas) + + deallocate(tmp_m) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(a, b, aa, ab, c, d, cd) & + !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, tmp, KC) !$OMP DO do a = nO+1, nBas-nR aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1 @@ -153,13 +245,7 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI do d = c+1, nBas-nR cd = cd + 1 - KC(ab,cd) = 0d0 - do m = 1, nS - KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) & - + rho(a,d,m) * rho(b,c,m) * Om_tmp(m) - end do - - KC(ab,cd) = lambda4 * KC(ab,cd) + KC(ab,cd) = lambda4 * (-tmp(a,c,b,d) + tmp(a,d,b,c)) enddo enddo enddo @@ -167,8 +253,63 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI !$OMP END DO !$OMP END PARALLEL - deallocate(Om_tmp) + deallocate(tmp) + +! --- --- --- +! OpenMP implementation +! --- --- --- +! +! a0 = nBas - nR - nO - 1 +! lambda4 = 4.d0 * lambda +! eta2 = eta * eta +! +! allocate(Om_tmp(nS)) +! +! !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp) +! !$OMP DO +! do m = 1, nS +! Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2) +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m) & +! !$OMP SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC) +! !$OMP DO +! do a = nO+1, nBas-nR +! aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1 +! do b = a+1, nBas-nR +! ab = aa + b +! +! cd = 0 +! do c = nO+1, nBas-nR +! do d = c+1, nBas-nR +! cd = cd + 1 +! +! KC(ab,cd) = 0d0 +! do m = 1, nS +! KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) & +! + rho(a,d,m) * rho(b,c,m) * Om_tmp(m) +! end do +! +! KC(ab,cd) = lambda4 * KC(ab,cd) +! enddo +! enddo +! enddo +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +! deallocate(Om_tmp) +! --- --- --- + + +! --- --- --- +! Naive implementation +! --- --- --- +! ! ab = 0 ! do a=nO+1,nBas-nR ! do b=a+1,nBas-nR @@ -191,6 +332,7 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI ! end do ! end do ! end do +! --- --- --- end if From 675fc77acc40253ff88d3ab276d6c88278a10984 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 18:27:52 +0200 Subject: [PATCH 17/46] rm timing --- src/GW/GW_ppBSE.f90 | 81 --------------------------------------------- src/GW/RG0W0.f90 | 49 --------------------------- 2 files changed, 130 deletions(-) diff --git a/src/GW/GW_ppBSE.f90 b/src/GW/GW_ppBSE.f90 index e26b2e1..371836d 100644 --- a/src/GW/GW_ppBSE.f90 +++ b/src/GW/GW_ppBSE.f90 @@ -66,10 +66,6 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, double precision,intent(out) :: EcBSE(nspin) - double precision :: t0, t1 - double precision :: tt0, tt1 - - call wall_time(t0) !--------------------------------- ! Compute (singlet) RPA screening @@ -81,25 +77,13 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, allocate(OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS), & Aph(nS,nS),Bph(nS,nS)) - call wall_time(tt0) call phLR_A(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,eW,ERI,Aph) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_A =',tt1-tt0,' seconds' - call wall_time(tt0) if(.not.TDA_W) call phLR_B(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_B =',tt1-tt0,' seconds' - call wall_time(tt0) call phLR(TDA_W,nS,Aph,Bph,EcRPA,OmRPA,XpY_RPA,XmY_RPA) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR =',tt1-tt0,' seconds' - call wall_time(tt0) call GW_excitation_density(nBas,nC,nO,nR,nS,ERI,XpY_RPA,rho_RPA) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_excitation_density =',tt1-tt0,' seconds' deallocate(XpY_RPA,XmY_RPA,Aph,Bph) @@ -127,61 +111,30 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, ! Compute BSE excitation energies - call wall_time(tt0) call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_C =',tt1-tt0,' seconds' - - call wall_time(tt0) call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_D =',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_B =',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C =',tt1-tt0,' seconds' - - call wall_time(tt0) call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D =',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B =',tt1-tt0,' seconds' Bpp(:,:) = Bpp(:,:) + KB_sta(:,:) Cpp(:,:) = Cpp(:,:) + KC_sta(:,:) Dpp(:,:) = Dpp(:,:) + KD_sta(:,:) - call wall_time(tt0) call ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin)) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR =',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR_transition_vectors(.true.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_transition_vectors =',tt1-tt0,' seconds' !----------------------------------------------------! ! Compute the dynamical screening at the ppBSE level ! !----------------------------------------------------! - call wall_time(tt0) if(dBSE) & call GW_ppBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,eW,eGW,ERI,dipole_int,OmRPA,rho_RPA, & Om1,X1,Y1,Om2,X2,Y2,KB_sta,KC_sta,KD_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_dynamic_perturbation =',tt1-tt0,' seconds' deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,KB_sta,KC_sta,KD_sta) end if @@ -210,66 +163,32 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, ! Compute BSE excitation energies - call wall_time(tt0) call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_C =',tt1-tt0,' seconds' - - call wall_time(tt0) call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_D =',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_static_kernel_B =',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_C =',tt1-tt0,' seconds' - - call wall_time(tt0) call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_D =',tt1-tt0,' seconds' - - call wall_time(tt0) if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_B =',tt1-tt0,' seconds' Bpp(:,:) = Bpp(:,:) + KB_sta(:,:) Cpp(:,:) = Cpp(:,:) + KC_sta(:,:) Dpp(:,:) = Dpp(:,:) + KD_sta(:,:) - call wall_time(tt0) call ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin)) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR =',tt1-tt0,' seconds' - call wall_time(tt0) call ppLR_transition_vectors(.false.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppLR_transition_vectors =',tt1-tt0,' seconds' !----------------------------------------------------! ! Compute the dynamical screening at the ppBSE level ! !----------------------------------------------------! - call wall_time(tt0) if(dBSE) & call GW_ppBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,eW,eGW,ERI,dipole_int,OmRPA,rho_RPA, & Om1,X1,Y1,Om2,X2,Y2,KB_sta,KC_sta,KD_sta) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE_dynamic_perturbation =',tt1-tt0,' seconds' deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,KB_sta,KC_sta,KD_sta) end if - call wall_time(t1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_ppBSE =',t1-t0,' seconds' - end subroutine diff --git a/src/GW/RG0W0.f90 b/src/GW/RG0W0.f90 index 1bd18e0..65ffb4d 100644 --- a/src/GW/RG0W0.f90 +++ b/src/GW/RG0W0.f90 @@ -59,10 +59,6 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA double precision,allocatable :: eGWlin(:) double precision,allocatable :: eGW(:) - double precision :: t0, t1 - double precision :: tt0, tt1 - - call wall_time(t0) ! Output variables @@ -106,48 +102,27 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Compute screening ! !-------------------! - call wall_time(tt0) call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_A =',tt1-tt0,' seconds' - call wall_time(tt0) if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_B =',tt1-tt0,' seconds' - call wall_time(tt0) call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR =',tt1-tt0,' seconds' - call wall_time(tt0) if(print_W) call print_excitation_energies('phRPA@RHF','singlet',nS,Om) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for print_excitation_energies =',tt1-tt0,' seconds' !--------------------------! ! Compute spectral weights ! !--------------------------! - call wall_time(tt0) call GW_excitation_density(nBas,nC,nO,nR,nS,ERI,XpY,rho) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_excitation_density =',tt1-tt0,' seconds' !------------------------! ! Compute GW self-energy ! !------------------------! - call wall_time(tt0) if(regularize) call GW_regularization(nBas,nC,nO,nV,nR,nS,eHF,Om,rho) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_regularization =',tt1-tt0,' seconds' - call wall_time(tt0) call GW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,EcGM,SigC,Z) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for GW_self_energy_diag =',tt1-tt0,' seconds' !-----------------------------------! ! Solve the quasi-particle equation ! @@ -155,7 +130,6 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Linearized or graphical solution? - call wall_time(tt0) eGWlin(:) = eHF(:) + Z(:)*SigC(:) if(linearize) then @@ -173,8 +147,6 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA call GW_QP_graph(eta,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,eGWlin,eHF,eGW,Z) end if - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for QP =',tt1-tt0,' seconds' ! Plot self-energy, renormalization factor, and spectral function @@ -188,33 +160,20 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Compute the RPA correlation energy - call wall_time(tt0) call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI,Aph) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_A =',tt1-tt0,' seconds' - call wall_time(tt0) if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR_B =',tt1-tt0,' seconds' - call wall_time(tt0) call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phLR =',tt1-tt0,' seconds' !--------------! ! Dump results ! !--------------! - call wall_time(tt0) call print_RG0W0(nBas,nO,eHF,ENuc,ERHF,SigC,Z,eGW,EcRPA,EcGM) - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for print_RG0W0 =',tt1-tt0,' seconds' ! Perform BSE calculation - call wall_time(tt0) if(dophBSE) then call GW_phBSE(dophBSE2,TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGW,EcBSE) @@ -265,10 +224,7 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA end if end if - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for phBSE =',tt1-tt0,' seconds' - call wall_time(tt0) if(doppBSE) then call GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGW,EcBSE) @@ -285,8 +241,6 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA write(*,*) end if - call wall_time(tt1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for ppBSE =',tt1-tt0,' seconds' ! end if @@ -300,7 +254,4 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA end if - call wall_time(t1) - write(*,'(A65,1X,F9.3,A8)') 'Wall time for RG0W0 =',t1-t0,' seconds' - end subroutine From 368cd7adf9a58395c7d0d57e47001f5dfae99f22 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 22 Aug 2024 18:35:17 +0200 Subject: [PATCH 18/46] OpenMP for tmp_m in GW_ppBSE_static_kernel_C --- src/GW/GW_ppBSE_static_kernel_C.f90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/GW/GW_ppBSE_static_kernel_C.f90 b/src/GW/GW_ppBSE_static_kernel_C.f90 index 2df0025..eb1e912 100644 --- a/src/GW/GW_ppBSE_static_kernel_C.f90 +++ b/src/GW/GW_ppBSE_static_kernel_C.f90 @@ -51,6 +51,10 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI allocate(tmp_m(nBas,nBas,nS)) allocate(tmp(nBas,nBas,nBas,nBas)) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(m, c, a, eps) & + !$OMP SHARED(nS, nBas, eta2, Om, rho, tmp_m) + !$OMP DO do m = 1, nS eps = Om(m) / (Om(m)*Om(m) + eta2) do c = 1, nBas @@ -59,6 +63,8 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL call dgemm("N", "T", nBas*nBas, nBas*nBas, nS, 1.d0, & tmp_m(1,1,1), nBas*nBas, rho(1,1,1), nBas*nBas, & @@ -216,6 +222,10 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI allocate(tmp_m(nBas,nBas,nS)) allocate(tmp(nBas,nBas,nBas,nBas)) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(m, c, a, eps) & + !$OMP SHARED(nS, nBas, eta2, Om, rho, tmp_m) + !$OMP DO do m = 1, nS eps = Om(m) / (Om(m)*Om(m) + eta2) do c = 1, nBas @@ -224,6 +234,8 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL call dgemm("N", "T", nBas*nBas, nBas*nBas, nS, 1.d0, & tmp_m(1,1,1), nBas*nBas, rho(1,1,1), nBas*nBas, & From 4b03a45e58045793d30cc39aaaaf2bdb94949c3d Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Tue, 27 Aug 2024 23:32:11 +0200 Subject: [PATCH 19/46] added class for RHF --- tests/test_hf.py | 204 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 204 insertions(+) create mode 100644 tests/test_hf.py diff --git a/tests/test_hf.py b/tests/test_hf.py new file mode 100644 index 0000000..f25183f --- /dev/null +++ b/tests/test_hf.py @@ -0,0 +1,204 @@ + +import os +from pathlib import Path +import subprocess +import platform +from datetime import datetime + +current_date = datetime.now() + +quack_root = os.getenv('QUACK_ROOT') + +# User Name +user_name = os.getlogin() + +# Operating System +os_name = platform.system() +os_release = platform.release() +os_version = platform.version() + +# CPU Information +machine = platform.machine() +processor = platform.processor() + +# System Architecture +architecture = platform.architecture()[0] + +# Python Version +python_version_full = platform.python_version_tuple() +PYTHON_VERSION = "{}.{}".format(python_version_full[0], python_version_full[1]) + + +print(f"The current date and time is {current_date.strftime('%Y-%m-%d %H:%M:%S')}") +print(f"User Name: {user_name}") +print(f"Operating System: {os_name} {os_release} ({os_version})") +print(f"CPU: {processor} ({machine})") +print(f"System Architecture: {architecture}") +print(f"QUACK_ROOT: {quack_root}") +print(f"Python version: {python_version_full}\n\n") + +# --- + +mp2 = "# MP2 MP3\n F F\n" +cc = "# CCD pCCD DCD CCSD CCSD(T)\n F F F F F\n" +rcc = "# drCCD rCCD crCCD lCCD\n F F F F\n" +ci = "# CIS CIS(D) CID CISD FCI\n F F F F F\n" +rpa = "# phRPA phRPAx crRPA ppRPA\n F F F F\n" +gf = "# G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3\n F F F F F F\n" +gw = "# G0W0 evGW qsGW SRG-qsGW ufG0W0 ufGW\n F F F F F F\n" +gtpp = "# G0T0pp evGTpp qsGTpp ufG0T0pp\n F F F F\n" +gteh = "# G0T0eh evGTeh qsGTeh\n F F F\n" +tests = "# Rtest Utest Gtest\n F F F\n" + +# --- + +hf_opt = "# HF: maxSCF thresh DIIS guess mix shift stab search\n 256 0.00001 5 1 0.0 0.0 F F\n" +mp_opt = "# MP: reg\n F\n" +cc_opt = "# CC: maxSCF thresh DIIS\n 64 0.00001 5\n" +tda_opt = "# spin: TDA singlet triplet\n F T T\n" +gf_opt = "# GF: maxSCF thresh DIIS lin eta renorm reg\n 256 0.00001 5 F 0.0 0 F\n" +gw_opt = "# GW: maxSCF thresh DIIS lin eta TDA_W reg\n 256 0.00001 5 F 0.0 F F\n" +gt_opt = "# GT: maxSCF thresh DIIS lin eta TDA_T reg\n 256 0.00001 5 F 0.0 F F\n" +acfdt_opt = "# ACFDT: AC Kx XBS\n F F T\n" +bse_opt = "# BSE: phBSE phBSE2 ppBSE dBSE dTDA\n F F F F T\n" +list_opt = [hf_opt, mp_opt, cc_opt, tda_opt, gf_opt, gw_opt, gt_opt, acfdt_opt, bse_opt] + +# --- + +mol_multip = { + "Ne": 1, + "H2O": 1, +} + +list_basis = ["cc-pvdz", "cc-pvtz", "cc-pvqz"] + +# --- + +class class_RHF: + + def gen_input(): + + f = open("methods", "w") + f.write("# RHF UHF GHF ROHF\n") + f.write(" T F F F\n") + f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) + f.close() + + f = open("options", "w") + for opt in list_opt: + f.write("{}".format(opt)) + f.close() + + def run_job(file_out, mol, bas, multip): + + os.chdir('..') + print(f" :$ cd ..") + + for file_in in ["methods", "options"]: + command = ['cp', 'tests/{}'.format(file_in), 'input/{}'.format(file_in)] + print(f" :$ {' '.join(command)}") + result = subprocess.run(command, capture_output=True, text=True) + if result.returncode != 0: + print("Error moving file: {}".format(result.stderr)) + + command = [ + 'python{}'.format(PYTHON_VERSION), 'PyDuck.py', + '-x', '{}'.format(mol), + '-b', '{}'.format(bas), + '-m', '{}'.format(multip) + ] + print(f" :$ {' '.join(command)}") + with open(file_out, 'w') as fobj: + result = subprocess.run(command, stdout=fobj, stderr=subprocess.PIPE, text=True) + if result.stderr: + print("Error output:", result.stderr) + + os.chdir('tests') + print(f" :$ cd tests") + + +# --- + +class class_UHF: + def gen_input(): + f = open("methods", "w") + f.write("# RHF UHF GHF ROHF\n") + f.write(" F T F F\n") + f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) + f.close() + +# --- + +class class_GHF: + def gen_input(): + f = open("methods", "w") + f.write("# RHF UHF GHF ROHF\n") + f.write(" F F T F\n") + f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) + f.close() + +# --- + +class class_ROHF: + def gen_input(): + f = open("methods", "w") + f.write("# RHF UHF GHF ROHF\n") + f.write(" F F F T\n") + f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) + f.close() + +# --- + +class_map = { + "RHF": class_RHF, + "UHF": class_UHF, + "GHF": class_GHF, + "ROHF": class_ROHF, +} + +def main(): + + work_path = Path('{}/tests/work'.format(quack_root)) + if not work_path.exists(): + work_path.mkdir(parents=True, exist_ok=True) + print(f"Directory '{work_path}' created.\n") + + for methd in ["RHF", "UHF", "GHF", "ROHF"]: + + work_methd = Path('{}/{}'.format(work_path, methd)) + if not work_methd.exists(): + work_methd.mkdir(parents=True, exist_ok=True) + print(f"Directory '{work_methd}' created.\n") + + class_methd = class_map.get(methd) + + # create input files + class_methd.gen_input() + + for mol in mol_multip: + + multip = mol_multip[mol] + + for bas in list_basis: + + file_out = "{}/{}/{}_{}_{}.out".format(work_path, methd, mol, multip, bas) + + print(" testing {} for {}@{} (2S+1 = {})".format(methd, mol, bas, multip)) + print(" file_out: {}".format(file_out)) + + class_methd.run_job(file_out, mol, bas, multip) + + print("\n") + print("\n\n") + + print(" --- --- --- ---") + print("\n\n\n") + + +main() + + + + + + From 1a195f90ccc6983415fce92fd9eb0088fd955a20 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 01:06:31 +0200 Subject: [PATCH 20/46] add SQLite database --- tests/create_database.py | 42 ++++++++++++++++++++ tests/molecule.py | 86 ++++++++++++++++++++++++++++++++++++++++ tests/test_hf.py | 58 +++++++++++++-------------- 3 files changed, 157 insertions(+), 29 deletions(-) create mode 100644 tests/create_database.py create mode 100644 tests/molecule.py diff --git a/tests/create_database.py b/tests/create_database.py new file mode 100644 index 0000000..3a91252 --- /dev/null +++ b/tests/create_database.py @@ -0,0 +1,42 @@ + +import sqlite3 + +from molecule import Molecule +from molecule import save_molecules_to_json, load_molecules_from_json +from molecule import create_database, add_molecule_to_db + + + +molecules = [ + Molecule( + name="H2O", + multiplicity=1, + geometry=[ + {"element": "O", "x": 0.000000, "y": 0.000000, "z": 0.117790}, + {"element": "H", "x": 0.000000, "y": 0.755453, "z": -0.471161}, + {"element": "H", "x": 0.000000, "y": -0.755453, "z": -0.471161} + ], + energies={ + "RHF": { + "cc-pvdz": -76.0267058009, + "cc-pvtz": -76.0570239304, + "cc-pvqz": -76.0646816616 + }, + } + ), +] + + +# Save molecules to JSON +save_molecules_to_json(molecules, 'molecules.json') + +# Load molecules from JSON +loaded_molecules = load_molecules_from_json('molecules.json') +print(loaded_molecules) + +# Create a database and add molecules +db_name = 'molecules.db' +create_database(db_name) +for molecule in molecules: + add_molecule_to_db(db_name, molecule) + diff --git a/tests/molecule.py b/tests/molecule.py new file mode 100644 index 0000000..9d7b648 --- /dev/null +++ b/tests/molecule.py @@ -0,0 +1,86 @@ + +import json +import sqlite3 + +class Molecule: + def __init__(self, name, multiplicity, geometry, energies): + self.name = name + self.multiplicity = multiplicity + self.geometry = geometry # List of tuples (atom, x, y, z) + self.energies = energies # Dictionary of dictionaries: {method: {basis: energy}} + + def get_energy(self, method, basis): + """Retrieve energy for a specific method and basis set.""" + return self.energies.get(method, {}).get(basis, None) + + def to_dict(self): + return { + "name": self.name, + "multiplicity": self.multiplicity, + "geometry": self.geometry, + "energies": self.energies, + } + + @staticmethod + def from_dict(data): + return Molecule( + name=data["name"], + multiplicity=data["multiplicity"], + geometry=data["geometry"], + energies=data["energies"] + ) + +def save_molecules_to_json(molecules, filename): + with open(filename, 'w') as f: + json_data = [molecule.to_dict() for molecule in molecules] + json.dump(json_data, f, indent=4) + +def load_molecules_from_json(filename): + with open(filename, 'r') as f: + json_data = json.load(f) + return [Molecule.from_dict(data) for data in json_data] + + +def create_database(db_name): + conn = sqlite3.connect(db_name) + cursor = conn.cursor() + cursor.execute('''CREATE TABLE IF NOT EXISTS molecules + (name TEXT, multiplicity INTEGER, geometry TEXT, energies TEXT)''') + conn.commit() + conn.close() + +def add_molecule_to_db(db_name, molecule): + conn = sqlite3.connect(db_name) + cursor = conn.cursor() + geometry_str = json.dumps(molecule.geometry) + energies_str = json.dumps(molecule.energies) + cursor.execute("INSERT INTO molecules VALUES (?, ?, ?, ?)", + (molecule.name, molecule.multiplicity, geometry_str, energies_str)) + conn.commit() + conn.close() + +def get_molecules_from_db(db_name): + conn = sqlite3.connect(db_name) + cursor = conn.cursor() + cursor.execute("SELECT name, multiplicity, geometry, energies FROM molecules") + rows = cursor.fetchall() + molecules = [] + for row in rows: + name, multiplicity, geometry_str, energies_str = row + geometry = json.loads(geometry_str) + energies = json.loads(energies_str) # energies is a dictionary of dictionaries + molecules.append(Molecule(name, multiplicity, geometry, energies)) + conn.close() + return molecules + +def write_geometry_to_xyz(molecule, filename): + with open(filename, 'w') as f: + # First line: number of atoms + f.write(f"{len(molecule.geometry)}\n") + # Second line: empty comment line + f.write("\n") + # Remaining lines: atom positions + for atom, x, y, z in molecule.geometry: + f.write(f"{atom} {x:.6f} {y:.6f} {z:.6f}\n") + + diff --git a/tests/test_hf.py b/tests/test_hf.py index f25183f..fd04121 100644 --- a/tests/test_hf.py +++ b/tests/test_hf.py @@ -5,6 +5,9 @@ import subprocess import platform from datetime import datetime +from molecule import get_molecules_from_db + + current_date = datetime.now() quack_root = os.getenv('QUACK_ROOT') @@ -65,15 +68,6 @@ list_opt = [hf_opt, mp_opt, cc_opt, tda_opt, gf_opt, gw_opt, gt_opt, acfdt_opt, # --- -mol_multip = { - "Ne": 1, - "H2O": 1, -} - -list_basis = ["cc-pvdz", "cc-pvtz", "cc-pvqz"] - -# --- - class class_RHF: def gen_input(): @@ -163,30 +157,36 @@ def main(): work_path.mkdir(parents=True, exist_ok=True) print(f"Directory '{work_path}' created.\n") - for methd in ["RHF", "UHF", "GHF", "ROHF"]: + for mol in molecules: - work_methd = Path('{}/{}'.format(work_path, methd)) - if not work_methd.exists(): - work_methd.mkdir(parents=True, exist_ok=True) - print(f"Directory '{work_methd}' created.\n") + mol_name = mol.name + mol_mult = mol.multiplicity - class_methd = class_map.get(methd) - # create input files - class_methd.gen_input() + for methd in list_methd: - for mol in mol_multip: + if methd not in mol.energies: + print(f"Method {methd} does not exist for {mol_name}.") + continue - multip = mol_multip[mol] + for bas, _ in mol.energies[methd].items(): - for bas in list_basis: + work_methd = Path('{}/{}'.format(work_path, methd)) + if not work_methd.exists(): + work_methd.mkdir(parents=True, exist_ok=True) + print(f"Directory '{work_methd}' created.\n") + + class_methd = class_map.get(methd) + + # create input files + class_methd.gen_input() + + file_out = "{}/{}/{}_{}_{}.out".format(work_path, methd, mol_name, mol_mult, bas) - file_out = "{}/{}/{}_{}_{}.out".format(work_path, methd, mol, multip, bas) - - print(" testing {} for {}@{} (2S+1 = {})".format(methd, mol, bas, multip)) + print(" testing {} for {}@{} (2S+1 = {})".format(methd, mol_name, bas, mol_mult)) print(" file_out: {}".format(file_out)) - class_methd.run_job(file_out, mol, bas, multip) + class_methd.run_job(file_out, mol_name, bas, mol_mult) print("\n") print("\n\n") @@ -195,10 +195,10 @@ def main(): print("\n\n\n") +db_name = 'molecules.db' +molecules = get_molecules_from_db(db_name) + +list_methd = ["RHF", "UHF", "GHF", "ROHF"] + main() - - - - - From 567e77dd4a7500009ed97f7888d30e2124ea0141 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 15:07:20 +0200 Subject: [PATCH 21/46] ERI dat -> binary --- PyDuck.py | 23 ++++++++--- src/QuAcK/QuAcK.f90 | 59 +++++++++++++++------------- src/utils/read_basis_pyscf.f90 | 14 +++---- src/utils/read_integrals.f90 | 71 ++++++++++++++++------------------ 4 files changed, 90 insertions(+), 77 deletions(-) diff --git a/PyDuck.py b/PyDuck.py index c74dc22..a8e9033 100644 --- a/PyDuck.py +++ b/PyDuck.py @@ -18,6 +18,7 @@ parser.add_argument('-b', '--basis', type=str, required=True, help='Name of the parser.add_argument('--bohr', default='Angstrom', action='store_const', const='Bohr', help='By default QuAcK assumes that the xyz files are in Angstrom. Add this argument if your xyz file is in Bohr.') parser.add_argument('-c', '--charge', type=int, default=0, help='Total charge of the molecule. Specify negative charges with "m" instead of the minus sign, for example m1 instead of -1. Default is 0') parser.add_argument('--cartesian', default=False, action='store_true', help='Add this option if you want to use cartesian basis functions.') +parser.add_argument('--print_2e', default=False, action='store_true', help='Add this option if you want to print 2e-integrals.') parser.add_argument('-fc', '--frozen_core', type=bool, default=False, help='Freeze core MOs. Default is false') parser.add_argument('-m', '--multiplicity', type=int, default=1, help='Spin multiplicity. Default is 1 therefore singlet') parser.add_argument('--working_dir', type=str, default=QuAcK_dir, help='Set a working directory to run the calculation.') @@ -32,6 +33,7 @@ frozen_core=args.frozen_core multiplicity=args.multiplicity xyz=args.xyz + '.xyz' cartesian=args.cartesian +print_2e=args.print_2e working_dir=args.working_dir #Read molecule @@ -90,11 +92,10 @@ t1e = mol.intor('int1e_kin') #Kinetic energy matrix elements dipole = mol.intor('int1e_r') #Matrix elements of the x, y, z operators x,y,z = dipole[0],dipole[1],dipole[2] -norb = len(ovlp) +norb = len(ovlp) # nBAS_AOs subprocess.call(['rm', working_dir + '/int/nBas.dat']) f = open(working_dir+'/int/nBas.dat','w') -f.write(str(norb)) -f.write(' ') +f.write(" {} ".format(str(norb))) f.close() @@ -122,7 +123,6 @@ write_matrix_to_file(y,norb,working_dir+'/int/y.dat') subprocess.call(['rm', working_dir + '/int/z.dat']) write_matrix_to_file(z,norb,working_dir+'/int/z.dat') -#Write two-electron integrals eri_ao = mol.intor('int2e') def write_tensor_to_file(tensor,size,file,cutoff=1e-15): @@ -132,12 +132,23 @@ def write_tensor_to_file(tensor,size,file,cutoff=1e-15): for k in range(i,size): for l in range(j,size): if abs(tensor[i][k][j][l]) > cutoff: + #f.write(str(i+1)+' '+str(j+1)+' '+str(k+1)+' '+str(l+1)+' '+"{:.16E}".format(tensor[i][k][j][l])) f.write(str(i+1)+' '+str(j+1)+' '+str(k+1)+' '+str(l+1)+' '+"{:.16E}".format(tensor[i][k][j][l])) f.write('\n') f.close() -subprocess.call(['rm', working_dir + '/int/ERI.dat']) -write_tensor_to_file(eri_ao,norb,working_dir+'/int/ERI.dat') +# Write two-electron integrals +if print_2e: + # (formatted) + subprocess.call(['rm', working_dir + '/int/ERI.dat']) + write_tensor_to_file(eri_ao,norb,working_dir+'/int/ERI.dat') +else: + # (binary) + subprocess.call(['rm', working_dir + '/int/ERI.bin']) + # chem -> phys notation + eri_ao = eri_ao.transpose(0, 2, 1, 3) + eri_ao.tofile('int/ERI.bin') + #Execute the QuAcK fortran program subprocess.call(QuAcK_dir+'/bin/QuAcK') diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index 6af981b..d1aa007 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -15,7 +15,7 @@ program QuAcK logical :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW logical :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh - integer :: nNuc,nBas + integer :: nNuc,nBas_AOs integer :: nC(nspin) integer :: nO(nspin) integer :: nV(nspin) @@ -120,15 +120,15 @@ program QuAcK doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA) -!------------------------------------------------! -! Read input information ! -!------------------------------------------------! -! 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) ! -!------------------------------------------------! +!---------------------------------------------------! +! Read input information ! +!---------------------------------------------------! +! nC = number of core orbitals ! +! nO = number of occupied orbitals ! +! nV = number of virtual orbitals (see below) ! +! nR = number of Rydberg orbitals ! +! nBas_AOs = number of basis functions in AOs ! +!---------------------------------------------------! call read_molecule(nNuc,nO,nC,nR) allocate(ZNuc(nNuc),rNuc(nNuc,ncart)) @@ -141,7 +141,7 @@ program QuAcK ! Read basis set information from PySCF ! !---------------------------------------! - call read_basis_pyscf(nBas,nO,nV) + call read_basis_pyscf(nBas_AOs, nO, nV) !--------------------------------------! ! Read one- and two-electron integrals ! @@ -149,26 +149,31 @@ program QuAcK ! Memory allocation for one- and two-electron integrals - allocate(S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas), & - ERI_AO(nBas,nBas,nBas,nBas),dipole_int_AO(nBas,nBas,ncart)) + allocate(S(nBas_AOs,nBas_AOs)) + allocate(T(nBas_AOs,nBas_AOs)) + allocate(V(nBas_AOs,nBas_AOs)) + allocate(Hc(nBas_AOs,nBas_AOs)) + allocate(X(nBas_AOs,nBas_AOs)) + allocate(ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs)) + allocate(dipole_int_AO(nBas_AOs,nBas_AOs,ncart)) ! Read integrals call wall_time(start_int) - call read_integrals(nBas,S,T,V,Hc,ERI_AO) - call read_dipole_integrals(nBas,dipole_int_AO) + call read_integrals(nBas_AOs, S(1,1), T(1,1), V(1,1), Hc(1,1), ERI_AO(1,1,1,1)) + call read_dipole_integrals(nBas_AOs, dipole_int_AO) call wall_time(end_int) t_int = end_int - start_int write(*,*) - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for reading integrals = ',t_int,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for reading integrals = ',t_int,' seconds' write(*,*) ! Compute orthogonalization matrix - call orthogonalization_matrix(nBas,S,X) + call orthogonalization_matrix(nBas_AOs, S, X) !---------------------! ! Choose QuAcK branch ! @@ -200,7 +205,7 @@ program QuAcK dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas_AOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & @@ -216,7 +221,7 @@ program QuAcK dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas_AOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & @@ -228,13 +233,13 @@ program QuAcK !--------------------------! if(doGQuAcK) & - call GQuAcK(doGtest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & - dodrCCD,dorCCD,docrCCD,dolCCD,dophRPA,dophRPAx,docrRPA,doppRPA, & - doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2, & - nNuc,nBas,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_AO,ERI_AO, & - maxSCF_HF,max_diis_HF,thresh_HF,level_shift,guess_type,mix,reg_MP, & - maxSCF_CC,max_diis_CC,thresh_CC,TDA,maxSCF_GF,max_diis_GF,thresh_GF,lin_GF,reg_GF,eta_GF, & - maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & + call GQuAcK(doGtest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & + dodrCCD,dorCCD,docrCCD,dolCCD,dophRPA,dophRPAx,docrRPA,doppRPA, & + doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2, & + nNuc,nBas_AOs,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_AO,ERI_AO, & + maxSCF_HF,max_diis_HF,thresh_HF,level_shift,guess_type,mix,reg_MP, & + maxSCF_CC,max_diis_CC,thresh_CC,TDA,maxSCF_GF,max_diis_GF,thresh_GF,lin_GF,reg_GF,eta_GF, & + maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS) !-----------! @@ -256,7 +261,7 @@ program QuAcK call wall_time(end_QuAcK) t_QuAcK = end_QuAcK - start_QuAcK - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for QuAcK = ',t_QuAcK,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for QuAcK = ',t_QuAcK,' seconds' write(*,*) end program diff --git a/src/utils/read_basis_pyscf.f90 b/src/utils/read_basis_pyscf.f90 index a677323..027fcac 100644 --- a/src/utils/read_basis_pyscf.f90 +++ b/src/utils/read_basis_pyscf.f90 @@ -1,4 +1,4 @@ -subroutine read_basis_pyscf(nBas,nO,nV) +subroutine read_basis_pyscf(nBas_AOs, nO, nV) ! Read basis set information from PySCF @@ -14,23 +14,23 @@ subroutine read_basis_pyscf(nBas,nO,nV) ! Output variables integer,intent(out) :: nV(nspin) - integer,intent(out) :: nBas + integer,intent(out) :: nBas_AOs !------------------------------------------------------------------------ ! Primary basis set information !------------------------------------------------------------------------ open(unit=3,file='int/nBas.dat') - read(3,*) nBas + read(3, *) nBas_AOs close(unit=3) - write(*,'(A28)') '------------------' - write(*,'(A28,1X,I16)') 'Number of basis functions',nBas - write(*,'(A28)') '------------------' + write(*,'(A38)') '--------------------------------------' + write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas_AOs + write(*,'(A38)') '--------------------------------------' write(*,*) ! Number of virtual orbitals - nV(:) = nBas - nO(:) + nV(:) = nBas_AOs - nO(:) end subroutine diff --git a/src/utils/read_integrals.f90 b/src/utils/read_integrals.f90 index 9e215e4..ef8e1d9 100644 --- a/src/utils/read_integrals.f90 +++ b/src/utils/read_integrals.f90 @@ -1,4 +1,4 @@ -subroutine read_integrals(nBas,S,T,V,Hc,G) +subroutine read_integrals(nBas_AOs, S, T, V, Hc, G) ! Read one- and two-electron integrals from files @@ -7,7 +7,7 @@ subroutine read_integrals(nBas,S,T,V,Hc,G) ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs ! Local variables @@ -18,11 +18,11 @@ subroutine read_integrals(nBas,S,T,V,Hc,G) ! Output variables - double precision,intent(out) :: S(nBas,nBas) - double precision,intent(out) :: T(nBas,nBas) - double precision,intent(out) :: V(nBas,nBas) - double precision,intent(out) :: Hc(nBas,nBas) - double precision,intent(out) :: G(nBas,nBas,nBas,nBas) + double precision,intent(out) :: S(nBas_AOs,nBas_AOs) + double precision,intent(out) :: T(nBas_AOs,nBas_AOs) + double precision,intent(out) :: V(nBas_AOs,nBas_AOs) + double precision,intent(out) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(out) :: G(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) ! Open file with integrals @@ -35,7 +35,6 @@ subroutine read_integrals(nBas,S,T,V,Hc,G) 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') open(unit=21,file='int/x.dat') open(unit=22,file='int/y.dat') @@ -75,31 +74,29 @@ subroutine read_integrals(nBas,S,T,V,Hc,G) Hc(:,:) = T(:,:) + V(:,:) -! Read nuclear integrals +! Read 2e-integrals - G(:,:,:,:) = 0d0 - do - read(11,*,end=11) mu,nu,la,si,ERI +! ! formatted file +! open(unit=11, file='int/ERI.dat') +! G(:,:,:,:) = 0d0 +! do +! read(11,*,end=11) mu, nu, la, si, ERI +! ERI = lambda*ERI +! G(mu,nu,la,si) = ERI ! <12|34> +! G(la,nu,mu,si) = ERI ! <32|14> +! G(mu,si,la,nu) = ERI ! <14|32> +! G(la,si,mu,nu) = ERI ! <34|12> +! G(si,mu,nu,la) = ERI ! <41|23> +! G(nu,la,si,mu) = ERI ! <23|41> +! G(nu,mu,si,la) = ERI ! <21|43> +! G(si,la,nu,mu) = ERI ! <43|21> +! end do +! 11 close(unit=11) - ERI = lambda*ERI -! <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 - end do - 11 close(unit=11) + ! binary file + open(unit=11, file='int/ERI.bin', form='unformatted', access='stream') + read(11) G + close(11) ! Print results @@ -107,24 +104,24 @@ subroutine read_integrals(nBas,S,T,V,Hc,G) write(*,'(A28)') '----------------------' write(*,'(A28)') 'Overlap integrals' write(*,'(A28)') '----------------------' - call matout(nBas,nBas,S) + call matout(nBas_AOs,nBas_AOs,S) write(*,*) write(*,'(A28)') '----------------------' write(*,'(A28)') 'Kinetic integrals' write(*,'(A28)') '----------------------' - call matout(nBas,nBas,T) + call matout(nBas_AOs,nBas_AOs,T) write(*,*) write(*,'(A28)') '----------------------' write(*,'(A28)') 'Nuclear integrals' write(*,'(A28)') '----------------------' - call matout(nBas,nBas,V) + call matout(nBas_AOs,nBas_AOs,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)) + do la=1,nBas_AOs + do si=1,nBas_AOs + call matout(nBas_AOs, nBas_AOs, G(1,1,la,si)) end do end do write(*,*) From de867f2b54e9757111b7a7a41258a9cc94002986 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 17:27:46 +0200 Subject: [PATCH 22/46] introduce nBas_MOs in RHF --- src/HF/GHF.f90 | 4 +- src/HF/RHF.f90 | 93 ++++++++++++++++---------- src/HF/RMOM.f90 | 2 +- src/HF/ROHF.f90 | 4 +- src/HF/UHF.f90 | 4 +- src/HF/cRHF.f90 | 6 +- src/HF/core_guess.f90 | 21 +++--- src/HF/huckel_guess.f90 | 22 +++--- src/HF/mo_guess.f90 | 19 +++--- src/HF/print_RHF.f90 | 15 +++-- src/QuAcK/QuAcK.f90 | 43 ++++++++++-- src/QuAcK/RQuAcK.f90 | 91 ++++++++++++++----------- src/utils/level_shifting.f90 | 22 +++--- src/utils/orthogonalization_matrix.f90 | 40 ++++++++--- src/utils/read_basis_pyscf.f90 | 8 +-- 15 files changed, 251 insertions(+), 143 deletions(-) diff --git a/src/HF/GHF.f90 b/src/HF/GHF.f90 index 60fd9d2..5659a04 100644 --- a/src/HF/GHF.f90 +++ b/src/HF/GHF.f90 @@ -123,7 +123,7 @@ subroutine GHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu ! Guess coefficients and density matrices - call mo_guess(nBas2,guess_type,S,H,X,C) + call mo_guess(nBas2,nBas2,guess_type,S,H,X,C) ! Construct super density matrix @@ -227,7 +227,7 @@ subroutine GHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu ! Level-shifting - if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nO,S,C,F) + if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nBas,nO,S,C,F) ! Transform Fock matrix in orthogonal basis diff --git a/src/HF/RHF.f90 b/src/HF/RHF.f90 index 8b1e441..5756744 100644 --- a/src/HF/RHF.f90 +++ b/src/HF/RHF.f90 @@ -1,5 +1,8 @@ -subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI,dipole_int,X,ERHF,eHF,c,P) + +! --- + +subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI, dipole_int, X, ERHF, eHF, c, P) ! Perform restricted Hartree-Fock calculation @@ -16,24 +19,24 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN double precision,intent(in) :: thresh double precision,intent(in) :: level_shift - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO integer,intent(in) :: nNuc double precision,intent(in) :: ZNuc(nNuc) double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - 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) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(in) :: dipole_int(nBas_AOs,nBas_AOs,ncart) ! Local variables integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: n_diis double precision :: ET double precision :: EV @@ -56,9 +59,9 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN ! Output variables double precision,intent(out) :: ERHF - double precision,intent(out) :: eHF(nBas) - double precision,intent(inout):: c(nBas,nBas) - double precision,intent(out) :: P(nBas,nBas) + double precision,intent(out) :: eHF(nBas_MOs) + double precision,intent(inout):: c(nBas_AOs,nBas_MOs) + double precision,intent(out) :: P(nBas_AOs,nBas_AOs) ! Hello world @@ -70,21 +73,32 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN ! Useful quantities - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! Memory allocation - allocate(J(nBas,nBas),K(nBas,nBas),err(nBas,nBas),cp(nBas,nBas),F(nBas,nBas), & - Fp(nBas,nBas),err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(J(nBas_AOs,nBas_AOs)) + allocate(K(nBas_AOs,nBas_AOs)) + + allocate(err(nBas_AOs,nBas_AOs)) + allocate(F(nBas_AOs,nBas_AOs)) + + allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Fp(nBas_MOs,nBas_MOs)) + + allocate(err_diis(nBas_AOs_Sq,max_diis)) + allocate(F_diis(nBas_AOs_Sq,max_diis)) ! Guess coefficients and density matrix - call mo_guess(nBas,guess_type,S,Hc,X,c) - P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + call mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) + + !P(:,:) = 2d0 * matmul(c(:,1:nO), transpose(c(:,1:nO))) + call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO, 2.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P, nBas_AOs) ! Initialization - n_diis = 0 + n_diis = 0 F_diis(:,:) = 0d0 err_diis(:,:) = 0d0 rcond = 0d0 @@ -110,31 +124,31 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN ! Build Fock matrix - call Hartree_matrix_AO_basis(nBas,P,ERI,J) - call exchange_matrix_AO_basis(nBas,P,ERI,K) + call Hartree_matrix_AO_basis(nBas_AOs, P, ERI, J) + call exchange_matrix_AO_basis(nBas_AOs, P, ERI, K) F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) ! Check convergence - err = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + err = matmul(F, matmul(P, S)) - matmul(matmul(S, P), F) if(nSCF > 1) Conv = maxval(abs(err)) ! Kinetic energy - ET = trace_matrix(nBas,matmul(P,T)) + ET = trace_matrix(nBas_AOs, matmul(P, T)) ! Potential energy - EV = trace_matrix(nBas,matmul(P,V)) + EV = trace_matrix(nBas_AOs, matmul(P, V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas_AOs, matmul(P, J)) ! Exchange energy - EK = 0.25d0*trace_matrix(nBas,matmul(P,K)) + EK = 0.25d0*trace_matrix(nBas_AOs, matmul(P, K)) ! Total energy @@ -144,25 +158,28 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN if(max_diis > 1) then - n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,F) + n_diis = min(n_diis+1, max_diis) + call DIIS_extrapolation(rcond, nBas_AOs_Sq, nBas_AOs_Sq, n_diis, err_diis, F_diis, err, F) end if ! Level shift - if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nO,S,c,F) + if(level_shift > 0d0 .and. Conv > thresh) then + call level_shifting(level_shift, nBas_AOs, nBas_MOs, nO, S, c, F) + endif ! Diagonalize Fock matrix - Fp = matmul(transpose(X),matmul(F,X)) + Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eHF) - c = matmul(X,cp) + call diagonalize_matrix(nBas_MOs, cp, eHF) + c = matmul(X, cp) ! Density matrix - P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + !P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO))) + call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO, 2.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P, nBas_AOs) ! Dump results @@ -185,14 +202,16 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(J, K, err, F, cp, Fp, err_diis, F_diis) + stop end if ! Compute dipole moments - call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int,dipole) - call print_RHF(nBas,nO,eHF,C,ENuc,ET,EV,EJ,EK,ERHF,dipole) + call dipole_moment(nBas_AOs, P, nNuc, ZNuc, rNuc, dipole_int, dipole) + call print_RHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, EK, ERHF, dipole) ! Testing zone @@ -205,4 +224,6 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN end if + deallocate(J, K, err, F, cp, Fp, err_diis, F_diis) + end subroutine diff --git a/src/HF/RMOM.f90 b/src/HF/RMOM.f90 index a49746d..fc43b76 100644 --- a/src/HF/RMOM.f90 +++ b/src/HF/RMOM.f90 @@ -190,6 +190,6 @@ subroutine RMOM(maxSCF,thresh,max_diis,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P) 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) + call print_RHF(nBas,nBas,nO,e,c,ENuc,ET,EV,EJ,EK,ERHF) end subroutine diff --git a/src/HF/ROHF.f90 b/src/HF/ROHF.f90 index 7d86359..0cd1f5f 100644 --- a/src/HF/ROHF.f90 +++ b/src/HF/ROHF.f90 @@ -86,7 +86,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN ! Guess coefficients and demsity matrices - call mo_guess(nBas,guess_type,S,Hc,X,c) + call mo_guess(nBas,nBas,guess_type,S,Hc,X,c) do ispin=1,nspin P(:,:,ispin) = matmul(c(:,1:nO(ispin)),transpose(c(:,1:nO(ispin)))) end do @@ -185,7 +185,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN if(level_shift > 0d0 .and. Conv > thresh) then do ispin=1,nspin - call level_shifting(level_shift,nBas,maxval(nO),S,c,Ftot) + call level_shifting(level_shift,nBas,nBas,maxval(nO),S,c,Ftot) end do end if diff --git a/src/HF/UHF.f90 b/src/HF/UHF.f90 index 919cb0f..faa7de1 100644 --- a/src/HF/UHF.f90 +++ b/src/HF/UHF.f90 @@ -85,7 +85,7 @@ subroutine UHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu ! Guess coefficients and demsity matrices do ispin=1,nspin - call mo_guess(nBas,guess_type,S,Hc,X,c(:,:,ispin)) + call mo_guess(nBas,nBas,guess_type,S,Hc,X,c(:,:,ispin)) P(:,:,ispin) = matmul(c(:,1:nO(ispin),ispin),transpose(c(:,1:nO(ispin),ispin))) end do @@ -186,7 +186,7 @@ subroutine UHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu if(level_shift > 0d0 .and. Conv > thresh) then do ispin=1,nspin - call level_shifting(level_shift,nBas,nO(ispin),S,c(:,:,ispin),F(:,:,ispin)) + call level_shifting(level_shift,nBas,nBas,nO(ispin),S,c(:,:,ispin),F(:,:,ispin)) end do end if diff --git a/src/HF/cRHF.f90 b/src/HF/cRHF.f90 index 9640a48..36cfa41 100644 --- a/src/HF/cRHF.f90 +++ b/src/HF/cRHF.f90 @@ -94,7 +94,7 @@ subroutine cRHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,r ! Guess coefficients and density matrix - call mo_guess(nBas,guess_type,S,Hc,X,c) + call mo_guess(nBas,nBas,guess_type,S,Hc,X,c) P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) ! Initialization @@ -166,7 +166,7 @@ subroutine cRHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,r ! Level shift - if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nO,S,c,F) + if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nBas,nO,S,c,F) ! Diagonalize Fock matrix @@ -207,7 +207,7 @@ subroutine cRHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,r ! Compute dipole moments call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int,dipole) - call print_RHF(nBas,nO,eHF,C,ENuc,ET,EV,EJ,EK,ERHF,dipole) + call print_RHF(nBas,nBas,nO,eHF,C,ENuc,ET,EV,EJ,EK,ERHF,dipole) ! Testing zone diff --git a/src/HF/core_guess.f90 b/src/HF/core_guess.f90 index 7e45e8e..c48c3ae 100644 --- a/src/HF/core_guess.f90 +++ b/src/HF/core_guess.f90 @@ -1,4 +1,4 @@ -subroutine core_guess(nBas,Hc,X,c) +subroutine core_guess(nBas_AOs, nBas_MOs, Hc, X, c) ! Core guess of the molecular orbitals for HF calculation @@ -6,9 +6,9 @@ subroutine core_guess(nBas,Hc,X,c) ! Input variables - integer,intent(in) :: nBas - double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: X(nBas,nBas) + integer,intent(in) :: nBas_AOs, nBas_MOs + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) ! Local variables @@ -18,16 +18,19 @@ subroutine core_guess(nBas,Hc,X,c) ! Output variables - double precision,intent(out) :: c(nBas,nBas) + double precision,intent(out) :: c(nBas_AOs,nBas_MOs) ! Memory allocation - allocate(cp(nBas,nBas),e(nBas)) + allocate(cp(nBas_MOs,nBas_MOs), e(nBas_MOs)) ! Core guess - cp(:,:) = matmul(transpose(X(:,:)),matmul(Hc(:,:),X(:,:))) - call diagonalize_matrix(nBas,cp,e) - c(:,:) = matmul(X(:,:),cp(:,:)) + cp(:,:) = matmul(transpose(X(:,:)), matmul(Hc(:,:), X(:,:))) + + call diagonalize_matrix(nBas_MOs, cp, e) + c(:,:) = matmul(X(:,:), cp(:,:)) + + deallocate(cp, e) end subroutine diff --git a/src/HF/huckel_guess.f90 b/src/HF/huckel_guess.f90 index 658c853..a8e7e52 100644 --- a/src/HF/huckel_guess.f90 +++ b/src/HF/huckel_guess.f90 @@ -1,4 +1,4 @@ -subroutine huckel_guess(nBas,S,Hc,X,c) +subroutine huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) ! Hickel guess @@ -6,10 +6,10 @@ subroutine huckel_guess(nBas,S,Hc,X,c) ! Input variables - integer,intent(in) :: nBas - double precision,intent(in) :: S(nBas,nBas) - double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: X(nBas,nBas) + integer,intent(in) :: nBas_AOs, nBas_MOs + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) ! Local variables @@ -20,11 +20,11 @@ subroutine huckel_guess(nBas,S,Hc,X,c) ! Output variables - double precision,intent(out) :: c(nBas,nBas) + double precision,intent(out) :: c(nBas_AOs,nBas_MOs) ! Memory allocation - allocate(F(nBas,nBas)) + allocate(F(nBas_AOs,nBas_AOs)) ! Extended Huckel parameter @@ -32,9 +32,9 @@ subroutine huckel_guess(nBas,S,Hc,X,c) ! GWH approximation - do mu=1,nBas + do mu = 1, nBas_AOs F(mu,mu) = Hc(mu,mu) - do nu=mu+1,nBas + do nu = mu+1, nBas_AOs F(mu,nu) = 0.5d0*a*S(mu,nu)*(Hc(mu,mu) + Hc(nu,nu)) F(nu,mu) = F(mu,nu) @@ -42,6 +42,8 @@ subroutine huckel_guess(nBas,S,Hc,X,c) end do end do - call core_guess(nBas,F,X,c) + call core_guess(nBas_AOs, nBas_MOs, F, X, c) + + deallocate(F) end subroutine diff --git a/src/HF/mo_guess.f90 b/src/HF/mo_guess.f90 index fef8d87..fd1f20d 100644 --- a/src/HF/mo_guess.f90 +++ b/src/HF/mo_guess.f90 @@ -1,4 +1,7 @@ -subroutine mo_guess(nBas,guess_type,S,Hc,X,c) + +! --- + +subroutine mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) ! Guess of the molecular orbitals for HF calculation @@ -6,15 +9,15 @@ subroutine mo_guess(nBas,guess_type,S,Hc,X,c) ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: guess_type - double precision,intent(in) :: S(nBas,nBas) - double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: X(nBas,nBas) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) ! Output variables - double precision,intent(inout) :: c(nBas,nBas) + double precision,intent(inout) :: c(nBas_AOs,nBas_MOs) if(guess_type == 0) then @@ -24,12 +27,12 @@ subroutine mo_guess(nBas,guess_type,S,Hc,X,c) elseif(guess_type == 1) then write(*,*) 'Core guess...' - call core_guess(nBas,Hc,X,c) + call core_guess(nBas_AOs, nBas_MOs, Hc, X, c) elseif(guess_type == 2) then write(*,*) 'Huckel guess...' - call huckel_guess(nBas,S,Hc,X,c) + call huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) elseif(guess_type == 3) then diff --git a/src/HF/print_RHF.f90 b/src/HF/print_RHF.f90 index 3a06d31..6790fcf 100644 --- a/src/HF/print_RHF.f90 +++ b/src/HF/print_RHF.f90 @@ -1,4 +1,7 @@ -subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF,dipole) + +! --- + +subroutine print_RHF(nBas_AOs, nBas_MOs, nO, eHF, cHF, ENuc, ET, EV, EJ, EK, ERHF, dipole) ! Print one-electron energies and other stuff for G0W0 @@ -7,10 +10,10 @@ subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF,dipole) ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) double precision,intent(in) :: ENuc double precision,intent(in) :: ET double precision,intent(in) :: EV @@ -75,13 +78,13 @@ subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF,dipole) write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' RHF orbital coefficients ' write(*,'(A50)') '---------------------------------------' - call matout(nBas,nBas,cHF) + call matout(nBas_AOs, nBas_MOs, cHF) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' RHF orbital energies (au) ' write(*,'(A50)') '---------------------------------------' - call vecout(nBas,eHF) + call vecout(nBas_MOs, eHF) write(*,*) end subroutine diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index d1aa007..75514f4 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -15,7 +15,7 @@ program QuAcK logical :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW logical :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh - integer :: nNuc,nBas_AOs + integer :: nNuc, nBas_AOs, nBas_MOs integer :: nC(nspin) integer :: nO(nspin) integer :: nV(nspin) @@ -31,6 +31,7 @@ program QuAcK double precision,allocatable :: X(:,:) double precision,allocatable :: dipole_int_AO(:,:,:) double precision,allocatable :: ERI_AO(:,:,:,:) + double precision,allocatable :: Uvec(:,:), Uval(:) double precision :: start_QuAcK,end_QuAcK,t_QuAcK double precision :: start_int ,end_int ,t_int @@ -68,6 +69,8 @@ program QuAcK logical :: dotest,doRtest,doUtest,doGtest + integer :: i, j + !-------------! ! Hello World ! !-------------! @@ -128,6 +131,7 @@ program QuAcK ! nV = number of virtual orbitals (see below) ! ! nR = number of Rydberg orbitals ! ! nBas_AOs = number of basis functions in AOs ! +! nBas_MOs = number of basis functions in MOs ! !---------------------------------------------------! call read_molecule(nNuc,nO,nC,nR) @@ -153,7 +157,6 @@ program QuAcK allocate(T(nBas_AOs,nBas_AOs)) allocate(V(nBas_AOs,nBas_AOs)) allocate(Hc(nBas_AOs,nBas_AOs)) - allocate(X(nBas_AOs,nBas_AOs)) allocate(ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs)) allocate(dipole_int_AO(nBas_AOs,nBas_AOs,ncart)) @@ -173,7 +176,39 @@ program QuAcK ! Compute orthogonalization matrix - call orthogonalization_matrix(nBas_AOs, S, X) + !call orthogonalization_matrix(nBas_AOs, S, X) + + allocate(Uvec(nBas_AOs,nBas_AOs), Uval(nBas_AOs)) + + Uvec(1:nBas_AOs,1:nBas_AOs) = S(1:nBas_AOs,1:nBas_AOs) + call diagonalize_matrix(nBas_AOs, Uvec, Uval) + + nBas_MOs = 0 + do i = 1, nBas_AOs + if(Uval(i) > 1d-6) then + Uval(i) = 1d0 / dsqrt(Uval(i)) + nBas_MOs = nBas_MOs + 1 + else + write(*,*) ' Eigenvalue',i,'too small for canonical orthogonalization' + end if + end do + + write(*,'(A38)') '--------------------------------------' + write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas_AOs + write(*,'(A38,1X,I16)') 'Number of basis functions (MOs)', nBas_MOs + write(*,'(A38,1X,F9.3)') ' % of discarded orbitals = ', 100.d0 * (1.d0 - dble(nBas_MOs)/dble(nBas_AOs)) + write(*,'(A38)') '--------------------------------------' + write(*,*) + + allocate(X(nBas_AOs,nBas_MOs)) + do j = 1, nBas_MOs + do i = 1, nBas_AOs + X(i,j) = Uvec(i,j) * Uval(j) + enddo + enddo + + deallocate(Uvec, Uval) + !---------------------! ! Choose QuAcK branch ! @@ -205,7 +240,7 @@ program QuAcK dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas_AOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas_AOs,nBas_MOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 3897f37..1c9545b 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -2,7 +2,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas_AOs,nBas_MOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,singlet,triplet,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & @@ -29,7 +29,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d logical,intent(in) :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp logical,intent(in) :: doG0T0eh,doevGTeh,doqsGTeh - integer,intent(in) :: nNuc,nBas + integer,intent(in) :: nNuc,nBas_AOs,nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -38,13 +38,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d double precision,intent(in) :: ZNuc(nNuc),rNuc(nNuc,ncart) - 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) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) integer,intent(in) :: maxSCF_HF,max_diis_HF double precision,intent(in) :: thresh_HF,level_shift,mix @@ -109,8 +109,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d ! Memory allocation ! !-------------------! - allocate(cHF(nBas,nBas),eHF(nBas),PHF(nBas,nBas), & - dipole_int_MO(nBas,nBas,ncart),ERI_MO(nBas,nBas,nBas,nBas)) + allocate(cHF(nBas_AOs,nBas_MOs)) + allocate(eHF(nBas_MOs)) + allocate(PHF(nBas_AOs,nBas_AOs)) + allocate(dipole_int_MO(nBas_AOs,nBas_AOs,ncart)) + allocate(ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs)) !---------------------! ! Hartree-Fock module ! @@ -119,12 +122,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doRHF) then call wall_time(start_HF) - call RHF(dotest,maxSCF_HF,thresh_HF,max_diis_HF,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF) + ! TODO + call RHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) call wall_time(end_HF) t_HF = end_HF - start_HF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RHF = ',t_HF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RHF = ',t_HF,' seconds' write(*,*) end if @@ -132,12 +136,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doROHF) then call wall_time(start_HF) + ! TODO call ROHF(dotest,maxSCF_HF,thresh_HF,max_diis_HF,guess_type,mix,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF) + nBas_AOs,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF) call wall_time(end_HF) t_HF = end_HF - start_HF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ROHF = ',t_HF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ROHF = ',t_HF,' seconds' write(*,*) end if @@ -154,18 +159,20 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d ! Read and transform dipole-related integrals - do ixyz=1,ncart - call AOtoMO(nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + do ixyz = 1, ncart + ! TODO + call AOtoMO(nBas_AOs,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do ! 4-index transform - call AOtoMO_ERI_RHF(nBas,cHF,ERI_AO,ERI_MO) + ! TODO + call AOtoMO_ERI_RHF(nBas_AOs,cHF,ERI_AO,ERI_MO) call wall_time(end_AOtoMO) t_AOtoMO = end_AOtoMO - start_AOtoMO - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for AO to MO transformation = ',t_AOtoMO,' seconds' write(*,*) !-----------------------------------! @@ -177,11 +184,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(dostab) then call wall_time(start_stab) - call RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI_MO) + call RHF_stability(nBas_AOs,nC,nO,nV,nR,nS,eHF,ERI_MO) call wall_time(end_stab) t_stab = end_stab - start_stab - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for stability analysis = ',t_stab,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for stability analysis = ',t_stab,' seconds' write(*,*) end if @@ -189,12 +196,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(dosearch) then call wall_time(start_stab) + ! TODO call RHF_search(maxSCF_HF,thresh_HF,max_diis_HF,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nC,nO,nV,nR,S,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,X,ERHF,eHF,cHF,PHF) + nBas_AOs,nC,nO,nV,nR,S,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,X,ERHF,eHF,cHF,PHF) call wall_time(end_stab) t_stab = end_stab - start_stab - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for stability analysis = ',t_stab,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for stability analysis = ',t_stab,' seconds' write(*,*) end if @@ -208,11 +216,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doMP) then call wall_time(start_MP) - call RMP(dotest,doMP2,doMP3,reg_MP,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) + ! TODO + call RMP(dotest,doMP2,doMP3,reg_MP,nBas_AOs,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_MP) t_MP = end_MP - start_MP - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP = ',t_MP,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for MP = ',t_MP,' seconds' write(*,*) end if @@ -227,12 +236,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doCC) then call wall_time(start_CC) + ! TODO call RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF,cHF) + maxSCF_CC,thresh_CC,max_diis_CC,nBas_AOs,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF,cHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CC = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CC = ',t_CC,' seconds' write(*,*) end if @@ -246,12 +256,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doCI) then call wall_time(start_CI) - call RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & + ! TODO + call RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas_AOs,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & eHF,ERHF,cHF,S) call wall_time(end_CI) t_CI = end_CI - start_CI - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CI = ',t_CI,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CI = ',t_CI,' seconds' write(*,*) end if @@ -265,12 +276,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doRPA) then call wall_time(start_RPA) + ! TODO call RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_kernel,singlet,triplet, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,cHF,S) + nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,cHF,S) call wall_time(end_RPA) t_RPA = end_RPA - start_RPA - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RPA = ',t_RPA,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RPA = ',t_RPA,' seconds' write(*,*) end if @@ -284,14 +296,15 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doGF) then call wall_time(start_GF) + ! TODO call RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm_GF,maxSCF_GF,thresh_GF,max_diis_GF, & dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,lin_GF,eta_GF,reg_GF, & - nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO, & + nNuc,ZNuc,rNuc,ENuc,nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO, & dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF2 = ',t_GF,' seconds' write(*,*) end if @@ -305,14 +318,15 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doGW) then call wall_time(start_GW) + ! TODO call RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF_GW,thresh_GW,max_diis_GW, & doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet, & - lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & + lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc,nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GW = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GW = ',t_GW,' seconds' write(*,*) end if @@ -326,14 +340,15 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doGT) then call wall_time(start_GT) + ! TODO call RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & maxSCF_GT,thresh_GT,max_diis_GT,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE, & TDA_T,TDA,dBSE,dTDA,singlet,triplet,lin_GT,eta_GT,reg_GT,nNuc,ZNuc,rNuc,ENuc, & - nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GT = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GT = ',t_GT,' seconds' write(*,*) end if diff --git a/src/utils/level_shifting.f90 b/src/utils/level_shifting.f90 index 8435b32..a006622 100644 --- a/src/utils/level_shifting.f90 +++ b/src/utils/level_shifting.f90 @@ -1,4 +1,4 @@ -subroutine level_shifting(level_shift,nBas,nO,S,c,F) +subroutine level_shifting(level_shift, nBas_AOs, nBas_MOs, nO, S, c, F) ! Perform level-shifting on the Fock matrix @@ -7,10 +7,10 @@ subroutine level_shifting(level_shift,nBas,nO,S,c,F) ! Input variables double precision,intent(in) :: level_shift - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO - double precision,intent(in) :: S(nBas,nBas) - double precision,intent(in) :: c(nBas,nBas) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) ! Local variables @@ -21,17 +21,19 @@ subroutine level_shifting(level_shift,nBas,nO,S,c,F) ! Output variables - double precision,intent(inout):: F(nBas,nBas) + double precision,intent(inout):: F(nBas_AOs,nBas_AOs) - allocate(F_MO(nBas,nBas),Sc(nBas,nBas)) + allocate(F_MO(nBas_MOs,nBas_MOs), Sc(nBas_AOs,nBas_MOs)) - F_MO(:,:) = matmul(transpose(c),matmul(F,c)) + F_MO(:,:) = matmul(transpose(c), matmul(F, c)) - do a=nO+1,nBas + do a = nO+1, nBas_MOs F_MO(a,a) = F_MO(a,a) + level_shift end do - Sc(:,:) = matmul(S,c) - F(:,:) = matmul(Sc,matmul(F_MO,transpose(Sc))) + Sc(:,:) = matmul(S, c) + F(:,:) = matmul(Sc, matmul(F_MO, transpose(Sc))) + + deallocate(F_MO, Sc) end subroutine diff --git a/src/utils/orthogonalization_matrix.f90 b/src/utils/orthogonalization_matrix.f90 index d7e0089..af781e1 100644 --- a/src/utils/orthogonalization_matrix.f90 +++ b/src/utils/orthogonalization_matrix.f90 @@ -1,4 +1,7 @@ -subroutine orthogonalization_matrix(nBas,S,X) + +! --- + +subroutine orthogonalization_matrix(nBas, S, X) ! Compute the orthogonalization matrix X @@ -35,14 +38,32 @@ subroutine orthogonalization_matrix(nBas,S,X) if(ortho_type == 1) then + ! + ! S V = V s where + ! + ! V.T V = 1 and s > 0 (S is positive def) + ! + ! S = V s V.T + ! = V s^0.5 s^0.5 V.T + ! = V s^0.5 V.T V s^0.5 V.T + ! = S^0.5 S^0.5 + ! + ! where + ! + ! S^0.5 = V s^0.5 V.T + ! + ! X = S^(-0.5) + ! = V s^(-0.5) V.T + ! + ! write(*,*) ! write(*,*) ' Lowdin orthogonalization' ! write(*,*) Uvec = S - call diagonalize_matrix(nBas,Uvec,Uval) + call diagonalize_matrix(nBas, Uvec, Uval) - do i=1,nBas + do i = 1, nBas if(Uval(i) < thresh) then @@ -50,7 +71,7 @@ subroutine orthogonalization_matrix(nBas,S,X) end if - Uval(i) = 1d0/sqrt(Uval(i)) + Uval(i) = 1d0 / dsqrt(Uval(i)) end do @@ -63,13 +84,13 @@ subroutine orthogonalization_matrix(nBas,S,X) ! write(*,*) Uvec = S - call diagonalize_matrix(nBas,Uvec,Uval) + call diagonalize_matrix(nBas, Uvec, Uval) - do i=1,nBas + do i = 1, nBas if(Uval(i) > thresh) then - Uval(i) = 1d0/sqrt(Uval(i)) + Uval(i) = 1d0 / dsqrt(Uval(i)) else @@ -79,7 +100,7 @@ subroutine orthogonalization_matrix(nBas,S,X) end do - call AD(nBas,Uvec,Uval) + call AD(nBas, Uvec, Uval) X = Uvec elseif(ortho_type == 3) then @@ -117,3 +138,6 @@ subroutine orthogonalization_matrix(nBas,S,X) end if end subroutine + +! --- + diff --git a/src/utils/read_basis_pyscf.f90 b/src/utils/read_basis_pyscf.f90 index 027fcac..42dfde2 100644 --- a/src/utils/read_basis_pyscf.f90 +++ b/src/utils/read_basis_pyscf.f90 @@ -24,10 +24,10 @@ subroutine read_basis_pyscf(nBas_AOs, nO, nV) read(3, *) nBas_AOs close(unit=3) - write(*,'(A38)') '--------------------------------------' - write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas_AOs - write(*,'(A38)') '--------------------------------------' - write(*,*) +! write(*,'(A38)') '--------------------------------------' +! write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas_AOs +! write(*,'(A38)') '--------------------------------------' +! write(*,*) ! Number of virtual orbitals From d823cdcd20a4041b76bdf0d31ee2a0ef0cc76fb8 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 18:39:51 +0200 Subject: [PATCH 23/46] introduce nBas_MOs in ROHF --- src/AOtoMO/AOtoMO.f90 | 29 +++++++--- src/AOtoMO/MOtoAO.f90 | 39 +++++++++---- src/GF/qsRGF2.f90 | 2 +- src/GF/qsUGF2.f90 | 2 +- src/GT/qsRGTeh.f90 | 2 +- src/GT/qsRGTpp.f90 | 2 +- src/GT/qsUGTpp.f90 | 2 +- src/GW/SRG_qsGW.f90 | 6 +- src/GW/SRG_qsUGW.f90 | 8 +-- src/GW/qsRGW.f90 | 6 +- src/GW/qsUGW.f90 | 8 +-- src/HF/RHF_search.f90 | 2 +- src/HF/ROHF.f90 | 111 +++++++++++++++++++++--------------- src/HF/ROHF_fock_matrix.f90 | 35 +++++++----- src/HF/UHF_search.f90 | 4 +- src/HF/print_ROHF.f90 | 17 +++--- src/QuAcK/RQuAcK.f90 | 9 ++- src/QuAcK/UQuAcK.f90 | 4 +- 18 files changed, 171 insertions(+), 117 deletions(-) diff --git a/src/AOtoMO/AOtoMO.f90 b/src/AOtoMO/AOtoMO.f90 index 2192bc7..8c5ce8f 100644 --- a/src/AOtoMO/AOtoMO.f90 +++ b/src/AOtoMO/AOtoMO.f90 @@ -1,14 +1,15 @@ -subroutine AOtoMO(nBas,C,A,B) +subroutine AOtoMO(nBas_AOs, nBas_MOs, C, M_AOs, M_MOs) -! Perform AO to MO transformation of a matrix A for given coefficients c +! Perform AO to MO transformation of a matrix M_AOs for given coefficients c +! M_MOs = C.T M_AOs C implicit none ! Input variables - integer,intent(in) :: nBas - double precision,intent(in) :: C(nBas,nBas) - double precision,intent(in) :: A(nBas,nBas) + integer,intent(in) :: nBas_AOs, nBas_MOs + double precision,intent(in) :: C(nBas_AOs,nBas_MOs) + double precision,intent(in) :: M_AOs(nBas_AOs,nBas_AOs) ! Local variables @@ -16,11 +17,21 @@ subroutine AOtoMO(nBas,C,A,B) ! Output variables - double precision,intent(out) :: B(nBas,nBas) + double precision,intent(out) :: M_MOs(nBas_MOs,nBas_MOs) - allocate(AC(nBas,nBas)) + allocate(AC(nBas_AOs,nBas_MOs)) - AC = matmul(A,C) - B = matmul(transpose(C),AC) + !AC = matmul(M_AOs, C) + !M_MOs = matmul(transpose(C), AC) + + call dgemm("N", "N", nBas_AOs, nBas_MOs, nBas_AOs, 1.d0, & + M_AOs(1,1), nBas_AOs, C(1,1), nBas_AOs, & + 0.d0, AC(1,1), nBas_AOs) + + call dgemm("T", "N", nBas_MOs, nBas_MOs, nBas_AOs, 1.d0, & + C(1,1), nBas_AOs, AC(1,1), nBas_AOs, & + 0.d0, M_MOs(1,1), nBas_MOs) + + deallocate(AC) end subroutine diff --git a/src/AOtoMO/MOtoAO.f90 b/src/AOtoMO/MOtoAO.f90 index faffa92..06abb38 100644 --- a/src/AOtoMO/MOtoAO.f90 +++ b/src/AOtoMO/MOtoAO.f90 @@ -1,16 +1,19 @@ -subroutine MOtoAO(nBas,S,C,B,A) +subroutine MOtoAO(nBas_AOs, nBas_MOs, S, C, M_MOs, M_AOs) -! Perform MO to AO transformation of a matrix A for a given metric S +! Perform MO to AO transformation of a matrix M_AOs for a given metric S ! and coefficients c +! +! M_AOs = S C M_MOs (S C).T +! implicit none ! Input variables - integer,intent(in) :: nBas - double precision,intent(in) :: S(nBas,nBas) - double precision,intent(in) :: C(nBas,nBas) - double precision,intent(in) :: B(nBas,nBas) + integer,intent(in) :: nBas_AOs, nBas_MOs + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: C(nBas_AOs,nBas_MOs) + double precision,intent(in) :: M_MOs(nBas_MOs,nBas_MOs) ! Local variables @@ -18,14 +21,28 @@ subroutine MOtoAO(nBas,S,C,B,A) ! Output variables - double precision,intent(out) :: A(nBas,nBas) + double precision,intent(out) :: M_AOs(nBas_AOs,nBas_AOs) ! Memory allocation - allocate(SC(nBas,nBas),BSC(nBas,nBas)) + allocate(SC(nBas_AOs,nBas_MOs), BSC(nBas_MOs,nBas_AOs)) - SC = matmul(S,C) - BSC = matmul(B,transpose(SC)) - A = matmul(SC,BSC) + !SC = matmul(S, C) + !BSC = matmul(M_MOs, transpose(SC)) + !M_AOs = matmul(SC, BSC) + + call dgemm("N", "N", nBas_AOs, nBas_MOs, nBas_AOs, 0.d0, & + S(1,1), nBas_AOs, C(1,1), nBas_AOs, & + 1.d0, SC(1,1), nBas_AOs) + + call dgemm("N", "T", nBas_MOs, nBas_AOs, nBas_MOs, 0.d0, & + M_MOs(1,1), nBas_MOs, SC(1,1), nBas_AOs, & + 1.d0, BSC(1,1), nBas_MOs) + + call dgemm("N", "N", nBas_AOs, nBas_AOs, nBas_MOs, 0.d0, & + SC(1,1), nBas_AOs, BSC(1,1), nBas_MOs, & + 1.d0, M_AOs(1,1), nBas_AOs) + + deallocate(SC, BSC) end subroutine diff --git a/src/GF/qsRGF2.f90 b/src/GF/qsRGF2.f90 index 8222e56..cb744c9 100644 --- a/src/GF/qsRGF2.f90 +++ b/src/GF/qsRGF2.f90 @@ -161,7 +161,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si SigC = 0.5d0*(SigC + transpose(SigC)) - call MOtoAO(nBas,S,c,SigC,SigCp) + call MOtoAO(nBas,nBas,S,c,SigC,SigCp) ! Solve the quasi-particle equation diff --git a/src/GF/qsUGF2.f90 b/src/GF/qsUGF2.f90 index 6fa0bdb..2aedac1 100644 --- a/src/GF/qsUGF2.f90 +++ b/src/GF/qsUGF2.f90 @@ -197,7 +197,7 @@ subroutine qsUGF2(dotest,maxSCF,thresh,max_diis,BSE,TDA,dBSE,dTDA,spin_conserved end do do is=1,nspin - call MOtoAO(nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is)) + call MOtoAO(nBas,nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is)) end do ! Solve the quasi-particle equation diff --git a/src/GT/qsRGTeh.f90 b/src/GT/qsRGTeh.f90 index b814001..60f8d1b 100644 --- a/src/GT/qsRGTeh.f90 +++ b/src/GT/qsRGTeh.f90 @@ -192,7 +192,7 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d Sig = 0.5d0*(Sig + transpose(Sig)) - call MOtoAO(nBas,S,c,Sig,Sigp) + call MOtoAO(nBas,nBas,S,c,Sig,Sigp) ! Solve the quasi-particle equation diff --git a/src/GT/qsRGTpp.f90 b/src/GT/qsRGTpp.f90 index 2ff7165..9cb12da 100644 --- a/src/GT/qsRGTpp.f90 +++ b/src/GT/qsRGTpp.f90 @@ -235,7 +235,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d Sig = 0.5d0*(Sig + transpose(Sig)) - call MOtoAO(nBas,S,c,Sig,Sigp) + call MOtoAO(nBas,nBas,S,c,Sig,Sigp) ! Solve the quasi-particle equation diff --git a/src/GT/qsUGTpp.f90 b/src/GT/qsUGTpp.f90 index 5f539bb..81c1cda 100644 --- a/src/GT/qsUGTpp.f90 +++ b/src/GT/qsUGTpp.f90 @@ -280,7 +280,7 @@ subroutine qsUGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,B end do do ispin=1,nspin - call MOtoAO(nBas,S,c(:,:,ispin),SigT(:,:,ispin),SigTp(:,:,ispin)) + call MOtoAO(nBas,nBas,S,c(:,:,ispin),SigT(:,:,ispin),SigTp(:,:,ispin)) end do ! Solve the quasi-particle equation diff --git a/src/GW/SRG_qsGW.f90 b/src/GW/SRG_qsGW.f90 index 9fbbd8c..84c953f 100644 --- a/src/GW/SRG_qsGW.f90 +++ b/src/GW/SRG_qsGW.f90 @@ -175,7 +175,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, call wall_time(tao1) do ixyz=1,ncart - call AOtoMO(nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + call AOtoMO(nBas,nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) @@ -218,7 +218,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Make correlation self-energy Hermitian and transform it back to AO basis call wall_time(tmo1) - call MOtoAO(nBas,S,c,SigC,SigCp) + call MOtoAO(nBas,nBas,S,c,SigC,SigCp) call wall_time(tmo2) tmo = tmo + tmo2 - tmo1 ! Solve the quasi-particle equation @@ -245,7 +245,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, call diagonalize_matrix(nBas,cp,eGW) c = matmul(X,cp) - call AOtoMO(nBas,c,SigCp,SigC) + call AOtoMO(nBas,nBas,c,SigCp,SigC) ! Compute new density matrix in the AO basis diff --git a/src/GW/SRG_qsUGW.f90 b/src/GW/SRG_qsUGW.f90 index 0705847..6939afb 100644 --- a/src/GW/SRG_qsUGW.f90 +++ b/src/GW/SRG_qsUGW.f90 @@ -184,8 +184,8 @@ subroutine SRG_qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS !-------------------------------------------------- do ixyz=1,ncart - call AOtoMO(nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) - call AOtoMO(nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) + call AOtoMO(nBas,nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) + call AOtoMO(nBas,nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) end do ! 4-index transform for (aa|aa) block @@ -228,7 +228,7 @@ subroutine SRG_qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS ! Make correlation self-energy Hermitian and transform it back to AO basis do is=1,nspin - call MOtoAO(nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is)) + call MOtoAO(nBas,nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is)) end do ! Solve the quasi-particle equation @@ -279,7 +279,7 @@ subroutine SRG_qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS ! Back-transform self-energy do is=1,nspin - call AOtoMO(nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is)) + call AOtoMO(nBas,nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is)) end do ! Compute density matrix diff --git a/src/GW/qsRGW.f90 b/src/GW/qsRGW.f90 index 6e10f75..a0df0e5 100644 --- a/src/GW/qsRGW.f90 +++ b/src/GW/qsRGW.f90 @@ -166,7 +166,7 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop ! AO to MO transformation of two-electron integrals do ixyz=1,ncart - call AOtoMO(nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + call AOtoMO(nBas,nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) @@ -191,7 +191,7 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop SigC = 0.5d0*(SigC + transpose(SigC)) - call MOtoAO(nBas,S,c,SigC,SigCp) + call MOtoAO(nBas,nBas,S,c,SigC,SigCp) ! Solve the quasi-particle equation @@ -238,7 +238,7 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop cp(:,:) = Fp(:,:) call diagonalize_matrix(nBas,cp,eGW) c = matmul(X,cp) - call AOtoMO(nBas,c,SigCp,SigC) + call AOtoMO(nBas,nBas,c,SigCp,SigC) ! Density matrix diff --git a/src/GW/qsUGW.f90 b/src/GW/qsUGW.f90 index ea57d9e..69e3f11 100644 --- a/src/GW/qsUGW.f90 +++ b/src/GW/qsUGW.f90 @@ -184,8 +184,8 @@ subroutine qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE !-------------------------------------------------- do ixyz=1,ncart - call AOtoMO(nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) - call AOtoMO(nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) + call AOtoMO(nBas,nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) + call AOtoMO(nBas,nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) end do ! 4-index transform for (aa|aa) block @@ -232,7 +232,7 @@ subroutine qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE end do do is=1,nspin - call MOtoAO(nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is)) + call MOtoAO(nBas,nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is)) end do ! Solve the quasi-particle equation @@ -283,7 +283,7 @@ subroutine qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE ! Back-transform self-energy do is=1,nspin - call AOtoMO(nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is)) + call AOtoMO(nBas,nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is)) end do ! Compute density matrix diff --git a/src/HF/RHF_search.f90 b/src/HF/RHF_search.f90 index b0bdb30..b28469f 100644 --- a/src/HF/RHF_search.f90 +++ b/src/HF/RHF_search.f90 @@ -109,7 +109,7 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN write(*,*) 'AO to MO transformation... Please be patient' write(*,*) do ixyz=1,ncart - call AOtoMO(nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + call AOtoMO(nBas,nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) call wall_time(end_AOtoMO) diff --git a/src/HF/ROHF.f90 b/src/HF/ROHF.f90 index 0cd1f5f..d67fc0b 100644 --- a/src/HF/ROHF.f90 +++ b/src/HF/ROHF.f90 @@ -1,5 +1,8 @@ -subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI,dipole_int,X,EROHF,eHF,c,Ptot) + +! --- + +subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI, dipole_int, X, EROHF, eHF, c, Ptot) ! Perform restricted open-shell Hartree-Fock calculation @@ -16,7 +19,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN double precision,intent(in) :: mix double precision,intent(in) :: level_shift double precision,intent(in) :: thresh - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nNuc double precision,intent(in) :: ZNuc(nNuc) @@ -24,18 +27,18 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN double precision,intent(in) :: ENuc 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) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(in) :: dipole_int(nBas_AOs,nBas_AOs,ncart) ! Local variables integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: n_diis double precision :: Conv double precision :: rcond @@ -62,9 +65,9 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN ! Output variables double precision,intent(out) :: EROHF - double precision,intent(out) :: eHF(nBas) - double precision,intent(inout):: c(nBas,nBas) - double precision,intent(out) :: Ptot(nBas,nBas) + double precision,intent(out) :: eHF(nBas_MOs) + double precision,intent(inout):: c(nBas_AOs,nBas_MOs) + double precision,intent(out) :: Ptot(nBas_AOs,nBas_AOs) ! Hello world @@ -76,19 +79,30 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN ! Useful stuff - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! Memory allocation - allocate(J(nBas,nBas,nspin),F(nBas,nBas,nspin),Fp(nBas,nBas),Ftot(nBas,nBas), & - P(nBas,nBas,nspin),K(nBas,nBas,nspin),err(nBas,nBas),cp(nBas,nBas), & - err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(J(nBas_AOs,nBas_AOs,nspin)) + allocate(K(nBas_AOs,nBas_AOs,nspin)) + allocate(F(nBas_AOs,nBas_AOs,nspin)) + allocate(Ftot(nBas_AOs,nBas_AOs)) + allocate(P(nBas_AOs,nBas_AOs,nspin)) + allocate(err(nBas_AOs,nBas_AOs)) + + allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(cp(nBas_MOs,nBas_MOs)) + + allocate(err_diis(nBas_AOs_Sq,max_diis)) + allocate(F_diis(nBas_AOs_Sq,max_diis)) ! Guess coefficients and demsity matrices - call mo_guess(nBas,nBas,guess_type,S,Hc,X,c) - do ispin=1,nspin - P(:,:,ispin) = matmul(c(:,1:nO(ispin)),transpose(c(:,1:nO(ispin)))) + call mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) + + do ispin = 1, nspin + !P(:,:,ispin) = matmul(c(:,1:nO(ispin)), transpose(c(:,1:nO(ispin)))) + call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO(ispin), 1.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P(1,1,ispin), nBas_AOs) end do Ptot(:,:) = P(:,:,1) + P(:,:,2) @@ -120,51 +134,51 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN ! Build Hartree repulsion - do ispin=1,nspin - call Hartree_matrix_AO_basis(nBas,P(:,:,ispin),ERI(:,:,:,:),J(:,:,ispin)) + do ispin = 1, nspin + call Hartree_matrix_AO_basis(nBas_AOs, P(:,:,ispin), ERI(:,:,:,:), J(:,:,ispin)) end do ! Compute exchange potential - do ispin=1,nspin - call exchange_matrix_AO_basis(nBas,P(:,:,ispin),ERI(:,:,:,:),K(:,:,ispin)) + do ispin = 1, nspin + call exchange_matrix_AO_basis(nBas_AOs, P(:,:,ispin), ERI(:,:,:,:), K(:,:,ispin)) end do ! Build Fock operator - do ispin=1,nspin + do ispin = 1, nspin F(:,:,ispin) = Hc(:,:) + J(:,:,ispin) + J(:,:,mod(ispin,2)+1) + K(:,:,ispin) end do - call ROHF_fock_matrix(nBas,nO(1),nO(2),S,c,F(:,:,1),F(:,:,2),Ftot) + call ROHF_fock_matrix(nBas_AOs, nBas_MOs, nO(1), nO(2), S, c, F(:,:,1), F(:,:,2), Ftot) ! Check convergence - err(:,:) = matmul(Ftot,matmul(Ptot,S)) - matmul(matmul(S,Ptot),Ftot) + err(:,:) = matmul(Ftot, matmul(Ptot, S)) - matmul(matmul(S, Ptot), Ftot) if(nSCF > 1) Conv = maxval(abs(err(:,:))) ! Kinetic energy - do ispin=1,nspin - ET(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),T(:,:))) + do ispin = 1, nspin + ET(ispin) = trace_matrix(nBas_AOs, matmul(P(:,:,ispin), T(:,:))) end do ! Potential energy - do ispin=1,nspin - EV(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),V(:,:))) + do ispin = 1, nspin + EV(ispin) = trace_matrix(nBas_AOs, matmul(P(:,:,ispin), V(:,:))) end do ! Hartree 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))) + EJ(1) = 0.5d0*trace_matrix(nBas_AOs, matmul(P(:,:,1), J(:,:,1))) + EJ(2) = trace_matrix(nBas_AOs, matmul(P(:,:,1), J(:,:,2))) + EJ(3) = 0.5d0*trace_matrix(nBas_AOs, matmul(P(:,:,2), J(:,:,2))) ! Exchange energy - do ispin=1,nspin - EK(ispin) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,ispin),K(:,:,ispin))) + do ispin = 1, nspin + EK(ispin) = 0.5d0*trace_matrix(nBas_AOs, matmul(P(:,:,ispin), K(:,:,ispin))) end do ! Total energy @@ -176,7 +190,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,Ftot) + call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,err_diis,F_diis,err,Ftot) end if @@ -185,28 +199,29 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN if(level_shift > 0d0 .and. Conv > thresh) then do ispin=1,nspin - call level_shifting(level_shift,nBas,nBas,maxval(nO),S,c,Ftot) + call level_shifting(level_shift, nBas_AOs, nBas_MOs, maxval(nO), S, c, Ftot) end do end if ! Transform Fock matrix in orthogonal basis - Fp(:,:) = matmul(transpose(X(:,:)),matmul(Ftot(:,:),X(:,:))) + Fp(:,:) = matmul(transpose(X(:,:)), matmul(Ftot(:,:), X(:,:))) ! Diagonalize Fock matrix to get eigenvectors and eigenvalues cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eHF) + call diagonalize_matrix(nBas_MOs, cp, eHF) ! Back-transform eigenvectors in non-orthogonal basis - c(:,:) = matmul(X(:,:),cp(:,:)) + c(:,:) = matmul(X(:,:), cp(:,:)) ! Compute density matrix - do ispin=1,nspin - P(:,:,ispin) = matmul(c(:,1:nO(ispin)),transpose(c(:,1:nO(ispin)))) + do ispin = 1, nspin + !P(:,:,ispin) = matmul(c(:,1:nO(ispin)), transpose(c(:,1:nO(ispin)))) + call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO(ispin), 1.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P(1,1,ispin), nBas_AOs) end do Ptot(:,:) = P(:,:,1) + P(:,:,2) @@ -231,14 +246,16 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(J, K, F, Ftot, P, err, Fp, cp, err_diis, F_diis) + stop end if ! Compute final UHF energy - call dipole_moment(nBas,Ptot,nNuc,ZNuc,rNuc,dipole_int,dipole) - call print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,EK,EROHF,dipole) + call dipole_moment(nBas_AOs,Ptot,nNuc,ZNuc,rNuc,dipole_int,dipole) + call print_ROHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, EK, EROHF, dipole) ! Print test values @@ -248,4 +265,6 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN end if + deallocate(J, K, F, Ftot, P, err, Fp, cp, err_diis, F_diis) + end subroutine diff --git a/src/HF/ROHF_fock_matrix.f90 b/src/HF/ROHF_fock_matrix.f90 index bb23662..a3c5aad 100644 --- a/src/HF/ROHF_fock_matrix.f90 +++ b/src/HF/ROHF_fock_matrix.f90 @@ -1,4 +1,7 @@ -subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO) + +! --- + +subroutine ROHF_fock_matrix(nBas_AOs, nBas_MOs, nOa, nOb, S, c, FaAO, FbAO, FAO) ! Construct the ROHF Fock matrix in the AO basis ! For open shells, the ROHF Fock matrix in the MO basis reads @@ -17,14 +20,14 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO) ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nOa integer,intent(in) :: nOb - double precision,intent(in) :: S(nBas,nBas) - double precision,intent(in) :: c(nBas,nBas) - double precision,intent(inout):: FaAO(nBas,nBas) - double precision,intent(inout):: FbAO(nBas,nBas) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(inout):: FaAO(nBas_AOs,nBas_AOs) + double precision,intent(inout):: FbAO(nBas_AOs,nBas_AOs) ! Local variables @@ -42,11 +45,11 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO) ! Output variables - double precision,intent(out) :: FAO(nBas,nBas) + double precision,intent(out) :: FAO(nBas_AOs,nBas_AOs) ! Memory allocation - allocate(F(nBas,nBas),Fa(nBas,nBas),Fb(nBas,nBas)) + allocate(F(nBas_MOs,nBas_MOs), Fa(nBas_MOs,nBas_MOs), Fb(nBas_MOs,nBas_MOs)) ! Roothan canonicalization parameters @@ -61,14 +64,14 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO) ! Number of closed, open, and virtual orbitals - nC = min(nOa,nOb) + nC = min(nOa, nOb) nO = abs(nOa - nOb) - nV = nBas - nC - nO + nV = nBas_AOs - nC - nO ! Block-by-block Fock matrix - call AOtoMO(nBas,c,FaAO,Fa) - call AOtoMO(nBas,c,FbAO,Fb) + call AOtoMO(nBas_AOs, nBas_MOs, c, FaAO, Fa) + call AOtoMO(nBas_AOs, nBas_MOs, c, FbAO, Fb) F(1:nC, 1:nC ) = aC*Fa(1:nC, 1:nC ) + bC*Fb(1:nC, 1:nC ) F(1:nC, nC+1:nC+nO ) = Fb(1:nC, nC+1:nC+nO ) @@ -82,8 +85,10 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO) F(nO+nC+1:nC+nO+nV, nC+1:nC+nO ) = Fa(nO+nC+1:nC+nO+nV, nC+1:nC+nO ) F(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) = aV*Fa(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) + bV*Fb(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) - call MOtoAO(nBas,S,c,F,FAO) - call MOtoAO(nBas,S,c,Fa,FaAO) - call MOtoAO(nBas,S,c,Fb,FbAO) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, F, FAO) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, Fa, FaAO) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, Fb, FbAO) + + deallocate(F, Fa, Fb) end subroutine diff --git a/src/HF/UHF_search.f90 b/src/HF/UHF_search.f90 index 30ae0e2..dcc1025 100644 --- a/src/HF/UHF_search.f90 +++ b/src/HF/UHF_search.f90 @@ -124,8 +124,8 @@ subroutine UHF_search(maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu ! Transform dipole-related integrals do ixyz=1,ncart - call AOtoMO(nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) - call AOtoMO(nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) + call AOtoMO(nBas,nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) + call AOtoMO(nBas,nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) end do ! 4-index transform for (aa|aa) block diff --git a/src/HF/print_ROHF.f90 b/src/HF/print_ROHF.f90 index 9d29535..09939f6 100644 --- a/src/HF/print_ROHF.f90 +++ b/src/HF/print_ROHF.f90 @@ -1,14 +1,17 @@ -subroutine print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,Ex,EROHF,dipole) + +! --- + +subroutine print_ROHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, Ex, EROHF, dipole) ! Print one- and two-electron energies and other stuff for RoHF calculation implicit none include 'parameters.h' - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO(nspin) - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: c(nBas,nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) double precision,intent(in) :: ENuc double precision,intent(in) :: ET(nspin) double precision,intent(in) :: EV(nspin) @@ -31,7 +34,7 @@ subroutine print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,Ex,EROHF,dipole) do ispin=1,nspin if(nO(ispin) > 0) then HOMO(ispin) = eHF(nO(ispin)) - if(nO(ispin) < nBas) then + if(nO(ispin) < nBas_MOs) then LUMO(ispin) = eHF(nO(ispin)+1) else LUMO(ispin) = 0d0 @@ -102,13 +105,13 @@ subroutine print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,Ex,EROHF,dipole) write(*,'(A50)') '-----------------------------------------' write(*,'(A50)') 'ROHF orbital coefficients ' write(*,'(A50)') '-----------------------------------------' - call matout(nBas,nBas,c) + call matout(nBas_AOs, nBas_MOs, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' ROHF orbital energies (au) ' write(*,'(A50)') '---------------------------------------' - call vecout(nBas,eHF) + call vecout(nBas_MOs, eHF) write(*,*) end subroutine diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 1c9545b..980a102 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -112,7 +112,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d allocate(cHF(nBas_AOs,nBas_MOs)) allocate(eHF(nBas_MOs)) allocate(PHF(nBas_AOs,nBas_AOs)) - allocate(dipole_int_MO(nBas_AOs,nBas_AOs,ncart)) + allocate(dipole_int_MO(nBas_MOs,nBas_MOs,ncart)) allocate(ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs)) !---------------------! @@ -122,7 +122,6 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doRHF) then call wall_time(start_HF) - ! TODO call RHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) call wall_time(end_HF) @@ -137,8 +136,8 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_HF) ! TODO - call ROHF(dotest,maxSCF_HF,thresh_HF,max_diis_HF,guess_type,mix,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas_AOs,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF) + call ROHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) call wall_time(end_HF) t_HF = end_HF - start_HF @@ -161,7 +160,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d do ixyz = 1, ncart ! TODO - call AOtoMO(nBas_AOs,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + call AOtoMO(nBas_AOs,nBas_MOs,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do ! 4-index transform diff --git a/src/QuAcK/UQuAcK.f90 b/src/QuAcK/UQuAcK.f90 index e3453b0..6e45b0d 100644 --- a/src/QuAcK/UQuAcK.f90 +++ b/src/QuAcK/UQuAcK.f90 @@ -163,8 +163,8 @@ subroutine UQuAcK(dotest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,do ! Read and transform dipole-related integrals do ixyz=1,ncart - call AOtoMO(nBas,cHF(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) - call AOtoMO(nBas,cHF(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) + call AOtoMO(nBas,nBas,cHF(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz)) + call AOtoMO(nBas,nBas,cHF(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz)) end do ! 4-index transform for (aa|aa) block From 56db8456b99b2cc8bec0aab29658291ae5bee651 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 18:59:55 +0200 Subject: [PATCH 24/46] introduce nBas_MOs in AOtoMO_ERI_RHF --- src/AOtoMO/AOtoMO_ERI_RHF.f90 | 50 +++++++++++++++++++++++++---------- src/GF/qsRGF2.f90 | 2 +- src/GT/qsRGTeh.f90 | 2 +- src/GT/qsRGTpp.f90 | 2 +- src/GW/SRG_qsGW.f90 | 4 +-- src/GW/qsRGW.f90 | 2 +- src/HF/RHF_search.f90 | 2 +- src/QuAcK/RQuAcK.f90 | 7 ++--- 8 files changed, 45 insertions(+), 26 deletions(-) diff --git a/src/AOtoMO/AOtoMO_ERI_RHF.f90 b/src/AOtoMO/AOtoMO_ERI_RHF.f90 index c93e111..6b1b95b 100644 --- a/src/AOtoMO/AOtoMO_ERI_RHF.f90 +++ b/src/AOtoMO/AOtoMO_ERI_RHF.f90 @@ -1,4 +1,7 @@ -subroutine AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + +! --- + +subroutine AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! AO to MO transformation of two-electron integrals via the semi-direct O(N^5) algorithm @@ -7,32 +10,51 @@ subroutine AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) ! Input variables - integer,intent(in) :: nBas - double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: c(nBas,nBas) + integer,intent(in) :: nBas_AOs, nBas_MOs + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) ! Local variables - double precision,allocatable :: scr(:,:,:,:) - integer :: mu,nu,la,si - integer :: i,j,k,l + double precision,allocatable :: a1(:,:,:,:) + double precision,allocatable :: a2(:,:,:,:) ! Output variables - double precision,intent(out) :: ERI_MO(nBas,nBas,nBas,nBas) + double precision,intent(out) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) ! Memory allocation - allocate(scr(nBas,nBas,nBas,nBas)) + allocate(a2(nBas_AOs,nBas_AOs,nBas_AOs,nBas_MOs)) + allocate(a1(nBas_AOs,nBas_AOs,nBas_MOs,nBas_MOs)) ! Four-index transform via semi-direct O(N^5) algorithm - call dgemm('T','N',nBas**3,nBas,nBas,1d0,ERI_AO,nBas,c(1,1),size(c,1),0d0,scr,nBas**3) - - call dgemm('T','N',nBas**3,nBas,nBas,1d0,scr,nBas,c(1,1),size(c,1),0d0,ERI_MO,nBas**3) + call dgemm( 'T', 'N', nBas_AOs*nBas_AOs*nBas_AOs, nBas_MOs, nBas_AOs, 1.d0 & + , ERI_AO(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & + , 0.d0, a2(1,1,1,1), nBas_AOs*nBas_AOs*nBas_AOs) - call dgemm('T','N',nBas**3,nBas,nBas,1d0,ERI_MO,nBas,c(1,1),size(c,1),0d0,scr,nBas**3) + call dgemm( 'T', 'N', nBas_AOs*nBas_AOs*nBas_MOs, nBas_MOs, nBas_AOs, 1.d0 & + , a2(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & + , 0.d0, a1(1,1,1,1), nBas_AOs*nBas_AOs*nBas_MOs) - call dgemm('T','N',nBas**3,nBas,nBas,1d0,scr,nBas,c(1,1),size(c,1),0d0,ERI_MO,nBas**3) + deallocate(a2) + allocate(a2(nBas_AOs,nBas_MOs,nBas_MOs,nBas_MOs)) + + call dgemm( 'T', 'N', nBas_AOs*nBas_MOs*nBas_MOs, nBas_MOs, nBas_AOs, 1.d0 & + , a1(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & + , 0.d0, a2(1,1,1,1), nBas_AOs*nBas_MOs*nBas_MOs) + + deallocate(a1) + + call dgemm( 'T', 'N', nBas_MOs*nBas_MOs*nBas_MOs, nBas_MOs, nBas_AOs, 1.d0 & + , a2(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & + , 0.d0, ERI_MO(1,1,1,1), nBas_MOs*nBas_MOs*nBas_MOs) + + deallocate(a2) end subroutine + + + + diff --git a/src/GF/qsRGF2.f90 b/src/GF/qsRGF2.f90 index cb744c9..9a2d71b 100644 --- a/src/GF/qsRGF2.f90 +++ b/src/GF/qsRGF2.f90 @@ -143,7 +143,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) ! Compute self-energy and renormalization factor diff --git a/src/GT/qsRGTeh.f90 b/src/GT/qsRGTeh.f90 index 60f8d1b..889e752 100644 --- a/src/GT/qsRGTeh.f90 +++ b/src/GT/qsRGTeh.f90 @@ -169,7 +169,7 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) ! Compute linear response diff --git a/src/GT/qsRGTpp.f90 b/src/GT/qsRGTpp.f90 index 9cb12da..9f4e78b 100644 --- a/src/GT/qsRGTpp.f90 +++ b/src/GT/qsRGTpp.f90 @@ -182,7 +182,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) ! Compute linear response diff --git a/src/GW/SRG_qsGW.f90 b/src/GW/SRG_qsGW.f90 index 84c953f..da87210 100644 --- a/src/GW/SRG_qsGW.f90 +++ b/src/GW/SRG_qsGW.f90 @@ -178,11 +178,11 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, call AOtoMO(nBas,nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do - call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) call wall_time(tao2) - tao = tao + tao2 -tao1 + tao = tao + tao2 - tao1 ! Compute linear response diff --git a/src/GW/qsRGW.f90 b/src/GW/qsRGW.f90 index a0df0e5..96af23b 100644 --- a/src/GW/qsRGW.f90 +++ b/src/GW/qsRGW.f90 @@ -169,7 +169,7 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop call AOtoMO(nBas,nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do - call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) ! Compute linear response diff --git a/src/HF/RHF_search.f90 b/src/HF/RHF_search.f90 index b28469f..c568fd3 100644 --- a/src/HF/RHF_search.f90 +++ b/src/HF/RHF_search.f90 @@ -111,7 +111,7 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN do ixyz=1,ncart call AOtoMO(nBas,nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) end do - call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) call wall_time(end_AOtoMO) t_AOtoMO = end_AOtoMO - start_AOtoMO diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 980a102..26f817a 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -135,7 +135,6 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doROHF) then call wall_time(start_HF) - ! TODO call ROHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, & nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) call wall_time(end_HF) @@ -159,14 +158,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d ! Read and transform dipole-related integrals do ixyz = 1, ncart - ! TODO - call AOtoMO(nBas_AOs,nBas_MOs,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + call AOtoMO(nBas_AOs, nBas_MOs, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do ! 4-index transform - ! TODO - call AOtoMO_ERI_RHF(nBas_AOs,cHF,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, cHF, ERI_AO, ERI_MO) call wall_time(end_AOtoMO) From a4eb01b589d85a7ad0e9a006c7cb154237c8d6b8 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 19:22:06 +0200 Subject: [PATCH 25/46] introduce nBas_MOs in RHF_search --- src/HF/RHF_search.f90 | 67 ++++++++++++++++++++++------------------ src/HF/RHF_stability.f90 | 4 ++- src/QuAcK/RQuAcK.f90 | 8 ++--- src/utils/utils.f90 | 24 +++++++------- 4 files changed, 57 insertions(+), 46 deletions(-) diff --git a/src/HF/RHF_search.f90 b/src/HF/RHF_search.f90 index c568fd3..714d11c 100644 --- a/src/HF/RHF_search.f90 +++ b/src/HF/RHF_search.f90 @@ -1,6 +1,9 @@ -subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nC,nO,nV,nR,S,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO, & - X,ERHF,e,c,P) + +! --- + +subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, & + X, ERHF, e, c, P) ! Search for RHF solutions @@ -13,7 +16,7 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN double precision,intent(in) :: thresh double precision,intent(in) :: level_shift - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -22,15 +25,15 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN double precision,intent(in) :: ZNuc(nNuc) double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(inout):: dipole_int_MO(nBas,nBas,ncart) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(inout):: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables @@ -59,9 +62,9 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN ! Output variables double precision,intent(out) :: ERHF - double precision,intent(out) :: e(nBas) - double precision,intent(inout):: c(nBas,nBas) - double precision,intent(out) :: P(nBas,nBas) + double precision,intent(out) :: e(nBas_MOs) + double precision,intent(inout):: c(nBas_AOs,nBas_MOs) + double precision,intent(out) :: P(nBas_AOs,nBas_AOs) ! Memory allocation @@ -76,7 +79,8 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN !-------------------! nS = (nO - nC)*(nV - nR) - allocate(Aph(nS,nS),Bph(nS,nS),AB(nS,nS),Om(nS),R(nBas,nBas),ExpR(nBas,nBas)) + allocate(Aph(nS,nS), Bph(nS,nS), AB(nS,nS), Om(nS)) + allocate(R(nBas_MOs,nBas_MOs), ExpR(nBas_MOs,nBas_MOs)) !------------------! ! Search algorithm ! @@ -92,12 +96,12 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN !---------------------! call wall_time(start_HF) - call RHF(.false.,maxSCF,thresh,max_diis,guess,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,e,c,P) + call RHF(.false., maxSCF, thresh, max_diis, guess, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, e, c, P) call wall_time(end_HF) t_HF = end_HF - start_HF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RHF = ',t_HF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RHF = ',t_HF,' seconds' write(*,*) !----------------------------------! @@ -108,14 +112,14 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN write(*,*) write(*,*) 'AO to MO transformation... Please be patient' write(*,*) - do ixyz=1,ncart - call AOtoMO(nBas,nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + do ixyz = 1, ncart + call AOtoMO(nBas_AOs, nBas_MOs, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do - call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) call wall_time(end_AOtoMO) t_AOtoMO = end_AOtoMO - start_AOtoMO - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for AO to MO transformation = ',t_AOtoMO,' seconds' write(*,*) !-------------------------------------------------------------! @@ -124,12 +128,12 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN ispin = 1 - call phLR_A(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,e,ERI_MO,Aph) - call phLR_B(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin,.false.,nBas_MOs,nC,nO,nV,nR,nS,1d0,e,ERI_MO,Aph) + call phLR_B(ispin,.false.,nBas_MOs,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) AB(:,:) = Aph(:,:) + Bph(:,:) - call diagonalize_matrix(nS,AB,Om) + call diagonalize_matrix(nS, AB, Om) Om(:) = 2d0*Om(:) write(*,*)'-------------------------------------------------------------' @@ -156,6 +160,7 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN if(eig < 0 .or. eig > nS) then write(*,'(1X,A40,1X,A10)') 'Invalid option...','Stop...' write(*,*) + deallocate(Aph, Bph, AB, Om, R, ExpR) stop end if @@ -164,15 +169,15 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN R(:,:) = 0d0 ia = 0 do i=nC+1,nO - do a=nO+1,nBas-nR + do a=nO+1,nBas_MOs-nR ia = ia + 1 R(a,i) = +AB(ia,eig) R(i,a) = -AB(ia,eig) end do end do - call matrix_exponential(nBas,R,ExpR) - c = matmul(c,ExpR) + call matrix_exponential(nBas_MOs, R, ExpR) + c = matmul(c, ExpR) else @@ -191,4 +196,6 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN !---------------! end do + deallocate(Aph, Bph, AB, Om, R, ExpR) + end subroutine diff --git a/src/HF/RHF_stability.f90 b/src/HF/RHF_stability.f90 index d7b5385..154a4f9 100644 --- a/src/HF/RHF_stability.f90 +++ b/src/HF/RHF_stability.f90 @@ -30,7 +30,7 @@ subroutine RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI) ! Memory allocation - allocate(A(nS,nS),B(nS,nS),AB(nS,nS),Om(nS)) + allocate(A(nS,nS), B(nS,nS), AB(nS,nS), Om(nS)) !-------------------------------------------------------------! ! Stability analysis: Real RHF -> Real RHF @@ -148,5 +148,7 @@ subroutine RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI) end if write(*,*)'-------------------------------------------------------------' write(*,*) + + deallocate(A, B, AB, Om) end subroutine diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 26f817a..18fc00a 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -180,7 +180,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(dostab) then call wall_time(start_stab) - call RHF_stability(nBas_AOs,nC,nO,nV,nR,nS,eHF,ERI_MO) + call RHF_stability(nBas_MOs, nC, nO, nV, nR, nS, eHF, ERI_MO) call wall_time(end_stab) t_stab = end_stab - start_stab @@ -192,9 +192,9 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(dosearch) then call wall_time(start_stab) - ! TODO - call RHF_search(maxSCF_HF,thresh_HF,max_diis_HF,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, & - nBas_AOs,nC,nO,nV,nR,S,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,X,ERHF,eHF,cHF,PHF) + call RHF_search(maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, & + dipole_int_MO, X, ERHF, eHF, cHF, PHF) call wall_time(end_stab) t_stab = end_stab - start_stab diff --git a/src/utils/utils.f90 b/src/utils/utils.f90 index 80b8322..316a87c 100644 --- a/src/utils/utils.f90 +++ b/src/utils/utils.f90 @@ -65,7 +65,7 @@ subroutine diagonal_matrix(N,D,A) end subroutine !------------------------------------------------------------------------ -subroutine matrix_exponential(N,A,ExpA) +subroutine matrix_exponential(N, A, ExpA) ! Compute Exp(A) @@ -81,7 +81,7 @@ subroutine matrix_exponential(N,A,ExpA) ! Memory allocation - allocate(W(N,N),tau(N),t(N,N)) + allocate(W(N,N), tau(N), t(N,N)) ! Initialize @@ -89,8 +89,8 @@ subroutine matrix_exponential(N,A,ExpA) ! Diagonalize - W(:,:) = - matmul(A,A) - call diagonalize_matrix(N,W,tau) + W(:,:) = - matmul(A, A) + call diagonalize_matrix(N, W, tau) ! do i=1,N ! tau(i) = max(abs(tau(i)),1d-14) @@ -99,16 +99,18 @@ subroutine matrix_exponential(N,A,ExpA) ! Construct cos part - call diagonal_matrix(N,cos(tau),t) - t(:,:) = matmul(t,transpose(W)) - ExpA(:,:) = ExpA(:,:) + matmul(W,t) + call diagonal_matrix(N, cos(tau), t) + t(:,:) = matmul(t, transpose(W)) + ExpA(:,:) = ExpA(:,:) + matmul(W, t) ! Construct sin part - call diagonal_matrix(N,sin(tau)/tau,t) - t(:,:) = matmul(t,transpose(W)) - t(:,:) = matmul(t,A) - ExpA(:,:) = ExpA(:,:) + matmul(W,t) + call diagonal_matrix(N, sin(tau)/tau, t) + t(:,:) = matmul(t, transpose(W)) + t(:,:) = matmul(t, A) + ExpA(:,:) = ExpA(:,:) + matmul(W, t) + + deallocate(W, tau, t) end subroutine From e91ef9dfebc0899e7b6bc7c0f4d698d93e072d91 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 19:52:07 +0200 Subject: [PATCH 26/46] introduce nBas_MOs in RCC --- src/CC/RCC.f90 | 51 ++++++++++++++++++++++++++----------------------- src/CC/pCCD.f90 | 22 +++++++++++++-------- src/MP/RMP.f90 | 4 ++-- 3 files changed, 43 insertions(+), 34 deletions(-) diff --git a/src/CC/RCC.f90 b/src/CC/RCC.f90 index 21f6866..a95121b 100644 --- a/src/CC/RCC.f90 +++ b/src/CC/RCC.f90 @@ -1,5 +1,8 @@ -subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) + +! --- + +subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, docrCCD, dolCCD, & + maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) ! Coupled-cluster module @@ -24,17 +27,17 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d integer,intent(in) :: max_diis double precision,intent(in) :: thresh - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: ERI(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) ! Local variables @@ -47,11 +50,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(doCCD) then call wall_time(start_CC) - call CCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call CCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CCD = ',t_CC,' seconds' write(*,*) end if @@ -63,12 +66,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(doDCD) then call wall_time(start_CC) - call DCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR, & - ERI,ENuc,ERHF,eHF) + call DCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for DCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for DCD = ',t_CC,' seconds' write(*,*) end if @@ -82,11 +84,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(doCCSD) then call wall_time(start_CC) - call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CCSD or CCSD(T)= ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CCSD or CCSD(T)= ',t_CC,' seconds' write(*,*) end if @@ -98,11 +100,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dodrCCD) then call wall_time(start_CC) - call drCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call drCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for direct ring CCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for direct ring CCD = ',t_CC,' seconds' write(*,*) end if @@ -114,11 +116,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dorCCD) then call wall_time(start_CC) - call rCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call rCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for rCCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for rCCD = ',t_CC,' seconds' write(*,*) end if @@ -130,11 +132,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(docrCCD) then call wall_time(start_CC) - call crCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call crCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for crossed-ring CCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for crossed-ring CCD = ',t_CC,' seconds' write(*,*) end if @@ -146,11 +148,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dolCCD) then call wall_time(start_CC) - call lCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call lCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ladder CCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ladder CCD = ',t_CC,' seconds' write(*,*) end if @@ -162,11 +164,12 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dopCCD) then call wall_time(start_CC) - call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) + call pCCD(dotest, maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, & + nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) call wall_time(end_CC) t_CC = end_CC - start_CC - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for pair CCD = ',t_CC,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for pair CCD = ',t_CC,' seconds' write(*,*) end if diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index 4f8b67d..2f5afb2 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -1,4 +1,8 @@ -subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) + +! --- + +subroutine pCCD(dotest, maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, & + nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) ! pair CCD module @@ -12,12 +16,12 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, integer,intent(in) :: max_diis double precision,intent(in) :: thresh - integer,intent(in) :: nBas,nC,nO,nV,nR + integer,intent(in) :: nBas_AOs, nBas_MOs, nC, nO, nV, nR double precision,intent(in) :: ENuc,ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: ERI(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) ! Local variables @@ -90,7 +94,7 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, allocate(eO(O),eV(V),delta_OV(O,V)) eO(:) = eHF(nC+1:nO) - eV(:) = eHF(nO+1:nBas-nR) + eV(:) = eHF(nO+1:nBas_MOs-nR) call form_delta_OV(nC,nO,nV,nR,eO,eV,delta_OV) @@ -486,8 +490,10 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, ! Compute electronic energy + ! TODO + ! adapt for nO, nC allocate(h(N,N)) - h = matmul(transpose(cHF),matmul(Hc,cHF)) + h = matmul(transpose(cHF), matmul(Hc, cHF)) E1 = 0d0 E2 = 0d0 diff --git a/src/MP/RMP.f90 b/src/MP/RMP.f90 index 9fba986..daf3f1e 100644 --- a/src/MP/RMP.f90 +++ b/src/MP/RMP.f90 @@ -41,7 +41,7 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_MP) t_MP = end_MP - start_MP - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2 = ',t_MP,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for MP2 = ',t_MP,' seconds' write(*,*) end if @@ -57,7 +57,7 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_MP) t_MP = end_MP - start_MP - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2 = ',t_MP,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for MP2 = ',t_MP,' seconds' write(*,*) end if From d7403a946bd769389902b3092bcb9cb569976d3c Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 20:01:24 +0200 Subject: [PATCH 27/46] introduce nBas_MOs in RCI --- src/CI/RCI.f90 | 33 +++++++++++++++++---------------- src/CI/RCIS.f90 | 4 +++- src/QuAcK/RQuAcK.f90 | 13 +++++-------- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/CI/RCI.f90 b/src/CI/RCI.f90 index 3762baf..1d068f3 100644 --- a/src/CI/RCI.f90 +++ b/src/CI/RCI.f90 @@ -1,5 +1,8 @@ -subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,nO,nV,nR,nS,ERI,dipole_int, & - epsHF,EHF,cHF,S) + +! --- + +subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nBas_MOs, & + nC, nO, nV, nR, nS, ERI, dipole_int, epsHF, EHF) ! Configuration interaction module @@ -18,18 +21,16 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n logical,intent(in) :: singlet logical,intent(in) :: triplet - integer,intent(in) :: nBas + integer,intent(in) :: nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: EHF - double precision,intent(in) :: epsHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: S(nBas,nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: epsHF(nBas_MOs) + double precision,intent(in) :: ERI(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int(nBas_MOs,nBas_MOs,ncart) ! Local variables @@ -42,11 +43,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n if(doCIS) then call wall_time(start_CI) - call RCIS(dotest,singlet,triplet,doCIS_D,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,epsHF) + call RCIS(dotest,singlet,triplet,doCIS_D,nBas_MOs,nC,nO,nV,nR,nS,ERI,dipole_int,epsHF) call wall_time(end_CI) t_CI = end_CI - start_CI - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CIS = ',t_CI,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CIS = ',t_CI,' seconds' write(*,*) end if @@ -58,11 +59,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n if(doCID) then call wall_time(start_CI) - call CID(dotest,singlet,triplet,nBas,nC,nO,nV,nR,ERI,epsHF,EHF) + call CID(dotest,singlet,triplet,nBas_MOs,nC,nO,nV,nR,ERI,epsHF,EHF) call wall_time(end_CI) t_CI = end_CI - start_CI - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CID = ',t_CI,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CID = ',t_CI,' seconds' write(*,*) end if @@ -74,11 +75,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n if(doCISD) then call wall_time(start_CI) - call CISD(dotest,singlet,triplet,nBas,nC,nO,nV,nR,ERI,epsHF,EHF) + call CISD(dotest,singlet,triplet,nBas_MOs,nC,nO,nV,nR,ERI,epsHF,EHF) call wall_time(end_CI) t_CI = end_CI - start_CI - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CISD = ',t_CI,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CISD = ',t_CI,' seconds' write(*,*) end if @@ -91,11 +92,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n call wall_time(start_CI) write(*,*) ' FCI is not yet implemented! Sorry.' -! call FCI(nBas,nC,nO,nV,nR,ERI,epsHF) +! call FCI(nBas_MOs,nC,nO,nV,nR,ERI,epsHF) call wall_time(end_CI) t_CI = end_CI - start_CI - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for FCI = ',t_CI,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for FCI = ',t_CI,' seconds' write(*,*) end if diff --git a/src/CI/RCIS.f90 b/src/CI/RCIS.f90 index 84489e3..aed3196 100644 --- a/src/CI/RCIS.f90 +++ b/src/CI/RCIS.f90 @@ -41,7 +41,7 @@ subroutine RCIS(dotest,singlet,triplet,doCIS_D,nBas,nC,nO,nV,nR,nS,ERI,dipole_in ! Memory allocation - allocate(A(nS,nS),Om(nS)) + allocate(A(nS,nS), Om(nS)) ! Compute CIS matrix @@ -117,4 +117,6 @@ subroutine RCIS(dotest,singlet,triplet,doCIS_D,nBas,nC,nO,nV,nR,nS,ERI,dipole_in end if + deallocate(A, Om) + end subroutine diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 18fc00a..c9c3888 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -212,8 +212,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doMP) then call wall_time(start_MP) - ! TODO - call RMP(dotest,doMP2,doMP3,reg_MP,nBas_AOs,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) + call RMP(dotest, doMP2, doMP3, reg_MP, nBas_MOs, nBas_MOs, nC, nO, nV, nR, ERI_MO, ENuc, ERHF, eHF) call wall_time(end_MP) t_MP = end_MP - start_MP @@ -232,9 +231,8 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doCC) then call wall_time(start_CC) - ! TODO - call RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF_CC,thresh_CC,max_diis_CC,nBas_AOs,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF,cHF) + call RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, docrCCD, dolCCD, & + maxSCF_CC, thresh_CC, max_diis_CC, nBas_AOs, nBas_MOs, nC, nO, nV, nR, Hc, ERI_MO, ENuc, ERHF, eHF, cHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -252,9 +250,8 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doCI) then call wall_time(start_CI) - ! TODO - call RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas_AOs,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & - eHF,ERHF,cHF,S) + call RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nBas_MOs, & + nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eHF, ERHF) call wall_time(end_CI) t_CI = end_CI - start_CI From 0366561ce34df6c07eafa27ec48089530fe1a77e Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 28 Aug 2024 21:11:05 +0200 Subject: [PATCH 28/46] introduce nBas_MOs in RGF --- src/GF/RG0F2.f90 | 4 +- src/GF/RGF.f90 | 70 +++++++++++++----------- src/GF/evRGF2.f90 | 4 +- src/GF/print_qsRGF2.f90 | 24 +++++---- src/GF/qsRGF2.f90 | 117 ++++++++++++++++++++++++---------------- src/QuAcK/RQuAcK.f90 | 22 ++++---- src/RPA/RRPA.f90 | 12 ++--- 7 files changed, 144 insertions(+), 109 deletions(-) diff --git a/src/GF/RG0F2.f90 b/src/GF/RG0F2.f90 index 7cb3c40..53aeb1e 100644 --- a/src/GF/RG0F2.f90 +++ b/src/GF/RG0F2.f90 @@ -51,7 +51,7 @@ subroutine RG0F2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize, ! Memory allocation - allocate(SigC(nBas),Z(nBas),eGFlin(nBas),eGF(nBas)) + allocate(SigC(nBas), Z(nBas), eGFlin(nBas), eGF(nBas)) ! Frequency-dependent second-order contribution @@ -133,4 +133,6 @@ subroutine RG0F2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize, end if + deallocate(SigC, Z, eGFlin, eGF) + end subroutine diff --git a/src/GF/RGF.f90 b/src/GF/RGF.f90 index 2fe50f2..72911e4 100644 --- a/src/GF/RGF.f90 +++ b/src/GF/RGF.f90 @@ -1,7 +1,10 @@ -subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,maxSCF,thresh,max_diis, & - dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize,eta,regularize, & - nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,EHF,S,X,T,V,Hc,ERI_AO,ERI, & - dipole_int_AO,dipole_int,PHF,cHF,epsHF) + +! --- + +subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, renorm, maxSCF, & + thresh, max_diis, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, linearize, & + eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, EHF, & + S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, epsHF) ! Green's function module @@ -39,7 +42,7 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -47,18 +50,18 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max integer,intent(in) :: nS double precision,intent(in) :: EHF - double precision,intent(in) :: epsHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: epsHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(in) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables @@ -71,12 +74,13 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max if(doG0F2) then call wall_time(start_GF) - call RG0F2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize,eta,regularize, & - nBas,nC,nO,nV,nR,nS,ENuc,EHF,ERI,dipole_int,epsHF) + call RG0F2(dotest, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, & + linearize, eta, regularize, nBas_MOs, nC, nO, nV, nR, nS, & + ENuc, EHF, ERI_MO, dipole_int_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF2 = ',t_GF,' seconds' write(*,*) end if @@ -89,12 +93,12 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max call wall_time(start_GF) call evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis, & - singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,EHF, & - ERI,dipole_int,epsHF) + singlet,triplet,linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,EHF, & + ERI_MO,dipole_int_MO,epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF2 = ',t_GF,' seconds' write(*,*) end if @@ -106,12 +110,14 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max if(doqsGF2) then call wall_time(start_GF) - call qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc, & - nBas,nC,nO,nV,nR,nS,EHF,S,X,T,V,Hc,ERI_AO,ERI,dipole_int_AO,dipole_int,PHF,cHF,epsHF) + call qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & + dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, & + rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, EHF, S, & + X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGF2 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGF2 = ',t_GF,' seconds' write(*,*) end if @@ -123,11 +129,11 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max if(doufG0F02) then call wall_time(start_GF) - call ufRG0F02(dotest,nBas,nC,nO,nV,nR,nS,ENuc,EHF,ERI,epsHF) + call ufRG0F02(dotest, nBas_MOs, nC, nO, nV, nR, nS, ENuc, EHF, ERI_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufG0F02 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufG0F02 = ',t_GF,' seconds' write(*,*) end if @@ -139,11 +145,11 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max if(doG0F3) then call wall_time(start_GF) - call RG0F3(dotest,renorm,nBas,nC,nO,nV,nR,ERI,epsHF) + call RG0F3(dotest, renorm, nBas_MOs, nC, nO, nV, nR, ERI_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF3 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF3 = ',t_GF,' seconds' write(*,*) end if @@ -155,11 +161,11 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max if(doevGF3) then call wall_time(start_GF) - call evRGF3(dotest,maxSCF,thresh,max_diis,renorm,nBas,nC,nO,nV,nR,ERI,epsHF) + call evRGF3(dotest, maxSCF, thresh, max_diis, renorm, nBas_MOs, nC, nO, nV, nR, ERI_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF3 = ',t_GF,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF3 = ',t_GF,' seconds' write(*,*) end if diff --git a/src/GF/evRGF2.f90 b/src/GF/evRGF2.f90 index 4dc2610..c3c4637 100644 --- a/src/GF/evRGF2.f90 +++ b/src/GF/evRGF2.f90 @@ -62,7 +62,7 @@ subroutine evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis,si ! Memory allocation - allocate(SigC(nBas),Z(nBas),eGF(nBas),eOld(nBas),error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + allocate(SigC(nBas), Z(nBas), eGF(nBas), eOld(nBas), error_diis(nBas,max_diis), e_diis(nBas,max_diis)) ! Initialization @@ -189,4 +189,6 @@ subroutine evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis,si end if + deallocate(SigC, Z, eGF, eOld, error_diis, e_diis) + end subroutine diff --git a/src/GF/print_qsRGF2.f90 b/src/GF/print_qsRGF2.f90 index 845c5a0..42132c0 100644 --- a/src/GF/print_qsRGF2.f90 +++ b/src/GF/print_qsRGF2.f90 @@ -1,4 +1,8 @@ -subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ,Ex,Ec,EqsGF,dipole) + +! --- + +subroutine print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, c, & + SigC, Z, ENuc, ET, EV, EJ, Ex, Ec, EqsGF, dipole) ! Print one-electron energies and other stuff for qsGF2 @@ -7,17 +11,17 @@ subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ, ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: eGF(nBas) - double precision,intent(in) :: c(nBas) - double precision,intent(in) :: SigC(nBas,nBas) - double precision,intent(in) :: Z(nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: eGF(nBas_MOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) + double precision,intent(in) :: Z(nBas_MOs) double precision,intent(in) :: ET double precision,intent(in) :: EV double precision,intent(in) :: EJ @@ -53,7 +57,7 @@ subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ, '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do q=1,nBas + do q = 1, nBas_MOs 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)') & '|',q,'|',eHF(q)*HaToeV,'|',SigC(q,q)*HaToeV,'|',Z(q),'|',eGF(q)*HaToeV,'|' end do @@ -102,12 +106,12 @@ subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ, write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGF2 MO coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas,nBas,c) + call matout(nBas_AOs, nBas_MOs, c) write(*,*) write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGF2 MO energies' write(*,'(A50)') '---------------------------------------' - call matout(nBas,1,eGF) + call matout(nBas_MOs, 1, eGF) write(*,*) end if diff --git a/src/GF/qsRGF2.f90 b/src/GF/qsRGF2.f90 index 9a2d71b..4287676 100644 --- a/src/GF/qsRGF2.f90 +++ b/src/GF/qsRGF2.f90 @@ -1,6 +1,10 @@ -subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet, & - eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, & - S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + +! --- + +subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & + dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, & + rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, & + S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GF2 calculation @@ -29,25 +33,25 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas,nC,nO,nV,nR,nS + integer,intent(in) :: nBas_AOs,nBas_MOs,nC,nO,nV,nR,nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: dipole_int_MO(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: ispin integer :: n_diis double precision :: EqsGF2 @@ -94,7 +98,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! Stuff - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! TDA @@ -105,9 +109,27 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! Memory allocation - allocate(eGF(nBas),eOld(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),Z(nBas), & - error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(eGF(nBas_MOs)) + allocate(eOld(nBas_MOs)) + + allocate(c(nBas_AOs,nBas_MOs)) + + allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Fp(nBas_MOs,nBas_MOs)) + + allocate(P(nBas_AOs,nBas_AOs)) + allocate(F(nBas_AOs,nBas_AOs)) + allocate(J(nBas_AOs,nBas_AOs)) + allocate(K(nBas_AOs,nBas_AOs)) + allocate(error(nBas_AOs,nBas_AOs)) + + allocate(Z(nBas_MOs)) + allocate(SigC(nBas_MOs,nBas_MOs)) + + allocate(SigCp(nBas_AOs,nBas_AOs)) + + allocate(error_diis(nBas_AOs_Sq,max_diis)) + allocate(F_diis(nBas_AOs_Sq,max_diis)) ! Initialization @@ -117,7 +139,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si Conv = 1d0 P(:,:) = PHF(:,:) eOld(:) = eHF(:) - eGF(:) = eHF(:) + eGF(:) = eHF(:) c(:,:) = cHF(:,:) F_diis(:,:) = 0d0 error_diis(:,:) = 0d0 @@ -135,25 +157,25 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! Buid Hartree matrix - call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas_AOs, P, ERI_AO, J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas_AOs, P, ERI_AO, K) ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! Compute self-energy and renormalization factor if(regularize) then - call GF2_reg_self_energy(eta,nBas,nC,nO,nV,nR,eGF,ERI_MO,SigC,Z) + call GF2_reg_self_energy(eta, nBas_MOs, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z) else - call GF2_self_energy(eta,nBas,nC,nO,nV,nR,eGF,ERI_MO,SigC,Z) + call GF2_self_energy(eta, nBas_MOs, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z) end if @@ -161,7 +183,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si SigC = 0.5d0*(SigC + transpose(SigC)) - call MOtoAO(nBas,nBas,S,c,SigC,SigCp) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, SigC, SigCp) ! Solve the quasi-particle equation @@ -169,28 +191,27 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! Compute commutator and convergence criteria - error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + error = matmul(F, matmul(P, S)) - matmul(matmul(S, P), F) ! DIIS extrapolation - n_diis = min(n_diis+1,max_diis) + n_diis = min(n_diis+1, max_diis) if(abs(rcond) > 1d-7) then - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,error_diis,F_diis,error,F) else n_diis = 0 end if ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X),matmul(F,X)) + Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eGF) - c = matmul(X,cp) - SigCp = matmul(transpose(c),matmul(SigCp,c)) + call diagonalize_matrix(nBas_MOs, cp, eGF) + c = matmul(X, cp) ! Compute new density matrix in the AO basis - P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO))) ! Save quasiparticles energy for next cycle @@ -203,23 +224,23 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! Kinetic energy - ET = trace_matrix(nBas,matmul(P,T)) + ET = trace_matrix(nBas_AOs, matmul(P, T)) ! Potential energy - EV = trace_matrix(nBas,matmul(P,V)) + EV = trace_matrix(nBas_AOs, matmul(P, V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas_AOs, matmul(P, J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas_AOs, matmul(P, K)) ! Correlation energy - call RMP2(.false.,regularize,nBas,nC,nO,nV,nR,ERI_MO,ENuc,EqsGF2,eGF,Ec) + call RMP2(.false., regularize, nBas_MOs, nC, nO, nV, nR, ERI_MO, ENuc, EqsGF2, eGF, Ec) ! Total energy @@ -230,8 +251,9 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si ! Print results !------------------------------------------------------------------------ - call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigCp,Z,ENuc,ET,EV,EJ,Ex,Ec,EqsGF2,dipole) + call dipole_moment(nBas_AOs, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole) + call print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, & + c, SigC, Z, ENuc, ET, EV, EJ, Ex, Ec, EqsGF2, dipole) end do !------------------------------------------------------------------------ @@ -248,19 +270,21 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, error, error_diis, F_diis) stop end if ! Deallocate memory - deallocate(c,cp,P,F,Fp,J,K,SigC,SigCp,Z,error,error_diis,F_diis) + deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, error, error_diis, F_diis) ! Perform BSE calculation if(dophBSE) then - call GF2_phBSE2(TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eGF,EcBSE) + call GF2_phBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, nC, nO, & + nV, nR, nS, ERI_MO, dipole_int_MO, eGF, EcBSE) write(*,*) write(*,*)'-------------------------------------------------------------------------------' @@ -278,7 +302,8 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si if(doppBSE) then - call GF2_ppBSE2(TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,ERI_MO,dipole_int_MO,eGF,EcBSE) + call GF2_ppBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, & + nC, nO, nV, nR, ERI_MO, dipole_int_MO, eGF, EcBSE) write(*,*) write(*,*)'-------------------------------------------------------------------------------' diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index c9c3888..63a081c 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -269,9 +269,8 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doRPA) then call wall_time(start_RPA) - ! TODO - call RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_kernel,singlet,triplet, & - nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,cHF,S) + call RRPA(dotest, dophRPA, dophRPAx, docrRPA, doppRPA, TDA, doACFDT, exchange_kernel, singlet, triplet, & + nBas_MOs, nC, nO, nV, nR, nS, ENuc, ERHF, ERI_MO, dipole_int_MO, eHF) call wall_time(end_RPA) t_RPA = end_RPA - start_RPA @@ -289,11 +288,10 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doGF) then call wall_time(start_GF) - ! TODO - call RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm_GF,maxSCF_GF,thresh_GF,max_diis_GF, & - dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,lin_GF,eta_GF,reg_GF, & - nNuc,ZNuc,rNuc,ENuc,nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO, & - dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + call RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, renorm_GF, maxSCF_GF, & + thresh_GF, max_diis_GF, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, lin_GF, & + eta_GF, reg_GF, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, & + S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GF) t_GF = end_GF - start_GF @@ -314,7 +312,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d ! TODO call RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF_GW,thresh_GW,max_diis_GW, & doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet, & - lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc,nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & + lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc,nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) call wall_time(end_GW) @@ -334,9 +332,9 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_GT) ! TODO - call RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - maxSCF_GT,thresh_GT,max_diis_GT,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE, & - TDA_T,TDA,dBSE,dTDA,singlet,triplet,lin_GT,eta_GT,reg_GT,nNuc,ZNuc,rNuc,ENuc, & + call RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & + maxSCF_GT,thresh_GT,max_diis_GT,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE, & + TDA_T,TDA,dBSE,dTDA,singlet,triplet,lin_GT,eta_GT,reg_GT,nNuc,ZNuc,rNuc,ENuc, & nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) call wall_time(end_GT) diff --git a/src/RPA/RRPA.f90 b/src/RPA/RRPA.f90 index 93bf457..ab38932 100644 --- a/src/RPA/RRPA.f90 +++ b/src/RPA/RRPA.f90 @@ -1,5 +1,5 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_kernel,singlet,triplet, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF,cHF,S) + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF) ! Random-phase approximation module @@ -29,8 +29,6 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: S(nBas,nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) double precision,intent(in) :: dipole_int(nBas,nBas,ncart) @@ -49,7 +47,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker call wall_time(end_RPA) t_RPA = end_RPA - start_RPA - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RPA = ',t_RPA,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RPA = ',t_RPA,' seconds' write(*,*) end if @@ -65,7 +63,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker call wall_time(end_RPA) t_RPA = end_RPA - start_RPA - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RPAx = ',t_RPA,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RPAx = ',t_RPA,' seconds' write(*,*) end if @@ -81,7 +79,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker call wall_time(end_RPA) t_RPA = end_RPA - start_RPA - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for pp-RPA = ',t_RPA,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for pp-RPA = ',t_RPA,' seconds' write(*,*) end if @@ -97,7 +95,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker call wall_time(end_RPA) t_RPA = end_RPA - start_RPA - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for pp-RPA = ',t_RPA,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for pp-RPA = ',t_RPA,' seconds' write(*,*) end if From c06871a0ffb646d5cf5b6aa994c38807db36fc45 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 00:00:41 +0200 Subject: [PATCH 29/46] introduce nBas_MOs in RGW --- src/GW/RGW.f90 | 74 ++++++++++++----------- src/GW/SRG_qsGW.f90 | 124 ++++++++++++++++++++++++--------------- src/GW/print_qsRGW.f90 | 24 ++++---- src/GW/qsRGW.f90 | 130 +++++++++++++++++++++++++---------------- src/QuAcK/RQuAcK.f90 | 9 ++- 5 files changed, 217 insertions(+), 144 deletions(-) diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index 696039d..8498485 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -1,7 +1,10 @@ -subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thresh,max_diis,doACFDT, & - exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet, & - linearize,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & - ERI_AO,ERI_MO,dipole_int_AO,dipole_int,PHF,cHF,eHF) + +! --- + +subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxSCF, thresh, max_diis, doACFDT, & + exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, TDA_W, TDA, dBSE, dTDA, singlet, triplet, & + linearize, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, & + S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Restricted GW module @@ -43,7 +46,7 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -51,18 +54,18 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(in) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables @@ -76,11 +79,11 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre call wall_time(start_GW) call RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF) + linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0W0 = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for G0W0 = ',t_GW,' seconds' write(*,*) end if @@ -93,11 +96,11 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre call wall_time(start_GW) call evRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & - singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF) + singlet,triplet,linearize,eta,regularize,nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGW = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for evGW = ',t_GW,' seconds' write(*,*) end if @@ -109,13 +112,14 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre if(doqsGW) then call wall_time(start_GW) - call qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & - singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO, & - dipole_int_AO,dipole_int,PHF,cHF,eHF) + call qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, & + TDA_W, TDA, dBSE, dTDA, doppBSE, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, & + ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, & + dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGW = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGW = ',t_GW,' seconds' write(*,*) end if @@ -127,13 +131,15 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre if(doSRGqsGW) then call wall_time(start_GW) - call SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA, & - singlet,triplet,eta,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO, & - dipole_int_AO,dipole_int,PHF,cHF,eHF) + call SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, & + dophBSE, dophBSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, & + nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, & + ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, & + PHF, cHF, eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGW = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGW = ',t_GW,' seconds' write(*,*) end if @@ -145,11 +151,12 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre if(doufG0W0) then call wall_time(start_GW) - call ufG0W0(dotest,TDA_W,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) + ! TODO + call ufG0W0(dotest,TDA_W,nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufG0W0 = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufG0W0 = ',t_GW,' seconds' write(*,*) end if @@ -161,11 +168,12 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre if(doufGW) then call wall_time(start_GW) - call ufGW(dotest,TDA_W,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) + ! TODO + call ufGW(dotest,TDA_W,nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufGW = ',t_GW,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufGW = ',t_GW,' seconds' write(*,*) end if diff --git a/src/GW/SRG_qsGW.f90 b/src/GW/SRG_qsGW.f90 index da87210..32c2a19 100644 --- a/src/GW/SRG_qsGW.f90 +++ b/src/GW/SRG_qsGW.f90 @@ -1,6 +1,10 @@ -subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE,BSE2,TDA_W,TDA, & - dBSE,dTDA,singlet,triplet,eta,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, & - S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + +! --- + +subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, & + BSE, BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nNuc, & + ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, & + X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GW calculation @@ -32,30 +36,30 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(inout):: dipole_int_MO(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(inout):: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: ispin integer :: ixyz integer :: n_diis @@ -114,7 +118,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Stuff - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! TDA for W @@ -132,9 +136,32 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Memory allocation - allocate(eGW(nBas),eOld(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),Z(nBas),Aph(nS,nS),Bph(nS,nS), & - Om(nS),XpY(nS,nS),XmY(nS,nS),rho(nBas,nBas,nS),error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(eGW(nBas_MOs)) + allocate(eOld(nBas_MOs)) + allocate(Z(nBas_MOs)) + + allocate(c(nBas_AOs,nBas_MOs)) + + allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(SigC(nBas_MOs,nBas_MOs)) + + allocate(P(nBas_AOs,nBas_AOs)) + allocate(F(nBas_AOs,nBas_AOs)) + allocate(J(nBas_AOs,nBas_AOs)) + allocate(K(nBas_AOs,nBas_AOs)) + allocate(error(nBas_AOs,nBas_AOs)) + allocate(SigCp(nBas_AOs,nBas_AOs)) + + allocate(Aph(nS,nS)) + allocate(Bph(nS,nS)) + allocate(Om(nS)) + allocate(XpY(nS,nS)) + allocate(XmY(nS,nS)) + allocate(rho(nBas_MOs,nBas_MOs,nS)) + + allocate(error_diis(nBas_AOs_Sq,max_diis)) + allocate(F_diis(nBas_AOs_Sq,max_diis)) ! Initialization @@ -162,11 +189,11 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Buid Hartree matrix call wall_time(t1) - call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas_AOs,P,ERI_AO,J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas_AOs,P,ERI_AO,K) call wall_time(t2) tt=tt+t2-t1 @@ -174,11 +201,11 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, call wall_time(tao1) - do ixyz=1,ncart - call AOtoMO(nBas,nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + do ixyz = 1, ncart + call AOtoMO(nBas_AOs, nBas_MOs, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do - call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) call wall_time(tao2) @@ -188,8 +215,8 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, call wall_time(tlr1) - call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph) - if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph) + if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) @@ -203,13 +230,13 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, call wall_time(tex1) - call GW_excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY,rho) + call GW_excitation_density(nBas_MOs,nC,nO,nR,nS,ERI_MO,XpY,rho) call wall_time(tex2) tex=tex+tex2-tex1 call wall_time(tsrg1) - call SRG_self_energy(flow,nBas,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z) + call SRG_self_energy(flow,nBas_MOs,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z) call wall_time(tsrg2) @@ -218,7 +245,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Make correlation self-energy Hermitian and transform it back to AO basis call wall_time(tmo1) - call MOtoAO(nBas,nBas,S,c,SigC,SigCp) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, SigC, SigCp) call wall_time(tmo2) tmo = tmo + tmo2 - tmo1 ! Solve the quasi-particle equation @@ -234,18 +261,18 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,error_diis,F_diis,error,F) end if ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X),matmul(F,X)) + Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eGW) - c = matmul(X,cp) + call diagonalize_matrix(nBas_MOs, cp, eGW) + c = matmul(X, cp) - call AOtoMO(nBas,nBas,c,SigCp,SigC) + call AOtoMO(nBas_AOs, nBas_MOs, c, SigCp, SigC) ! Compute new density matrix in the AO basis @@ -262,19 +289,19 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Kinetic energy - ET = trace_matrix(nBas,matmul(P,T)) + ET = trace_matrix(nBas_AOs,matmul(P,T)) ! Potential energy - EV = trace_matrix(nBas,matmul(P,V)) + EV = trace_matrix(nBas_AOs,matmul(P,V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas_AOs,matmul(P,J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas_AOs,matmul(P,K)) ! Total energy @@ -282,8 +309,9 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Print results - call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGW,dipole) + call dipole_moment(nBas_AOs,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, & + SigC, Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGW, dipole) end do !------------------------------------------------------------------------ @@ -300,6 +328,8 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(c, cp, P, F, Fp, J, K, SigC, Z, Om, XpY, XmY, rho, error, error_diis, F_diis) + stop end if @@ -313,17 +343,18 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, ! Cumulant expansion - call RGWC(dotest,eta,nBas,nC,nO,nV,nR,nS,Om,rho,eHF,eGW,eGW,Z) + call RGWC(dotest,eta,nBas_MOs,nC,nO,nV,nR,nS,Om,rho,eHF,eGW,eGW,Z) ! Deallocate memory - deallocate(c,cp,P,F,Fp,J,K,SigC,Z,Om,XpY,XmY,rho,error,error_diis,F_diis) + deallocate(c, cp, P, F, Fp, J, K, SigC, Z, Om, XpY, XmY, rho, error, error_diis, F_diis) ! Perform BSE calculation if(BSE) then - call GW_phBSE(BSE2,TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eGW,eGW,EcBSE) + call GW_phBSE(BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, & + nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE) if(exchange_kernel) then @@ -357,7 +388,8 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, end if - call GW_phACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcBSE) + call GW_phACFDT(exchange_kernel, doXBS, .true., TDA_W, TDA, BSE, singlet, triplet, & + eta, nBas_MOs, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE) write(*,*) write(*,*)'-------------------------------------------------------------------------------' diff --git a/src/GW/print_qsRGW.f90 b/src/GW/print_qsRGW.f90 index d09a670..7e90ce7 100644 --- a/src/GW/print_qsRGW.f90 +++ b/src/GW/print_qsRGW.f90 @@ -1,4 +1,8 @@ -subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,EK,EcGM,EcRPA,EqsGW,dipole) + +! --- + +subroutine print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, & + Z, ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole) ! Print useful information about qsRGW calculation @@ -7,7 +11,7 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc @@ -19,11 +23,11 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E double precision,intent(in) :: EcRPA double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: eGW(nBas) - double precision,intent(in) :: c(nBas) - double precision,intent(in) :: SigC(nBas,nBas) - double precision,intent(in) :: Z(nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: eGW(nBas_MOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) + double precision,intent(in) :: Z(nBas_MOs) double precision,intent(in) :: EqsGW double precision,intent(in) :: dipole(ncart) @@ -59,7 +63,7 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E '|','#','|','e_HF (eV)','|','Sig_GW (eV)','|','Z','|','e_GW (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do p=1,nBas + do p=1,nBas_MOs 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)') & '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGW(p)*HaToeV,'|' end do @@ -110,13 +114,13 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' Restricted qsGW orbital coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas,nBas,c) + call matout(nBas_AOs, nBas_MOs, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' Restricted qsGW orbital energies (au) ' write(*,'(A50)') '---------------------------------------' - call vecout(nBas,eGW) + call vecout(nBas_MOs, eGW) write(*,*) end if diff --git a/src/GW/qsRGW.f90 b/src/GW/qsRGW.f90 index 96af23b..395c30e 100644 --- a/src/GW/qsRGW.f90 +++ b/src/GW/qsRGW.f90 @@ -1,6 +1,10 @@ -subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & - singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO, & - ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + +! --- + +subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, & + TDA_W, TDA, dBSE, dTDA, doppBSE, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, & + ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, & + ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GW calculation @@ -34,30 +38,30 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(inout):: dipole_int_MO(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_AOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(inout):: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: ispin integer :: ixyz integer :: n_diis @@ -112,7 +116,7 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop ! Stuff - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! TDA for W @@ -130,10 +134,31 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop ! Memory allocation - allocate(eGW(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),Z(nBas), & - Aph(nS,nS),Bph(nS,nS),Om(nS),XpY(nS,nS),XmY(nS,nS),rho(nBas,nBas,nS), & - err(nBas,nBas),err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(eGW(nBas_MOs)) + allocate(Z(nBas_MOs)) + + allocate(c(nBas_AOs,nBas_MOs)) + + allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(SigC(nBas_MOs,nBas_MOs)) + + allocate(P(nBas_AOs,nBas_AOs)) + allocate(F(nBas_AOs,nBas_AOs)) + allocate(J(nBas_AOs,nBas_AOs)) + allocate(K(nBas_AOs,nBas_AOs)) + allocate(err(nBas_AOs,nBas_AOs)) + allocate(SigCp(nBas_AOs,nBas_AOs)) + + allocate(Aph(nS,nS)) + allocate(Bph(nS,nS)) + allocate(Om(nS)) + allocate(XpY(nS,nS)) + allocate(XmY(nS,nS)) + allocate(rho(nBas_MOs,nBas_MOs,nS)) + + allocate(err_diis(nBas_AOs_Sq,max_diis)) + allocate(F_diis(nBas_AOs_Sq,max_diis)) ! Initialization @@ -160,38 +185,38 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop ! Build Hartree-exchange matrix - call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) - call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) + call Hartree_matrix_AO_basis(nBas_AOs, P, ERI_AO, J) + call exchange_matrix_AO_basis(nBas_AOs, P, ERI_AO, K) ! AO to MO transformation of two-electron integrals - do ixyz=1,ncart - call AOtoMO(nBas,nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz)) + do ixyz = 1, ncart + call AOtoMO(nBas_AOs, nBas_MOs, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do - call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! Compute linear response - call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph) - if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin, dRPA, nBas_MOs, nC, nO, nV, nR, nS, 1d0, eGW, ERI_MO, Aph) + if(.not.TDA_W) call phLR_B(ispin, dRPA, nBas_MOs, nC, nO, nV, nR, nS, 1d0, ERI_MO, Bph) - call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) + call phLR(TDA_W, nS, Aph, Bph, EcRPA, Om, XpY, XmY) if(print_W) call print_excitation_energies('phRPA@GW@RHF','singlet',nS,Om) ! Compute correlation part of the self-energy - call GW_excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY,rho) + call GW_excitation_density(nBas_MOs, nC, nO, nR, nS, ERI_MO, XpY, rho) - if(regularize) call GW_regularization(nBas,nC,nO,nV,nR,nS,eGW,Om,rho) + if(regularize) call GW_regularization(nBas_MOs, nC, nO, nV, nR, nS, eGW, Om, rho) - call GW_self_energy(eta,nBas,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z) + call GW_self_energy(eta, nBas_MOs, nC, nO, nV, nR, nS, eGW, Om, rho, EcGM, SigC, Z) ! Make correlation self-energy Hermitian and transform it back to AO basis SigC = 0.5d0*(SigC + transpose(SigC)) - call MOtoAO(nBas,nBas,S,c,SigC,SigCp) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, SigC, SigCp) ! Solve the quasi-particle equation @@ -205,19 +230,19 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop ! Kinetic energy - ET = trace_matrix(nBas,matmul(P,T)) + ET = trace_matrix(nBas_AOs, matmul(P, T)) ! Potential energy - EV = trace_matrix(nBas,matmul(P,V)) + EV = trace_matrix(nBas_AOs, matmul(P, V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas_AOs, matmul(P, J)) ! Exchange energy - EK = 0.25d0*trace_matrix(nBas,matmul(P,K)) + EK = 0.25d0*trace_matrix(nBas_AOs, matmul(P, K)) ! Total energy @@ -228,26 +253,27 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,F) + call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,err_diis,F_diis,err,F) end if ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X),matmul(F,X)) + Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eGW) - c = matmul(X,cp) - call AOtoMO(nBas,nBas,c,SigCp,SigC) + call diagonalize_matrix(nBas_MOs, cp, eGW) + c = matmul(X, cp) + call AOtoMO(nBas_AOs, nBas_MOs, c, SigCp, SigC) ! Density matrix - P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO))) ! Print results - call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigCp,Z,ENuc,ET,EV,EJ,EK,EcGM,EcRPA,EqsGW,dipole) + call dipole_moment(nBas_AOs, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole) + call print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, Z, & + ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole) end do !------------------------------------------------------------------------ @@ -264,19 +290,21 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, Om, XpY, XmY, rho, err, err_diis, F_diis) stop end if ! Deallocate memory - deallocate(c,cp,P,F,Fp,J,K,SigC,SigCp,Z,Om,XpY,XmY,rho,err,err_diis,F_diis) + deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, Om, XpY, XmY, rho, err, err_diis, F_diis) ! Perform BSE calculation if(dophBSE) then - call GW_phBSE(dophBSE2,TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eGW,eGW,EcBSE) + call GW_phBSE(dophBSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, & + nBas_MOs, nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE) if(exchange_kernel) then @@ -310,7 +338,8 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop end if - call GW_phACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,dophBSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcBSE) + call GW_phACFDT(exchange_kernel, doXBS, .true., TDA_W, TDA, dophBSE, singlet, triplet, & + eta, nBas_MOs, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE) write(*,*) write(*,*)'-------------------------------------------------------------------------------' @@ -327,7 +356,8 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop if(doppBSE) then - call GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eHF,eGW,EcBSE) + call GW_ppBSE(TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, & + nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eHF, eGW, EcBSE) EcBSE(2) = 3d0*EcBSE(2) diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 63a081c..5796562 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -309,11 +309,10 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doGW) then call wall_time(start_GW) - ! TODO - call RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF_GW,thresh_GW,max_diis_GW, & - doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet, & - lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc,nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & - ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + call RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxSCF_GW, thresh_GW, max_diis_GW, & + doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, TDA_W, TDA, dBSE, dTDA, singlet, triplet, & + lin_GW, eta_GW, reg_GW, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, & + V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GW) t_GW = end_GW - start_GW From c25e934e8b1a010f166e4f06388bc6063bb2ecb8 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 00:47:12 +0200 Subject: [PATCH 30/46] introduce nBas_MOs in RGT --- src/GT/RGT.f90 | 75 ++++++++++---------- src/GT/print_qsRGTeh.f90 | 24 ++++--- src/GT/print_qsRGTpp.f90 | 24 ++++--- src/GT/qsRGTeh.f90 | 110 ++++++++++++++++++----------- src/GT/qsRGTpp.f90 | 147 +++++++++++++++++++++++---------------- src/QuAcK/RQuAcK.f90 | 10 +-- 6 files changed, 229 insertions(+), 161 deletions(-) diff --git a/src/GT/RGT.f90 b/src/GT/RGT.f90 index 4225d36..a4f46b6 100644 --- a/src/GT/RGT.f90 +++ b/src/GT/RGT.f90 @@ -1,7 +1,11 @@ -subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,maxSCF,thresh,max_diis, & - doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet, & - linearize,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc, & - ERI_AO,ERI_MO,dipole_int_AO,dipole_int,PHF,cHF,eHF) + +! --- + +subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevGTeh, doqsGTeh, & + maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, & + doppBSE, TDA_T, TDA, dBSE, dTDA, singlet, triplet, linearize, eta, regularize, & + nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, & + V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! T-matrix module @@ -44,7 +48,7 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -52,18 +56,18 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(in) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables @@ -78,11 +82,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do call wall_time(start_GT) call RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF) + linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0T0pp = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for G0T0pp = ',t_GT,' seconds' write(*,*) end if @@ -95,11 +99,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do call wall_time(start_GT) call evRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet, & - linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF) + linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGTpp = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for evGTpp = ',t_GT,' seconds' write(*,*) end if @@ -111,13 +115,13 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do if(doqsGTpp) then call wall_time(start_GT) - call qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet, & - eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int, & - PHF,cHF,eHF) + call qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, TDA_T, TDA, dBSE, & + dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, & + nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGTpp = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGTpp = ',t_GT,' seconds' write(*,*) end if @@ -129,11 +133,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do if(doufG0T0pp) then call wall_time(start_GT) - call ufG0T0pp(dotest,TDA_T,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) + call ufG0T0pp(dotest,TDA_T,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufG0T0pp = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufG0T0pp = ',t_GT,' seconds' write(*,*) end if @@ -146,11 +150,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do call wall_time(start_GT) call RG0T0eh(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF) + linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0T0eh = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for G0T0eh = ',t_GT,' seconds' write(*,*) end if @@ -163,11 +167,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do call wall_time(start_GT) call evRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,doppBSE, & - singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF) + singlet,triplet,linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGTeh = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for evGTeh = ',t_GT,' seconds' write(*,*) end if @@ -179,13 +183,14 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do if(doqsGTeh) then call wall_time(start_GT) - call qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,singlet,triplet, & - eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int, & - PHF,cHF,eHF) + call qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, & + dophBSE2, TDA_T, TDA, dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, & + ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, & + Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GT) t_GT = end_GT - start_GT - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGTeh = ',t_GT,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGTeh = ',t_GT,' seconds' write(*,*) end if diff --git a/src/GT/print_qsRGTeh.f90 b/src/GT/print_qsRGTeh.f90 index 9f8f266..72ffe99 100644 --- a/src/GT/print_qsRGTeh.f90 +++ b/src/GT/print_qsRGTeh.f90 @@ -1,4 +1,8 @@ -subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole) + +! --- + +subroutine print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, & + Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole) ! Print one-electron energies and other stuff for qsGTeh @@ -7,7 +11,7 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc @@ -19,11 +23,11 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ double precision,intent(in) :: EcRPA(nspin) double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: eGT(nBas) - double precision,intent(in) :: c(nBas) - double precision,intent(in) :: SigC(nBas,nBas) - double precision,intent(in) :: Z(nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: eGT(nBas_MOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) + double precision,intent(in) :: Z(nBas_MOs) double precision,intent(in) :: EqsGT double precision,intent(in) :: dipole(ncart) @@ -58,7 +62,7 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ '|','#','|','e_HF (eV)','|','Sig_GTeh (eV)','|','Z','|','e_GTeh (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do p=1,nBas + do p=1,nBas_MOs 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)') & '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGT(p)*HaToeV,'|' end do @@ -109,13 +113,13 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTeh MO coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas,nBas,c) + call matout(nBas_AOs, nBas_MOs, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTeh MO energies' write(*,'(A50)') '---------------------------------------' - call vecout(nBas,eGT) + call vecout(nBas_MOs, eGT) write(*,*) end if diff --git a/src/GT/print_qsRGTpp.f90 b/src/GT/print_qsRGTpp.f90 index c3bebfa..9d1479d 100644 --- a/src/GT/print_qsRGTpp.f90 +++ b/src/GT/print_qsRGTpp.f90 @@ -1,4 +1,8 @@ -subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole) + +! --- + +subroutine print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, Z, & + ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole) ! Print one-electron energies and other stuff for qsGT @@ -7,7 +11,7 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ ! Input variables - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc @@ -19,11 +23,11 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ double precision,intent(in) :: EcRPA(nspin) double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: eGT(nBas) - double precision,intent(in) :: c(nBas) - double precision,intent(in) :: SigC(nBas,nBas) - double precision,intent(in) :: Z(nBas) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: eGT(nBas_MOs) + double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) + double precision,intent(in) :: Z(nBas_MOs) double precision,intent(in) :: EqsGT double precision,intent(in) :: dipole(ncart) @@ -58,7 +62,7 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ '|','#','|','e_HF (eV)','|','Sig_GTpp (eV)','|','Z','|','e_GTpp (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do p=1,nBas + do p=1,nBas_MOs 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)') & '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGT(p)*HaToeV,'|' end do @@ -109,13 +113,13 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTpp MO coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas,nBas,c) + call matout(nBas_AOs, nBas_MOs, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTpp MO energies' write(*,'(A50)') '---------------------------------------' - call vecout(nBas,eGT) + call vecout(nBas_MOs, eGT) write(*,*) end if diff --git a/src/GT/qsRGTeh.f90 b/src/GT/qsRGTeh.f90 index 889e752..e608d9a 100644 --- a/src/GT/qsRGTeh.f90 +++ b/src/GT/qsRGTeh.f90 @@ -1,6 +1,10 @@ -subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA, & - dBSE,dTDA,singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, & - S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + +! --- + +subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, & + dophBSE2, TDA_T, TDA, dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, & + ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, & + Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GTeh calculation @@ -33,31 +37,31 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas + integer,intent(in) :: nBas_AOs, nBas_MOs integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: dipole_int_MO(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables logical :: dRPA = .false. integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: ispin integer :: n_diis double precision :: ET @@ -113,7 +117,7 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Stuff - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! TDA for T @@ -131,9 +135,29 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Memory allocation - allocate(Aph(nS,nS),Bph(nS,nS),eGT(nBas),eOld(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & - J(nBas,nBas),K(nBas,nBas),Sig(nBas,nBas),Sigp(nBas,nBas),Z(nBas),Om(nS),XpY(nS,nS),XmY(nS,nS), & - rhoL(nBas,nBas,nS),rhoR(nBas,nBas,nS),err(nBas,nBas),err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(Aph(nS,nS), Bph(nS,nS), Om(nS), XpY(nS,nS), XmY(nS,nS)) + + allocate(eGT(nBas_MOs)) + allocate(eOld(nBas_MOs)) + allocate(Z(nBas_MOs)) + + allocate(c(nBas_AOs,nBas_MOs)) + + allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(Sig(nBas_MOs,nBas_MOs)) + + allocate(P(nBas_AOs,nBas_AOs)) + allocate(F(nBas_AOs,nBas_AOs)) + allocate(J(nBas_AOs,nBas_AOs)) + allocate(K(nBas_AOs,nBas_AOs)) + allocate(Sigp(nBas_AOs,nBas_AOs)) + allocate(err(nBas_AOs,nBas_AOs)) + + allocate(err_diis(nBas_AOs_Sq,max_diis), F_diis(nBas_AOs_Sq,max_diis)) + + allocate(rhoL(nBas_MOs,nBas_MOs,nS), rhoR(nBas_MOs,nBas_MOs,nS)) + ! Initialization @@ -161,20 +185,20 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Buid Hartree matrix - call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas_AOs,P,ERI_AO,J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas_AOs,P,ERI_AO,K) ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! Compute linear response - call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGT,ERI_MO,Aph) - if(.not.TDA_T) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,eGT,ERI_MO,Aph) + if(.not.TDA_T) call phLR_B(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) call phLR(TDA_T,nS,Aph,Bph,EcRPA,Om,XpY,XmY) @@ -182,17 +206,17 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Compute correlation part of the self-energy - call GTeh_excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY,XmY,rhoL,rhoR) + call GTeh_excitation_density(nBas_MOs,nC,nO,nR,nS,ERI_MO,XpY,XmY,rhoL,rhoR) - if(regularize) call GTeh_regularization(nBas,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR) + if(regularize) call GTeh_regularization(nBas_MOs,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR) - call GTeh_self_energy(eta,nBas,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR,EcGM,Sig,Z) + call GTeh_self_energy(eta,nBas_MOs,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR,EcGM,Sig,Z) ! Make correlation self-energy Hermitian and transform it back to AO basis Sig = 0.5d0*(Sig + transpose(Sig)) - call MOtoAO(nBas,nBas,S,c,Sig,Sigp) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, Sig, Sigp) ! Solve the quasi-particle equation @@ -207,7 +231,7 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,F) + call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,err_diis,F_diis,err,F) end if @@ -215,9 +239,8 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d Fp = matmul(transpose(X),matmul(F,X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eGT) + call diagonalize_matrix(nBas_MOs, cp, eGT) c = matmul(X,cp) - Sigp = matmul(transpose(c),matmul(Sigp,c)) ! Compute new density matrix in the AO basis @@ -234,19 +257,19 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Kinetic energy - ET = trace_matrix(nBas,matmul(P,T)) + ET = trace_matrix(nBas_AOs,matmul(P,T)) ! Potential energy - EV = trace_matrix(nBas,matmul(P,V)) + EV = trace_matrix(nBas_AOs,matmul(P,V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas_AOs,matmul(P,J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas_AOs,matmul(P,K)) ! Total energy @@ -254,8 +277,9 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Print results - call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,Sigp,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole) + call dipole_moment(nBas_AOs,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c, Sig, & + Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole) end do !------------------------------------------------------------------------ @@ -272,19 +296,21 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, Om, XpY, XmY, rhoL, rhoR, err, err_diis, F_diis) + stop end if ! Deallocate memory - deallocate(c,cp,P,F,Fp,J,K,Sig,Sigp,Z,Om,XpY,XmY,rhoL,rhoR,err,err_diis,F_diis) + deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, Om, XpY, XmY, rhoL, rhoR, err, err_diis, F_diis) ! Perform BSE calculation ! if(BSE) then -! call Bethe_Salpeter(BSE2,TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & +! call Bethe_Salpeter(BSE2,TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas_AOs,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & ! eGT,eGT,EcBSE) ! if(exchange_kernel) then @@ -319,7 +345,7 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! end if -! call ACFDT(exchange_kernel,doXBS,.true.,TDA_T,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcAC) +! call ACFDT(exchange_kernel,doXBS,.true.,TDA_T,TDA,BSE,singlet,triplet,eta,nBas_AOs,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcAC) ! write(*,*) ! write(*,*)'-------------------------------------------------------------------------------' diff --git a/src/GT/qsRGTpp.f90 b/src/GT/qsRGTpp.f90 index 9f4e78b..1f8e17e 100644 --- a/src/GT/qsRGTpp.f90 +++ b/src/GT/qsRGTpp.f90 @@ -1,6 +1,9 @@ -subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA, & - dBSE,dTDA,singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, & - S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + +! --- + +subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, TDA_T, TDA, & + dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, & + nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GT calculation @@ -31,25 +34,26 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas,nC,nO,nV,nR,nS + integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nC,nO,nV,nR,nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: cHF(nBas,nBas) - double precision,intent(in) :: PHF(nBas,nBas) - 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_AO(nBas,nBas,nBas,nBas) - double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) - double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) - double precision,intent(in) :: dipole_int_MO(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas_MOs) + double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas_AOs,nBas_AOs) + double precision,intent(in) :: T(nBas_AOs,nBas_AOs) + double precision,intent(in) :: V(nBas_AOs,nBas_AOs) + double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) + double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) + double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) ! Local variables integer :: nSCF - integer :: nBasSq + integer :: nBas_AOs_Sq integer :: ispin integer :: iblock integer :: n_diis @@ -119,7 +123,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Stuff - nBasSq = nBas*nBas + nBas_AOs_Sq = nBas_AOs*nBas_AOs ! TDA for T @@ -137,16 +141,30 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Memory allocation - allocate(eGT(nBas),eOld(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & - J(nBas,nBas),K(nBas,nBas),Sig(nBas,nBas),Sigp(nBas,nBas),Z(nBas), & - error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + allocate(eGT(nBas_MOs)) + allocate(eOld(nBas_MOs)) + allocate(Z(nBas_MOs)) - allocate(Om1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & - Om2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & - rho1s(nBas,nBas,nVVs),rho2s(nBas,nBas,nOOs), & - Om1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & - Om2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & - rho1t(nBas,nBas,nVVt),rho2t(nBas,nBas,nOOt)) + allocate(c(nBas_AOs,nBas_MOs)) + + allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Sig(nBas_MOs,nBas_MOs)) + + allocate(P(nBas_AOs,nBas_AOs)) + allocate(F(nBas_AOs,nBas_AOs)) + allocate(J(nBas_AOs,nBas_AOs)) + allocate(K(nBas_AOs,nBas_AOs)) + allocate(error(nBas_AOs,nBas_AOs)) + allocate(Sigp(nBas_AOs,nBas_AOs)) + + allocate(error_diis(nBas_AOs_Sq,max_diis)) + allocate(F_diis(nBas_AOs_Sq,max_diis)) + + allocate(Om1s(nVVs), X1s(nVVs,nVVs), Y1s(nOOs,nVVs), rho1s(nBas_MOs,nBas_MOs,nVVs)) + allocate(Om2s(nOOs), X2s(nVVs,nOOs), Y2s(nOOs,nOOs), rho2s(nBas_MOs,nBas_MOs,nOOs)) + allocate(Om1t(nVVt), X1t(nVVt,nVVt), Y1t(nOOt,nVVt), rho1t(nBas_MOs,nBas_MOs,nVVt)) + allocate(Om2t(nOOt), X2t(nVVt,nOOt), Y2t(nOOt,nOOt), rho2t(nBas_MOs,nBas_MOs,nOOt)) ! Initialization @@ -174,15 +192,15 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Buid Hartree matrix - call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas_AOs,P,ERI_AO,J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas_AOs,P,ERI_AO,K) ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas,nBas,c,ERI_AO,ERI_MO) + call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! Compute linear response @@ -191,9 +209,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs)) - if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp) - call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp) - call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp) + call ppLR_C(iblock,nBas_MOs,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp) + call ppLR_D(iblock,nBas_MOs,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp) + if(.not.TDA_T) call ppLR_B(iblock,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp) call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin)) @@ -204,9 +222,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) - if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp) - call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp) - call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp) + call ppLR_C(iblock,nBas_MOs,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp) + call ppLR_D(iblock,nBas_MOs,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp) + if(.not.TDA_T) call ppLR_B(iblock,nBas_MOs,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) @@ -217,25 +235,25 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Compute correlation part of the self-energy - iblock = 3 - call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI_MO,X1s,Y1s,rho1s,X2s,Y2s,rho2s) + iblock = 3 + call GTpp_excitation_density(iblock,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,ERI_MO,X1s,Y1s,rho1s,X2s,Y2s,rho2s) - iblock = 4 - call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI_MO,X1t,Y1t,rho1t,X2t,Y2t,rho2t) + iblock = 4 + call GTpp_excitation_density(iblock,nBas_MOs,nC,nO,nV,nR,nOOt,nVVt,ERI_MO,X1t,Y1t,rho1t,X2t,Y2t,rho2t) if(regularize) then - call GTpp_regularization(eta,nBas,nC,nO,nV,nR,nOOs,nVVs,eGT,Om1s,rho1s,Om2s,rho2s) - call GTpp_regularization(eta,nBas,nC,nO,nV,nR,nOOt,nVVt,eGT,Om1t,rho1t,Om2t,rho2t) + call GTpp_regularization(eta,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,eGT,Om1s,rho1s,Om2s,rho2s) + call GTpp_regularization(eta,nBas_MOs,nC,nO,nV,nR,nOOt,nVVt,eGT,Om1t,rho1t,Om2t,rho2t) end if - call GTpp_self_energy(eta,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eGT,Om1s,rho1s,Om2s,rho2s, & + call GTpp_self_energy(eta,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eGT,Om1s,rho1s,Om2s,rho2s, & Om1t,rho1t,Om2t,rho2t,EcGM,Sig,Z) ! Make correlation self-energy Hermitian and transform it back to AO basis Sig = 0.5d0*(Sig + transpose(Sig)) - call MOtoAO(nBas,nBas,S,c,Sig,Sigp) + call MOtoAO(nBas_AOs, nBas_MOs, S, c, Sig, Sigp) ! Solve the quasi-particle equation @@ -249,22 +267,21 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d n_diis = min(n_diis+1,max_diis) if(abs(rcond) > 1d-7) then - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,error_diis,F_diis,error,F) else n_diis = 0 end if ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X),matmul(F,X)) + Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas,cp,eGT) - c = matmul(X,cp) - Sigp = matmul(transpose(c),matmul(Sigp,c)) + call diagonalize_matrix(nBas_MOs, cp, eGT) + c = matmul(X, cp) ! Compute new density matrix in the AO basis - P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO))) ! Save quasiparticles energy for next cycle @@ -277,19 +294,19 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Kinetic energy - ET = trace_matrix(nBas,matmul(P,T)) + ET = trace_matrix(nBas_AOs,matmul(P,T)) ! Potential energy - EV = trace_matrix(nBas,matmul(P,V)) + EV = trace_matrix(nBas_AOs,matmul(P,V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas_AOs,matmul(P,J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas_AOs,matmul(P,K)) ! Total energy @@ -297,8 +314,10 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d ! Print results - call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,Sigp,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole) + call dipole_moment(nBas_AOs,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, & + eGT, c, Sig, Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, & + EqsGT, dipole) end do !------------------------------------------------------------------------ @@ -315,19 +334,24 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) + deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, error, error_diis, F_diis) + deallocate(Om1s, X1s, Y1s, rho1s) + deallocate(Om2s, X2s, Y2s, rho2s) + deallocate(Om1t, X1t, Y1t, rho1t) + deallocate(Om2t, X2t, Y2t, rho2t) stop end if ! Deallocate memory - deallocate(c,cp,P,F,Fp,J,K,Sig,Sigp,Z,error,error_diis,F_diis) + deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, error, error_diis, F_diis) ! Perform BSE calculation if(dophBSE) then - call GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + call GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas_MOs,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & Om1s,X1s,Y1s,Om2s,X2s,Y2s,rho1s,rho2s,Om1t,X1t,Y1t,Om2t,X2t,Y2t,rho1t,rho2t, & ERI_MO,dipole_int_MO,eGT,eGT,EcBSE) @@ -363,7 +387,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d end if - call GTpp_phACFDT(exchange_kernel,doXBS,.false.,TDA_T,TDA,dophBSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, & + call GTpp_phACFDT(exchange_kernel,doXBS,.false.,TDA_T,TDA,dophBSE,singlet,triplet,eta,nBas_MOs,nC,nO,nV,nR,nS, & nOOs,nVVs,nOOt,nVVt,Om1s,X1s,Y1s,Om2s,X2s,Y2s,rho1s,rho2s,Om1t,X1t,Y1t, & Om2t,X2t,Y2t,rho1t,rho2t,ERI_MO,eGT,eGT,EcBSE) @@ -391,4 +415,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d end if + deallocate(Om1s, X1s, Y1s, rho1s) + deallocate(Om2s, X2s, Y2s, rho2s) + deallocate(Om1t, X1t, Y1t, rho1t) + deallocate(Om2t, X2t, Y2t, rho2t) + end subroutine diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 5796562..db16eab 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -330,11 +330,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doGT) then call wall_time(start_GT) - ! TODO - call RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - maxSCF_GT,thresh_GT,max_diis_GT,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE, & - TDA_T,TDA,dBSE,dTDA,singlet,triplet,lin_GT,eta_GT,reg_GT,nNuc,ZNuc,rNuc,ENuc, & - nBas_AOs,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + call RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevGTeh, doqsGTeh, & + maxSCF_GT, thresh_GT, max_diis_GT, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, & + TDA_T, TDA, dBSE, dTDA, singlet, triplet, lin_GT, eta_GT, reg_GT, nNuc, ZNuc, rNuc, ENuc, & + nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, & + dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GT) t_GT = end_GT - start_GT From 0262e733536b20bafa1e8c4127ca003ff8b29c7e Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 09:45:30 +0200 Subject: [PATCH 31/46] saving (found BUG in RGWC) --- tests/bulk_set.py | 0 tests/create_database.py | 31 ++++------------ tests/equi_set.py | 0 tests/methods.test | 22 ++++++++++++ tests/swift_set.py | 76 ++++++++++++++++++++++++++++++++++++++++ 5 files changed, 105 insertions(+), 24 deletions(-) create mode 100644 tests/bulk_set.py create mode 100644 tests/equi_set.py create mode 100644 tests/methods.test create mode 100644 tests/swift_set.py diff --git a/tests/bulk_set.py b/tests/bulk_set.py new file mode 100644 index 0000000..e69de29 diff --git a/tests/create_database.py b/tests/create_database.py index 3a91252..224b9b3 100644 --- a/tests/create_database.py +++ b/tests/create_database.py @@ -1,42 +1,25 @@ import sqlite3 -from molecule import Molecule from molecule import save_molecules_to_json, load_molecules_from_json from molecule import create_database, add_molecule_to_db +from swift_set import swiftset -molecules = [ - Molecule( - name="H2O", - multiplicity=1, - geometry=[ - {"element": "O", "x": 0.000000, "y": 0.000000, "z": 0.117790}, - {"element": "H", "x": 0.000000, "y": 0.755453, "z": -0.471161}, - {"element": "H", "x": 0.000000, "y": -0.755453, "z": -0.471161} - ], - energies={ - "RHF": { - "cc-pvdz": -76.0267058009, - "cc-pvtz": -76.0570239304, - "cc-pvqz": -76.0646816616 - }, - } - ), -] - # Save molecules to JSON -save_molecules_to_json(molecules, 'molecules.json') +save_molecules_to_json(swiftset, 'swiftset.json') # Load molecules from JSON -loaded_molecules = load_molecules_from_json('molecules.json') +loaded_molecules = load_molecules_from_json('swiftset.json') print(loaded_molecules) # Create a database and add molecules -db_name = 'molecules.db' +db_name = 'swiftset.db' create_database(db_name) -for molecule in molecules: +for molecule in swiftset: add_molecule_to_db(db_name, molecule) + + diff --git a/tests/equi_set.py b/tests/equi_set.py new file mode 100644 index 0000000..e69de29 diff --git a/tests/methods.test b/tests/methods.test new file mode 100644 index 0000000..e315154 --- /dev/null +++ b/tests/methods.test @@ -0,0 +1,22 @@ +# RHF UHF GHF ROHF + T F F F +# MP2 MP3 + T T +# CCD pCCD DCD CCSD CCSD(T) + T T T T F +# drCCD rCCD crCCD lCCD + T T T T +# CIS CIS(D) CID CISD FCI + T F F F F +# phRPA phRPAx crRPA ppRPA + T T T T +# G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3 + T T F F F F +# G0W0 evGW qsGW SRG-qsGW ufG0W0 ufGW + T T F F F F +# G0T0pp evGTpp qsGTpp ufG0T0pp + T T F F +# G0T0eh evGTeh qsGTeh + F F F +# Rtest Utest Gtest + T F F diff --git a/tests/swift_set.py b/tests/swift_set.py new file mode 100644 index 0000000..5c846ce --- /dev/null +++ b/tests/swift_set.py @@ -0,0 +1,76 @@ + +from molecule import Molecule + + +He = Molecule( + name="He", + multiplicity=1, + geometry=[ + {"element": "He", "x": 0.0, "y": 0.0, "z": 0.0} + ], + properties={ + "6-31g": { + "RHF energy": -2.855160426884076, + "RHF HOMO energy": -0.914126628614305, + "RHF LUMO energy": 1.399859335225087, + "RHF dipole moment": 0.000000000000000, + "RMP2 correlation energy": -0.011200122910187, + "CCD correlation energy": -0.014985063408247, + "DCD correlation energy": -0.014985062907429, + "CCSD correlation energy": -0.015001711549550, + "drCCD correlation energy": -0.018845374502248, + "rCCD correlation energy": -0.016836324636164, + "crCCD correlation energy": 0.008524677369855, + "lCCD correlation energy": -0.008082420815100, + "pCCD correlation energy": -0.014985062519068, + "RCIS singlet excitation energy": 1.911193619935257, + "RCIS triplet excitation energy": 1.455852629402236, + "phRRPA correlation energy": -0.018845374129105, + "phRRPAx correlation energy": -0.015760565121283, + "crRRPA correlation energy": -0.008868581132405, + "ppRRPA correlation energy": -0.008082420815100, + "RG0F2 correlation energy": -0.011438430540374, + "RG0F2 HOMO energy": -0.882696116247871, + "RG0F2 LUMO energy": 1.383080391811630, + "evRGF2 correlation energy": -0.011448483158486, + "evRGF2 HOMO energy": -0.881327878713477, + "evRGF2 LUMO energy": 1.382458968133448, + "RG0W0 correlation energy": -0.019314094399756, + "RG0W0 HOMO energy": -0.870533880190454, + "RG0W0 LUMO energy": 1.377171287010956, + "evRGW correlation energy": -0.019335511771724, + "evRGW HOMO energy": -0.868460640957913, + "evRGW LUMO energy": 1.376287581471769, + "RG0T0pp correlation energy": -0.008082420815100, + "RG0T0pp HOMO energy": -0.914126628614305, + "RG0T0pp LUMO energy": 1.399859335225087, + "evRGTpp correlation energy": -0.008082420815100, + "evRGTpp HOMO energy": -0.914126628614305, + "evRGTpp LUMO energy": 1.399859335225087 + } + } +) + +# --- + +H2O = Molecule( + name="H2O", + multiplicity=1, + geometry=[ + {"element": "O", "x": 0.0000, "y": 0.0000, "z": 0.0000}, + {"element": "H", "x": 0.7571, "y": 0.0000, "z": 0.5861}, + {"element": "H", "x": -0.7571, "y": 0.0000, "z": 0.5861} + ], + properties={ + "cc-pvdz": { + } +) + +# --- + +SwiftSet = [He, H2O] + + + + + From 0b28512edcf8eb7d71abf88d335c2b7b64ffe91a Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 14:05:21 +0200 Subject: [PATCH 32/46] fixed small bugs --- src/GT/GTpp_excitation_density.f90 | 470 +++++++++++++++-------------- src/GW/evRGW.f90 | 4 +- 2 files changed, 239 insertions(+), 235 deletions(-) diff --git a/src/GT/GTpp_excitation_density.f90 b/src/GT/GTpp_excitation_density.f90 index 05f9c2d..6bfe164 100644 --- a/src/GT/GTpp_excitation_density.f90 +++ b/src/GT/GTpp_excitation_density.f90 @@ -135,131 +135,132 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 dim_1 = (nBas - nO) * (nBas - nO - 1) / 2 dim_2 = nO * (nO - 1) / 2 - allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) - ERI_1 = 0.d0 - ERI_2 = 0.d0 + if((dim_1 .eq. 0) .or. (dim_2 .eq. 0)) then - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & - !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) - !$OMP DO COLLAPSE(2) - do q = nC+1, nBas-nR - do p = nC+1, nBas-nR - cd = 0 - do c = nO+1, nBas-nR - do d = c+1, nBas-nR - cd = cd + 1 - ERI_1(p,q,cd) = ERI(p,q,c,d) - ERI(p,q,d,c) - enddo - enddo - kl = 0 - do k = nC+1, nO - do l = k+1, nO - kl = kl + 1 - ERI_2(p,q,kl) = ERI(p,q,k,l) - ERI(p,q,l,k) - end do - end do - enddo - enddo + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) + do q = nC+1, nBas-nR + do p = nC+1, nBas-nR + + ab = 0 + + do a = nO+1, nBas-nR + do b = a+1, nBas-nR + + ab = ab + 1 + + cd = 0 + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + + cd = cd + 1 + + rho1(p,q,ab) = rho1(p,q,ab) & + + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) + end do ! d + end do ! c + + kl = 0 + do k = nC+1, nO + do l = k+1, nO + + kl = kl + 1 + + rho1(p,q,ab) = rho1(p,q,ab) & + + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) + end do ! l + end do ! k + end do ! b + end do ! a + + ij = 0 + do i = nC+1, nO + do j = i+1, nO + + ij = ij + 1 + + cd = 0 + + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + + cd = cd + 1 + + rho2(p,q,ij) = rho2(p,q,ij) & + + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) + end do ! d + end do ! c + + kl = 0 + do k = nC+1, nO + do l = k+1, nO + + kl = kl + 1 + + rho2(p,q,ij) = rho2(p,q,ij) & + + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) + end do ! l + end do ! k + end do ! j + end do ! i + end do ! p + end do ! q !$OMP END DO !$OMP END PARALLEL - call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & - ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & - 0.d0, rho1(1,1,1), nBas*nBas) + else - call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & - ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & - 1.d0, rho1(1,1,1), nBas*nBas) + allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) + ERI_1 = 0.d0 + ERI_2 = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) + !$OMP DO COLLAPSE(2) + do q = nC+1, nBas-nR + do p = nC+1, nBas-nR + cd = 0 + do c = nO+1, nBas-nR + do d = c+1, nBas-nR + cd = cd + 1 + ERI_1(p,q,cd) = ERI(p,q,c,d) - ERI(p,q,d,c) + enddo + enddo + kl = 0 + do k = nC+1, nO + do l = k+1, nO + kl = kl + 1 + ERI_2(p,q,kl) = ERI(p,q,k,l) - ERI(p,q,l,k) + end do + end do + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & + 0.d0, rho1(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & + 1.d0, rho1(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & + 0.d0, rho2(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & + 1.d0, rho2(1,1,1), nBas*nBas) + + deallocate(ERI_1, ERI_2) - call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & - ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & - 0.d0, rho2(1,1,1), nBas*nBas) - - call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & - ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & - 1.d0, rho2(1,1,1), nBas*nBas) - - deallocate(ERI_1, ERI_2) - - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & -! !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) -! !$OMP DO COLLAPSE(2) -! do q = nC+1, nBas-nR -! do p = nC+1, nBas-nR -! -! ab = 0 -! -! do a = nO+1, nBas-nR -! do b = a+1, nBas-nR -! -! ab = ab + 1 -! -! cd = 0 -! do c = nO+1, nBas-nR -! do d = c+1, nBas-nR -! -! cd = cd + 1 -! -! rho1(p,q,ab) = rho1(p,q,ab) & -! + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) -! end do ! d -! end do ! c -! -! kl = 0 -! do k = nC+1, nO -! do l = k+1, nO -! -! kl = kl + 1 -! -! rho1(p,q,ab) = rho1(p,q,ab) & -! + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) -! end do ! l -! end do ! k -! -! end do ! b -! end do ! a -! -! ij = 0 -! do i = nC+1, nO -! do j = i+1, nO -! -! ij = ij + 1 -! -! cd = 0 -! -! do c = nO+1, nBas-nR -! do d = c+1, nBas-nR -! -! cd = cd + 1 -! -! rho2(p,q,ij) = rho2(p,q,ij) & -! + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) -! end do ! d -! end do ! c -! -! kl = 0 -! do k = nC+1, nO -! do l = k+1, nO -! -! kl = kl + 1 -! -! rho2(p,q,ij) = rho2(p,q,ij) & -! + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) -! end do ! l -! end do ! k -! -! end do ! j -! end do ! i -! -! end do ! p -! end do ! q -! !$OMP END DO -! !$OMP END PARALLEL - - end if + endif + endif !---------------------------------------------- ! alpha-beta block @@ -270,125 +271,126 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1 dim_1 = (nBas - nO) * (nBas - nO) dim_2 = nO * nO - allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) - ERI_1 = 0.d0 - ERI_2 = 0.d0 + if((dim_1 .eq. 0) .or. (dim_2 .eq. 0)) then - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & - !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) - !$OMP DO COLLAPSE(2) - do q = nC+1, nBas-nR - do p = nC+1, nBas-nR - cd = 0 - do c = nO+1, nBas-nR - do d = nO+1, nBas-nR - cd = cd + 1 - ERI_1(p,q,cd) = ERI(p,q,c,d) - enddo - enddo - kl = 0 - do k = nC+1, nO - do l = nC+1, nO - kl = kl + 1 - ERI_2(p,q,kl) = ERI(p,q,k,l) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) + + do q = nC+1, nBas-nR + do p = nC+1, nBas-nR + + ab = 0 + do a = nO+1, nBas-nR + do b = nO+1, nBas-nR + + ab = ab + 1 + + cd = 0 + do c = nO+1, nBas-nR + do d = nO+1, nBas-nR + + cd = cd + 1 + + rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) + end do + end do + + kl = 0 + do k = nC+1, nO + do l = nC+1, nO + + kl = kl + 1 + + rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) + end do + end do + end do + end do + + ij = 0 + do i = nC+1, nO + do j = nC+1, nO + + ij = ij + 1 + + cd = 0 + do c = nO+1, nBas-nR + do d = nO+1, nBas-nR + + cd = cd + 1 + + rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) + end do + end do + + kl = 0 + do k = nC+1, nO + do l = nC+1, nO + + kl = kl + 1 + + rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) + end do + end do + end do end do end do + end do + !$OMP END DO + !$OMP END PARALLEL + + else + + allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2)) + ERI_1 = 0.d0 + ERI_2 = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, c, d, cd, k, l, kl) & + !$OMP SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI) + !$OMP DO COLLAPSE(2) + do q = nC+1, nBas-nR + do p = nC+1, nBas-nR + cd = 0 + do c = nO+1, nBas-nR + do d = nO+1, nBas-nR + cd = cd + 1 + ERI_1(p,q,cd) = ERI(p,q,c,d) + enddo + enddo + kl = 0 + do k = nC+1, nO + do l = nC+1, nO + kl = kl + 1 + ERI_2(p,q,kl) = ERI(p,q,k,l) + end do + end do + enddo enddo - enddo - !$OMP END DO - !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL + + call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & + 0.d0, rho1(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & + 1.d0, rho1(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & + ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & + 0.d0, rho2(1,1,1), nBas*nBas) + + call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & + ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & + 1.d0, rho2(1,1,1), nBas*nBas) + + deallocate(ERI_1, ERI_2) - call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, & - ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, & - 0.d0, rho1(1,1,1), nBas*nBas) - - call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, & - ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, & - 1.d0, rho1(1,1,1), nBas*nBas) - - call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, & - ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, & - 0.d0, rho2(1,1,1), nBas*nBas) - - call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, & - ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, & - 1.d0, rho2(1,1,1), nBas*nBas) - - deallocate(ERI_1, ERI_2) - - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & -! !$OMP SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2) -! !$OMP DO COLLAPSE(2) -! -! do q = nC+1, nBas-nR -! do p = nC+1, nBas-nR -! -! ab = 0 -! do a = nO+1, nBas-nR -! do b = nO+1, nBas-nR -! -! ab = ab + 1 -! -! cd = 0 -! do c = nO+1, nBas-nR -! do d = nO+1, nBas-nR -! -! cd = cd + 1 -! -! rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) -! end do -! end do -! -! kl = 0 -! do k = nC+1, nO -! do l = nC+1, nO -! -! kl = kl + 1 -! -! rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) -! end do -! end do -! -! end do -! end do -! -! ij = 0 -! do i = nC+1, nO -! do j = nC+1, nO -! -! ij = ij + 1 -! -! cd = 0 -! do c = nO+1, nBas-nR -! do d = nO+1, nBas-nR -! -! cd = cd + 1 -! -! rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) -! end do -! end do -! -! kl = 0 -! do k = nC+1, nO -! do l = nC+1, nO -! -! kl = kl + 1 -! -! rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) -! end do -! end do -! -! end do -! end do -! -! end do -! end do -! !$OMP END DO -! !$OMP END PARALLEL - - end if + endif + endif end subroutine diff --git a/src/GW/evRGW.f90 b/src/GW/evRGW.f90 index ee92faf..acd44d3 100644 --- a/src/GW/evRGW.f90 +++ b/src/GW/evRGW.f90 @@ -209,7 +209,9 @@ subroutine evRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop ! Cumulant expansion ! !--------------------! - call RGWC(dotest,nBas,nC,nO,nR,nS,Om,rho,eGW,Z) + ! TODO + !call RGWC(dotest, eta, nBas, nC, nO, nV, nR, nS, Om, rho, eHF, eGW, eGW, Z) + call RGWC(dotest, eta, nBas, nC, nO, nV, nR, nS, Om, rho, eHF, eHF, eGW, Z) ! Deallocate memory From 8d7fb2a29255637fb824c691422c0c1436ba0cd4 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 15:19:16 +0200 Subject: [PATCH 33/46] few modifs in QuAck tests --- src/test/check_test_value.f90 | 10 +++++----- src/test/dump_test_value.f90 | 17 +++++++++-------- src/test/init_test.f90 | 6 +++--- src/test/stop_test.f90 | 6 +++--- 4 files changed, 20 insertions(+), 19 deletions(-) diff --git a/src/test/check_test_value.f90 b/src/test/check_test_value.f90 index 2ee9bde..8828f82 100755 --- a/src/test/check_test_value.f90 +++ b/src/test/check_test_value.f90 @@ -9,12 +9,12 @@ subroutine check_test_value(branch) ! Local variables character(len=30) :: description - double precision :: value + double precision :: val double precision :: reference character(len=15) :: answer logical :: failed - double precision,parameter :: cutoff = 1d-10 + double precision,parameter :: thresh = 1d-10 ! Output variables @@ -45,19 +45,19 @@ subroutine check_test_value(branch) do read(11,'(A30)',end=11) description - read(11,'(F20.15)',end=11) value + read(11,'(F20.15)',end=11) val read(12,*,end=12) read(12,'(F20.15)',end=12) reference - if(abs(value-reference) < cutoff) then + if(dabs(val-reference)/(1d-15+dabs(reference)) < thresh) then answer = '.......... :-)' else answer = '.......... :-( ' failed = .true. end if write(*,'(1X,A1,1X,A30,1X,A1,1X,3F15.10,1X,A1,1X,A15,1X,A1)') & - '|',description,'|',value,reference,abs(value-reference),'|',answer,'|' + '|',description,'|',val,reference,abs(val-reference),'|',answer,'|' end do diff --git a/src/test/dump_test_value.f90 b/src/test/dump_test_value.f90 index ea00afe..e903e28 100755 --- a/src/test/dump_test_value.f90 +++ b/src/test/dump_test_value.f90 @@ -1,4 +1,4 @@ -subroutine dump_test_value(branch,description,value) +subroutine dump_test_value(branch, description, val) implicit none @@ -7,7 +7,7 @@ subroutine dump_test_value(branch,description,value) character(len=1),intent(in) :: branch character(len=*),intent(in) :: description - double precision,intent(in) :: value + double precision,intent(in) :: val ! Local variables @@ -15,18 +15,19 @@ subroutine dump_test_value(branch,description,value) if(branch == 'R') then - write(11,*) trim(description) - write(11,'(F20.15)') value + !write(1231597, '(A, ": ", F20.15)') '"' // trim(description) // '"', val + write(1231597, *) trim(description) + write(1231597, '(F20.15)') val elseif(branch == 'U') then - write(12,*) trim(description) - write(12,'(F20.15)') value + write(1232584,*) trim(description) + write(1232584,'(F20.15)') val elseif(branch == 'G') then - write(13,*) trim(description) - write(13,'(F20.15)') value + write(1234181,*) trim(description) + write(1234181,'(F20.15)') val else diff --git a/src/test/init_test.f90 b/src/test/init_test.f90 index 602ba54..b5ef295 100755 --- a/src/test/init_test.f90 +++ b/src/test/init_test.f90 @@ -12,10 +12,10 @@ subroutine init_test(doRtest,doUtest,doGtest) ! Output variables - if(doRtest) open(unit=11,file='test/Rtest.dat') + if(doRtest) open(unit=1231597, file='test/Rtest.dat') - if(doUtest) open(unit=12,file='test/Utest.dat') + if(doUtest) open(unit=1232584, file='test/Utest.dat') - if(doGtest) open(unit=13,file='test/Gtest.dat') + if(doGtest) open(unit=1234181, file='test/Gtest.dat') end subroutine diff --git a/src/test/stop_test.f90 b/src/test/stop_test.f90 index d41e2b0..185cbc5 100755 --- a/src/test/stop_test.f90 +++ b/src/test/stop_test.f90 @@ -12,10 +12,10 @@ subroutine stop_test(doRtest,doUtest,doGtest) ! Output variables - if(doRtest) close(unit=11) + if(doRtest) close(unit=1231597) - if(doUtest) close(unit=12) + if(doUtest) close(unit=1231597) - if(doGtest) close(unit=13) + if(doGtest) close(unit=1234181) end subroutine From 9910e6e88924b6f788171dff1386b3132a5d6f1d Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 29 Aug 2024 19:21:25 +0200 Subject: [PATCH 34/46] working on pCCD --- src/CC/pCCD.f90 | 79 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 71 insertions(+), 8 deletions(-) diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index 4f8b67d..570a679 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -57,10 +57,13 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, double precision :: E1,E2 double precision,allocatable :: h(:,:) + double precision,allocatable :: c(:,:) double precision,allocatable :: grad(:) double precision,allocatable :: tmp(:,:,:,:) double precision,allocatable :: hess(:,:) - double precision,allocatable :: eig(:) + double precision,allocatable :: hessInv(:,:) + double precision,allocatable :: kappa(:,:) + double precision,allocatable :: ekappa(:,:) integer :: O,V,N integer :: n_diis @@ -126,6 +129,13 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, allocate(err_diis(O*V,max_diis),t2_diis(O*V,max_diis)) +!------------------------------------------------------------------------ +! Start orbital optimization +!------------------------------------------------------------------------ + + allocate(c(N,N)) + c(:,:) = cHF(:,:) + !------------------------------------------------------------------------ ! Compute t ampltiudes !------------------------------------------------------------------------ @@ -540,6 +550,13 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, write(*,*) 'Orbital gradient at the pCCD level:' call matout(N,N,grad) + write(*,*) + +! Convergence + + Conv = maxval(abs(grad)) + write(*,*) ' Convergence of orbtial gradient = ',Conv + write(*,*) ! Compute Hessian @@ -550,7 +567,6 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, do p=1,N do q=1,N - rs = 0 do r=1,N do s=1,N @@ -614,7 +630,8 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, rs = rs + 1 - hess(pq,rs) = tmp(p,q,r,s) - tmp(q,p,r,s) - tmp(p,q,s,r) + tmp(q,p,s,r) + hess(pq,rs) = tmp(p,r,q,s) - tmp(r,p,q,s) - tmp(p,r,s,q) + tmp(r,p,s,q) +! hess(pq,rs) = tmp(p,q,r,s) - tmp(q,p,r,s) - tmp(p,q,s,r) + tmp(q,p,s,r) end do end do @@ -624,13 +641,59 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, call matout(N**2,N**2,hess) - deallocate(tmp) +! allocate(eig(N**2)) - allocate(eig(N**2)) - - call diagonalize_matrix(N**2,hess,eig) +! call diagonalize_matrix(N**2,hess,eig) - call vecout(N**2,eig) +! call vecout(N**2,eig) + + allocate(hessInv(N**2,N**2)) + + call inverse_matrix(N**2,hess,hessInv) + + allocate(kappa(N,N),ekappa(N,N)) + + kappa(:,:) = 0d0 + + pq = 0 + do p=1,N + do q=1,N + + pq = pq + 1 + + rs = 0 + do r=1,N + do s=1,N + + rs = rs + 1 + + kappa(p,q) = kappa(p,q) + hessInv(pq,rs)*grad(rs) + + end do + end do + + end do + end do + + write(*,*) 'kappa' + call matout(N,N,kappa) + write(*,*) + + call matrix_exponential(N,kappa,ekappa) + + write(*,*) 'e^kappa' + call matout(N,N,ekappa) + write(*,*) + + write(*,*) 'Old orbitals' + call matout(N,N,c) + write(*,*) + + c = matmul(c,ekappa) + + write(*,*) 'Rotated orbitals' + call matout(N,N,c) + write(*,*) ! Testing zone From 9aebbe74f060bf6cb1f7e4866c37fe4b2f0e8db3 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 20:48:16 +0200 Subject: [PATCH 35/46] saving --- .gitignore | 3 + tests/.gitignore | 6 + tests/{bulk_set.py => balance_bench.py} | 0 tests/create_database.py | 10 +- tests/feather_bench.py | 93 +++++++++++ tests/{methods.test => inp/methods.RHF} | 0 tests/inp/options.RHF | 18 +++ tests/lunch_bench.py | 205 ++++++++++++++++++++++++ tests/molecule.py | 63 +++++--- tests/swift_set.py | 76 --------- tests/test_hf.py | 204 ----------------------- tests/{equi_set.py => titan_bench.py} | 0 tests/utils.py | 39 +++++ 13 files changed, 410 insertions(+), 307 deletions(-) create mode 100644 tests/.gitignore rename tests/{bulk_set.py => balance_bench.py} (100%) create mode 100644 tests/feather_bench.py rename tests/{methods.test => inp/methods.RHF} (100%) create mode 100644 tests/inp/options.RHF create mode 100644 tests/lunch_bench.py delete mode 100644 tests/swift_set.py delete mode 100644 tests/test_hf.py rename tests/{equi_set.py => titan_bench.py} (100%) create mode 100644 tests/utils.py diff --git a/.gitignore b/.gitignore index 288e294..899b091 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,5 @@ *.o *. +__pycache__ + +.ninja_deps diff --git a/tests/.gitignore b/tests/.gitignore new file mode 100644 index 0000000..89c22b8 --- /dev/null +++ b/tests/.gitignore @@ -0,0 +1,6 @@ + +FeatherBench.db +FeatherBench.json + +*.xyz + diff --git a/tests/bulk_set.py b/tests/balance_bench.py similarity index 100% rename from tests/bulk_set.py rename to tests/balance_bench.py diff --git a/tests/create_database.py b/tests/create_database.py index 224b9b3..55c5718 100644 --- a/tests/create_database.py +++ b/tests/create_database.py @@ -4,21 +4,21 @@ import sqlite3 from molecule import save_molecules_to_json, load_molecules_from_json from molecule import create_database, add_molecule_to_db -from swift_set import swiftset +from feather_bench import FeatherBench # Save molecules to JSON -save_molecules_to_json(swiftset, 'swiftset.json') +save_molecules_to_json(FeatherBench, 'FeatherBench.json') # Load molecules from JSON -loaded_molecules = load_molecules_from_json('swiftset.json') +loaded_molecules = load_molecules_from_json('FeatherBench.json') print(loaded_molecules) # Create a database and add molecules -db_name = 'swiftset.db' +db_name = 'FeatherBench.db' create_database(db_name) -for molecule in swiftset: +for molecule in FeatherBench: add_molecule_to_db(db_name, molecule) diff --git a/tests/feather_bench.py b/tests/feather_bench.py new file mode 100644 index 0000000..1cfd07e --- /dev/null +++ b/tests/feather_bench.py @@ -0,0 +1,93 @@ + +from molecule import Molecule + + +He = Molecule( + name="He", + multiplicity=1, + geometry=[ + {"element": "He", "x": 0.0, "y": 0.0, "z": 0.0} + ], + properties={ + "properties_rhf":{ + "6-31g": { + "RHF energy": -2.855160426884076, + "RHF HOMO energy": -0.914126628614305, + "RHF LUMO energy": 1.399859335225087, + "RHF dipole moment": 0.000000000000000, + "RMP2 correlation energy": -0.011200122910187, + "CCD correlation energy": -0.014985063408247, + "DCD correlation energy": -0.014985062907429, + "CCSD correlation energy": -0.015001711549550, + "drCCD correlation energy": -0.018845374502248, + "rCCD correlation energy": -0.016836324636164, + "crCCD correlation energy": 0.008524677369855, + "lCCD correlation energy": -0.008082420815100, + "pCCD correlation energy": -0.014985062519068, + "RCIS singlet excitation energy": 1.911193619935257, + "RCIS triplet excitation energy": 1.455852629402236, + "phRRPA correlation energy": -0.018845374129105, + "phRRPAx correlation energy": -0.015760565121283, + "crRRPA correlation energy": -0.008868581132405, + "ppRRPA correlation energy": -0.008082420815100, + "RG0F2 correlation energy": -0.011438430540374, + "RG0F2 HOMO energy": -0.882696116247871, + "RG0F2 LUMO energy": 1.383080391811630, + "evRGF2 correlation energy": -0.011448483158486, + "evRGF2 HOMO energy": -0.881327878713477, + "evRGF2 LUMO energy": 1.382458968133448, + "RG0W0 correlation energy": -0.019314094399756, + "RG0W0 HOMO energy": -0.870533880190454, + "RG0W0 LUMO energy": 1.377171287010956, + "evRGW correlation energy": -0.019335511771724, + "evRGW HOMO energy": -0.868460640957913, + "evRGW LUMO energy": 1.376287581471769, + "RG0T0pp correlation energy": -0.008082420815100, + "RG0T0pp HOMO energy": -0.914126628614305, + "RG0T0pp LUMO energy": 1.399859335225087, + "evRGTpp correlation energy": -0.008082420815100, + "evRGTpp HOMO energy": -0.914126628614305, + "evRGTpp LUMO energy": 1.399859335225087 + } + }, + "properties_uhf":{ + "6-31g": { + } + }, + "properties_ghf":{ + "6-31g": { + } + }, + "properties_rohf":{ + "6-31g": { + } + } + } +) + +# --- + +#H2O = Molecule( +# name="H2O", +# multiplicity=1, +# geometry=[ +# {"element": "O", "x": 0.0000, "y": 0.0000, "z": 0.0000}, +# {"element": "H", "x": 0.7571, "y": 0.0000, "z": 0.5861}, +# {"element": "H", "x": -0.7571, "y": 0.0000, "z": 0.5861} +# ], +# properties={ +# "cc-pvdz": { +# } +#) + +# --- + +FeatherBench = [ + He, + #H2O +] + + + + + diff --git a/tests/methods.test b/tests/inp/methods.RHF similarity index 100% rename from tests/methods.test rename to tests/inp/methods.RHF diff --git a/tests/inp/options.RHF b/tests/inp/options.RHF new file mode 100644 index 0000000..92084cd --- /dev/null +++ b/tests/inp/options.RHF @@ -0,0 +1,18 @@ +# HF: maxSCF thresh DIIS guess mix shift stab search + 10000 0.0000001 5 1 0.0 0.0 F F +# MP: reg + F +# CC: maxSCF thresh DIIS + 64 0.0000001 5 +# spin: TDA singlet triplet + F T T +# GF: maxSCF thresh DIIS lin eta renorm reg + 256 0.00001 5 F 0.0 0 F +# GW: maxSCF thresh DIIS lin eta TDA_W reg + 256 0.00001 5 F 0.0 F F +# GT: maxSCF thresh DIIS lin eta TDA_T reg + 256 0.00001 5 F 0.0 F F +# ACFDT: AC Kx XBS + F F T +# BSE: phBSE phBSE2 ppBSE dBSE dTDA + F F F F T diff --git a/tests/lunch_bench.py b/tests/lunch_bench.py new file mode 100644 index 0000000..8f8bbba --- /dev/null +++ b/tests/lunch_bench.py @@ -0,0 +1,205 @@ + +import sys +import os +import shutil +from pathlib import Path +import subprocess +import platform +from datetime import datetime +import argparse + +from molecule import get_molecules_from_db +from molecule import generate_xyz +from utils import print_col + + +current_date = datetime.now() + +quack_root = os.getenv('QUACK_ROOT') + +# User Name +user_name = os.getlogin() + +# Operating System +os_name = platform.system() +os_release = platform.release() +os_version = platform.version() + +# CPU Information +machine = platform.machine() +processor = platform.processor() + +# System Architecture +architecture = platform.architecture()[0] + +# Python Version +python_version_full = platform.python_version_tuple() +PYTHON_VERSION = "{}.{}".format(python_version_full[0], python_version_full[1]) + + + +print(f"The current date and time is {current_date.strftime('%Y-%m-%d %H:%M:%S')}") +print(f"User Name: {user_name}") +print(f"Operating System: {os_name} {os_release} ({os_version})") +print(f"CPU: {processor} ({machine})") +print(f"System Architecture: {architecture}") +print(f"QUACK_ROOT: {quack_root}") +print(f"Python version: {python_version_full}\n\n") + + +parser = argparse.ArgumentParser(description="Benchmark Data Sets") + +parser.add_argument( + '-s', '--set_type', + choices=['light', 'medium', 'heavy'], + default='light', + help="Specify the type of data set: light (default), medium, or heavy." +) + +args = parser.parse_args() + +if args.set_type == 'light': + bench = 'FeatherBench' + bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench) +elif args.set_type == 'medium': + bench = 'BalanceBench' + bench_title = "\n\nSelected Medium Benchmark: {}\n\n".format(bench) +elif args.set_type == 'heavy': + bench = 'TitanBench' + bench_title = "\n\nSelected Heavy Benchmark: {}\n\n".format(bench) +else: + bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench) + +print(bench_title.center(150, '-')) +print("\n\n") + +# --- + +class Quack_Job: + + def __init__(self, mol, multip, basis, geom, methd): + self.mol = mol + self.multip = multip + self.basis = basis + self.geom = geom + self.methd = methd + + def prep_inp(self): + + # geometry + generate_xyz(self.geom, filename="{}.xyz".format(self.mol)) + + # input files + for inp in ["methods", "options"]: + inp_file = "{}.{}".format(inp, self.methd.upper()) + if os.path.exists("inp/{}".format(inp_file)): + shutil.copy("inp/{}".format(inp_file), "../mol/{}".format(inp_file)) + else: + print_col("File 'inp/{}' does not exist.".format(inp_file), "red") + sys.exit(1) + + def run(file_out, mol, bas, multip): + + os.chdir('..') + print(f" :$ cd ..") + + for file_in in ["methods", "options"]: + command = ['cp', 'tests/{}.RHF'.format(file_in), 'input/{}'.format(file_in)] + print(f" :$ {' '.join(command)}") + result = subprocess.run(command, capture_output=True, text=True) + if result.returncode != 0: + print("Error moving file: {}".format(result.stderr)) + + command = [ + 'python{}'.format(PYTHON_VERSION), 'PyDuck.py', + '-x', '{}'.format(mol), + '-b', '{}'.format(bas), + '-m', '{}'.format(multip) + ] + print(f" :$ {' '.join(command)}") + with open(file_out, 'w') as fobj: + result = subprocess.run(command, stdout=fobj, stderr=subprocess.PIPE, text=True) + if result.stderr: + print("Error output:", result.stderr) + + os.chdir('tests') + print(f" :$ cd tests") + + +# --- + + +def main(): + + work_path = Path('{}/tests/work'.format(quack_root)) + if not work_path.exists(): + work_path.mkdir(parents=True, exist_ok=True) + print(f"Directory '{work_path}' created.\n") + + for mol in molecules: + + mol_name = mol.name + mol_mult = mol.multiplicity + mol_geom = mol.geometry + mol_data = mol.properties + + print_col(" Molecule: {} (2S+1 = {})".format(mol_name, mol_mult), "blue") + + for mol_prop_name, mol_prop_data in mol_data.items(): + + print_col(" Testing {}".format(mol_prop_name), "cyan") + + methd = mol_prop_name[len('properties_'):] + + if(len(mol_prop_data) == 0): + print_col(" {} is empty. Skipping...".format(mol_prop_name), "cyan") + print() + continue + + for basis_name, basis_data in mol_prop_data.items(): + print_col(" Basis set = {}".format(basis_name), "yellow") + + if(len(basis_data) == 0): + print_col(" {} is empty. Skipping...".format(basis_name), "yellow") + print() + continue + + work_methd = Path('{}/{}'.format(work_path, methd)) + if not work_methd.exists(): + work_methd.mkdir(parents=True, exist_ok=True) + #print(f"Directory '{work_methd}' created.\n") + + New_Quack_Job = Quack_Job(mol_name, mol_mult, basis_name, mol_geom, methd) + New_Quack_Job.prep_inp() + +# for name, val in basis_data.items(): +# print(f" name = {name}") +# print(f" val = {val}") + + print() + print() + print() + + quit() + + +# # create input files +# class_methd.gen_input() +# +# file_out = "{}/{}/{}_{}_{}.out".format(work_path, prop, mol_name, mol_mult, bas) +# +# print(" testing {} for {}@{} (2S+1 = {})".format(prop, mol_name, bas, mol_mult)) +# print(" file_out: {}".format(file_out)) +# +# class_methd.run_job(file_out, mol_name, bas, mol_mult) + + + + + +db_name = '{}.db'.format(bench) + +molecules = get_molecules_from_db(db_name) + +main() + diff --git a/tests/molecule.py b/tests/molecule.py index 9d7b648..147c53e 100644 --- a/tests/molecule.py +++ b/tests/molecule.py @@ -3,22 +3,18 @@ import json import sqlite3 class Molecule: - def __init__(self, name, multiplicity, geometry, energies): + def __init__(self, name, multiplicity, geometry, properties): self.name = name self.multiplicity = multiplicity - self.geometry = geometry # List of tuples (atom, x, y, z) - self.energies = energies # Dictionary of dictionaries: {method: {basis: energy}} - - def get_energy(self, method, basis): - """Retrieve energy for a specific method and basis set.""" - return self.energies.get(method, {}).get(basis, None) + self.geometry = geometry + self.properties = properties def to_dict(self): return { "name": self.name, "multiplicity": self.multiplicity, "geometry": self.geometry, - "energies": self.energies, + "properties": self.properties, } @staticmethod @@ -27,7 +23,7 @@ class Molecule: name=data["name"], multiplicity=data["multiplicity"], geometry=data["geometry"], - energies=data["energies"] + properties=data["properties"] ) def save_molecules_to_json(molecules, filename): @@ -45,7 +41,7 @@ def create_database(db_name): conn = sqlite3.connect(db_name) cursor = conn.cursor() cursor.execute('''CREATE TABLE IF NOT EXISTS molecules - (name TEXT, multiplicity INTEGER, geometry TEXT, energies TEXT)''') + (name TEXT, multiplicity INTEGER, geometry TEXT, properties TEXT)''') conn.commit() conn.close() @@ -53,7 +49,7 @@ def add_molecule_to_db(db_name, molecule): conn = sqlite3.connect(db_name) cursor = conn.cursor() geometry_str = json.dumps(molecule.geometry) - energies_str = json.dumps(molecule.energies) + energies_str = json.dumps(molecule.properties) cursor.execute("INSERT INTO molecules VALUES (?, ?, ?, ?)", (molecule.name, molecule.multiplicity, geometry_str, energies_str)) conn.commit() @@ -62,25 +58,48 @@ def add_molecule_to_db(db_name, molecule): def get_molecules_from_db(db_name): conn = sqlite3.connect(db_name) cursor = conn.cursor() - cursor.execute("SELECT name, multiplicity, geometry, energies FROM molecules") + cursor.execute("SELECT name, multiplicity, geometry, properties FROM molecules") rows = cursor.fetchall() molecules = [] for row in rows: name, multiplicity, geometry_str, energies_str = row geometry = json.loads(geometry_str) - energies = json.loads(energies_str) # energies is a dictionary of dictionaries - molecules.append(Molecule(name, multiplicity, geometry, energies)) + properties = json.loads(energies_str) + molecules.append(Molecule(name, multiplicity, geometry, properties)) conn.close() return molecules -def write_geometry_to_xyz(molecule, filename): + +def generate_xyz(elements, filename="output.xyz", verbose=False): + """ + Generate an XYZ file from a list of elements. + + Parameters: + elements (list): A list of dictionaries, where each dictionary represents + an atom with its element and x, y, z coordinates. + filename (str): The name of the output XYZ file. Default is 'output.xyz'. + """ + + # Get the number of atoms + num_atoms = len(elements) + + # Open the file in write mode with open(filename, 'w') as f: - # First line: number of atoms - f.write(f"{len(molecule.geometry)}\n") - # Second line: empty comment line - f.write("\n") - # Remaining lines: atom positions - for atom, x, y, z in molecule.geometry: - f.write(f"{atom} {x:.6f} {y:.6f} {z:.6f}\n") + # Write the number of atoms + f.write(f"{num_atoms}\n") + + # Write a comment line (can be left blank or customized) + f.write("XYZ file generated by generate_xyz function\n") + + # Write the element and coordinates + for atom in elements: + element = atom['element'] + x = atom['x'] + y = atom['y'] + z = atom['z'] + f.write(f"{element} {x:.6f} {y:.6f} {z:.6f}\n") + + if(verbose): + print(f"XYZ file '{filename}' generated successfully!") diff --git a/tests/swift_set.py b/tests/swift_set.py deleted file mode 100644 index 5c846ce..0000000 --- a/tests/swift_set.py +++ /dev/null @@ -1,76 +0,0 @@ - -from molecule import Molecule - - -He = Molecule( - name="He", - multiplicity=1, - geometry=[ - {"element": "He", "x": 0.0, "y": 0.0, "z": 0.0} - ], - properties={ - "6-31g": { - "RHF energy": -2.855160426884076, - "RHF HOMO energy": -0.914126628614305, - "RHF LUMO energy": 1.399859335225087, - "RHF dipole moment": 0.000000000000000, - "RMP2 correlation energy": -0.011200122910187, - "CCD correlation energy": -0.014985063408247, - "DCD correlation energy": -0.014985062907429, - "CCSD correlation energy": -0.015001711549550, - "drCCD correlation energy": -0.018845374502248, - "rCCD correlation energy": -0.016836324636164, - "crCCD correlation energy": 0.008524677369855, - "lCCD correlation energy": -0.008082420815100, - "pCCD correlation energy": -0.014985062519068, - "RCIS singlet excitation energy": 1.911193619935257, - "RCIS triplet excitation energy": 1.455852629402236, - "phRRPA correlation energy": -0.018845374129105, - "phRRPAx correlation energy": -0.015760565121283, - "crRRPA correlation energy": -0.008868581132405, - "ppRRPA correlation energy": -0.008082420815100, - "RG0F2 correlation energy": -0.011438430540374, - "RG0F2 HOMO energy": -0.882696116247871, - "RG0F2 LUMO energy": 1.383080391811630, - "evRGF2 correlation energy": -0.011448483158486, - "evRGF2 HOMO energy": -0.881327878713477, - "evRGF2 LUMO energy": 1.382458968133448, - "RG0W0 correlation energy": -0.019314094399756, - "RG0W0 HOMO energy": -0.870533880190454, - "RG0W0 LUMO energy": 1.377171287010956, - "evRGW correlation energy": -0.019335511771724, - "evRGW HOMO energy": -0.868460640957913, - "evRGW LUMO energy": 1.376287581471769, - "RG0T0pp correlation energy": -0.008082420815100, - "RG0T0pp HOMO energy": -0.914126628614305, - "RG0T0pp LUMO energy": 1.399859335225087, - "evRGTpp correlation energy": -0.008082420815100, - "evRGTpp HOMO energy": -0.914126628614305, - "evRGTpp LUMO energy": 1.399859335225087 - } - } -) - -# --- - -H2O = Molecule( - name="H2O", - multiplicity=1, - geometry=[ - {"element": "O", "x": 0.0000, "y": 0.0000, "z": 0.0000}, - {"element": "H", "x": 0.7571, "y": 0.0000, "z": 0.5861}, - {"element": "H", "x": -0.7571, "y": 0.0000, "z": 0.5861} - ], - properties={ - "cc-pvdz": { - } -) - -# --- - -SwiftSet = [He, H2O] - - - - - diff --git a/tests/test_hf.py b/tests/test_hf.py deleted file mode 100644 index fd04121..0000000 --- a/tests/test_hf.py +++ /dev/null @@ -1,204 +0,0 @@ - -import os -from pathlib import Path -import subprocess -import platform -from datetime import datetime - -from molecule import get_molecules_from_db - - -current_date = datetime.now() - -quack_root = os.getenv('QUACK_ROOT') - -# User Name -user_name = os.getlogin() - -# Operating System -os_name = platform.system() -os_release = platform.release() -os_version = platform.version() - -# CPU Information -machine = platform.machine() -processor = platform.processor() - -# System Architecture -architecture = platform.architecture()[0] - -# Python Version -python_version_full = platform.python_version_tuple() -PYTHON_VERSION = "{}.{}".format(python_version_full[0], python_version_full[1]) - - -print(f"The current date and time is {current_date.strftime('%Y-%m-%d %H:%M:%S')}") -print(f"User Name: {user_name}") -print(f"Operating System: {os_name} {os_release} ({os_version})") -print(f"CPU: {processor} ({machine})") -print(f"System Architecture: {architecture}") -print(f"QUACK_ROOT: {quack_root}") -print(f"Python version: {python_version_full}\n\n") - -# --- - -mp2 = "# MP2 MP3\n F F\n" -cc = "# CCD pCCD DCD CCSD CCSD(T)\n F F F F F\n" -rcc = "# drCCD rCCD crCCD lCCD\n F F F F\n" -ci = "# CIS CIS(D) CID CISD FCI\n F F F F F\n" -rpa = "# phRPA phRPAx crRPA ppRPA\n F F F F\n" -gf = "# G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3\n F F F F F F\n" -gw = "# G0W0 evGW qsGW SRG-qsGW ufG0W0 ufGW\n F F F F F F\n" -gtpp = "# G0T0pp evGTpp qsGTpp ufG0T0pp\n F F F F\n" -gteh = "# G0T0eh evGTeh qsGTeh\n F F F\n" -tests = "# Rtest Utest Gtest\n F F F\n" - -# --- - -hf_opt = "# HF: maxSCF thresh DIIS guess mix shift stab search\n 256 0.00001 5 1 0.0 0.0 F F\n" -mp_opt = "# MP: reg\n F\n" -cc_opt = "# CC: maxSCF thresh DIIS\n 64 0.00001 5\n" -tda_opt = "# spin: TDA singlet triplet\n F T T\n" -gf_opt = "# GF: maxSCF thresh DIIS lin eta renorm reg\n 256 0.00001 5 F 0.0 0 F\n" -gw_opt = "# GW: maxSCF thresh DIIS lin eta TDA_W reg\n 256 0.00001 5 F 0.0 F F\n" -gt_opt = "# GT: maxSCF thresh DIIS lin eta TDA_T reg\n 256 0.00001 5 F 0.0 F F\n" -acfdt_opt = "# ACFDT: AC Kx XBS\n F F T\n" -bse_opt = "# BSE: phBSE phBSE2 ppBSE dBSE dTDA\n F F F F T\n" -list_opt = [hf_opt, mp_opt, cc_opt, tda_opt, gf_opt, gw_opt, gt_opt, acfdt_opt, bse_opt] - -# --- - -class class_RHF: - - def gen_input(): - - f = open("methods", "w") - f.write("# RHF UHF GHF ROHF\n") - f.write(" T F F F\n") - f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) - f.close() - - f = open("options", "w") - for opt in list_opt: - f.write("{}".format(opt)) - f.close() - - def run_job(file_out, mol, bas, multip): - - os.chdir('..') - print(f" :$ cd ..") - - for file_in in ["methods", "options"]: - command = ['cp', 'tests/{}'.format(file_in), 'input/{}'.format(file_in)] - print(f" :$ {' '.join(command)}") - result = subprocess.run(command, capture_output=True, text=True) - if result.returncode != 0: - print("Error moving file: {}".format(result.stderr)) - - command = [ - 'python{}'.format(PYTHON_VERSION), 'PyDuck.py', - '-x', '{}'.format(mol), - '-b', '{}'.format(bas), - '-m', '{}'.format(multip) - ] - print(f" :$ {' '.join(command)}") - with open(file_out, 'w') as fobj: - result = subprocess.run(command, stdout=fobj, stderr=subprocess.PIPE, text=True) - if result.stderr: - print("Error output:", result.stderr) - - os.chdir('tests') - print(f" :$ cd tests") - - -# --- - -class class_UHF: - def gen_input(): - f = open("methods", "w") - f.write("# RHF UHF GHF ROHF\n") - f.write(" F T F F\n") - f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) - f.close() - -# --- - -class class_GHF: - def gen_input(): - f = open("methods", "w") - f.write("# RHF UHF GHF ROHF\n") - f.write(" F F T F\n") - f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) - f.close() - -# --- - -class class_ROHF: - def gen_input(): - f = open("methods", "w") - f.write("# RHF UHF GHF ROHF\n") - f.write(" F F F T\n") - f.write("{}{}{}{}{}{}{}{}{}{}".format(mp2, cc, rcc, ci, rpa, gf, gw, gtpp, gteh, tests)) - f.close() - -# --- - -class_map = { - "RHF": class_RHF, - "UHF": class_UHF, - "GHF": class_GHF, - "ROHF": class_ROHF, -} - -def main(): - - work_path = Path('{}/tests/work'.format(quack_root)) - if not work_path.exists(): - work_path.mkdir(parents=True, exist_ok=True) - print(f"Directory '{work_path}' created.\n") - - for mol in molecules: - - mol_name = mol.name - mol_mult = mol.multiplicity - - - for methd in list_methd: - - if methd not in mol.energies: - print(f"Method {methd} does not exist for {mol_name}.") - continue - - for bas, _ in mol.energies[methd].items(): - - work_methd = Path('{}/{}'.format(work_path, methd)) - if not work_methd.exists(): - work_methd.mkdir(parents=True, exist_ok=True) - print(f"Directory '{work_methd}' created.\n") - - class_methd = class_map.get(methd) - - # create input files - class_methd.gen_input() - - file_out = "{}/{}/{}_{}_{}.out".format(work_path, methd, mol_name, mol_mult, bas) - - print(" testing {} for {}@{} (2S+1 = {})".format(methd, mol_name, bas, mol_mult)) - print(" file_out: {}".format(file_out)) - - class_methd.run_job(file_out, mol_name, bas, mol_mult) - - print("\n") - print("\n\n") - - print(" --- --- --- ---") - print("\n\n\n") - - -db_name = 'molecules.db' -molecules = get_molecules_from_db(db_name) - -list_methd = ["RHF", "UHF", "GHF", "ROHF"] - -main() - diff --git a/tests/equi_set.py b/tests/titan_bench.py similarity index 100% rename from tests/equi_set.py rename to tests/titan_bench.py diff --git a/tests/utils.py b/tests/utils.py new file mode 100644 index 0000000..297cb4c --- /dev/null +++ b/tests/utils.py @@ -0,0 +1,39 @@ + +def print_col(text, color): + + if(color == "black"): + + print("\033[30m{}\033[0m".format(text)) + + elif(color == "red"): + + print("\033[31m{}\033[0m".format(text)) + + elif(color == "green"): + + print("\033[32m{}\033[0m".format(text)) + + elif(color == "yellow"): + + print("\033[33m{}\033[0m".format(text)) + + elif(color == "blue"): + + print("\033[34m{}\033[0m".format(text)) + + elif(color == "magenta"): + + print("\033[35m{}\033[0m".format(text)) + + elif(color == "cyan"): + + print("\033[36m{}\033[0m".format(text)) + + elif(color == "white"): + + print("\033[37m{}\033[0m".format(text)) + + else: + + print("{}".format(text)) + From 76c797fa4a35e989f938fa303d9dd1b7c5b3a252 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Aug 2024 23:18:44 +0200 Subject: [PATCH 36/46] spinner simulation --- tests/.gitignore | 1 + tests/lunch_bench.py | 95 ++++++++++++++++++++++++-------------------- tests/utils.py | 49 +++++++++++++++++++++++ 3 files changed, 102 insertions(+), 43 deletions(-) diff --git a/tests/.gitignore b/tests/.gitignore index 89c22b8..afb251f 100644 --- a/tests/.gitignore +++ b/tests/.gitignore @@ -3,4 +3,5 @@ FeatherBench.db FeatherBench.json *.xyz +work diff --git a/tests/lunch_bench.py b/tests/lunch_bench.py index 8f8bbba..678a4fc 100644 --- a/tests/lunch_bench.py +++ b/tests/lunch_bench.py @@ -1,4 +1,6 @@ +import time +import threading import sys import os import shutil @@ -10,7 +12,7 @@ import argparse from molecule import get_molecules_from_db from molecule import generate_xyz -from utils import print_col +from utils import print_col, stdout_col current_date = datetime.now() @@ -98,34 +100,54 @@ class Quack_Job: print_col("File 'inp/{}' does not exist.".format(inp_file), "red") sys.exit(1) - def run(file_out, mol, bas, multip): + def run(self, work_path): - os.chdir('..') - print(f" :$ cd ..") + def display_spinner(): + spinner = ['|', '/', '-', '\\'] + idx = 0 + while not done_event.is_set(): + stdout_col(f'\r Testing {self.methd} ({self.basis}) {spinner[idx]}', "yellow") + sys.stdout.flush() + idx = (idx + 1) % len(spinner) + time.sleep(0.1) + stdout_col(f'\r Testing {self.methd} ({self.basis}) ', "yellow") - for file_in in ["methods", "options"]: - command = ['cp', 'tests/{}.RHF'.format(file_in), 'input/{}'.format(file_in)] - print(f" :$ {' '.join(command)}") - result = subprocess.run(command, capture_output=True, text=True) - if result.returncode != 0: - print("Error moving file: {}".format(result.stderr)) + done_event = threading.Event() + spinner_thread = threading.Thread(target=display_spinner) + spinner_thread.start() - command = [ - 'python{}'.format(PYTHON_VERSION), 'PyDuck.py', - '-x', '{}'.format(mol), - '-b', '{}'.format(bas), - '-m', '{}'.format(multip) - ] - print(f" :$ {' '.join(command)}") - with open(file_out, 'w') as fobj: - result = subprocess.run(command, stdout=fobj, stderr=subprocess.PIPE, text=True) - if result.stderr: - print("Error output:", result.stderr) + try: + + os.chdir('..') + #print_col(f" Starting QuAck..", "magenta") + #print_col(f" $ cd ..", "magenta") + + command = [ + 'python{}'.format(PYTHON_VERSION), 'PyDuck.py', + '-x', '{}'.format(self.mol), + '-b', '{}'.format(self.basis), + '-m', '{}'.format(self.multip) + ] + #print_col(f" $ {' '.join(command)}", "magenta") + + file_out = "{}/{}/{}_{}_{}.out".format(work_path, self.methd, self.mol, self.multip, self.basis) + with open(file_out, 'w') as fobj: + result = subprocess.run(command, stdout=fobj, stderr=subprocess.PIPE, text=True) + if result.stderr: + print("Error output:", result.stderr) + + os.chdir('tests') + #print_col(f" $ cd tests", "magenta") + + except Exception as e: - os.chdir('tests') - print(f" :$ cd tests") + print_col(f"An error occurred: {str(e)}", "red") + finally: + done_event.set() + spinner_thread.join() + # --- @@ -147,21 +169,21 @@ def main(): for mol_prop_name, mol_prop_data in mol_data.items(): - print_col(" Testing {}".format(mol_prop_name), "cyan") + #print_col(" Testing {}".format(mol_prop_name), "cyan") methd = mol_prop_name[len('properties_'):] if(len(mol_prop_data) == 0): - print_col(" {} is empty. Skipping...".format(mol_prop_name), "cyan") - print() + #print_col(" {} is empty. Skipping...".format(mol_prop_name), "cyan") + #print() continue for basis_name, basis_data in mol_prop_data.items(): - print_col(" Basis set = {}".format(basis_name), "yellow") + #print_col(" Basis set: {}".format(basis_name), "yellow") if(len(basis_data) == 0): - print_col(" {} is empty. Skipping...".format(basis_name), "yellow") - print() + #print_col(" {} is empty. Skipping...".format(basis_name), "yellow") + #print() continue work_methd = Path('{}/{}'.format(work_path, methd)) @@ -171,6 +193,7 @@ def main(): New_Quack_Job = Quack_Job(mol_name, mol_mult, basis_name, mol_geom, methd) New_Quack_Job.prep_inp() + New_Quack_Job.run(work_path) # for name, val in basis_data.items(): # print(f" name = {name}") @@ -183,20 +206,6 @@ def main(): quit() -# # create input files -# class_methd.gen_input() -# -# file_out = "{}/{}/{}_{}_{}.out".format(work_path, prop, mol_name, mol_mult, bas) -# -# print(" testing {} for {}@{} (2S+1 = {})".format(prop, mol_name, bas, mol_mult)) -# print(" file_out: {}".format(file_out)) -# -# class_methd.run_job(file_out, mol_name, bas, mol_mult) - - - - - db_name = '{}.db'.format(bench) molecules = get_molecules_from_db(db_name) diff --git a/tests/utils.py b/tests/utils.py index 297cb4c..a5f090f 100644 --- a/tests/utils.py +++ b/tests/utils.py @@ -1,4 +1,9 @@ +import sys + + + + def print_col(text, color): if(color == "black"): @@ -37,3 +42,47 @@ def print_col(text, color): print("{}".format(text)) + +# --- + +def stdout_col(text, color): + + if(color == "black"): + + sys.stdout.write("\033[30m{}\033[0m".format(text)) + + elif(color == "red"): + + sys.stdout.write("\033[31m{}\033[0m".format(text)) + + elif(color == "green"): + + sys.stdout.write("\033[32m{}\033[0m".format(text)) + + elif(color == "yellow"): + + sys.stdout.write("\033[33m{}\033[0m".format(text)) + + elif(color == "blue"): + + sys.stdout.write("\033[34m{}\033[0m".format(text)) + + elif(color == "magenta"): + + sys.stdout.write("\033[35m{}\033[0m".format(text)) + + elif(color == "cyan"): + + sys.stdout.write("\033[36m{}\033[0m".format(text)) + + elif(color == "white"): + + sys.stdout.write("\033[37m{}\033[0m".format(text)) + + else: + + sys.stdout.write("{}".format(text)) + +# --- + + From fadd1b39291511753bba04c78c486d54a9de168b Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Fri, 30 Aug 2024 00:10:19 +0200 Subject: [PATCH 37/46] added eval diff with ref --- tests/create_database.py | 6 ++-- tests/lunch_bench.py | 61 ++++++++++++++++++++++++++++++---------- 2 files changed, 49 insertions(+), 18 deletions(-) diff --git a/tests/create_database.py b/tests/create_database.py index 55c5718..59cdee2 100644 --- a/tests/create_database.py +++ b/tests/create_database.py @@ -9,11 +9,11 @@ from feather_bench import FeatherBench # Save molecules to JSON -save_molecules_to_json(FeatherBench, 'FeatherBench.json') +#save_molecules_to_json(FeatherBench, 'FeatherBench.json') # Load molecules from JSON -loaded_molecules = load_molecules_from_json('FeatherBench.json') -print(loaded_molecules) +#loaded_molecules = load_molecules_from_json('FeatherBench.json') +#print(loaded_molecules) # Create a database and add molecules db_name = 'FeatherBench.db' diff --git a/tests/lunch_bench.py b/tests/lunch_bench.py index 678a4fc..69a6093 100644 --- a/tests/lunch_bench.py +++ b/tests/lunch_bench.py @@ -57,9 +57,21 @@ parser.add_argument( default='light', help="Specify the type of data set: light (default), medium, or heavy." ) +parser.add_argument( + '-t', '--thresh', + type=float, + default=1e-8, + help='Threshold for acceptable difference (default: 1e-8)' +) + + + + args = parser.parse_args() +THRESH = args.thresh + if args.set_type == 'light': bench = 'FeatherBench' bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench) @@ -106,11 +118,11 @@ class Quack_Job: spinner = ['|', '/', '-', '\\'] idx = 0 while not done_event.is_set(): - stdout_col(f'\r Testing {self.methd} ({self.basis}) {spinner[idx]}', "yellow") + stdout_col(f'\r Testing {self.methd} ({self.basis}) {spinner[idx]}', "cyan") sys.stdout.flush() idx = (idx + 1) % len(spinner) - time.sleep(0.1) - stdout_col(f'\r Testing {self.methd} ({self.basis}) ', "yellow") + time.sleep(0.05) + stdout_col(f'\r Testing {self.methd} ({self.basis}) \n', "cyan") done_event = threading.Event() spinner_thread = threading.Thread(target=display_spinner) @@ -147,7 +159,37 @@ class Quack_Job: done_event.set() spinner_thread.join() + + def check_data(self, data_ref): + filepath = '../test/Rtest.dat' + data_new = {} + try: + # read data_new + with open(filepath, 'r') as f: + lines = f.readlines() + for i in range(0, len(lines) - 1, 2): + key = lines[i].strip() + value = lines[i + 1].strip() + data_new[key] = float(value) # Convert value to float + + # Compare with data_ref + for key in data_ref: + if key not in data_new: + print_col(f" 😐 {key} missing ⚠️ ", "yellow") + else: + diff = abs(data_new[key] - data_ref[key]) / (1e-15 + abs(data_ref[key])) + if(diff <= THRESH): + print_col(f" 🙂 {key}: ✔️ ", "green") + else: + print_col(f" ☹️ {key}: ❌ {data_ref[key]} ≠ {data_new[key]}", "red") + except FileNotFoundError: + print_col(f"Error: The file '{filepath}' does not exist.", "red") + sys.exist(1) + except Exception as e: + print_col(f"An error occurred: {str(e)}", "red") + sys.exist(1) + # --- @@ -169,35 +211,24 @@ def main(): for mol_prop_name, mol_prop_data in mol_data.items(): - #print_col(" Testing {}".format(mol_prop_name), "cyan") - methd = mol_prop_name[len('properties_'):] if(len(mol_prop_data) == 0): - #print_col(" {} is empty. Skipping...".format(mol_prop_name), "cyan") - #print() continue for basis_name, basis_data in mol_prop_data.items(): - #print_col(" Basis set: {}".format(basis_name), "yellow") if(len(basis_data) == 0): - #print_col(" {} is empty. Skipping...".format(basis_name), "yellow") - #print() continue work_methd = Path('{}/{}'.format(work_path, methd)) if not work_methd.exists(): work_methd.mkdir(parents=True, exist_ok=True) - #print(f"Directory '{work_methd}' created.\n") New_Quack_Job = Quack_Job(mol_name, mol_mult, basis_name, mol_geom, methd) New_Quack_Job.prep_inp() New_Quack_Job.run(work_path) - -# for name, val in basis_data.items(): -# print(f" name = {name}") -# print(f" val = {val}") + New_Quack_Job.check_data(basis_data) print() print() From 08bf6632dfbdd65f5aa18b9c1e8d67cf4d7d8049 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 30 Aug 2024 16:26:59 +0200 Subject: [PATCH 38/46] saving work in pCCD --- src/CC/RCC.f90 | 22 +- src/CC/pCCD.f90 | 1141 ++++++++++++++++++++++-------------------- src/QuAcK/RQuAcK.f90 | 2 +- 3 files changed, 603 insertions(+), 562 deletions(-) diff --git a/src/CC/RCC.f90 b/src/CC/RCC.f90 index 21f6866..aa8923b 100644 --- a/src/CC/RCC.f90 +++ b/src/CC/RCC.f90 @@ -1,5 +1,5 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) + maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI_AO,ERI_MO,ENuc,ERHF,eHF,cHF) ! Coupled-cluster module @@ -34,7 +34,8 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d double precision,intent(in) :: eHF(nBas) double precision,intent(in) :: cHF(nBas,nBas) double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) ! Local variables @@ -47,7 +48,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(doCCD) then call wall_time(start_CC) - call CCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call CCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -64,7 +65,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d call wall_time(start_CC) call DCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR, & - ERI,ENuc,ERHF,eHF) + ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -82,7 +83,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(doCCSD) then call wall_time(start_CC) - call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -98,7 +99,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dodrCCD) then call wall_time(start_CC) - call drCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call drCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -114,7 +115,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dorCCD) then call wall_time(start_CC) - call rCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call rCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -130,7 +131,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(docrCCD) then call wall_time(start_CC) - call crCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call crCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -146,7 +147,7 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dolCCD) then call wall_time(start_CC) - call lCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call lCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -162,7 +163,8 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d if(dopCCD) then call wall_time(start_CC) - call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) + call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI_AO,ENuc,ERHF,eHF,cHF) + call wall_time(end_CC) t_CC = end_CC - start_CC diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index 570a679..bcfd50b 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -1,4 +1,4 @@ -subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF,eHF,cHF) +subroutine pCCD(dotest,maxIt,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI_AO,ENuc,ERHF,eHF,cHF) ! pair CCD module @@ -8,25 +8,32 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, logical,intent(in) :: dotest - integer,intent(in) :: maxSCF + integer,intent(in) :: maxIt integer,intent(in) :: max_diis double precision,intent(in) :: thresh - integer,intent(in) :: nBas,nC,nO,nV,nR - double precision,intent(in) :: ENuc,ERHF + integer,intent(in) :: nBas + integer,intent(in) :: nC + integer,intent(in) :: nO + integer,intent(in) :: nV + integer,intent(in) :: nR + double precision,intent(in) :: ENuc + double precision,intent(in) :: ERHF double precision,intent(in) :: eHF(nBas) double precision,intent(in) :: cHF(nBas,nBas) double precision,intent(in) :: Hc(nBas,nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) ! Local variables - integer :: p,q,r,s,t,u + integer :: p,q,r,s,t,u,w integer :: pq,rs integer :: i,j,a,b - integer :: nSCF - double precision :: Conv + integer :: nItAmp + integer :: nItOrb + double precision :: CvgAmp + double precision :: CvgOrb double precision :: ECC double precision :: EcCC @@ -56,14 +63,15 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, double precision :: tr_2rdm double precision :: E1,E2 - double precision,allocatable :: h(:,:) double precision,allocatable :: c(:,:) + double precision,allocatable :: h(:,:) + double precision,allocatable :: ERI_MO(:,:,:,:) double precision,allocatable :: grad(:) double precision,allocatable :: tmp(:,:,:,:) double precision,allocatable :: hess(:,:) double precision,allocatable :: hessInv(:,:) - double precision,allocatable :: kappa(:,:) - double precision,allocatable :: ekappa(:,:) + double precision,allocatable :: Kap(:,:) + double precision,allocatable :: ExpKap(:,:) integer :: O,V,N integer :: n_diis @@ -77,9 +85,9 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, ! Hello world write(*,*) - write(*,*)'**************************************' - write(*,*)'| pair CCD calculation |' - write(*,*)'**************************************' + write(*,*)'*******************************' + write(*,*)'* Restricted pCCD Calculation *' + write(*,*)'*******************************' write(*,*) ! Useful quantities @@ -88,612 +96,643 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,Hc,ERI,ENuc,ERHF, V = nV - nR N = O + V -! Form energy denominator + !------------------------------------! + ! Star Loop for orbital optimization ! + !------------------------------------! + allocate(ERI_MO(N,N,N,N)) + allocate(c(N,N),h(N,N)) allocate(eO(O),eV(V),delta_OV(O,V)) - - eO(:) = eHF(nC+1:nO) - eV(:) = eHF(nO+1:nBas-nR) - - call form_delta_OV(nC,nO,nV,nR,eO,eV,delta_OV) - -! Create integral batches - allocate(OOOO(O,O),OOVV(O,V),OVOV(O,V),OVVO(O,V),VVVV(V,V)) - do i=1,O - do j=1,O - OOOO(i,j) = ERI(nC+i,nC+i,nC+j,nC+j) - end do - end do + c(:,:) = cHF(nC+1:nBas-nR,nC+1:nBas-nR) - do i=1,O - do a=1,V - OOVV(i,a) = ERI(nC+i,nC+i,nO+a,nO+a) - OVOV(i,a) = ERI(nC+i,nO+a,nC+i,nO+a) - OVVO(i,a) = ERI(nC+i,nO+a,nO+a,nC+i) - end do - end do + CvgOrb = 1d0 + nItOrb = 0 - do a=1,V - do b=1,V - VVVV(a,b) = ERI(nO+a,nO+a,nO+b,nO+b) - end do - end do - -! Initialization - - allocate(t2(O,V),r2(O,V),yO(O,O),yV(V,V)) - -! Memory allocation for DIIS - - allocate(err_diis(O*V,max_diis),t2_diis(O*V,max_diis)) - -!------------------------------------------------------------------------ -! Start orbital optimization -!------------------------------------------------------------------------ - - allocate(c(N,N)) - c(:,:) = cHF(:,:) - -!------------------------------------------------------------------------ -! Compute t ampltiudes -!------------------------------------------------------------------------ - - Conv = 1d0 - nSCF = 0 - ECC = ERHF - EcCC = 0d0 - - n_diis = 0 - t2(:,:) = 0d0 - t2_diis(:,:) = 0d0 - err_diis(:,:) = 0d0 - -!------------------------------------------------------------------------ -! Main SCF loop -!------------------------------------------------------------------------ write(*,*) write(*,*)'----------------------------------------------------' - write(*,*)'| pCCD calculation: t amplitudes |' - write(*,*)'----------------------------------------------------' - write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & - '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|' + write(*,*)'| Orbital Optimization for pCCD |' write(*,*)'----------------------------------------------------' - do while(Conv > thresh .and. nSCF < maxSCF) + do while(CvgOrb > thresh .and. nItOrb < 1) - ! Increment + nItOrb = nItOrb + 1 - nSCF = nSCF + 1 + ! Transform integrals - ! Form intermediate array - - yO(:,:) = matmul(t2,transpose(OOVV)) - - ! Compute residual + h = matmul(transpose(c),matmul(Hc(nC+1:nBas-nR,nC+1:nBas-nR),c)) + call AOtoMO_ERI_RHF(N,c,ERI_AO(nC+1:nBas-nR,nC+1:nBas-nR,nC+1:nBas-nR,nC+1:nBas-nR),ERI_MO) + ! Form energy denominator - r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*t2(:,:) & - - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - OOVV(:,:)*t2(:,:))*t2(:,:) + eO(:) = eHF(nC+1:nO) + eV(:) = eHF(nO+1:nBas-nR) do i=1,O do a=1,V - - do j=1,O - r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*t2(i,a) + OOOO(j,i)*t2(j,a) + yO(i,j)*t2(j,a) - end do - - do b=1,V - r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*t2(i,a) + VVVV(a,b)*t2(i,b) - end do - + delta_OV(i,a) = eV(a) - eO(i) end do end do - ! Check convergence - - Conv = maxval(abs(r2(:,:))) - - ! Update amplitudes - - t2(:,:) = t2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:) - - ! Compute correlation energy - - EcCC = trace_matrix(V,matmul(transpose(OOVV),t2)) - - ! Dump results - - ECC = ERHF + EcCC - - ! DIIS extrapolation - - if(max_diis > 1) then - - n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,err_diis,t2_diis,-0.5d0*r2/delta_OV,t2) - - end if - - write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & - '|',nSCF,'|',ECC+ENuc,'|',EcCC,'|',Conv,'|' - - end do - write(*,*)'----------------------------------------------------' -!------------------------------------------------------------------------ -! End of SCF loop -!------------------------------------------------------------------------ - -! Did it actually converge? - - if(nSCF == maxSCF) then - - write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' Convergence failed for t ampitudes ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - - stop - - end if - -! Deallocate memory - - deallocate(err_diis,t2_diis) - -! Memory allocation - - allocate(z2(O,V)) - -! Memory allocation for DIIS - - allocate(err_diis(O*V,max_diis),z2_diis(O*V,max_diis)) - -!------------------------------------------------------------------------ -! Compute z ampltiudes -!------------------------------------------------------------------------ - - Conv = 1d0 - nSCF = 0 - - n_diis = 0 - z2_diis(:,:) = 0d0 - err_diis(:,:) = 0d0 - -!------------------------------------------------------------------------ -! Main SCF loop -!------------------------------------------------------------------------ - write(*,*) - write(*,*)'----------------------------------------------------' - write(*,*)'| pCCD calculation: z amplitudes |' - write(*,*)'----------------------------------------------------' - write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & - '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|' - write(*,*)'----------------------------------------------------' - - do while(Conv > thresh .and. nSCF < maxSCF) - - ! Increment - - nSCF = nSCF + 1 - - ! Form intermediate array - - yO(:,:) = matmul(OOVV,transpose(t2)) - yV(:,:) = matmul(transpose(OOVV),t2) - - ! Compute residual - - r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*z2(:,:) & - - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - 2d0*OOVV(:,:)*t2(:,:))*z2(:,:) + ! Create integral batches + do i=1,O + do j=1,O + OOOO(i,j) = ERI_MO(i,i,j,j) + end do + end do + do i=1,O do a=1,V - - do j=1,O - r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*z2(i,a) - 2d0*OOVV(i,a)*z2(j,a)*t2(j,a) & - + OOOO(i,j)*z2(j,a) + yO(i,j)*z2(j,a) - end do - - do b=1,V - r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*z2(i,a) - 2d0*OOVV(i,a)*z2(i,b)*t2(i,b) & - + VVVV(b,a)*z2(i,b) + yV(a,b)*z2(i,b) - end do - + OOVV(i,a) = ERI_MO(i,i,O+a,O+a) + OVOV(i,a) = ERI_MO(i,O+a,i,O+a) + OVVO(i,a) = ERI_MO(i,O+a,O+a,i) + end do + end do + + do a=1,V + do b=1,V + VVVV(a,b) = ERI_MO(O+a,O+a,O+b,O+b) end do end do - ! Check convergence + !----------------------------! + ! Star Loop for t amplitudes ! + !----------------------------! + + allocate(t2(O,V),r2(O,V),yO(O,O)) + allocate(err_diis(O*V,max_diis),t2_diis(O*V,max_diis)) - Conv = maxval(abs(r2(:,:))) + CvgAmp = 1d0 + nItAmp = 0 + ECC = ERHF + EcCC = 0d0 + + n_diis = 0 + t2(:,:) = 0d0 + t2_diis(:,:) = 0d0 + err_diis(:,:) = 0d0 + + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| pCCD calculation: t amplitudes |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|' + write(*,*)'----------------------------------------------------' + + do while(CvgAmp > thresh .and. nItAmp < maxIt) + + ! Increment + + nItAmp = nItAmp + 1 + + ! Form intermediate array + + yO(:,:) = matmul(t2,transpose(OOVV)) + + ! Compute residual + + r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*t2(:,:) & + - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - OOVV(:,:)*t2(:,:))*t2(:,:) + + do i=1,O + do a=1,V + + do j=1,O + r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*t2(i,a) + OOOO(j,i)*t2(j,a) + yO(i,j)*t2(j,a) + end do + + do b=1,V + r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*t2(i,a) + VVVV(a,b)*t2(i,b) + end do + + end do + end do + + ! Check convergence + + CvgAmp = maxval(abs(r2(:,:))) + + ! Update amplitudes + + t2(:,:) = t2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:) + + ! Compute correlation energy + + EcCC = 0d0 + do i=1,O + do a=1,V + EcCC = EcCC + OOVV(i,a)*t2(i,a) + end do + end do + + ! Dump results + + ECC = ERHF + EcCC + + ! DIIS extrapolation + + if(max_diis > 1) then + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,err_diis,t2_diis,-0.5d0*r2/delta_OV,t2) + + end if + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nItAmp,'|',ECC+ENuc,'|',EcCC,'|',CvgAmp,'|' + + end do + write(*,*)'----------------------------------------------------' + + !---------------------------! + ! End Loop for t amplitudes ! + !---------------------------! + + deallocate(r2,yO) + deallocate(err_diis,t2_diis) + + ! Did it actually converge? + + if(nItAmp == maxIt) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'! Convergence failed for t ampitudes !' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + + stop - ! Update amplitudes - - z2(:,:) = z2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:) - - ! DIIS extrapolation - - if(max_diis > 1) then - - n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,O*V,O*V,n_diis,err_diis,z2_diis,-0.5d0*r2/delta_OV,z2) - end if + + !-----------------------------! + ! Start Loop for z amplitudes ! + !-----------------------------! + + allocate(z2(O,V),r2(O,V),yO(O,O),yV(V,V)) + allocate(err_diis(O*V,max_diis),z2_diis(O*V,max_diis)) - write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & - '|',nSCF,'|',ECC+ENuc,'|',EcCC,'|',Conv,'|' - - end do - write(*,*)'----------------------------------------------------' - write(*,*) -!------------------------------------------------------------------------ -! End of SCF loop -!------------------------------------------------------------------------ - -! Did it actually converge? - - if(nSCF == maxSCF) then + CvgAmp = 1d0 + nItAmp = 0 + + n_diis = 0 + z2_diis(:,:) = 0d0 + err_diis(:,:) = 0d0 write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' Convergence failed ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - - stop + write(*,*)'----------------------------------------------------' + write(*,*)'| pCCD calculation: z amplitudes |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|' + write(*,*)'----------------------------------------------------' + + do while(CvgAmp > thresh .and. nItAmp < maxIt) + + ! Increment + + nItAmp = nItAmp + 1 + + ! Form intermediate array + + yO(:,:) = matmul(OOVV,transpose(t2)) + yV(:,:) = matmul(transpose(OOVV),t2) + + ! Compute residual + + r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*z2(:,:) & + - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - 2d0*OOVV(:,:)*t2(:,:))*z2(:,:) + + do i=1,O + do a=1,V + + do j=1,O + r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*z2(i,a) - 2d0*OOVV(i,a)*z2(j,a)*t2(j,a) & + + OOOO(i,j)*z2(j,a) + yO(i,j)*z2(j,a) + end do + + do b=1,V + r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*z2(i,a) - 2d0*OOVV(i,a)*z2(i,b)*t2(i,b) & + + VVVV(b,a)*z2(i,b) + yV(a,b)*z2(i,b) + end do + + end do + end do + + ! Check convergence + + CvgAmp = maxval(abs(r2(:,:))) + + ! Update amplitudes + + z2(:,:) = z2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:) + + ! DIIS extrapolation + + if(max_diis > 1) then + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(rcond,O*V,O*V,n_diis,err_diis,z2_diis,-0.5d0*r2/delta_OV,z2) + + end if + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nItAmp,'|',ECC+ENuc,'|',EcCC,'|',CvgAmp,'|' - end if - -! Deallocate memory - - deallocate(err_diis,z2_diis,r2) - -!--------------------------! -! Compute density matrices ! -!--------------------------! - - allocate(xOO(O,O),xVV(V,V),xOV(O,V)) - - xOO(:,:) = matmul(t2,transpose(z2)) - xVV(:,:) = matmul(transpose(z2),t2) - xOV(:,:) = matmul(t2,matmul(transpose(z2),t2)) - -! Form 1RDM - - allocate(rdm1(N,N)) - - rdm1(:,:) = 0d0 - - do i=1,O - rdm1(i,i) = 2d0*(1d0 - xOO(i,i)) - end do - - do a=1,V - rdm1(O+a,O+a) = 2d0*xVV(a,a) - end do - -! Check 1RDM - - tr_1rdm = trace_matrix(N,rdm1) - write(*,'(A25,F16.10)') ' --> Trace of the 1RDM = ',tr_1rdm - - if( abs(dble(2*O) - tr_1rdm) > thresh ) & - write(*,*) ' !!! Your 1RDM seems broken !!! ' - write(*,*) - -! write(*,*) '1RDM is diagonal at the pCCD level:' -! call matout(N,N,rdm1) - -! Form 2RM - - allocate(rdm2(N,N,N,N)) - - rdm2(:,:,:,:) = 0d0 - - ! iijj - - do i=1,O - do j=1,O - rdm2(i,i,j,j) = 2d0*xOO(i,j) end do - end do + write(*,*)'----------------------------------------------------' + write(*,*) - ! iiaa + !---------------------------! + ! End Loop for z ampltiudes ! + !---------------------------! - do i=1,O + deallocate(r2,yO,yV) + deallocate(err_diis,z2_diis) + + ! Did it actually converge? + + if(nItAmp == maxIt) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'! Convergence failed for z ampltiudes !' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + + stop + + end if + + !--------------------------! + ! Compute density matrices ! + !--------------------------! + + allocate(rdm1(N,N),rdm2(N,N,N,N)) + allocate(xOO(O,O),xVV(V,V),xOV(O,V)) + + xOO(:,:) = matmul(t2,transpose(z2)) + xVV(:,:) = matmul(transpose(z2),t2) + xOV(:,:) = matmul(t2,matmul(transpose(z2),t2)) + + ! Form 1RDM + + rdm1(:,:) = 0d0 + + do i=1,O + rdm1(i,i) = 2d0*(1d0 - xOO(i,i)) + end do + do a=1,V - rdm2(i,i,O+a,O+a) = 2d0*(t2(i,a) + xOV(i,a) - 2d0*t2(i,a)*(xVV(a,a) + xOO(i,i) - t2(i,a)*z2(i,a))) + rdm1(O+a,O+a) = 2d0*xVV(a,a) end do - end do - - ! aaii - - do i=1,O + + ! Check 1RDM + + tr_1rdm = trace_matrix(N,rdm1) + write(*,'(A25,F16.10)') ' --> Trace of the 1RDM = ',tr_1rdm + + if( abs(dble(2*O) - tr_1rdm) > thresh ) & + write(*,*) ' !!! Your 1RDM seems broken !!! ' + write(*,*) + + ! write(*,*) '1RDM is diagonal at the pCCD level:' + ! call matout(N,N,rdm1) + + ! Form 2RM + + rdm2(:,:,:,:) = 0d0 + + ! iijj + + do i=1,O + do j=1,O + rdm2(i,i,j,j) = 2d0*xOO(i,j) + end do + end do + + ! iiaa + + do i=1,O + do a=1,V + rdm2(i,i,O+a,O+a) = 2d0*(t2(i,a) + xOV(i,a) - 2d0*t2(i,a)*(xVV(a,a) + xOO(i,i) - t2(i,a)*z2(i,a))) + end do + end do + + ! aaii + + do i=1,O + do a=1,V + rdm2(O+a,O+a,i,i) = 2d0*z2(i,a) + end do + end do + + ! aabb + do a=1,V - rdm2(O+a,O+a,i,i) = 2d0*z2(i,a) + do b=1,V + rdm2(O+a,O+a,O+b,O+b) = 2d0*xVV(a,b) + end do end do - end do - - ! aabb - - do a=1,V - do b=1,V - rdm2(O+a,O+a,O+b,O+b) = 2d0*xVV(a,b) + + ! ijij + + do i=1,O + do j=1,O + rdm2(i,j,i,j) = 4d0*(1d0 - xOO(i,i) - xOO(j,j)) + end do end do - end do - - ! ijij - - do i=1,O - do j=1,O - rdm2(i,j,i,j) = 4d0*(1d0 - xOO(i,i) - xOO(j,j)) + + ! ijji + + do i=1,O + do j=1,O + rdm2(i,j,j,i) = - 2d0*(1d0 - xOO(i,i) - xOO(j,j)) + end do end do - end do - - ! ijji - - do i=1,O - do j=1,O - rdm2(i,j,j,i) = - 2d0*(1d0 - xOO(i,i) - xOO(j,j)) + + ! iiii + + do i=1,O + rdm2(i,i,i,i) = 2d0*(1d0 - xOO(i,i)) end do - end do - - ! iiii - - do i=1,O - rdm2(i,i,i,i) = 2d0*(1d0 - xOO(i,i)) - end do - - ! iaia - - do i=1,O + + ! iaia + + do i=1,O + do a=1,V + rdm2(i,O+a,i,O+a) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a)) + end do + end do + + ! iaai + + do i=1,O + do a=1,V + rdm2(i,O+a,O+a,i) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a)) + end do + end do + + ! aiai + + do i=1,O + do a=1,V + rdm2(O+a,i,O+a,i) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a)) + end do + end do + + ! aiia + + do i=1,O + do a=1,V + rdm2(O+a,i,i,O+a) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a)) + end do + end do + + ! abab + do a=1,V - rdm2(i,O+a,i,O+a) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a)) + rdm2(O+a,O+a,O+a,O+a) = 2d0*xVV(a,a) end do - end do + + ! Check 2RDM + + tr_2rdm = trace_matrix(N**2,rdm2) + write(*,'(A25,F16.10)') ' --> Trace of the 2RDM = ',tr_2rdm + + if( abs(dble(2*O*(2*O-1)) - tr_2rdm) > thresh ) & + write(*,*) ' !!! Your 2RDM seems broken !!! ' + write(*,*) + + ! write(*,*) '2RDM is not diagonal at the pCCD level:' + ! call matout(N**2,N**2,rdm2) - ! iaai - - do i=1,O - do a=1,V - rdm2(i,O+a,O+a,i) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a)) - end do - end do - - ! aiai - - do i=1,O - do a=1,V - rdm2(O+a,i,O+a,i) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a)) - end do - end do - - ! aiia - - do i=1,O - do a=1,V - rdm2(O+a,i,i,O+a) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a)) - end do - end do - - ! abab - - do a=1,V - rdm2(O+a,O+a,O+a,O+a) = 2d0*xVV(a,a) - end do - -! Check 2RDM - - tr_2rdm = trace_matrix(N**2,rdm2) - write(*,'(A25,F16.10)') ' --> Trace of the 2RDM = ',tr_2rdm - - if( abs(dble(2*O*(2*O-1)) - tr_2rdm) > thresh ) & - write(*,*) ' !!! Your 2RDM seems broken !!! ' - write(*,*) - -! write(*,*) '2RDM is not diagonal at the pCCD level:' -! call matout(N**2,N**2,rdm2) - -! Compute electronic energy - - allocate(h(N,N)) - h = matmul(transpose(cHF),matmul(Hc,cHF)) - - E1 = 0d0 - E2 = 0d0 - - do p=1,N - do q=1,N - E1 = E1 + rdm1(p,q)*h(p,q) - do r=1,N - do s=1,N - E2 = E2 + rdm2(p,q,r,s)*ERI(p,q,r,s) + deallocate(xOO,xVV,xOV) + deallocate(t2,z2) + + ! Compute electronic energy + + E1 = 0d0 + E2 = 0d0 + + do p=1,N + do q=1,N + E1 = E1 + rdm1(p,q)*h(p,q) + do r=1,N + do s=1,N + E2 = E2 + rdm2(p,q,r,s)*ERI_MO(p,q,r,s) + end do end do end do end do - end do - - E2 = 0.5d0*E2 - - write(*,'(A25,F16.10)') ' One-electron energy = ',E1 - write(*,'(A25,F16.10)') ' Two-electron energy = ',E2 - write(*,'(A25,F16.10)') ' Electronic energy = ',E1 + E2 - write(*,'(A25,F16.10)') ' Total energy = ',E1 + E2 + ENuc - write(*,*) - -! Compute gradient - - allocate(grad(N**2)) - - grad(:) = 0d0 - - pq = 0 - do p=1,N - do q=1,N - - pq = pq + 1 - - do r=1,N - grad(pq) = grad(pq) + h(r,p)*rdm1(r,q) - h(q,r)*rdm1(p,r) - end do - - do r=1,N - do s=1,N - do t=1,N - grad(pq) = grad(pq) + (ERI(r,s,p,t)*rdm2(r,s,q,t) - ERI(q,t,r,s)*rdm2(p,t,r,s)) + + E2 = 0.5d0*E2 + + write(*,'(A25,F16.10)') ' One-electron energy = ',E1 + write(*,'(A25,F16.10)') ' Two-electron energy = ',E2 + write(*,'(A25,F16.10)') ' Electronic energy = ',E1 + E2 + write(*,'(A25,F16.10)') ' Total energy = ',E1 + E2 + ENuc + write(*,*) + + !--------------------------! + ! Compute orbital gradient ! + !--------------------------! + + allocate(grad(N**2)) + + grad(:) = 0d0 + + pq = 0 + do p=1,N + do q=1,N + + pq = pq + 1 + + do r=1,N + grad(pq) = grad(pq) + h(r,p)*rdm1(r,q) - h(q,r)*rdm1(p,r) + end do + + do r=1,N + do s=1,N + do t=1,N + grad(pq) = grad(pq) + (ERI_MO(r,s,p,t)*rdm2(r,s,q,t) - ERI_MO(q,t,r,s)*rdm2(p,t,r,s)) + end do end do end do - end do - - end do - end do - - write(*,*) 'Orbital gradient at the pCCD level:' - call matout(N,N,grad) - write(*,*) - -! Convergence - - Conv = maxval(abs(grad)) - write(*,*) ' Convergence of orbtial gradient = ',Conv - write(*,*) -! Compute Hessian - - allocate(hess(N**2,N**2),tmp(N,N,N,N)) - - tmp(:,:,:,:) = 0d0 - - do p=1,N - do q=1,N - - do r=1,N - do s=1,N - - tmp(p,q,r,s) = - h(s,p)*rdm1(r,q) - h(q,r)*rdm1(p,s) - - do u=1,N - - tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*( & - Kronecker_delta(q,r)*(h(u,p)*rdm1(u,s) + h(s,u)*rdm1(p,u)) & - + Kronecker_delta(p,s)*(h(u,r)*rdm1(u,q) + h(q,u)*rdm1(r,u)) ) - - end do - - do u=1,N - do v=1,N - - tmp(p,q,r,s) = tmp(p,q,r,s) + ERI(u,v,p,r)*rdm2(u,v,q,s) + ERI(q,s,u,v)*rdm2(p,r,u,v) - - end do - end do - - do t=1,N + end do + end do + + write(*,*) 'Orbital gradient at the pCCD level:' + call matout(N,N,grad) + write(*,*) + + ! Check convergence of orbital optimization + + CvgOrb = maxval(abs(grad)) + write(*,*) ' Iteration',nItOrb,'for pCCD orbital optimization' + write(*,*) ' Convergence of orbital gradient = ',CvgOrb + write(*,*) + + !-------------------------! + ! Compute orbital Hessian ! + !-------------------------! + + allocate(hess(N**2,N**2),tmp(N,N,N,N)) + + tmp(:,:,:,:) = 0d0 + + do p=1,N + do q=1,N + + do r=1,N + do s=1,N + + tmp(p,q,r,s) = - h(s,p)*rdm1(r,q) - h(q,r)*rdm1(p,s) + do u=1,N - - tmp(p,q,r,s) = tmp(p,q,r,s) - ( & - ERI(s,t,p,u)*rdm2(r,t,q,u) + ERI(t,s,p,u)*rdm2(t,r,q,u) & - + ERI(q,u,r,t)*rdm2(p,u,s,t) + ERI(q,u,t,r)*rdm2(p,u,t,s) ) - + + tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*( & + Kronecker_delta(q,r)*(h(u,p)*rdm1(u,s) + h(s,u)*rdm1(p,u)) & + + Kronecker_delta(p,s)*(h(u,r)*rdm1(u,q) + h(q,u)*rdm1(r,u)) ) + end do - end do - - do t=1,N + do u=1,N - do v=1,N - - tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*( & - Kronecker_delta(q,r)*(ERI(u,v,p,t)*rdm2(u,v,s,t) + ERI(s,t,u,v)*rdm2(p,t,u,v)) & - + Kronecker_delta(p,s)*(ERI(q,t,u,v)*rdm2(r,t,u,v) + ERI(u,v,r,t)*rdm2(u,v,q,t)) ) - + do w=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) + ERI_MO(u,w,p,r)*rdm2(u,w,q,s) + ERI_MO(q,s,u,w)*rdm2(p,r,u,w) + end do end do + + do t=1,N + do u=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) - ( & + ERI_MO(s,t,p,u)*rdm2(r,t,q,u) + ERI_MO(t,s,p,u)*rdm2(t,r,q,u) & + + ERI_MO(q,u,r,t)*rdm2(p,u,s,t) + ERI_MO(q,u,t,r)*rdm2(p,u,t,s) ) + + end do + end do + + do t=1,N + do u=1,N + do w=1,N + + tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*( & + Kronecker_delta(q,r)*(ERI_MO(u,w,p,t)*rdm2(u,w,s,t) + ERI_MO(s,t,u,w)*rdm2(p,t,u,w)) & + + Kronecker_delta(p,s)*(ERI_MO(q,t,u,w)*rdm2(r,t,u,w) + ERI_MO(u,w,r,t)*rdm2(u,w,q,t)) ) + + end do + end do + end do + end do - end do + end do - end do + + ! Flatten Hessian matrix and add permutations + + pq = 0 + do p=1,N + do q=1,N + + pq = pq + 1 + + rs = 0 + do r=1,N + do s=1,N + + rs = rs + 1 + + hess(pq,rs) = tmp(p,r,q,s) - tmp(r,p,q,s) - tmp(p,r,s,q) + tmp(r,p,s,q) +!! hess(pq,rs) = tmp(p,q,r,s) - tmp(q,p,r,s) - tmp(p,q,s,r) + tmp(q,p,s,r) + + end do + end do + + end do + end do + + deallocate(rdm1,rdm2,tmp) + + allocate(hessInv(N**2,N**2)) + + call inverse_matrix(N**2,hess,hessInv) + + deallocate(hess) + + allocate(Kap(N,N)) + + Kap(:,:) = 0d0 + + pq = 0 + do p=1,N + do q=1,N + + pq = pq + 1 + + rs = 0 + do r=1,N + do s=1,N + + rs = rs + 1 + + Kap(p,q) = Kap(p,q) - hessInv(pq,rs)*grad(rs) + + end do + end do + + end do + end do + + deallocate(hessInv,grad) + + write(*,*) 'kappa' + call matout(N,N,Kap) + write(*,*) + + allocate(ExpKap(N,N)) + call matrix_exponential(N,Kap,ExpKap) + deallocate(Kap) + + write(*,*) 'e^kappa' + call matout(N,N,ExpKap) + write(*,*) + + write(*,*) 'Old orbitals' + call matout(N,N,c) + write(*,*) + + c = matmul(c,ExpKap) + deallocate(ExpKap) + + write(*,*) 'Rotated orbitals' + call matout(N,N,c) + write(*,*) + end do -! Flatten Hessian matrix and add permutations + !-----------------------------------! + ! End Loop for orbital optimization ! + !-----------------------------------! - pq = 0 - do p=1,N - do q=1,N + ! Did it actually converge? - pq = pq + 1 - - rs = 0 - do r=1,N - do s=1,N + if(nItOrb == maxIt) then - rs = rs + 1 + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'! Convergence failed for orbital optimization !' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - hess(pq,rs) = tmp(p,r,q,s) - tmp(r,p,q,s) - tmp(p,r,s,q) + tmp(r,p,s,q) -! hess(pq,rs) = tmp(p,q,r,s) - tmp(q,p,r,s) - tmp(p,q,s,r) + tmp(q,p,s,r) + stop - end do - end do - - end do - end do - - call matout(N**2,N**2,hess) - -! allocate(eig(N**2)) - -! call diagonalize_matrix(N**2,hess,eig) - -! call vecout(N**2,eig) - - allocate(hessInv(N**2,N**2)) - - call inverse_matrix(N**2,hess,hessInv) - - allocate(kappa(N,N),ekappa(N,N)) - - kappa(:,:) = 0d0 - - pq = 0 - do p=1,N - do q=1,N - - pq = pq + 1 - - rs = 0 - do r=1,N - do s=1,N - - rs = rs + 1 - - kappa(p,q) = kappa(p,q) + hessInv(pq,rs)*grad(rs) - - end do - end do - - end do - end do - - write(*,*) 'kappa' - call matout(N,N,kappa) - write(*,*) - - call matrix_exponential(N,kappa,ekappa) - - write(*,*) 'e^kappa' - call matout(N,N,ekappa) - write(*,*) - - write(*,*) 'Old orbitals' - call matout(N,N,c) - write(*,*) - - c = matmul(c,ekappa) - - write(*,*) 'Rotated orbitals' - call matout(N,N,c) - write(*,*) + end if ! Testing zone diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 3897f37..9632c32 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -228,7 +228,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_CC) call RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & - maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,Hc,ERI_MO,ENuc,ERHF,eHF,cHF) + maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,Hc,ERI_AO,ERI_MO,ENuc,ERHF,eHF,cHF) call wall_time(end_CC) t_CC = end_CC - start_CC From eb6e0bcc02f9cc58fe2748f4e098e8c59a256b2a Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Fri, 30 Aug 2024 19:10:54 +0200 Subject: [PATCH 39/46] added non-sym diag with biorthog condition --- src/LR/ppLR.f90 | 138 +++++---- src/make_ninja.py | 4 +- src/utils/non_sym_diag.f90 | 571 +++++++++++++++++++++++++++++++++++++ 3 files changed, 657 insertions(+), 56 deletions(-) create mode 100644 src/utils/non_sym_diag.f90 diff --git a/src/LR/ppLR.f90 b/src/LR/ppLR.f90 index 2e54490..64d533c 100644 --- a/src/LR/ppLR.f90 +++ b/src/LR/ppLR.f90 @@ -1,93 +1,123 @@ -subroutine ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcRPA) -! Solve the pp-RPA linear eigenvalue problem +! --- + +subroutine ppLR(TDA, nOO, nVV, Bpp, Cpp, Dpp, Om1, X1, Y1, Om2, X2, Y2, EcRPA) + + ! + ! Solve the pp-RPA linear eigenvalue problem + ! + ! right eigen-problem: H R = R w + ! left eigen-problem: H.T L = L w + ! + ! where L.T R = 1 + ! + ! + ! (+C +B) + ! H = ( ) where C = C.T and D = D.T + ! (-B.T -D) + ! + ! (w1 0) (X1 X2) (+X1 +X2) + ! w = ( ), R = ( ) and L = ( ) + ! (0 w2) (Y1 Y2) (-Y1 -Y2) + ! + ! + ! the normalisation condition reduces to + ! + ! X1.T X2 - Y1.T Y2 = 0 + ! X1.T X1 - Y1.T Y1 = 1 + ! X2.T X2 - Y2.T Y2 = 1 + ! implicit none include 'parameters.h' -! Input variables - - logical,intent(in) :: TDA - integer,intent(in) :: nOO - integer,intent(in) :: nVV - double precision,intent(in) :: Bpp(nVV,nOO) - double precision,intent(in) :: Cpp(nVV,nVV) - double precision,intent(in) :: Dpp(nOO,nOO) + logical, intent(in) :: TDA + integer, intent(in) :: nOO, nVV + double precision, intent(in) :: Bpp(nVV,nOO), Cpp(nVV,nVV), Dpp(nOO,nOO) + double precision, intent(out) :: Om1(nVV), X1(nVV,nVV), Y1(nOO,nVV) + double precision, intent(out) :: Om2(nOO), X2(nVV,nOO), Y2(nOO,nOO) + double precision, intent(out) :: EcRPA -! Local variables + logical :: imp_bio, verbose + integer :: i, j, N + double precision :: EcRPA1, EcRPA2 + double precision :: thr_d, thr_nd, thr_deg + double precision,allocatable :: M(:,:), Z(:,:), Om(:) - double precision :: trace_matrix - double precision :: EcRPA1 - double precision :: EcRPA2 - double precision,allocatable :: M(:,:) - double precision,allocatable :: Z(:,:) - double precision,allocatable :: Om(:) + double precision, external :: trace_matrix -! Output variables - double precision,intent(out) :: Om1(nVV) - double precision,intent(out) :: X1(nVV,nVV) - double precision,intent(out) :: Y1(nOO,nVV) - double precision,intent(out) :: Om2(nOO) - double precision,intent(out) :: X2(nVV,nOO) - double precision,intent(out) :: Y2(nOO,nOO) - double precision,intent(out) :: EcRPA -! Memory allocation + N = nOO + nVV - allocate(M(nOO+nVV,nOO+nVV),Z(nOO+nVV,nOO+nVV),Om(nOO+nVV)) - -!-------------------------------------------------! -! Solve the p-p eigenproblem ! -!-------------------------------------------------! -! ! -! | C B | | X1 X2 | | w1 0 | | X1 X2 | ! -! | | | | = | | | | ! -! | -Bt -D | | Y1 Y2 | | 0 w2 | | Y1 Y2 | ! -! ! -!-------------------------------------------------! + allocate(M(N,N), Z(N,N), Om(N)) if(TDA) then X1(:,:) = +Cpp(:,:) Y1(:,:) = 0d0 - if(nVV > 0) call diagonalize_matrix(nVV,X1,Om1) + if(nVV > 0) call diagonalize_matrix(nVV, X1, Om1) X2(:,:) = 0d0 Y2(:,:) = -Dpp(:,:) - if(nOO > 0) call diagonalize_matrix(nOO,Y2,Om2) + if(nOO > 0) call diagonalize_matrix(nOO, Y2, Om2) else - ! Diagonal blocks - + ! Diagonal blocks M( 1:nVV , 1:nVV) = + Cpp(1:nVV,1:nVV) M(nVV+1:nVV+nOO,nVV+1:nVV+nOO) = - Dpp(1:nOO,1:nOO) - ! Off-diagonal blocks - + ! Off-diagonal blocks M( 1:nVV ,nVV+1:nOO+nVV) = - Bpp(1:nVV,1:nOO) M(nVV+1:nOO+nVV, 1:nVV) = + transpose(Bpp(1:nVV,1:nOO)) -! call matout(nOO,nOO,Dpp) + !! Diagonalize the p-p matrix + !if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV, M, Om, Z) + !! Split the various quantities in p-p and h-h parts + !call sort_ppRPA(nOO, nVV, Om, Z, Om1, X1, Y1, Om2, X2, Y2) - ! Diagonalize the p-p matrix - if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV,M,Om,Z) + thr_d = 1d-6 ! to determine if diagonal elements of L.T x R are close enouph to 1 + thr_nd = 1d-6 ! to determine if non-diagonal elements of L.T x R are close enouph to 1 + thr_deg = 1d-8 ! to determine if two eigenvectors are degenerate or not + imp_bio = .True. ! impose bi-orthogonality + verbose = .False. + call diagonalize_nonsym_matrix(N, M, Z, Om, thr_d, thr_nd, thr_deg, imp_bio, verbose) - ! Split the various quantities in p-p and h-h parts + do i = 1, nOO + Om2(i) = Om(i) + do j = 1, nVV + X2(j,i) = Z(j,i) + enddo + do j = 1, nOO + Y2(j,i) = Z(nVV+j,i) + enddo + enddo - call sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2) + do i = 1, nVV + Om1(i) = Om(nOO+i) + do j = 1, nVV + X1(j,i) = M(j,nOO+i) + enddo + do j = 1, nOO + Y1(j,i) = M(nVV+j,nOO+i) + enddo + enddo end if -! Compute the RPA correlation energy + ! Compute the RPA correlation energy + EcRPA = 0.5d0 * (sum(Om1) - sum(Om2) - trace_matrix(nVV, Cpp) - trace_matrix(nOO, Dpp)) + EcRPA1 = +sum(Om1) - trace_matrix(nVV, Cpp) + EcRPA2 = -sum(Om2) - trace_matrix(nOO, Dpp) - EcRPA = 0.5d0*( sum(Om1) - sum(Om2) - trace_matrix(nVV,Cpp) - trace_matrix(nOO,Dpp) ) - EcRPA1 = +sum(Om1) - trace_matrix(nVV,Cpp) - EcRPA2 = -sum(Om2) - trace_matrix(nOO,Dpp) - - if(abs(EcRPA - EcRPA1) > 1d-6 .or. abs(EcRPA - EcRPA2) > 1d-6) & + if(abs(EcRPA - EcRPA1) > 1d-6 .or. abs(EcRPA - EcRPA2) > 1d-6) then print*,'!!! Issue in pp-RPA linear reponse calculation RPA1 != RPA2 !!!' + endif + + deallocate(M, Z, Om) end subroutine + + diff --git a/src/make_ninja.py b/src/make_ninja.py index 1e72639..a5e6e84 100755 --- a/src/make_ninja.py +++ b/src/make_ninja.py @@ -89,8 +89,8 @@ FIX_ORDER_OF_LIBS=-Wl,--start-group if sys.platform in ["linux", "linux2"]: # compiler = compile_gfortran_linux -# compiler = compile_ifort_linux - compiler = compile_olympe + compiler = compile_ifort_linux +# compiler = compile_olympe elif sys.platform == "darwin": compiler = compile_gfortran_mac else: diff --git a/src/utils/non_sym_diag.f90 b/src/utils/non_sym_diag.f90 new file mode 100644 index 0000000..04279ac --- /dev/null +++ b/src/utils/non_sym_diag.f90 @@ -0,0 +1,571 @@ + +! --- + +subroutine diagonalize_nonsym_matrix(N, A, L, e_re, thr_d, thr_nd, thr_deg, imp_bio, verbose) + + ! Diagonalize a non-symmetric matrix + ! + ! Output + ! right-eigenvectors are saved in A + ! left-eigenvectors are saved in L + ! eigenvalues are saved in e = e_re + i e_im + + implicit none + + integer, intent(in) :: N + logical, intent(in) :: imp_bio, verbose + double precision, intent(in) :: thr_d, thr_nd, thr_deg + double precision, intent(inout) :: A(N,N) + double precision, intent(out) :: e_re(N), L(N,N) + + integer :: i, j, ii + integer :: lwork, info + double precision :: accu_d, accu_nd + integer, allocatable :: iorder(:), deg_num(:) + double precision, allocatable :: Atmp(:,:), Ltmp(:,:), work(:), e_im(:) + double precision, allocatable :: S(:,:) + + if(verbose) then + print*, ' Starting a non-Hermitian diagonalization ...' + print*, ' Good Luck ;)' + print*, ' imp_bio = ', imp_bio + endif + + ! --- + ! diagonalize + + allocate(Atmp(N,N), e_im(N)) + Atmp(1:N,1:N) = A(1:N,1:N) + + allocate(work(1)) + lwork = -1 + call dgeev('V', 'V', N, Atmp, N, e_re, e_im, L, N, A, N, work, lwork, info) + if(info .gt. 0) then + print*,'dgeev failed !!', info + stop + endif + + lwork = max(int(work(1)), 1) + deallocate(work) + allocate(work(lwork)) + + call dgeev('V', 'V', N, Atmp, N, e_re, e_im, L, N, A, N, work, lwork, info) + if(info .ne. 0) then + print*,'dgeev failed !!', info + stop + endif + + deallocate(Atmp, WORK) + + + ! --- + ! check if eigenvalues are real + + i = 1 + ii = 0 + do while(i .le. N) + if(dabs(e_im(i)) .gt. 1.d-12) then + ii = ii + 1 + if(verbose) then + print*, ' Warning: complex eigenvalue !' + print*, i, e_re(i), e_im(i) + if(dabs(e_im(i)/e_re(i)) .lt. 1.d-6) then + print*, ' small enouph to be igored' + else + print*, ' IMAGINARY PART IS SIGNIFANT !!!' + endif + endif + endif + i = i + 1 + enddo + + if(verbose) then + if(ii .eq. 0) print*, ' congratulations :) eigenvalues are real-valued !!' + endif + + + ! --- + ! track & sort the real eigenvalues + + allocate(Atmp(N,N), Ltmp(N,N), iorder(N)) + + do i = 1, N + iorder(i) = i + enddo + call quick_sort(e_re, iorder, N) + + Atmp(:,:) = A(:,:) + Ltmp(:,:) = L(:,:) + do i = 1, N + do j = 1, N + A(j,i) = Atmp(j,iorder(i)) + L(j,i) = Ltmp(j,iorder(i)) + enddo + enddo + + deallocate(Atmp, Ltmp, iorder) + + + + + ! --- + ! check bi-orthog + + allocate(S(N,N)) + call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .false., verbose) + + if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(N))/dble(N) .lt. thr_d)) then + + if(verbose) then + print *, ' lapack vectors are normalized and bi-orthogonalized' + endif + + elseif((accu_nd .lt. thr_nd) .and. (dabs(accu_d - dble(N)) .gt. thr_d)) then + + if(verbose) then + print *, ' lapack vectors are not normalized but bi-orthogonalized' + endif + + call check_biorthog_binormalize(N, N, L, A, thr_d, thr_nd, .true.) + call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .true., verbose) + + else + + if(verbose) then + print *, ' lapack vectors are not normalized neither bi-orthogonalized' + endif + + allocate(deg_num(N)) + call reorder_degen_eigvec(N, thr_deg, deg_num, e_re, L, A) + call impose_biorthog_degen_eigvec(N, deg_num, e_re, L, A) + deallocate(deg_num) + + call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .false., verbose) + if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(N))/dble(N) .lt. thr_d)) then + if(verbose) then + print *, ' lapack vectors are now normalized and bi-orthogonalized' + endif + elseif((accu_nd .lt. thr_nd) .and. (dabs(accu_d - dble(N)) .gt. thr_d)) then + if(verbose) then + print *, ' lapack vectors are now not normalized but bi-orthogonalized' + endif + call check_biorthog_binormalize(N, N, L, A, thr_d, thr_nd, .true.) + call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .true., verbose) + else + if(verbose) then + print*, ' bi-orthogonalization failed !' + endif + if(imp_bio) then + print*, ' bi-orthogonalization failed !' + deallocate(S) + stop + endif + endif + + endif + + deallocate(S) + return + +end + +! --- + +subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot, verbose) + + implicit none + + integer, intent(in) :: n, m + logical, intent(in) :: stop_ifnot, verbose + double precision, intent(in) :: Vl(n,m), Vr(n,m) + double precision, intent(in) :: thr_d, thr_nd + double precision, intent(out) :: accu_d, accu_nd, S(m,m) + + integer :: i, j + double precision, allocatable :: SS(:,:) + + if(verbose) then + print *, ' check bi-orthogonality' + endif + + ! --- + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , Vl, size(Vl, 1), Vr, size(Vr, 1) & + , 0.d0, S, size(S, 1) ) + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, m + do j = 1, m + if(i==j) then + accu_d = accu_d + dabs(S(i,i)) + else + accu_nd = accu_nd + S(j,i) * S(j,i) + endif + enddo + enddo + accu_nd = dsqrt(accu_nd) / dble(m) + + if(verbose) then + if((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) then + print *, ' non bi-orthogonal vectors !' + print *, ' accu_nd = ', accu_nd + print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) + else + print *, ' vectors are bi-orthogonals' + endif + endif + + ! --- + + if(stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d)) then + print *, ' non bi-orthogonal vectors !' + print *, ' accu_nd = ', accu_nd + print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) + stop + endif + +end + +! --- + +subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot) + + implicit none + + integer, intent(in) :: n, m + logical, intent(in) :: stop_ifnot + double precision, intent(in) :: thr_d, thr_nd + double precision, intent(inout) :: Vl(n,m), Vr(n,m) + + integer :: i, j + double precision :: accu_d, accu_nd, s_tmp + double precision, allocatable :: S(:,:) + + ! --- + + allocate(S(m,m)) + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , Vl, size(Vl, 1), Vr, size(Vr, 1) & + , 0.d0, S, size(S, 1) ) + + do i = 1, m + if(S(i,i) .lt. 0.d0) then + do j = 1, n + Vl(j,i) = -1.d0 * Vl(j,i) + enddo + S(i,i) = -S(i,i) + endif + enddo + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, m + do j = 1, m + if(i==j) then + accu_d = accu_d + S(i,i) + else + accu_nd = accu_nd + S(j,i) * S(j,i) + endif + enddo + enddo + accu_nd = dsqrt(accu_nd) / dble(m) + + ! --- + + if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then + + do i = 1, m + if(S(i,i) <= 0.d0) then + print *, ' overap negative' + print *, i, S(i,i) + exit + endif + if(dabs(S(i,i) - 1.d0) .gt. thr_d) then + s_tmp = 1.d0 / dsqrt(S(i,i)) + do j = 1, n + Vl(j,i) = Vl(j,i) * s_tmp + Vr(j,i) = Vr(j,i) * s_tmp + enddo + endif + + enddo + + endif + + ! --- + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , Vl, size(Vl, 1), Vr, size(Vr, 1) & + , 0.d0, S, size(S, 1) ) + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, m + do j = 1, m + if(i==j) then + accu_d = accu_d + S(i,i) + else + accu_nd = accu_nd + S(j,i) * S(j,i) + endif + enddo + enddo + accu_nd = dsqrt(accu_nd) / dble(m) + + deallocate(S) + + ! --- + + if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d)) ) then + print *, accu_nd, thr_nd + print *, dabs(accu_d-dble(m))/dble(m), thr_d + print *, ' biorthog_binormalize failed !' + stop + endif + +end + +! --- + +subroutine reorder_degen_eigvec(n, thr_deg, deg_num, e0, L0, R0) + + implicit none + + integer, intent(in) :: n + double precision, intent(in) :: thr_deg + double precision, intent(inout) :: e0(n), L0(n,n), R0(n,n) + integer, intent(out) :: deg_num(n) + + logical :: complex_root + integer :: i, j, k, m, ii, j_tmp + double precision :: ei, ej, de + double precision :: accu_d, accu_nd + double precision :: e0_tmp, L0_tmp(n), R0_tmp(n) + double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) + + do i = 1, n + deg_num(i) = 1 + enddo + + do i = 1, n-1 + ei = e0(i) + + ! already considered in degen vectors + if(deg_num(i) .eq. 0) cycle + + ii = 0 + do j = i+1, n + ej = e0(j) + de = dabs(ei - ej) + + if(de .lt. thr_deg) then + ii = ii + 1 + + j_tmp = i + ii + + deg_num(j_tmp) = 0 + + e0_tmp = e0(j_tmp) + e0(j_tmp) = e0(j) + e0(j) = e0_tmp + + L0_tmp(1:n) = L0(1:n,j_tmp) + L0(1:n,j_tmp) = L0(1:n,j) + L0(1:n,j) = L0_tmp(1:n) + + R0_tmp(1:n) = R0(1:n,j_tmp) + R0(1:n,j_tmp) = R0(1:n,j) + R0(1:n,j) = R0_tmp(1:n) + endif + enddo + + deg_num(i) = ii + 1 + enddo + + ii = 0 + do i = 1, n + if(deg_num(i) .gt. 1) then + ii = ii + 1 + endif + enddo + + if(ii .eq. 0) then + print*, ' WARNING: bi-orthogonality is lost but there is no degeneracies' + print*, ' rotations may change energy' + stop + endif + +end + +! --- + +subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0) + + implicit none + + integer, intent(in) :: n, deg_num(n) + double precision, intent(in) :: e0(n) + double precision, intent(inout) :: L0(n,n), R0(n,n) + + logical :: complex_root + integer :: i, j, k, m + double precision :: ei, ej, de + double precision :: accu_d, accu_nd + double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) + + !do i = 1, n + ! if(deg_num(i) .gt. 1) then + ! print *, ' degen on', i, deg_num(i), e0(i) + ! endif + !enddo + + ! --- + + do i = 1, n + m = deg_num(i) + + if(m .gt. 1) then + + allocate(L(n,m), R(n,m), S(m,m)) + + do j = 1, m + L(1:n,j) = L0(1:n,i+j-1) + R(1:n,j) = R0(1:n,i+j-1) + enddo + + ! --- + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + + accu_nd = 0.d0 + do j = 1, m + do k = 1, m + if(j==k) cycle + accu_nd = accu_nd + dabs(S(j,k)) + enddo + enddo + + if(accu_nd .lt. 1d-12) then + deallocate(S, L, R) + cycle + endif + + call impose_biorthog_svd(n, m, L, R) + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + accu_nd = 0.d0 + do j = 1, m + do k = 1, m + if(j==k) cycle + accu_nd = accu_nd + dabs(S(j,k)) + enddo + enddo + if(accu_nd .gt. 1d-12) then + print*, ' accu_nd =', accu_nd + print*, ' your strategy for degenerates orbitals failed !' + print*, m, 'deg on', i + stop + endif + + deallocate(S) + + ! --- + + do j = 1, m + L0(1:n,i+j-1) = L(1:n,j) + R0(1:n,i+j-1) = R(1:n,j) + enddo + + deallocate(L, R) + + endif + enddo + +end + +! --- + +subroutine impose_biorthog_svd(n, m, L, R) + + implicit none + + integer, intent(in) :: n, m + double precision, intent(inout) :: L(n,m), R(n,m) + + integer :: i, j, num_linear_dependencies + double precision :: threshold + double precision, allocatable :: S(:,:), tmp(:,:) + double precision, allocatable :: U(:,:), V(:,:), Vt(:,:), D(:) + + allocate(S(m,m)) + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + + ! --- + + allocate(U(m,m), Vt(m,m), D(m)) + + call svd(S, m, U, m, D, Vt, m, m, m) + + deallocate(S) + + threshold = 1.d-6 + num_linear_dependencies = 0 + do i = 1, m + if(abs(D(i)) <= threshold) then + D(i) = 0.d0 + num_linear_dependencies = num_linear_dependencies + 1 + else + D(i) = 1.d0 / dsqrt(D(i)) + endif + enddo + if(num_linear_dependencies > 0) then + write(*,*) ' linear dependencies = ', num_linear_dependencies + write(*,*) ' m = ', m + stop + endif + + allocate(V(m,m)) + do i = 1, m + do j = 1, m + V(j,i) = Vt(i,j) + enddo + enddo + deallocate(Vt) + + ! --- + + ! R <-- R x V x D^{-0.5} + ! L <-- L x U x D^{-0.5} + + do i = 1, m + do j = 1, m + V(j,i) = V(j,i) * D(i) + U(j,i) = U(j,i) * D(i) + enddo + enddo + + allocate(tmp(n,m)) + tmp(:,:) = R(:,:) + call dgemm( 'N', 'N', n, m, m, 1.d0 & + , tmp, size(tmp, 1), V, size(V, 1) & + , 0.d0, R, size(R, 1)) + + tmp(:,:) = L(:,:) + call dgemm( 'N', 'N', n, m, m, 1.d0 & + , tmp, size(tmp, 1), U, size(U, 1) & + , 0.d0, L, size(L, 1)) + + deallocate(tmp, U, V, D) + +end + +! --- + From 2c312cfc579690f4a17ab2a27571a770e446e99a Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Fri, 30 Aug 2024 20:15:39 +0200 Subject: [PATCH 40/46] v0 of FeatherBench --- src/LR/ppLR.f90 | 61 +++++++++--------- test/export_tobench.py | 26 ++++++++ tests/create_database.py | 35 +++++++++-- tests/feather_bench.py | 130 ++++++++++++++++++++++----------------- tests/inp/methods.RHF | 6 +- tests/lunch_bench.py | 2 +- tests/molecule.py | 63 ++++++++++++++++--- 7 files changed, 223 insertions(+), 100 deletions(-) create mode 100644 test/export_tobench.py diff --git a/src/LR/ppLR.f90 b/src/LR/ppLR.f90 index 64d533c..582e28f 100644 --- a/src/LR/ppLR.f90 +++ b/src/LR/ppLR.f90 @@ -72,38 +72,43 @@ subroutine ppLR(TDA, nOO, nVV, Bpp, Cpp, Dpp, Om1, X1, Y1, Om2, X2, Y2, EcRPA) M( 1:nVV ,nVV+1:nOO+nVV) = - Bpp(1:nVV,1:nOO) M(nVV+1:nOO+nVV, 1:nVV) = + transpose(Bpp(1:nVV,1:nOO)) - !! Diagonalize the p-p matrix - !if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV, M, Om, Z) - !! Split the various quantities in p-p and h-h parts - !call sort_ppRPA(nOO, nVV, Om, Z, Om1, X1, Y1, Om2, X2, Y2) + if((nOO .eq. 0) .or. (nVV .eq. 0)) then + ! Diagonalize the p-p matrix + if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV, M, Om, Z) + ! Split the various quantities in p-p and h-h parts + call sort_ppRPA(nOO, nVV, Om, Z, Om1, X1, Y1, Om2, X2, Y2) - thr_d = 1d-6 ! to determine if diagonal elements of L.T x R are close enouph to 1 - thr_nd = 1d-6 ! to determine if non-diagonal elements of L.T x R are close enouph to 1 - thr_deg = 1d-8 ! to determine if two eigenvectors are degenerate or not - imp_bio = .True. ! impose bi-orthogonality - verbose = .False. - call diagonalize_nonsym_matrix(N, M, Z, Om, thr_d, thr_nd, thr_deg, imp_bio, verbose) + else - do i = 1, nOO - Om2(i) = Om(i) - do j = 1, nVV - X2(j,i) = Z(j,i) - enddo - do j = 1, nOO - Y2(j,i) = Z(nVV+j,i) - enddo - enddo + thr_d = 1d-6 ! to determine if diagonal elements of L.T x R are close enouph to 1 + thr_nd = 1d-6 ! to determine if non-diagonal elements of L.T x R are close enouph to 1 + thr_deg = 1d-8 ! to determine if two eigenvectors are degenerate or not + imp_bio = .True. ! impose bi-orthogonality + verbose = .False. + call diagonalize_nonsym_matrix(N, M, Z, Om, thr_d, thr_nd, thr_deg, imp_bio, verbose) + + do i = 1, nOO + Om2(i) = Om(i) + do j = 1, nVV + X2(j,i) = Z(j,i) + enddo + do j = 1, nOO + Y2(j,i) = Z(nVV+j,i) + enddo + enddo + + do i = 1, nVV + Om1(i) = Om(nOO+i) + do j = 1, nVV + X1(j,i) = M(j,nOO+i) + enddo + do j = 1, nOO + Y1(j,i) = M(nVV+j,nOO+i) + enddo + enddo - do i = 1, nVV - Om1(i) = Om(nOO+i) - do j = 1, nVV - X1(j,i) = M(j,nOO+i) - enddo - do j = 1, nOO - Y1(j,i) = M(nVV+j,nOO+i) - enddo - enddo + endif end if diff --git a/test/export_tobench.py b/test/export_tobench.py new file mode 100644 index 0000000..526716b --- /dev/null +++ b/test/export_tobench.py @@ -0,0 +1,26 @@ + +import sys + + +def read_quantities_from_file(filename): + quantities = {} + + with open(filename, 'r') as file: + lines = file.readlines() + for i in range(0, len(lines), 2): + # Remove any leading or trailing whitespace/newline characters + quantity_name = lines[i].strip() + quantity_value = float(lines[i+1].strip()) + quantities[quantity_name] = quantity_value + + return quantities + +def print_quantities(quantities): + for key, value in quantities.items(): + print(f'"{key}": {value},') + +filename = sys.argv[1] + +quantities = read_quantities_from_file(filename) +print_quantities(quantities) + diff --git a/tests/create_database.py b/tests/create_database.py index 59cdee2..14ed3f6 100644 --- a/tests/create_database.py +++ b/tests/create_database.py @@ -1,12 +1,39 @@ -import sqlite3 +import argparse from molecule import save_molecules_to_json, load_molecules_from_json -from molecule import create_database, add_molecule_to_db +from molecule import create_database, add_molecule_to_db, remove_database from feather_bench import FeatherBench +parser = argparse.ArgumentParser(description="Benchmark Data Sets") + +parser.add_argument( + '-s', '--set_type', + choices=['light', 'medium', 'heavy'], + default='light', + help="Specify the type of data set: light (default), medium, or heavy." +) + + +args = parser.parse_args() + +if args.set_type == 'light': + bench = 'FeatherBench' + bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench) +elif args.set_type == 'medium': + bench = 'BalanceBench' + bench_title = "\n\nSelected Medium Benchmark: {}\n\n".format(bench) +elif args.set_type == 'heavy': + bench = 'TitanBench' + bench_title = "\n\nSelected Heavy Benchmark: {}\n\n".format(bench) +else: + bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench) + + +db_name = '{}.db'.format(bench) + # Save molecules to JSON #save_molecules_to_json(FeatherBench, 'FeatherBench.json') @@ -15,8 +42,8 @@ from feather_bench import FeatherBench #loaded_molecules = load_molecules_from_json('FeatherBench.json') #print(loaded_molecules) -# Create a database and add molecules -db_name = 'FeatherBench.db' +#remove_database(db_name) + create_database(db_name) for molecule in FeatherBench: add_molecule_to_db(db_name, molecule) diff --git a/tests/feather_bench.py b/tests/feather_bench.py index 1cfd07e..b6d8f26 100644 --- a/tests/feather_bench.py +++ b/tests/feather_bench.py @@ -11,43 +11,35 @@ He = Molecule( properties={ "properties_rhf":{ "6-31g": { - "RHF energy": -2.855160426884076, - "RHF HOMO energy": -0.914126628614305, - "RHF LUMO energy": 1.399859335225087, - "RHF dipole moment": 0.000000000000000, - "RMP2 correlation energy": -0.011200122910187, - "CCD correlation energy": -0.014985063408247, - "DCD correlation energy": -0.014985062907429, - "CCSD correlation energy": -0.015001711549550, - "drCCD correlation energy": -0.018845374502248, - "rCCD correlation energy": -0.016836324636164, - "crCCD correlation energy": 0.008524677369855, - "lCCD correlation energy": -0.008082420815100, - "pCCD correlation energy": -0.014985062519068, - "RCIS singlet excitation energy": 1.911193619935257, - "RCIS triplet excitation energy": 1.455852629402236, - "phRRPA correlation energy": -0.018845374129105, - "phRRPAx correlation energy": -0.015760565121283, - "crRRPA correlation energy": -0.008868581132405, - "ppRRPA correlation energy": -0.008082420815100, - "RG0F2 correlation energy": -0.011438430540374, - "RG0F2 HOMO energy": -0.882696116247871, - "RG0F2 LUMO energy": 1.383080391811630, - "evRGF2 correlation energy": -0.011448483158486, - "evRGF2 HOMO energy": -0.881327878713477, - "evRGF2 LUMO energy": 1.382458968133448, - "RG0W0 correlation energy": -0.019314094399756, - "RG0W0 HOMO energy": -0.870533880190454, - "RG0W0 LUMO energy": 1.377171287010956, - "evRGW correlation energy": -0.019335511771724, - "evRGW HOMO energy": -0.868460640957913, - "evRGW LUMO energy": 1.376287581471769, - "RG0T0pp correlation energy": -0.008082420815100, - "RG0T0pp HOMO energy": -0.914126628614305, - "RG0T0pp LUMO energy": 1.399859335225087, - "evRGTpp correlation energy": -0.008082420815100, - "evRGTpp HOMO energy": -0.914126628614305, - "evRGTpp LUMO energy": 1.399859335225087 + "RHF energy": -2.855160426154444, + "RHF HOMO energy": -0.914126628640145, + "RHF LUMO energy": 1.399859335255765, + "RHF dipole moment": 0.0, + "MP2 correlation energy": -0.011200122909934, + "CCD correlation energy": -0.014985063116, + "CCSD correlation energy": -0.015001711549092, + "drCCD correlation energy": -0.01884537385338, + "rCCD correlation energy": -0.016836322809386, + "crCCD correlation energy": 0.008524676641474, + "lCCD correlation energy": -0.00808242082105, + "CIS singlet excitation energy": 1.911193619991987, + "CIS triplet excitation energy": 1.455852629458543, + "phRPA correlation energy": -0.018845374128748, + "phRPAx correlation energy": -0.015760565120758, + "crRPA correlation energy": -0.008868581132249, + "ppRPA correlation energy": -0.008082420814972, + "G0F2 correlation energy": -0.011438430540104, + "G0F2 HOMO energy": -0.882696116274599, + "G0F2 LUMO energy": 1.383080391842522, + "G0W0 correlation energy": -0.019314094399372, + "G0W0 HOMO energy": -0.87053388021722, + "G0W0 LUMO energy": 1.377171287041735, + "evGW correlation energy": -0.019335511771337, + "evGW HOMO energy": -0.868460640984803, + "evGW LUMO energy": 1.376287581502582, + "G0T0pp correlation energy": -0.008161908540634, + "G0T0pp HOMO energy": -0.898869172597701, + "G0T0pp LUMO energy": 1.383928087417952, } }, "properties_uhf":{ @@ -58,8 +50,51 @@ He = Molecule( "6-31g": { } }, - "properties_rohf":{ - "6-31g": { + } +) + +# --- + +H2O = Molecule( + name="H2O", + multiplicity=1, + geometry=[ + {"element": "O", "x": 0.0000, "y": 0.0000, "z": 0.0000}, + {"element": "H", "x": 0.7571, "y": 0.0000, "z": 0.5861}, + {"element": "H", "x": -0.7571, "y": 0.0000, "z": 0.5861} + ], + properties={ + "properties_rhf":{ + "cc-pvdz": { + "RHF energy": -85.21935817501823, + "RHF HOMO energy": -0.493132793449897, + "RHF LUMO energy": 0.185534869842355, + "RHF dipole moment": 0.233813698748474, + "MP2 correlation energy": -0.203978216774657, + "CCD correlation energy": -0.212571260121257, + "CCSD correlation energy": -0.213302190845899, + "drCCD correlation energy": -0.231281853419338, + "rCCD correlation energy": -0.277238348710547, + "crCCD correlation energy": 0.18014617422324, + "lCCD correlation energy": -0.15128653432796, + "CIS singlet excitation energy": 0.338828950934568, + "CIS triplet excitation energy": 0.304873339484139, + "phRPA correlation energy": -0.231281866582435, + "phRPAx correlation energy": -0.310796738307943, + "crRPA correlation energy": -0.246289801609294, + "ppRPA correlation energy": -0.151286536255888, + "G0F2 correlation energy": -0.217807591229668, + "G0F2 HOMO energy": -0.404541451101377, + "G0F2 LUMO energy": 0.16650398400197, + "G0W0 correlation energy": -0.23853664665404, + "G0W0 HOMO energy": -0.446828623007469, + "G0W0 LUMO energy": 0.173026609033024, + "evGW correlation energy": -0.239414217281308, + "evGW HOMO energy": -0.443076613314424, + "evGW LUMO energy": 0.172691758111392, + "G0T0pp correlation energy": -0.156214864467344, + "G0T0pp HOMO energy": -0.452117482732615, + "G0T0pp LUMO energy": 0.16679206983464, } } } @@ -67,24 +102,9 @@ He = Molecule( # --- -#H2O = Molecule( -# name="H2O", -# multiplicity=1, -# geometry=[ -# {"element": "O", "x": 0.0000, "y": 0.0000, "z": 0.0000}, -# {"element": "H", "x": 0.7571, "y": 0.0000, "z": 0.5861}, -# {"element": "H", "x": -0.7571, "y": 0.0000, "z": 0.5861} -# ], -# properties={ -# "cc-pvdz": { -# } -#) - -# --- - FeatherBench = [ He, - #H2O + H2O ] diff --git a/tests/inp/methods.RHF b/tests/inp/methods.RHF index e315154..2ddb2bb 100644 --- a/tests/inp/methods.RHF +++ b/tests/inp/methods.RHF @@ -3,7 +3,7 @@ # MP2 MP3 T T # CCD pCCD DCD CCSD CCSD(T) - T T T T F + T F F T F # drCCD rCCD crCCD lCCD T T T T # CIS CIS(D) CID CISD FCI @@ -11,11 +11,11 @@ # phRPA phRPAx crRPA ppRPA T T T T # G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3 - T T F F F F + T F F F F F # G0W0 evGW qsGW SRG-qsGW ufG0W0 ufGW T T F F F F # G0T0pp evGTpp qsGTpp ufG0T0pp - T T F F + T F F F # G0T0eh evGTeh qsGTeh F F F # Rtest Utest Gtest diff --git a/tests/lunch_bench.py b/tests/lunch_bench.py index 69a6093..f9e52d7 100644 --- a/tests/lunch_bench.py +++ b/tests/lunch_bench.py @@ -181,7 +181,7 @@ class Quack_Job: if(diff <= THRESH): print_col(f" 🙂 {key}: ✔️ ", "green") else: - print_col(f" ☹️ {key}: ❌ {data_ref[key]} ≠ {data_new[key]}", "red") + print_col(f" ☹️ {key}: ❌ {data_ref[key]} ≠ {data_new[key]}", "red") except FileNotFoundError: print_col(f"Error: The file '{filepath}' does not exist.", "red") sys.exist(1) diff --git a/tests/molecule.py b/tests/molecule.py index 147c53e..b5f33eb 100644 --- a/tests/molecule.py +++ b/tests/molecule.py @@ -1,7 +1,11 @@ +import os import json import sqlite3 +from utils import print_col + + class Molecule: def __init__(self, name, multiplicity, geometry, properties): self.name = name @@ -38,23 +42,64 @@ def load_molecules_from_json(filename): def create_database(db_name): - conn = sqlite3.connect(db_name) - cursor = conn.cursor() - cursor.execute('''CREATE TABLE IF NOT EXISTS molecules - (name TEXT, multiplicity INTEGER, geometry TEXT, properties TEXT)''') - conn.commit() - conn.close() + if os.path.exists(db_name): + conn = sqlite3.connect(db_name) + cursor = conn.cursor() + # Check if the table already exists + cursor.execute("SELECT name FROM sqlite_master WHERE type='table' AND name='molecules';") + table_exists = cursor.fetchone() + + if table_exists: + print_col(f"Database '{db_name}' already exists and table 'molecules' is already created.", "yellow") + else: + # Create the table if it does not exist + cursor.execute('''CREATE TABLE molecules + (name TEXT, multiplicity INTEGER, geometry TEXT, properties TEXT)''') + conn.commit() + print_col(f"Table 'molecules' created in existing database '{db_name}' successfully.", "green") + conn.close() + else: + # Create the database and table + conn = sqlite3.connect(db_name) + cursor = conn.cursor() + cursor.execute('''CREATE TABLE molecules + (name TEXT, multiplicity INTEGER, geometry TEXT, properties TEXT)''') + conn.commit() + conn.close() + print_col(f"Database '{db_name}' created and table 'molecules' added successfully.", "green") def add_molecule_to_db(db_name, molecule): + conn = sqlite3.connect(db_name) cursor = conn.cursor() + + # Convert geometry and properties to JSON strings geometry_str = json.dumps(molecule.geometry) energies_str = json.dumps(molecule.properties) - cursor.execute("INSERT INTO molecules VALUES (?, ?, ?, ?)", - (molecule.name, molecule.multiplicity, geometry_str, energies_str)) - conn.commit() + + # Check if the molecule already exists + cursor.execute("SELECT COUNT(*) FROM molecules WHERE name = ?", (molecule.name,)) + count = cursor.fetchone()[0] + + if count > 0: + print_col(f"Molecule '{molecule.name}' already exists in {db_name}.", "yellow") + else: + # Insert the molecule if it does not exist + cursor.execute("INSERT INTO molecules (name, multiplicity, geometry, properties) VALUES (?, ?, ?, ?)", + (molecule.name, molecule.multiplicity, geometry_str, energies_str)) + conn.commit() + print_col(f"'{molecule.name}' added to {db_name} successfully.", "green") + conn.close() + +def remove_database(db_name): + if os.path.exists(db_name): + os.remove(db_name) + print_col(f"Database '{db_name}' removed successfully.", "red") + else: + print_col(f"Database '{db_name}' does not exist.", "red") + def get_molecules_from_db(db_name): conn = sqlite3.connect(db_name) cursor = conn.cursor() From a44839e67d20797bdda66e7dc8d147082fdc69d3 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Fri, 30 Aug 2024 20:38:00 +0200 Subject: [PATCH 41/46] absolute path for bench --- tests/lunch_bench.py | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/tests/lunch_bench.py b/tests/lunch_bench.py index f9e52d7..be543b5 100644 --- a/tests/lunch_bench.py +++ b/tests/lunch_bench.py @@ -60,7 +60,7 @@ parser.add_argument( parser.add_argument( '-t', '--thresh', type=float, - default=1e-8, + default=1e-7, help='Threshold for acceptable difference (default: 1e-8)' ) @@ -101,13 +101,14 @@ class Quack_Job: def prep_inp(self): # geometry - generate_xyz(self.geom, filename="{}.xyz".format(self.mol)) + generate_xyz(self.geom, filename="{}/mol/{}.xyz".format(quack_root, self.mol)) # input files for inp in ["methods", "options"]: inp_file = "{}.{}".format(inp, self.methd.upper()) if os.path.exists("inp/{}".format(inp_file)): - shutil.copy("inp/{}".format(inp_file), "../mol/{}".format(inp_file)) + shutil.copy("{}/tests/inp/{}".format(quack_root, inp_file), + "{}/input/{}".format(quack_root, inp)) else: print_col("File 'inp/{}' does not exist.".format(inp_file), "red") sys.exit(1) @@ -184,10 +185,10 @@ class Quack_Job: print_col(f" ☹️ {key}: ❌ {data_ref[key]} ≠ {data_new[key]}", "red") except FileNotFoundError: print_col(f"Error: The file '{filepath}' does not exist.", "red") - sys.exist(1) + sys.exit(1) except Exception as e: print_col(f"An error occurred: {str(e)}", "red") - sys.exist(1) + sys.exit(1) # --- From 294ff753ac68f9d57eee4f567ae369ffed60dd0e Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Sat, 31 Aug 2024 13:30:34 +0200 Subject: [PATCH 42/46] few modifs --- src/utils/non_sym_diag.f90 | 4 ++-- tests/lunch_bench.py | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/utils/non_sym_diag.f90 b/src/utils/non_sym_diag.f90 index 04279ac..0f44099 100644 --- a/src/utils/non_sym_diag.f90 +++ b/src/utils/non_sym_diag.f90 @@ -3,7 +3,7 @@ subroutine diagonalize_nonsym_matrix(N, A, L, e_re, thr_d, thr_nd, thr_deg, imp_bio, verbose) - ! Diagonalize a non-symmetric matrix + ! Diagonalize a non-symmetric matrix A ! ! Output ! right-eigenvectors are saved in A @@ -278,7 +278,7 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot) do i = 1, m if(S(i,i) <= 0.d0) then - print *, ' overap negative' + print *, ' negative overlap !' print *, i, S(i,i) exit endif diff --git a/tests/lunch_bench.py b/tests/lunch_bench.py index be543b5..02d6db5 100644 --- a/tests/lunch_bench.py +++ b/tests/lunch_bench.py @@ -123,7 +123,7 @@ class Quack_Job: sys.stdout.flush() idx = (idx + 1) % len(spinner) time.sleep(0.05) - stdout_col(f'\r Testing {self.methd} ({self.basis}) \n', "cyan") + stdout_col(f'\r Testing {self.methd} ({self.basis}) \n\n', "cyan") done_event = threading.Event() spinner_thread = threading.Thread(target=display_spinner) @@ -180,7 +180,7 @@ class Quack_Job: else: diff = abs(data_new[key] - data_ref[key]) / (1e-15 + abs(data_ref[key])) if(diff <= THRESH): - print_col(f" 🙂 {key}: ✔️ ", "green") + print_col(f" 🙂 {key}", "green") else: print_col(f" ☹️ {key}: ❌ {data_ref[key]} ≠ {data_new[key]}", "red") except FileNotFoundError: From 5925fb73bcb6188d34286380d4fc6f8c753a5175 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Sun, 1 Sep 2024 13:50:29 +0200 Subject: [PATCH 43/46] RHF in nOrb representation has been tested --- src/AOtoMO/AOtoMO.f90 | 36 +++++----- src/AOtoMO/AOtoMO_ERI_RHF.f90 | 40 ++++++------ src/AOtoMO/MOtoAO.f90 | 51 ++++++--------- src/CC/RCC.f90 | 28 ++++---- src/CC/pCCD.f90 | 14 ++-- src/CI/RCI.f90 | 18 ++--- src/GF/RGF.f90 | 40 ++++++------ src/GF/print_qsRGF2.f90 | 20 +++--- src/GF/qsRGF2.f90 | 96 +++++++++++++-------------- src/GT/RGT.f90 | 42 ++++++------ src/GT/print_qsRGTeh.f90 | 20 +++--- src/GT/print_qsRGTpp.f90 | 20 +++--- src/GT/qsRGTeh.f90 | 100 ++++++++++++++-------------- src/GT/qsRGTpp.f90 | 120 +++++++++++++++++----------------- src/GW/RGW.f90 | 40 ++++++------ src/GW/SRG_qsGW.f90 | 106 +++++++++++++++--------------- src/GW/print_qsRGW.f90 | 20 +++--- src/GW/qsRGW.f90 | 106 +++++++++++++++--------------- src/HF/RHF.f90 | 95 +++++++++++++++------------ src/HF/RHF_search.f90 | 44 ++++++------- src/HF/ROHF.f90 | 82 +++++++++++------------ src/HF/ROHF_fock_matrix.f90 | 28 ++++---- src/HF/core_guess.f90 | 14 ++-- src/HF/huckel_guess.f90 | 20 +++--- src/HF/mo_guess.f90 | 16 ++--- src/HF/print_RHF.f90 | 12 ++-- src/HF/print_ROHF.f90 | 14 ++-- src/QuAcK/QuAcK.f90 | 84 +++++++++++++++--------- src/QuAcK/RQuAcK.f90 | 54 +++++++-------- src/utils/level_shifting.f90 | 14 ++-- 30 files changed, 709 insertions(+), 685 deletions(-) diff --git a/src/AOtoMO/AOtoMO.f90 b/src/AOtoMO/AOtoMO.f90 index 8c5ce8f..8383273 100644 --- a/src/AOtoMO/AOtoMO.f90 +++ b/src/AOtoMO/AOtoMO.f90 @@ -1,36 +1,30 @@ -subroutine AOtoMO(nBas_AOs, nBas_MOs, C, M_AOs, M_MOs) +subroutine AOtoMO(nBas, nOrb, C, M_AOs, M_MOs) -! Perform AO to MO transformation of a matrix M_AOs for given coefficients c -! M_MOs = C.T M_AOs C + ! Perform AO to MO transformation of a matrix M_AOs for given coefficients c + ! M_MOs = C.T M_AOs C implicit none -! Input variables + integer, intent(in) :: nBas, nOrb + double precision, intent(in) :: C(nBas,nOrb) + double precision, intent(in) :: M_AOs(nBas,nBas) - integer,intent(in) :: nBas_AOs, nBas_MOs - double precision,intent(in) :: C(nBas_AOs,nBas_MOs) - double precision,intent(in) :: M_AOs(nBas_AOs,nBas_AOs) + double precision, intent(out) :: M_MOs(nOrb,nOrb) -! Local variables + double precision, allocatable :: AC(:,:) - double precision,allocatable :: AC(:,:) - -! Output variables - - double precision,intent(out) :: M_MOs(nBas_MOs,nBas_MOs) - - allocate(AC(nBas_AOs,nBas_MOs)) + allocate(AC(nBas,nOrb)) !AC = matmul(M_AOs, C) !M_MOs = matmul(transpose(C), AC) - call dgemm("N", "N", nBas_AOs, nBas_MOs, nBas_AOs, 1.d0, & - M_AOs(1,1), nBas_AOs, C(1,1), nBas_AOs, & - 0.d0, AC(1,1), nBas_AOs) + call dgemm("N", "N", nBas, nOrb, nBas, 1.d0, & + M_AOs(1,1), nBas, C(1,1), nBas, & + 0.d0, AC(1,1), nBas) - call dgemm("T", "N", nBas_MOs, nBas_MOs, nBas_AOs, 1.d0, & - C(1,1), nBas_AOs, AC(1,1), nBas_AOs, & - 0.d0, M_MOs(1,1), nBas_MOs) + call dgemm("T", "N", nOrb, nOrb, nBas, 1.d0, & + C(1,1), nBas, AC(1,1), nBas, & + 0.d0, M_MOs(1,1), nOrb) deallocate(AC) diff --git a/src/AOtoMO/AOtoMO_ERI_RHF.f90 b/src/AOtoMO/AOtoMO_ERI_RHF.f90 index 6b1b95b..f9f64a2 100644 --- a/src/AOtoMO/AOtoMO_ERI_RHF.f90 +++ b/src/AOtoMO/AOtoMO_ERI_RHF.f90 @@ -1,7 +1,7 @@ ! --- -subroutine AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) +subroutine AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) ! AO to MO transformation of two-electron integrals via the semi-direct O(N^5) algorithm @@ -10,9 +10,9 @@ subroutine AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + integer,intent(in) :: nBas, nOrb + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: c(nBas,nOrb) ! Local variables @@ -21,35 +21,35 @@ subroutine AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) ! Output variables - double precision,intent(out) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(out) :: ERI_MO(nOrb,nOrb,nOrb,nOrb) ! Memory allocation - allocate(a2(nBas_AOs,nBas_AOs,nBas_AOs,nBas_MOs)) - allocate(a1(nBas_AOs,nBas_AOs,nBas_MOs,nBas_MOs)) + allocate(a2(nBas,nBas,nBas,nOrb)) + allocate(a1(nBas,nBas,nOrb,nOrb)) ! Four-index transform via semi-direct O(N^5) algorithm - call dgemm( 'T', 'N', nBas_AOs*nBas_AOs*nBas_AOs, nBas_MOs, nBas_AOs, 1.d0 & - , ERI_AO(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & - , 0.d0, a2(1,1,1,1), nBas_AOs*nBas_AOs*nBas_AOs) + call dgemm( 'T', 'N', nBas*nBas*nBas, nOrb, nBas, 1.d0 & + , ERI_AO(1,1,1,1), nBas, c(1,1), nBas & + , 0.d0, a2(1,1,1,1), nBas*nBas*nBas) - call dgemm( 'T', 'N', nBas_AOs*nBas_AOs*nBas_MOs, nBas_MOs, nBas_AOs, 1.d0 & - , a2(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & - , 0.d0, a1(1,1,1,1), nBas_AOs*nBas_AOs*nBas_MOs) + call dgemm( 'T', 'N', nBas*nBas*nOrb, nOrb, nBas, 1.d0 & + , a2(1,1,1,1), nBas, c(1,1), nBas & + , 0.d0, a1(1,1,1,1), nBas*nBas*nOrb) deallocate(a2) - allocate(a2(nBas_AOs,nBas_MOs,nBas_MOs,nBas_MOs)) + allocate(a2(nBas,nOrb,nOrb,nOrb)) - call dgemm( 'T', 'N', nBas_AOs*nBas_MOs*nBas_MOs, nBas_MOs, nBas_AOs, 1.d0 & - , a1(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & - , 0.d0, a2(1,1,1,1), nBas_AOs*nBas_MOs*nBas_MOs) + call dgemm( 'T', 'N', nBas*nOrb*nOrb, nOrb, nBas, 1.d0 & + , a1(1,1,1,1), nBas, c(1,1), nBas & + , 0.d0, a2(1,1,1,1), nBas*nOrb*nOrb) deallocate(a1) - call dgemm( 'T', 'N', nBas_MOs*nBas_MOs*nBas_MOs, nBas_MOs, nBas_AOs, 1.d0 & - , a2(1,1,1,1), nBas_AOs, c(1,1), nBas_AOs & - , 0.d0, ERI_MO(1,1,1,1), nBas_MOs*nBas_MOs*nBas_MOs) + call dgemm( 'T', 'N', nOrb*nOrb*nOrb, nOrb, nBas, 1.d0 & + , a2(1,1,1,1), nBas, c(1,1), nBas & + , 0.d0, ERI_MO(1,1,1,1), nOrb*nOrb*nOrb) deallocate(a2) diff --git a/src/AOtoMO/MOtoAO.f90 b/src/AOtoMO/MOtoAO.f90 index 06abb38..a5ffaed 100644 --- a/src/AOtoMO/MOtoAO.f90 +++ b/src/AOtoMO/MOtoAO.f90 @@ -1,47 +1,38 @@ -subroutine MOtoAO(nBas_AOs, nBas_MOs, S, C, M_MOs, M_AOs) +subroutine MOtoAO(nBas, nOrb, S, C, M_MOs, M_AOs) -! Perform MO to AO transformation of a matrix M_AOs for a given metric S -! and coefficients c -! -! M_AOs = S C M_MOs (S C).T -! + ! Perform MO to AO transformation of a matrix M_AOs for a given metric S + ! and coefficients c + ! + ! M_AOs = S C M_MOs (S C).T implicit none -! Input variables + integer, intent(in) :: nBas, nOrb + double precision, intent(in) :: S(nBas,nBas) + double precision, intent(in) :: C(nBas,nOrb) + double precision, intent(in) :: M_MOs(nOrb,nOrb) + double precision, intent(out) :: M_AOs(nBas,nBas) - integer,intent(in) :: nBas_AOs, nBas_MOs - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: C(nBas_AOs,nBas_MOs) - double precision,intent(in) :: M_MOs(nBas_MOs,nBas_MOs) + double precision, allocatable :: SC(:,:),BSC(:,:) -! Local variables - double precision,allocatable :: SC(:,:),BSC(:,:) - -! Output variables - - double precision,intent(out) :: M_AOs(nBas_AOs,nBas_AOs) - -! Memory allocation - - allocate(SC(nBas_AOs,nBas_MOs), BSC(nBas_MOs,nBas_AOs)) + allocate(SC(nBas,nOrb), BSC(nOrb,nBas)) !SC = matmul(S, C) !BSC = matmul(M_MOs, transpose(SC)) !M_AOs = matmul(SC, BSC) - call dgemm("N", "N", nBas_AOs, nBas_MOs, nBas_AOs, 0.d0, & - S(1,1), nBas_AOs, C(1,1), nBas_AOs, & - 1.d0, SC(1,1), nBas_AOs) + call dgemm("N", "N", nBas, nOrb, nBas, 1.d0, & + S(1,1), nBas, C(1,1), nBas, & + 0.d0, SC(1,1), nBas) - call dgemm("N", "T", nBas_MOs, nBas_AOs, nBas_MOs, 0.d0, & - M_MOs(1,1), nBas_MOs, SC(1,1), nBas_AOs, & - 1.d0, BSC(1,1), nBas_MOs) + call dgemm("N", "T", nOrb, nBas, nOrb, 1.d0, & + M_MOs(1,1), nOrb, SC(1,1), nBas, & + 0.d0, BSC(1,1), nOrb) - call dgemm("N", "N", nBas_AOs, nBas_AOs, nBas_MOs, 0.d0, & - SC(1,1), nBas_AOs, BSC(1,1), nBas_MOs, & - 1.d0, M_AOs(1,1), nBas_AOs) + call dgemm("N", "N", nBas, nBas, nOrb, 1.d0, & + SC(1,1), nBas, BSC(1,1), nOrb, & + 0.d0, M_AOs(1,1), nBas) deallocate(SC, BSC) diff --git a/src/CC/RCC.f90 b/src/CC/RCC.f90 index a95121b..57538ea 100644 --- a/src/CC/RCC.f90 +++ b/src/CC/RCC.f90 @@ -2,7 +2,7 @@ ! --- subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, docrCCD, dolCCD, & - maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) + maxSCF, thresh, max_diis, nBas, nOrb, nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) ! Coupled-cluster module @@ -27,17 +27,17 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d integer,intent(in) :: max_diis double precision,intent(in) :: thresh - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: ERI(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) ! Local variables @@ -50,7 +50,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(doCCD) then call wall_time(start_CC) - call CCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call CCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -66,7 +66,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(doDCD) then call wall_time(start_CC) - call DCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call DCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -84,7 +84,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(doCCSD) then call wall_time(start_CC) - call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -100,7 +100,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(dodrCCD) then call wall_time(start_CC) - call drCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call drCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -116,7 +116,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(dorCCD) then call wall_time(start_CC) - call rCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call rCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -132,7 +132,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(docrCCD) then call wall_time(start_CC) - call crCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call crCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -148,7 +148,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(dolCCD) then call wall_time(start_CC) - call lCCD(dotest,maxSCF,thresh,max_diis,nBas_MOs,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call lCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -164,7 +164,7 @@ subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, d if(dopCCD) then call wall_time(start_CC) - call pCCD(dotest, maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, & + call pCCD(dotest, maxSCF, thresh, max_diis, nBas, nOrb, & nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) call wall_time(end_CC) diff --git a/src/CC/pCCD.f90 b/src/CC/pCCD.f90 index 2f5afb2..7dfd3cd 100644 --- a/src/CC/pCCD.f90 +++ b/src/CC/pCCD.f90 @@ -1,7 +1,7 @@ ! --- -subroutine pCCD(dotest, maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, & +subroutine pCCD(dotest, maxSCF, thresh, max_diis, nBas, nOrb, & nC, nO, nV, nR, Hc, ERI, ENuc, ERHF, eHF, cHF) ! pair CCD module @@ -16,12 +16,12 @@ subroutine pCCD(dotest, maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, & integer,intent(in) :: max_diis double precision,intent(in) :: thresh - integer,intent(in) :: nBas_AOs, nBas_MOs, nC, nO, nV, nR + integer,intent(in) :: nBas, nOrb, nC, nO, nV, nR double precision,intent(in) :: ENuc,ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: ERI(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) ! Local variables @@ -94,7 +94,7 @@ subroutine pCCD(dotest, maxSCF, thresh, max_diis, nBas_AOs, nBas_MOs, & allocate(eO(O),eV(V),delta_OV(O,V)) eO(:) = eHF(nC+1:nO) - eV(:) = eHF(nO+1:nBas_MOs-nR) + eV(:) = eHF(nO+1:nOrb-nR) call form_delta_OV(nC,nO,nV,nR,eO,eV,delta_OV) diff --git a/src/CI/RCI.f90 b/src/CI/RCI.f90 index 1d068f3..3a9905e 100644 --- a/src/CI/RCI.f90 +++ b/src/CI/RCI.f90 @@ -1,7 +1,7 @@ ! --- -subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nBas_MOs, & +subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nOrb, & nC, nO, nV, nR, nS, ERI, dipole_int, epsHF, EHF) ! Configuration interaction module @@ -21,16 +21,16 @@ subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, n logical,intent(in) :: singlet logical,intent(in) :: triplet - integer,intent(in) :: nBas_MOs + integer,intent(in) :: nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: EHF - double precision,intent(in) :: epsHF(nBas_MOs) - double precision,intent(in) :: ERI(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: epsHF(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int(nOrb,nOrb,ncart) ! Local variables @@ -43,7 +43,7 @@ subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, n if(doCIS) then call wall_time(start_CI) - call RCIS(dotest,singlet,triplet,doCIS_D,nBas_MOs,nC,nO,nV,nR,nS,ERI,dipole_int,epsHF) + call RCIS(dotest,singlet,triplet,doCIS_D,nOrb,nC,nO,nV,nR,nS,ERI,dipole_int,epsHF) call wall_time(end_CI) t_CI = end_CI - start_CI @@ -59,7 +59,7 @@ subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, n if(doCID) then call wall_time(start_CI) - call CID(dotest,singlet,triplet,nBas_MOs,nC,nO,nV,nR,ERI,epsHF,EHF) + call CID(dotest,singlet,triplet,nOrb,nC,nO,nV,nR,ERI,epsHF,EHF) call wall_time(end_CI) t_CI = end_CI - start_CI @@ -75,7 +75,7 @@ subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, n if(doCISD) then call wall_time(start_CI) - call CISD(dotest,singlet,triplet,nBas_MOs,nC,nO,nV,nR,ERI,epsHF,EHF) + call CISD(dotest,singlet,triplet,nOrb,nC,nO,nV,nR,ERI,epsHF,EHF) call wall_time(end_CI) t_CI = end_CI - start_CI @@ -92,7 +92,7 @@ subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, n call wall_time(start_CI) write(*,*) ' FCI is not yet implemented! Sorry.' -! call FCI(nBas_MOs,nC,nO,nV,nR,ERI,epsHF) +! call FCI(nOrb,nC,nO,nV,nR,ERI,epsHF) call wall_time(end_CI) t_CI = end_CI - start_CI diff --git a/src/GF/RGF.f90 b/src/GF/RGF.f90 index 72911e4..0f1deaf 100644 --- a/src/GF/RGF.f90 +++ b/src/GF/RGF.f90 @@ -3,7 +3,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, renorm, maxSCF, & thresh, max_diis, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, linearize, & - eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, EHF, & + eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, EHF, & S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, epsHF) ! Green's function module @@ -42,7 +42,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -50,18 +50,18 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren integer,intent(in) :: nS double precision,intent(in) :: EHF - double precision,intent(in) :: epsHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(in) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: epsHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables @@ -75,7 +75,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren call wall_time(start_GF) call RG0F2(dotest, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, & - linearize, eta, regularize, nBas_MOs, nC, nO, nV, nR, nS, & + linearize, eta, regularize, nOrb, nC, nO, nV, nR, nS, & ENuc, EHF, ERI_MO, dipole_int_MO, epsHF) call wall_time(end_GF) @@ -93,7 +93,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren call wall_time(start_GF) call evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis, & - singlet,triplet,linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,EHF, & + singlet,triplet,linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,EHF, & ERI_MO,dipole_int_MO,epsHF) call wall_time(end_GF) @@ -112,7 +112,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren call wall_time(start_GF) call qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, & - rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, EHF, S, & + rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, EHF, S, & X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, epsHF) call wall_time(end_GF) @@ -129,7 +129,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren if(doufG0F02) then call wall_time(start_GF) - call ufRG0F02(dotest, nBas_MOs, nC, nO, nV, nR, nS, ENuc, EHF, ERI_MO, epsHF) + call ufRG0F02(dotest, nOrb, nC, nO, nV, nR, nS, ENuc, EHF, ERI_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF @@ -145,7 +145,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren if(doG0F3) then call wall_time(start_GF) - call RG0F3(dotest, renorm, nBas_MOs, nC, nO, nV, nR, ERI_MO, epsHF) + call RG0F3(dotest, renorm, nOrb, nC, nO, nV, nR, ERI_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF @@ -161,7 +161,7 @@ subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, ren if(doevGF3) then call wall_time(start_GF) - call evRGF3(dotest, maxSCF, thresh, max_diis, renorm, nBas_MOs, nC, nO, nV, nR, ERI_MO, epsHF) + call evRGF3(dotest, maxSCF, thresh, max_diis, renorm, nOrb, nC, nO, nV, nR, ERI_MO, epsHF) call wall_time(end_GF) t_GF = end_GF - start_GF diff --git a/src/GF/print_qsRGF2.f90 b/src/GF/print_qsRGF2.f90 index 42132c0..feb590f 100644 --- a/src/GF/print_qsRGF2.f90 +++ b/src/GF/print_qsRGF2.f90 @@ -1,7 +1,7 @@ ! --- -subroutine print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, c, & +subroutine print_qsRGF2(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGF, c, & SigC, Z, ENuc, ET, EV, EJ, Ex, Ec, EqsGF, dipole) ! Print one-electron energies and other stuff for qsGF2 @@ -11,17 +11,17 @@ subroutine print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, c, ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: eGF(nBas_MOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) - double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) - double precision,intent(in) :: Z(nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: eGF(nOrb) + double precision,intent(in) :: c(nBas,nOrb) + double precision,intent(in) :: SigC(nOrb,nOrb) + double precision,intent(in) :: Z(nOrb) double precision,intent(in) :: ET double precision,intent(in) :: EV double precision,intent(in) :: EJ @@ -57,7 +57,7 @@ subroutine print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, c, '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do q = 1, nBas_MOs + do q = 1, nOrb 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)') & '|',q,'|',eHF(q)*HaToeV,'|',SigC(q,q)*HaToeV,'|',Z(q),'|',eGF(q)*HaToeV,'|' end do @@ -106,12 +106,12 @@ subroutine print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, c, write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGF2 MO coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas_AOs, nBas_MOs, c) + call matout(nBas, nOrb, c) write(*,*) write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGF2 MO energies' write(*,'(A50)') '---------------------------------------' - call matout(nBas_MOs, 1, eGF) + call matout(nOrb, 1, eGF) write(*,*) end if diff --git a/src/GF/qsRGF2.f90 b/src/GF/qsRGF2.f90 index 4287676..651c876 100644 --- a/src/GF/qsRGF2.f90 +++ b/src/GF/qsRGF2.f90 @@ -3,7 +3,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, & - rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, & + rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, & S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GF2 calculation @@ -33,25 +33,25 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs,nBas_MOs,nC,nO,nV,nR,nS + integer,intent(in) :: nBas,nOrb,nC,nO,nV,nR,nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: ispin integer :: n_diis double precision :: EqsGF2 @@ -98,7 +98,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Stuff - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! TDA @@ -109,27 +109,27 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Memory allocation - allocate(eGF(nBas_MOs)) - allocate(eOld(nBas_MOs)) + allocate(eGF(nOrb)) + allocate(eOld(nOrb)) - allocate(c(nBas_AOs,nBas_MOs)) + allocate(c(nBas,nOrb)) - allocate(cp(nBas_MOs,nBas_MOs)) - allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(cp(nOrb,nOrb)) + allocate(Fp(nOrb,nOrb)) - allocate(P(nBas_AOs,nBas_AOs)) - allocate(F(nBas_AOs,nBas_AOs)) - allocate(J(nBas_AOs,nBas_AOs)) - allocate(K(nBas_AOs,nBas_AOs)) - allocate(error(nBas_AOs,nBas_AOs)) + allocate(P(nBas,nBas)) + allocate(F(nBas,nBas)) + allocate(J(nBas,nBas)) + allocate(K(nBas,nBas)) + allocate(error(nBas,nBas)) - allocate(Z(nBas_MOs)) - allocate(SigC(nBas_MOs,nBas_MOs)) + allocate(Z(nOrb)) + allocate(SigC(nOrb,nOrb)) - allocate(SigCp(nBas_AOs,nBas_AOs)) + allocate(SigCp(nBas,nBas)) - allocate(error_diis(nBas_AOs_Sq,max_diis)) - allocate(F_diis(nBas_AOs_Sq,max_diis)) + allocate(error_diis(nBas_Sq,max_diis)) + allocate(F_diis(nBas_Sq,max_diis)) ! Initialization @@ -157,25 +157,25 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Buid Hartree matrix - call Hartree_matrix_AO_basis(nBas_AOs, P, ERI_AO, J) + call Hartree_matrix_AO_basis(nBas, P, ERI_AO, J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas_AOs, P, ERI_AO, K) + call exchange_matrix_AO_basis(nBas, P, ERI_AO, K) ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) ! Compute self-energy and renormalization factor if(regularize) then - call GF2_reg_self_energy(eta, nBas_MOs, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z) + call GF2_reg_self_energy(eta, nOrb, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z) else - call GF2_self_energy(eta, nBas_MOs, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z) + call GF2_self_energy(eta, nOrb, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z) end if @@ -183,7 +183,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & SigC = 0.5d0*(SigC + transpose(SigC)) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, SigC, SigCp) + call MOtoAO(nBas, nOrb, S, c, SigC, SigCp) ! Solve the quasi-particle equation @@ -197,7 +197,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & n_diis = min(n_diis+1, max_diis) if(abs(rcond) > 1d-7) then - call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,error_diis,F_diis,error,F) + call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,error_diis,F_diis,error,F) else n_diis = 0 end if @@ -206,7 +206,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eGF) + call diagonalize_matrix(nOrb, cp, eGF) c = matmul(X, cp) ! Compute new density matrix in the AO basis @@ -224,23 +224,23 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Kinetic energy - ET = trace_matrix(nBas_AOs, matmul(P, T)) + ET = trace_matrix(nBas, matmul(P, T)) ! Potential energy - EV = trace_matrix(nBas_AOs, matmul(P, V)) + EV = trace_matrix(nBas, matmul(P, V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas_AOs, matmul(P, J)) + EJ = 0.5d0*trace_matrix(nBas, matmul(P, J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas_AOs, matmul(P, K)) + Ex = 0.25d0*trace_matrix(nBas, matmul(P, K)) ! Correlation energy - call RMP2(.false., regularize, nBas_MOs, nC, nO, nV, nR, ERI_MO, ENuc, EqsGF2, eGF, Ec) + call RMP2(.false., regularize, nOrb, nC, nO, nV, nR, ERI_MO, ENuc, EqsGF2, eGF, Ec) ! Total energy @@ -251,8 +251,8 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Print results !------------------------------------------------------------------------ - call dipole_moment(nBas_AOs, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole) - call print_qsRGF2(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGF, & + call dipole_moment(nBas, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole) + call print_qsRGF2(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGF, & c, SigC, Z, ENuc, ET, EV, EJ, Ex, Ec, EqsGF2, dipole) end do @@ -283,7 +283,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & if(dophBSE) then - call GF2_phBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, nC, nO, & + call GF2_phBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, nC, nO, & nV, nR, nS, ERI_MO, dipole_int_MO, eGF, EcBSE) write(*,*) @@ -302,7 +302,7 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & if(doppBSE) then - call GF2_ppBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, & + call GF2_ppBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, & nC, nO, nV, nR, ERI_MO, dipole_int_MO, eGF, EcBSE) write(*,*) diff --git a/src/GT/RGT.f90 b/src/GT/RGT.f90 index a4f46b6..74d1d12 100644 --- a/src/GT/RGT.f90 +++ b/src/GT/RGT.f90 @@ -4,7 +4,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevGTeh, doqsGTeh, & maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, & doppBSE, TDA_T, TDA, dBSE, dTDA, singlet, triplet, linearize, eta, regularize, & - nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, & + nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, & V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! T-matrix module @@ -48,7 +48,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -56,18 +56,18 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(in) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables @@ -82,7 +82,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG call wall_time(start_GT) call RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT @@ -99,7 +99,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG call wall_time(start_GT) call evRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet, & - linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT @@ -116,7 +116,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG call wall_time(start_GT) call qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, TDA_T, TDA, dBSE, & - dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, & + dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, & nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GT) @@ -133,7 +133,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG if(doufG0T0pp) then call wall_time(start_GT) - call ufG0T0pp(dotest,TDA_T,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) + call ufG0T0pp(dotest,TDA_T,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT @@ -150,7 +150,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG call wall_time(start_GT) call RG0T0eh(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT @@ -167,7 +167,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG call wall_time(start_GT) call evRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,doppBSE, & - singlet,triplet,linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + singlet,triplet,linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GT) t_GT = end_GT - start_GT @@ -185,7 +185,7 @@ subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevG call wall_time(start_GT) call qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, & dophBSE2, TDA_T, TDA, dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, & - ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, & + ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, & Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GT) diff --git a/src/GT/print_qsRGTeh.f90 b/src/GT/print_qsRGTeh.f90 index 72ffe99..e1e4f95 100644 --- a/src/GT/print_qsRGTeh.f90 +++ b/src/GT/print_qsRGTeh.f90 @@ -1,7 +1,7 @@ ! --- -subroutine print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, & +subroutine print_qsRGTeh(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, & Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole) ! Print one-electron energies and other stuff for qsGTeh @@ -11,7 +11,7 @@ subroutine print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc @@ -23,11 +23,11 @@ subroutine print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c double precision,intent(in) :: EcRPA(nspin) double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: eGT(nBas_MOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) - double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) - double precision,intent(in) :: Z(nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: eGT(nOrb) + double precision,intent(in) :: c(nBas,nOrb) + double precision,intent(in) :: SigC(nOrb,nOrb) + double precision,intent(in) :: Z(nOrb) double precision,intent(in) :: EqsGT double precision,intent(in) :: dipole(ncart) @@ -62,7 +62,7 @@ subroutine print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c '|','#','|','e_HF (eV)','|','Sig_GTeh (eV)','|','Z','|','e_GTeh (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do p=1,nBas_MOs + do p=1,nOrb 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)') & '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGT(p)*HaToeV,'|' end do @@ -113,13 +113,13 @@ subroutine print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTeh MO coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas_AOs, nBas_MOs, c) + call matout(nBas, nOrb, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTeh MO energies' write(*,'(A50)') '---------------------------------------' - call vecout(nBas_MOs, eGT) + call vecout(nOrb, eGT) write(*,*) end if diff --git a/src/GT/print_qsRGTpp.f90 b/src/GT/print_qsRGTpp.f90 index 9d1479d..8eab4c5 100644 --- a/src/GT/print_qsRGTpp.f90 +++ b/src/GT/print_qsRGTpp.f90 @@ -1,7 +1,7 @@ ! --- -subroutine print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, Z, & +subroutine print_qsRGTpp(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, Z, & ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole) ! Print one-electron energies and other stuff for qsGT @@ -11,7 +11,7 @@ subroutine print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc @@ -23,11 +23,11 @@ subroutine print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c double precision,intent(in) :: EcRPA(nspin) double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: eGT(nBas_MOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) - double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) - double precision,intent(in) :: Z(nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: eGT(nOrb) + double precision,intent(in) :: c(nBas,nOrb) + double precision,intent(in) :: SigC(nOrb,nOrb) + double precision,intent(in) :: Z(nOrb) double precision,intent(in) :: EqsGT double precision,intent(in) :: dipole(ncart) @@ -62,7 +62,7 @@ subroutine print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c '|','#','|','e_HF (eV)','|','Sig_GTpp (eV)','|','Z','|','e_GTpp (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do p=1,nBas_MOs + do p=1,nOrb 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)') & '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGT(p)*HaToeV,'|' end do @@ -113,13 +113,13 @@ subroutine print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTpp MO coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas_AOs, nBas_MOs, c) + call matout(nBas, nOrb, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A32)') ' qsGTpp MO energies' write(*,'(A50)') '---------------------------------------' - call vecout(nBas_MOs, eGT) + call vecout(nOrb, eGT) write(*,*) end if diff --git a/src/GT/qsRGTeh.f90 b/src/GT/qsRGTeh.f90 index e608d9a..5f6acab 100644 --- a/src/GT/qsRGTeh.f90 +++ b/src/GT/qsRGTeh.f90 @@ -3,7 +3,7 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, & dophBSE2, TDA_T, TDA, dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, & - ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, & + ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, & Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GTeh calculation @@ -37,31 +37,31 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables logical :: dRPA = .false. integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: ispin integer :: n_diis double precision :: ET @@ -117,7 +117,7 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Stuff - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! TDA for T @@ -137,26 +137,26 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d allocate(Aph(nS,nS), Bph(nS,nS), Om(nS), XpY(nS,nS), XmY(nS,nS)) - allocate(eGT(nBas_MOs)) - allocate(eOld(nBas_MOs)) - allocate(Z(nBas_MOs)) + allocate(eGT(nOrb)) + allocate(eOld(nOrb)) + allocate(Z(nOrb)) - allocate(c(nBas_AOs,nBas_MOs)) + allocate(c(nBas,nOrb)) - allocate(cp(nBas_MOs,nBas_MOs)) - allocate(Fp(nBas_MOs,nBas_MOs)) - allocate(Sig(nBas_MOs,nBas_MOs)) + allocate(cp(nOrb,nOrb)) + allocate(Fp(nOrb,nOrb)) + allocate(Sig(nOrb,nOrb)) - allocate(P(nBas_AOs,nBas_AOs)) - allocate(F(nBas_AOs,nBas_AOs)) - allocate(J(nBas_AOs,nBas_AOs)) - allocate(K(nBas_AOs,nBas_AOs)) - allocate(Sigp(nBas_AOs,nBas_AOs)) - allocate(err(nBas_AOs,nBas_AOs)) + allocate(P(nBas,nBas)) + allocate(F(nBas,nBas)) + allocate(J(nBas,nBas)) + allocate(K(nBas,nBas)) + allocate(Sigp(nBas,nBas)) + allocate(err(nBas,nBas)) - allocate(err_diis(nBas_AOs_Sq,max_diis), F_diis(nBas_AOs_Sq,max_diis)) + allocate(err_diis(nBas_Sq,max_diis), F_diis(nBas_Sq,max_diis)) - allocate(rhoL(nBas_MOs,nBas_MOs,nS), rhoR(nBas_MOs,nBas_MOs,nS)) + allocate(rhoL(nOrb,nOrb,nS), rhoR(nOrb,nOrb,nS)) ! Initialization @@ -185,20 +185,20 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Buid Hartree matrix - call Hartree_matrix_AO_basis(nBas_AOs,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas_AOs,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) ! Compute linear response - call phLR_A(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,eGT,ERI_MO,Aph) - if(.not.TDA_T) call phLR_B(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,eGT,ERI_MO,Aph) + if(.not.TDA_T) call phLR_B(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) call phLR(TDA_T,nS,Aph,Bph,EcRPA,Om,XpY,XmY) @@ -206,17 +206,17 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Compute correlation part of the self-energy - call GTeh_excitation_density(nBas_MOs,nC,nO,nR,nS,ERI_MO,XpY,XmY,rhoL,rhoR) + call GTeh_excitation_density(nOrb,nC,nO,nR,nS,ERI_MO,XpY,XmY,rhoL,rhoR) - if(regularize) call GTeh_regularization(nBas_MOs,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR) + if(regularize) call GTeh_regularization(nOrb,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR) - call GTeh_self_energy(eta,nBas_MOs,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR,EcGM,Sig,Z) + call GTeh_self_energy(eta,nOrb,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR,EcGM,Sig,Z) ! Make correlation self-energy Hermitian and transform it back to AO basis Sig = 0.5d0*(Sig + transpose(Sig)) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, Sig, Sigp) + call MOtoAO(nBas, nOrb, S, c, Sig, Sigp) ! Solve the quasi-particle equation @@ -231,7 +231,7 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,err_diis,F_diis,err,F) + call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,err_diis,F_diis,err,F) end if @@ -239,7 +239,7 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d Fp = matmul(transpose(X),matmul(F,X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eGT) + call diagonalize_matrix(nOrb, cp, eGT) c = matmul(X,cp) ! Compute new density matrix in the AO basis @@ -257,19 +257,19 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Kinetic energy - ET = trace_matrix(nBas_AOs,matmul(P,T)) + ET = trace_matrix(nBas,matmul(P,T)) ! Potential energy - EV = trace_matrix(nBas_AOs,matmul(P,V)) + EV = trace_matrix(nBas,matmul(P,V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas_AOs,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas_AOs,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) ! Total energy @@ -277,8 +277,8 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Print results - call dipole_moment(nBas_AOs,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGTeh(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGT, c, Sig, & + call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsRGTeh(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGT, c, Sig, & Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole) end do @@ -310,7 +310,7 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! if(BSE) then -! call Bethe_Salpeter(BSE2,TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas_AOs,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & +! call Bethe_Salpeter(BSE2,TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, & ! eGT,eGT,EcBSE) ! if(exchange_kernel) then @@ -345,7 +345,7 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! end if -! call ACFDT(exchange_kernel,doXBS,.true.,TDA_T,TDA,BSE,singlet,triplet,eta,nBas_AOs,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcAC) +! call ACFDT(exchange_kernel,doXBS,.true.,TDA_T,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcAC) ! write(*,*) ! write(*,*)'-------------------------------------------------------------------------------' diff --git a/src/GT/qsRGTpp.f90 b/src/GT/qsRGTpp.f90 index 1f8e17e..15a29dc 100644 --- a/src/GT/qsRGTpp.f90 +++ b/src/GT/qsRGTpp.f90 @@ -2,7 +2,7 @@ ! --- subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, TDA_T, TDA, & - dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, & + dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, & nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GT calculation @@ -34,26 +34,26 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC,nO,nV,nR,nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: ispin integer :: iblock integer :: n_diis @@ -123,7 +123,7 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Stuff - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! TDA for T @@ -141,30 +141,30 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Memory allocation - allocate(eGT(nBas_MOs)) - allocate(eOld(nBas_MOs)) - allocate(Z(nBas_MOs)) + allocate(eGT(nOrb)) + allocate(eOld(nOrb)) + allocate(Z(nOrb)) - allocate(c(nBas_AOs,nBas_MOs)) + allocate(c(nBas,nOrb)) - allocate(Fp(nBas_MOs,nBas_MOs)) - allocate(cp(nBas_MOs,nBas_MOs)) - allocate(Sig(nBas_MOs,nBas_MOs)) + allocate(Fp(nOrb,nOrb)) + allocate(cp(nOrb,nOrb)) + allocate(Sig(nOrb,nOrb)) - allocate(P(nBas_AOs,nBas_AOs)) - allocate(F(nBas_AOs,nBas_AOs)) - allocate(J(nBas_AOs,nBas_AOs)) - allocate(K(nBas_AOs,nBas_AOs)) - allocate(error(nBas_AOs,nBas_AOs)) - allocate(Sigp(nBas_AOs,nBas_AOs)) + allocate(P(nBas,nBas)) + allocate(F(nBas,nBas)) + allocate(J(nBas,nBas)) + allocate(K(nBas,nBas)) + allocate(error(nBas,nBas)) + allocate(Sigp(nBas,nBas)) - allocate(error_diis(nBas_AOs_Sq,max_diis)) - allocate(F_diis(nBas_AOs_Sq,max_diis)) + allocate(error_diis(nBas_Sq,max_diis)) + allocate(F_diis(nBas_Sq,max_diis)) - allocate(Om1s(nVVs), X1s(nVVs,nVVs), Y1s(nOOs,nVVs), rho1s(nBas_MOs,nBas_MOs,nVVs)) - allocate(Om2s(nOOs), X2s(nVVs,nOOs), Y2s(nOOs,nOOs), rho2s(nBas_MOs,nBas_MOs,nOOs)) - allocate(Om1t(nVVt), X1t(nVVt,nVVt), Y1t(nOOt,nVVt), rho1t(nBas_MOs,nBas_MOs,nVVt)) - allocate(Om2t(nOOt), X2t(nVVt,nOOt), Y2t(nOOt,nOOt), rho2t(nBas_MOs,nBas_MOs,nOOt)) + allocate(Om1s(nVVs), X1s(nVVs,nVVs), Y1s(nOOs,nVVs), rho1s(nOrb,nOrb,nVVs)) + allocate(Om2s(nOOs), X2s(nVVs,nOOs), Y2s(nOOs,nOOs), rho2s(nOrb,nOrb,nOOs)) + allocate(Om1t(nVVt), X1t(nVVt,nVVt), Y1t(nOOt,nVVt), rho1t(nOrb,nOrb,nVVt)) + allocate(Om2t(nOOt), X2t(nVVt,nOOt), Y2t(nOOt,nOOt), rho2t(nOrb,nOrb,nOOt)) ! Initialization @@ -192,15 +192,15 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Buid Hartree matrix - call Hartree_matrix_AO_basis(nBas_AOs,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas_AOs,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) ! AO to MO transformation of two-electron integrals - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) ! Compute linear response @@ -209,9 +209,9 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs)) - call ppLR_C(iblock,nBas_MOs,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp) - call ppLR_D(iblock,nBas_MOs,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp) - if(.not.TDA_T) call ppLR_B(iblock,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp) + call ppLR_C(iblock,nOrb,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp) + call ppLR_D(iblock,nOrb,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp) + if(.not.TDA_T) call ppLR_B(iblock,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp) call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin)) @@ -222,9 +222,9 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) - call ppLR_C(iblock,nBas_MOs,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp) - call ppLR_D(iblock,nBas_MOs,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp) - if(.not.TDA_T) call ppLR_B(iblock,nBas_MOs,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp) + call ppLR_C(iblock,nOrb,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp) + call ppLR_D(iblock,nOrb,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp) + if(.not.TDA_T) call ppLR_B(iblock,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) @@ -236,24 +236,24 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Compute correlation part of the self-energy iblock = 3 - call GTpp_excitation_density(iblock,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,ERI_MO,X1s,Y1s,rho1s,X2s,Y2s,rho2s) + call GTpp_excitation_density(iblock,nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI_MO,X1s,Y1s,rho1s,X2s,Y2s,rho2s) iblock = 4 - call GTpp_excitation_density(iblock,nBas_MOs,nC,nO,nV,nR,nOOt,nVVt,ERI_MO,X1t,Y1t,rho1t,X2t,Y2t,rho2t) + call GTpp_excitation_density(iblock,nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI_MO,X1t,Y1t,rho1t,X2t,Y2t,rho2t) if(regularize) then - call GTpp_regularization(eta,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,eGT,Om1s,rho1s,Om2s,rho2s) - call GTpp_regularization(eta,nBas_MOs,nC,nO,nV,nR,nOOt,nVVt,eGT,Om1t,rho1t,Om2t,rho2t) + call GTpp_regularization(eta,nOrb,nC,nO,nV,nR,nOOs,nVVs,eGT,Om1s,rho1s,Om2s,rho2s) + call GTpp_regularization(eta,nOrb,nC,nO,nV,nR,nOOt,nVVt,eGT,Om1t,rho1t,Om2t,rho2t) end if - call GTpp_self_energy(eta,nBas_MOs,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eGT,Om1s,rho1s,Om2s,rho2s, & + call GTpp_self_energy(eta,nOrb,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eGT,Om1s,rho1s,Om2s,rho2s, & Om1t,rho1t,Om2t,rho2t,EcGM,Sig,Z) ! Make correlation self-energy Hermitian and transform it back to AO basis Sig = 0.5d0*(Sig + transpose(Sig)) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, Sig, Sigp) + call MOtoAO(nBas, nOrb, S, c, Sig, Sigp) ! Solve the quasi-particle equation @@ -267,7 +267,7 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d n_diis = min(n_diis+1,max_diis) if(abs(rcond) > 1d-7) then - call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,error_diis,F_diis,error,F) + call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,error_diis,F_diis,error,F) else n_diis = 0 end if @@ -276,7 +276,7 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eGT) + call diagonalize_matrix(nOrb, cp, eGT) c = matmul(X, cp) ! Compute new density matrix in the AO basis @@ -294,19 +294,19 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Kinetic energy - ET = trace_matrix(nBas_AOs,matmul(P,T)) + ET = trace_matrix(nBas,matmul(P,T)) ! Potential energy - EV = trace_matrix(nBas_AOs,matmul(P,V)) + EV = trace_matrix(nBas,matmul(P,V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas_AOs,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas_AOs,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) ! Total energy @@ -314,8 +314,8 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Print results - call dipole_moment(nBas_AOs,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGTpp(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, & + call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsRGTpp(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, & eGT, c, Sig, Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, & EqsGT, dipole) @@ -351,7 +351,7 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d if(dophBSE) then - call GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas_MOs,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + call GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & Om1s,X1s,Y1s,Om2s,X2s,Y2s,rho1s,rho2s,Om1t,X1t,Y1t,Om2t,X2t,Y2t,rho1t,rho2t, & ERI_MO,dipole_int_MO,eGT,eGT,EcBSE) @@ -387,7 +387,7 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d end if - call GTpp_phACFDT(exchange_kernel,doXBS,.false.,TDA_T,TDA,dophBSE,singlet,triplet,eta,nBas_MOs,nC,nO,nV,nR,nS, & + call GTpp_phACFDT(exchange_kernel,doXBS,.false.,TDA_T,TDA,dophBSE,singlet,triplet,eta,nOrb,nC,nO,nV,nR,nS, & nOOs,nVVs,nOOt,nVVt,Om1s,X1s,Y1s,Om2s,X2s,Y2s,rho1s,rho2s,Om1t,X1t,Y1t, & Om2t,X2t,Y2t,rho1t,rho2t,ERI_MO,eGT,eGT,EcBSE) diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index 8498485..48408f7 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -3,7 +3,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxSCF, thresh, max_diis, doACFDT, & exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, TDA_W, TDA, dBSE, dTDA, singlet, triplet, & - linearize, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, & + linearize, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, & S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Restricted GW module @@ -46,7 +46,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -54,18 +54,18 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(in) :: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables @@ -79,7 +79,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS call wall_time(start_GW) call RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,regularize,nBas_MOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW @@ -96,7 +96,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS call wall_time(start_GW) call evRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & - singlet,triplet,linearize,eta,regularize,nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW @@ -114,7 +114,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS call wall_time(start_GW) call qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, & TDA_W, TDA, dBSE, dTDA, doppBSE, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, & - ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, & + ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, & dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GW) @@ -133,7 +133,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS call wall_time(start_GW) call SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, & dophBSE, dophBSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, & - nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, & + nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, & ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, & PHF, cHF, eHF) call wall_time(end_GW) @@ -152,7 +152,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS call wall_time(start_GW) ! TODO - call ufG0W0(dotest,TDA_W,nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) + call ufG0W0(dotest,TDA_W,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW @@ -169,7 +169,7 @@ subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxS call wall_time(start_GW) ! TODO - call ufGW(dotest,TDA_W,nBas_AOs,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) + call ufGW(dotest,TDA_W,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW diff --git a/src/GW/SRG_qsGW.f90 b/src/GW/SRG_qsGW.f90 index 32c2a19..807991b 100644 --- a/src/GW/SRG_qsGW.f90 +++ b/src/GW/SRG_qsGW.f90 @@ -3,7 +3,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, & BSE, BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nNuc, & - ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, & + ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, & X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GW calculation @@ -36,30 +36,30 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(inout):: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(inout):: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: ispin integer :: ixyz integer :: n_diis @@ -118,7 +118,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Stuff - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! TDA for W @@ -136,32 +136,32 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Memory allocation - allocate(eGW(nBas_MOs)) - allocate(eOld(nBas_MOs)) - allocate(Z(nBas_MOs)) + allocate(eGW(nOrb)) + allocate(eOld(nOrb)) + allocate(Z(nOrb)) - allocate(c(nBas_AOs,nBas_MOs)) + allocate(c(nBas,nOrb)) - allocate(cp(nBas_MOs,nBas_MOs)) - allocate(Fp(nBas_MOs,nBas_MOs)) - allocate(SigC(nBas_MOs,nBas_MOs)) + allocate(cp(nOrb,nOrb)) + allocate(Fp(nOrb,nOrb)) + allocate(SigC(nOrb,nOrb)) - allocate(P(nBas_AOs,nBas_AOs)) - allocate(F(nBas_AOs,nBas_AOs)) - allocate(J(nBas_AOs,nBas_AOs)) - allocate(K(nBas_AOs,nBas_AOs)) - allocate(error(nBas_AOs,nBas_AOs)) - allocate(SigCp(nBas_AOs,nBas_AOs)) + allocate(P(nBas,nBas)) + allocate(F(nBas,nBas)) + allocate(J(nBas,nBas)) + allocate(K(nBas,nBas)) + allocate(error(nBas,nBas)) + allocate(SigCp(nBas,nBas)) allocate(Aph(nS,nS)) allocate(Bph(nS,nS)) allocate(Om(nS)) allocate(XpY(nS,nS)) allocate(XmY(nS,nS)) - allocate(rho(nBas_MOs,nBas_MOs,nS)) + allocate(rho(nOrb,nOrb,nS)) - allocate(error_diis(nBas_AOs_Sq,max_diis)) - allocate(F_diis(nBas_AOs_Sq,max_diis)) + allocate(error_diis(nBas_Sq,max_diis)) + allocate(F_diis(nBas_Sq,max_diis)) ! Initialization @@ -189,11 +189,11 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Buid Hartree matrix call wall_time(t1) - call Hartree_matrix_AO_basis(nBas_AOs,P,ERI_AO,J) + call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J) ! Compute exchange part of the self-energy - call exchange_matrix_AO_basis(nBas_AOs,P,ERI_AO,K) + call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) call wall_time(t2) tt=tt+t2-t1 @@ -202,10 +202,10 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, call wall_time(tao1) do ixyz = 1, ncart - call AOtoMO(nBas_AOs, nBas_MOs, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) + call AOtoMO(nBas, nOrb, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) call wall_time(tao2) @@ -215,8 +215,8 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, call wall_time(tlr1) - call phLR_A(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph) - if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas_MOs,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph) + if(.not.TDA_W) call phLR_B(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY) @@ -230,13 +230,13 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, call wall_time(tex1) - call GW_excitation_density(nBas_MOs,nC,nO,nR,nS,ERI_MO,XpY,rho) + call GW_excitation_density(nOrb,nC,nO,nR,nS,ERI_MO,XpY,rho) call wall_time(tex2) tex=tex+tex2-tex1 call wall_time(tsrg1) - call SRG_self_energy(flow,nBas_MOs,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z) + call SRG_self_energy(flow,nOrb,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z) call wall_time(tsrg2) @@ -245,7 +245,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Make correlation self-energy Hermitian and transform it back to AO basis call wall_time(tmo1) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, SigC, SigCp) + call MOtoAO(nBas, nOrb, S, c, SigC, SigCp) call wall_time(tmo2) tmo = tmo + tmo2 - tmo1 ! Solve the quasi-particle equation @@ -261,7 +261,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,error_diis,F_diis,error,F) + call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,error_diis,F_diis,error,F) end if @@ -269,10 +269,10 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eGW) + call diagonalize_matrix(nOrb, cp, eGW) c = matmul(X, cp) - call AOtoMO(nBas_AOs, nBas_MOs, c, SigCp, SigC) + call AOtoMO(nBas, nOrb, c, SigCp, SigC) ! Compute new density matrix in the AO basis @@ -289,19 +289,19 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Kinetic energy - ET = trace_matrix(nBas_AOs,matmul(P,T)) + ET = trace_matrix(nBas,matmul(P,T)) ! Potential energy - EV = trace_matrix(nBas_AOs,matmul(P,V)) + EV = trace_matrix(nBas,matmul(P,V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas_AOs,matmul(P,J)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) ! Exchange energy - Ex = 0.25d0*trace_matrix(nBas_AOs,matmul(P,K)) + Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) ! Total energy @@ -309,8 +309,8 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Print results - call dipole_moment(nBas_AOs,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, & + call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, & SigC, Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGW, dipole) end do @@ -343,7 +343,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, ! Cumulant expansion - call RGWC(dotest,eta,nBas_MOs,nC,nO,nV,nR,nS,Om,rho,eHF,eGW,eGW,Z) + call RGWC(dotest,eta,nOrb,nC,nO,nV,nR,nS,Om,rho,eHF,eGW,eGW,Z) ! Deallocate memory @@ -353,7 +353,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, if(BSE) then - call GW_phBSE(BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, & + call GW_phBSE(BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, & nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE) if(exchange_kernel) then @@ -389,7 +389,7 @@ subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, end if call GW_phACFDT(exchange_kernel, doXBS, .true., TDA_W, TDA, BSE, singlet, triplet, & - eta, nBas_MOs, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE) + eta, nOrb, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE) write(*,*) write(*,*)'-------------------------------------------------------------------------------' diff --git a/src/GW/print_qsRGW.f90 b/src/GW/print_qsRGW.f90 index 7e90ce7..9fd695c 100644 --- a/src/GW/print_qsRGW.f90 +++ b/src/GW/print_qsRGW.f90 @@ -1,7 +1,7 @@ ! --- -subroutine print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, & +subroutine print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, & Z, ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole) ! Print useful information about qsRGW calculation @@ -11,7 +11,7 @@ subroutine print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO integer,intent(in) :: nSCF double precision,intent(in) :: ENuc @@ -23,11 +23,11 @@ subroutine print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, double precision,intent(in) :: EcRPA double precision,intent(in) :: Conv double precision,intent(in) :: thresh - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: eGW(nBas_MOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) - double precision,intent(in) :: SigC(nBas_MOs,nBas_MOs) - double precision,intent(in) :: Z(nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: eGW(nOrb) + double precision,intent(in) :: c(nBas,nOrb) + double precision,intent(in) :: SigC(nOrb,nOrb) + double precision,intent(in) :: Z(nOrb) double precision,intent(in) :: EqsGW double precision,intent(in) :: dipole(ncart) @@ -63,7 +63,7 @@ subroutine print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, '|','#','|','e_HF (eV)','|','Sig_GW (eV)','|','Z','|','e_GW (eV)','|' write(*,*)'-------------------------------------------------------------------------------' - do p=1,nBas_MOs + do p=1,nOrb 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)') & '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGW(p)*HaToeV,'|' end do @@ -114,13 +114,13 @@ subroutine print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' Restricted qsGW orbital coefficients' write(*,'(A50)') '---------------------------------------' - call matout(nBas_AOs, nBas_MOs, c) + call matout(nBas, nOrb, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' Restricted qsGW orbital energies (au) ' write(*,'(A50)') '---------------------------------------' - call vecout(nBas_MOs, eGW) + call vecout(nOrb, eGW) write(*,*) end if diff --git a/src/GW/qsRGW.f90 b/src/GW/qsRGW.f90 index 395c30e..1756a0b 100644 --- a/src/GW/qsRGW.f90 +++ b/src/GW/qsRGW.f90 @@ -3,7 +3,7 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, & TDA_W, TDA, dBSE, dTDA, doppBSE, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, & - ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, & + ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, & ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) ! Perform a quasiparticle self-consistent GW calculation @@ -38,30 +38,30 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR integer,intent(in) :: nS double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) - double precision,intent(in) :: PHF(nBas_AOs,nBas_AOs) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_AOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(inout):: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) + double precision,intent(in) :: PHF(nBas,nBas) + 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_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(inout):: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: ispin integer :: ixyz integer :: n_diis @@ -116,7 +116,7 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Stuff - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! TDA for W @@ -134,31 +134,31 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Memory allocation - allocate(eGW(nBas_MOs)) - allocate(Z(nBas_MOs)) + allocate(eGW(nOrb)) + allocate(Z(nOrb)) - allocate(c(nBas_AOs,nBas_MOs)) + allocate(c(nBas,nOrb)) - allocate(cp(nBas_MOs,nBas_MOs)) - allocate(Fp(nBas_MOs,nBas_MOs)) - allocate(SigC(nBas_MOs,nBas_MOs)) + allocate(cp(nOrb,nOrb)) + allocate(Fp(nOrb,nOrb)) + allocate(SigC(nOrb,nOrb)) - allocate(P(nBas_AOs,nBas_AOs)) - allocate(F(nBas_AOs,nBas_AOs)) - allocate(J(nBas_AOs,nBas_AOs)) - allocate(K(nBas_AOs,nBas_AOs)) - allocate(err(nBas_AOs,nBas_AOs)) - allocate(SigCp(nBas_AOs,nBas_AOs)) + allocate(P(nBas,nBas)) + allocate(F(nBas,nBas)) + allocate(J(nBas,nBas)) + allocate(K(nBas,nBas)) + allocate(err(nBas,nBas)) + allocate(SigCp(nBas,nBas)) allocate(Aph(nS,nS)) allocate(Bph(nS,nS)) allocate(Om(nS)) allocate(XpY(nS,nS)) allocate(XmY(nS,nS)) - allocate(rho(nBas_MOs,nBas_MOs,nS)) + allocate(rho(nOrb,nOrb,nS)) - allocate(err_diis(nBas_AOs_Sq,max_diis)) - allocate(F_diis(nBas_AOs_Sq,max_diis)) + allocate(err_diis(nBas_Sq,max_diis)) + allocate(F_diis(nBas_Sq,max_diis)) ! Initialization @@ -185,38 +185,38 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Build Hartree-exchange matrix - call Hartree_matrix_AO_basis(nBas_AOs, P, ERI_AO, J) - call exchange_matrix_AO_basis(nBas_AOs, P, ERI_AO, K) + call Hartree_matrix_AO_basis(nBas, P, ERI_AO, J) + call exchange_matrix_AO_basis(nBas, P, ERI_AO, K) ! AO to MO transformation of two-electron integrals do ixyz = 1, ncart - call AOtoMO(nBas_AOs, nBas_MOs, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) + call AOtoMO(nBas, nOrb, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) ! Compute linear response - call phLR_A(ispin, dRPA, nBas_MOs, nC, nO, nV, nR, nS, 1d0, eGW, ERI_MO, Aph) - if(.not.TDA_W) call phLR_B(ispin, dRPA, nBas_MOs, nC, nO, nV, nR, nS, 1d0, ERI_MO, Bph) + call phLR_A(ispin, dRPA, nOrb, nC, nO, nV, nR, nS, 1d0, eGW, ERI_MO, Aph) + if(.not.TDA_W) call phLR_B(ispin, dRPA, nOrb, nC, nO, nV, nR, nS, 1d0, ERI_MO, Bph) call phLR(TDA_W, nS, Aph, Bph, EcRPA, Om, XpY, XmY) if(print_W) call print_excitation_energies('phRPA@GW@RHF','singlet',nS,Om) ! Compute correlation part of the self-energy - call GW_excitation_density(nBas_MOs, nC, nO, nR, nS, ERI_MO, XpY, rho) + call GW_excitation_density(nOrb, nC, nO, nR, nS, ERI_MO, XpY, rho) - if(regularize) call GW_regularization(nBas_MOs, nC, nO, nV, nR, nS, eGW, Om, rho) + if(regularize) call GW_regularization(nOrb, nC, nO, nV, nR, nS, eGW, Om, rho) - call GW_self_energy(eta, nBas_MOs, nC, nO, nV, nR, nS, eGW, Om, rho, EcGM, SigC, Z) + call GW_self_energy(eta, nOrb, nC, nO, nV, nR, nS, eGW, Om, rho, EcGM, SigC, Z) ! Make correlation self-energy Hermitian and transform it back to AO basis SigC = 0.5d0*(SigC + transpose(SigC)) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, SigC, SigCp) + call MOtoAO(nBas, nOrb, S, c, SigC, SigCp) ! Solve the quasi-particle equation @@ -230,19 +230,19 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Kinetic energy - ET = trace_matrix(nBas_AOs, matmul(P, T)) + ET = trace_matrix(nBas, matmul(P, T)) ! Potential energy - EV = trace_matrix(nBas_AOs, matmul(P, V)) + EV = trace_matrix(nBas, matmul(P, V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas_AOs, matmul(P, J)) + EJ = 0.5d0*trace_matrix(nBas, matmul(P, J)) ! Exchange energy - EK = 0.25d0*trace_matrix(nBas_AOs, matmul(P, K)) + EK = 0.25d0*trace_matrix(nBas, matmul(P, K)) ! Total energy @@ -253,7 +253,7 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,err_diis,F_diis,err,F) + call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,err_diis,F_diis,err,F) end if @@ -261,9 +261,9 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX Fp = matmul(transpose(X), matmul(F, X)) cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eGW) + call diagonalize_matrix(nOrb, cp, eGW) c = matmul(X, cp) - call AOtoMO(nBas_AOs, nBas_MOs, c, SigCp, SigC) + call AOtoMO(nBas, nOrb, c, SigCp, SigC) ! Density matrix @@ -271,8 +271,8 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Print results - call dipole_moment(nBas_AOs, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole) - call print_qsRGW(nBas_AOs, nBas_MOs, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, Z, & + call dipole_moment(nBas, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole) + call print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, Z, & ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole) end do @@ -304,7 +304,7 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX if(dophBSE) then call GW_phBSE(dophBSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, & - nBas_MOs, nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE) + nOrb, nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE) if(exchange_kernel) then @@ -339,7 +339,7 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX end if call GW_phACFDT(exchange_kernel, doXBS, .true., TDA_W, TDA, dophBSE, singlet, triplet, & - eta, nBas_MOs, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE) + eta, nOrb, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE) write(*,*) write(*,*)'-------------------------------------------------------------------------------' @@ -356,7 +356,7 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX if(doppBSE) then - call GW_ppBSE(TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nBas_MOs, & + call GW_ppBSE(TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, & nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eHF, eGW, EcBSE) EcBSE(2) = 3d0*EcBSE(2) diff --git a/src/HF/RHF.f90 b/src/HF/RHF.f90 index 5756744..1ae1b27 100644 --- a/src/HF/RHF.f90 +++ b/src/HF/RHF.f90 @@ -2,7 +2,7 @@ ! --- subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI, dipole_int, X, ERHF, eHF, c, P) + nBas, nOrb, nO, S, T, V, Hc, ERI, dipole_int, X, ERHF, eHF, c, P) ! Perform restricted Hartree-Fock calculation @@ -19,24 +19,24 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, double precision,intent(in) :: thresh double precision,intent(in) :: level_shift - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO integer,intent(in) :: nNuc double precision,intent(in) :: ZNuc(nNuc) double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(in) :: dipole_int(nBas_AOs,nBas_AOs,ncart) + 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,nOrb) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int(nBas,nBas,ncart) ! Local variables integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: n_diis double precision :: ET double precision :: EV @@ -59,9 +59,9 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ! Output variables double precision,intent(out) :: ERHF - double precision,intent(out) :: eHF(nBas_MOs) - double precision,intent(inout):: c(nBas_AOs,nBas_MOs) - double precision,intent(out) :: P(nBas_AOs,nBas_AOs) + double precision,intent(out) :: eHF(nOrb) + double precision,intent(inout):: c(nBas,nOrb) + double precision,intent(out) :: P(nBas,nBas) ! Hello world @@ -73,35 +73,37 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ! Useful quantities - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! Memory allocation - allocate(J(nBas_AOs,nBas_AOs)) - allocate(K(nBas_AOs,nBas_AOs)) + allocate(J(nBas,nBas)) + allocate(K(nBas,nBas)) - allocate(err(nBas_AOs,nBas_AOs)) - allocate(F(nBas_AOs,nBas_AOs)) + allocate(err(nBas,nBas)) + allocate(F(nBas,nBas)) - allocate(cp(nBas_MOs,nBas_MOs)) - allocate(Fp(nBas_MOs,nBas_MOs)) + allocate(cp(nOrb,nOrb)) + allocate(Fp(nOrb,nOrb)) - allocate(err_diis(nBas_AOs_Sq,max_diis)) - allocate(F_diis(nBas_AOs_Sq,max_diis)) + allocate(err_diis(nBas_Sq,max_diis)) + allocate(F_diis(nBas_Sq,max_diis)) ! Guess coefficients and density matrix - call mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) + call mo_guess(nBas, nOrb, guess_type, S, Hc, X, c) !P(:,:) = 2d0 * matmul(c(:,1:nO), transpose(c(:,1:nO))) - call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO, 2.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P, nBas_AOs) + call dgemm('N', 'T', nBas, nBas, nO, 2.d0, & + c(1,1), nBas, c(1,1), nBas, & + 0.d0, P(1,1), nBas) ! Initialization n_diis = 0 F_diis(:,:) = 0d0 err_diis(:,:) = 0d0 - rcond = 0d0 + rcond = 0d0 Conv = 1d0 nSCF = 0 @@ -124,10 +126,14 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ! Build Fock matrix - call Hartree_matrix_AO_basis(nBas_AOs, P, ERI, J) - call exchange_matrix_AO_basis(nBas_AOs, P, ERI, K) + call Hartree_matrix_AO_basis(nBas, P, ERI, J) + call exchange_matrix_AO_basis(nBas, P, ERI, K) F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + if(nBas .ne. nOrb) then + call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1)) + call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1)) + endif ! Check convergence @@ -136,19 +142,19 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ! Kinetic energy - ET = trace_matrix(nBas_AOs, matmul(P, T)) + ET = trace_matrix(nBas, matmul(P, T)) ! Potential energy - EV = trace_matrix(nBas_AOs, matmul(P, V)) + EV = trace_matrix(nBas, matmul(P, V)) ! Hartree energy - EJ = 0.5d0*trace_matrix(nBas_AOs, matmul(P, J)) + EJ = 0.5d0*trace_matrix(nBas, matmul(P, J)) ! Exchange energy - EK = 0.25d0*trace_matrix(nBas_AOs, matmul(P, K)) + EK = 0.25d0*trace_matrix(nBas, matmul(P, K)) ! Total energy @@ -159,27 +165,36 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, if(max_diis > 1) then n_diis = min(n_diis+1, max_diis) - call DIIS_extrapolation(rcond, nBas_AOs_Sq, nBas_AOs_Sq, n_diis, err_diis, F_diis, err, F) + call DIIS_extrapolation(rcond, nBas_Sq, nBas_Sq, n_diis, err_diis, F_diis, err, F) end if ! Level shift if(level_shift > 0d0 .and. Conv > thresh) then - call level_shifting(level_shift, nBas_AOs, nBas_MOs, nO, S, c, F) + call level_shifting(level_shift, nBas, nOrb, nO, S, c, F) endif ! Diagonalize Fock matrix - Fp = matmul(transpose(X), matmul(F, X)) - cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eHF) - c = matmul(X, cp) + if(nBas .eq. nOrb) then + Fp = matmul(transpose(X), matmul(F, X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eHF) + c = matmul(X, cp) + else + Fp = matmul(transpose(c), matmul(F, c)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eHF) + c = matmul(c, cp) + endif ! Density matrix !P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO))) - call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO, 2.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P, nBas_AOs) + call dgemm('N', 'T', nBas, nBas, nO, 2.d0, & + c(1,1), nBas, c(1,1), nBas, & + 0.d0, P(1,1), nBas) ! Dump results @@ -210,8 +225,8 @@ subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ! Compute dipole moments - call dipole_moment(nBas_AOs, P, nNuc, ZNuc, rNuc, dipole_int, dipole) - call print_RHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, EK, ERHF, dipole) + call dipole_moment(nBas, P, nNuc, ZNuc, rNuc, dipole_int, dipole) + call print_RHF(nBas, nOrb, nO, eHF, c, ENuc, ET, EV, EJ, EK, ERHF, dipole) ! Testing zone diff --git a/src/HF/RHF_search.f90 b/src/HF/RHF_search.f90 index 714d11c..d200139 100644 --- a/src/HF/RHF_search.f90 +++ b/src/HF/RHF_search.f90 @@ -2,7 +2,7 @@ ! --- subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, & + nBas, nOrb, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, & X, ERHF, e, c, P) ! Search for RHF solutions @@ -16,7 +16,7 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z double precision,intent(in) :: thresh double precision,intent(in) :: level_shift - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -25,15 +25,15 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z double precision,intent(in) :: ZNuc(nNuc) double precision,intent(in) :: rNuc(nNuc,ncart) double precision,intent(in) :: ENuc - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(inout):: ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(inout):: dipole_int_MO(nBas_MOs,nBas_MOs,ncart) + 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,nOrb) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(inout):: dipole_int_MO(nOrb,nOrb,ncart) ! Local variables @@ -62,9 +62,9 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z ! Output variables double precision,intent(out) :: ERHF - double precision,intent(out) :: e(nBas_MOs) - double precision,intent(inout):: c(nBas_AOs,nBas_MOs) - double precision,intent(out) :: P(nBas_AOs,nBas_AOs) + double precision,intent(out) :: e(nOrb) + double precision,intent(inout):: c(nBas,nOrb) + double precision,intent(out) :: P(nBas,nBas) ! Memory allocation @@ -80,7 +80,7 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z nS = (nO - nC)*(nV - nR) allocate(Aph(nS,nS), Bph(nS,nS), AB(nS,nS), Om(nS)) - allocate(R(nBas_MOs,nBas_MOs), ExpR(nBas_MOs,nBas_MOs)) + allocate(R(nOrb,nOrb), ExpR(nOrb,nOrb)) !------------------! ! Search algorithm ! @@ -97,7 +97,7 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z call wall_time(start_HF) call RHF(.false., maxSCF, thresh, max_diis, guess, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, e, c, P) + nBas, nOrb, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, e, c, P) call wall_time(end_HF) t_HF = end_HF - start_HF @@ -113,9 +113,9 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z write(*,*) 'AO to MO transformation... Please be patient' write(*,*) do ixyz = 1, ncart - call AOtoMO(nBas_AOs, nBas_MOs, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) + call AOtoMO(nBas, nOrb, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, c, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO) call wall_time(end_AOtoMO) t_AOtoMO = end_AOtoMO - start_AOtoMO @@ -128,8 +128,8 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z ispin = 1 - call phLR_A(ispin,.false.,nBas_MOs,nC,nO,nV,nR,nS,1d0,e,ERI_MO,Aph) - call phLR_B(ispin,.false.,nBas_MOs,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) + call phLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,e,ERI_MO,Aph) + call phLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph) AB(:,:) = Aph(:,:) + Bph(:,:) @@ -169,14 +169,14 @@ subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, Z R(:,:) = 0d0 ia = 0 do i=nC+1,nO - do a=nO+1,nBas_MOs-nR + do a=nO+1,nOrb-nR ia = ia + 1 R(a,i) = +AB(ia,eig) R(i,a) = -AB(ia,eig) end do end do - call matrix_exponential(nBas_MOs, R, ExpR) + call matrix_exponential(nOrb, R, ExpR) c = matmul(c, ExpR) else diff --git a/src/HF/ROHF.f90 b/src/HF/ROHF.f90 index d67fc0b..5a0ff02 100644 --- a/src/HF/ROHF.f90 +++ b/src/HF/ROHF.f90 @@ -2,7 +2,7 @@ ! --- subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI, dipole_int, X, EROHF, eHF, c, Ptot) + nBas, nOrb, nO, S, T, V, Hc, ERI, dipole_int, X, EROHF, eHF, c, Ptot) ! Perform restricted open-shell Hartree-Fock calculation @@ -19,7 +19,7 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, double precision,intent(in) :: mix double precision,intent(in) :: level_shift double precision,intent(in) :: thresh - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nNuc double precision,intent(in) :: ZNuc(nNuc) @@ -27,18 +27,18 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, double precision,intent(in) :: ENuc integer,intent(in) :: nO(nspin) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: ERI(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) - double precision,intent(in) :: dipole_int(nBas_AOs,nBas_AOs,ncart) + 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,nOrb) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int(nBas,nBas,ncart) ! Local variables integer :: nSCF - integer :: nBas_AOs_Sq + integer :: nBas_Sq integer :: n_diis double precision :: Conv double precision :: rcond @@ -65,9 +65,9 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, ! Output variables double precision,intent(out) :: EROHF - double precision,intent(out) :: eHF(nBas_MOs) - double precision,intent(inout):: c(nBas_AOs,nBas_MOs) - double precision,intent(out) :: Ptot(nBas_AOs,nBas_AOs) + double precision,intent(out) :: eHF(nOrb) + double precision,intent(inout):: c(nBas,nOrb) + double precision,intent(out) :: Ptot(nBas,nBas) ! Hello world @@ -79,30 +79,30 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, ! Useful stuff - nBas_AOs_Sq = nBas_AOs*nBas_AOs + nBas_Sq = nBas*nBas ! Memory allocation - allocate(J(nBas_AOs,nBas_AOs,nspin)) - allocate(K(nBas_AOs,nBas_AOs,nspin)) - allocate(F(nBas_AOs,nBas_AOs,nspin)) - allocate(Ftot(nBas_AOs,nBas_AOs)) - allocate(P(nBas_AOs,nBas_AOs,nspin)) - allocate(err(nBas_AOs,nBas_AOs)) + allocate(J(nBas,nBas,nspin)) + allocate(K(nBas,nBas,nspin)) + allocate(F(nBas,nBas,nspin)) + allocate(Ftot(nBas,nBas)) + allocate(P(nBas,nBas,nspin)) + allocate(err(nBas,nBas)) - allocate(Fp(nBas_MOs,nBas_MOs)) - allocate(cp(nBas_MOs,nBas_MOs)) + allocate(Fp(nOrb,nOrb)) + allocate(cp(nOrb,nOrb)) - allocate(err_diis(nBas_AOs_Sq,max_diis)) - allocate(F_diis(nBas_AOs_Sq,max_diis)) + allocate(err_diis(nBas_Sq,max_diis)) + allocate(F_diis(nBas_Sq,max_diis)) ! Guess coefficients and demsity matrices - call mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) + call mo_guess(nBas, nOrb, guess_type, S, Hc, X, c) do ispin = 1, nspin !P(:,:,ispin) = matmul(c(:,1:nO(ispin)), transpose(c(:,1:nO(ispin)))) - call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO(ispin), 1.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P(1,1,ispin), nBas_AOs) + call dgemm('N', 'T', nBas, nBas, nO(ispin), 1.d0, c, nBas, c, nBas, 0.d0, P(1,1,ispin), nBas) end do Ptot(:,:) = P(:,:,1) + P(:,:,2) @@ -135,13 +135,13 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, ! Build Hartree repulsion do ispin = 1, nspin - call Hartree_matrix_AO_basis(nBas_AOs, P(:,:,ispin), ERI(:,:,:,:), J(:,:,ispin)) + call Hartree_matrix_AO_basis(nBas, P(:,:,ispin), ERI(:,:,:,:), J(:,:,ispin)) end do ! Compute exchange potential do ispin = 1, nspin - call exchange_matrix_AO_basis(nBas_AOs, P(:,:,ispin), ERI(:,:,:,:), K(:,:,ispin)) + call exchange_matrix_AO_basis(nBas, P(:,:,ispin), ERI(:,:,:,:), K(:,:,ispin)) end do ! Build Fock operator @@ -150,7 +150,7 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, F(:,:,ispin) = Hc(:,:) + J(:,:,ispin) + J(:,:,mod(ispin,2)+1) + K(:,:,ispin) end do - call ROHF_fock_matrix(nBas_AOs, nBas_MOs, nO(1), nO(2), S, c, F(:,:,1), F(:,:,2), Ftot) + call ROHF_fock_matrix(nBas, nOrb, nO(1), nO(2), S, c, F(:,:,1), F(:,:,2), Ftot) ! Check convergence @@ -160,25 +160,25 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, ! Kinetic energy do ispin = 1, nspin - ET(ispin) = trace_matrix(nBas_AOs, matmul(P(:,:,ispin), T(:,:))) + ET(ispin) = trace_matrix(nBas, matmul(P(:,:,ispin), T(:,:))) end do ! Potential energy do ispin = 1, nspin - EV(ispin) = trace_matrix(nBas_AOs, matmul(P(:,:,ispin), V(:,:))) + EV(ispin) = trace_matrix(nBas, matmul(P(:,:,ispin), V(:,:))) end do ! Hartree energy - EJ(1) = 0.5d0*trace_matrix(nBas_AOs, matmul(P(:,:,1), J(:,:,1))) - EJ(2) = trace_matrix(nBas_AOs, matmul(P(:,:,1), J(:,:,2))) - EJ(3) = 0.5d0*trace_matrix(nBas_AOs, matmul(P(:,:,2), J(:,:,2))) + 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 - EK(ispin) = 0.5d0*trace_matrix(nBas_AOs, matmul(P(:,:,ispin), K(:,:,ispin))) + EK(ispin) = 0.5d0*trace_matrix(nBas, matmul(P(:,:,ispin), K(:,:,ispin))) end do ! Total energy @@ -190,7 +190,7 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, if(max_diis > 1) then n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBas_AOs_Sq,nBas_AOs_Sq,n_diis,err_diis,F_diis,err,Ftot) + call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,err_diis,F_diis,err,Ftot) end if @@ -199,7 +199,7 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, if(level_shift > 0d0 .and. Conv > thresh) then do ispin=1,nspin - call level_shifting(level_shift, nBas_AOs, nBas_MOs, maxval(nO), S, c, Ftot) + call level_shifting(level_shift, nBas, nOrb, maxval(nO), S, c, Ftot) end do end if @@ -211,7 +211,7 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, ! Diagonalize Fock matrix to get eigenvectors and eigenvalues cp(:,:) = Fp(:,:) - call diagonalize_matrix(nBas_MOs, cp, eHF) + call diagonalize_matrix(nOrb, cp, eHF) ! Back-transform eigenvectors in non-orthogonal basis @@ -221,7 +221,7 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, do ispin = 1, nspin !P(:,:,ispin) = matmul(c(:,1:nO(ispin)), transpose(c(:,1:nO(ispin)))) - call dgemm('N', 'T', nBas_AOs, nBas_AOs, nO(ispin), 1.d0, c, nBas_AOs, c, nBas_AOs, 0.d0, P(1,1,ispin), nBas_AOs) + call dgemm('N', 'T', nBas, nBas, nO(ispin), 1.d0, c, nBas, c, nBas, 0.d0, P(1,1,ispin), nBas) end do Ptot(:,:) = P(:,:,1) + P(:,:,2) @@ -254,8 +254,8 @@ subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, ! Compute final UHF energy - call dipole_moment(nBas_AOs,Ptot,nNuc,ZNuc,rNuc,dipole_int,dipole) - call print_ROHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, EK, EROHF, dipole) + call dipole_moment(nBas,Ptot,nNuc,ZNuc,rNuc,dipole_int,dipole) + call print_ROHF(nBas, nOrb, nO, eHF, c, ENuc, ET, EV, EJ, EK, EROHF, dipole) ! Print test values diff --git a/src/HF/ROHF_fock_matrix.f90 b/src/HF/ROHF_fock_matrix.f90 index a3c5aad..a88c57a 100644 --- a/src/HF/ROHF_fock_matrix.f90 +++ b/src/HF/ROHF_fock_matrix.f90 @@ -1,7 +1,7 @@ ! --- -subroutine ROHF_fock_matrix(nBas_AOs, nBas_MOs, nOa, nOb, S, c, FaAO, FbAO, FAO) +subroutine ROHF_fock_matrix(nBas, nOrb, nOa, nOb, S, c, FaAO, FbAO, FAO) ! Construct the ROHF Fock matrix in the AO basis ! For open shells, the ROHF Fock matrix in the MO basis reads @@ -20,14 +20,14 @@ subroutine ROHF_fock_matrix(nBas_AOs, nBas_MOs, nOa, nOb, S, c, FaAO, FbAO, FAO) ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nOa integer,intent(in) :: nOb - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) - double precision,intent(inout):: FaAO(nBas_AOs,nBas_AOs) - double precision,intent(inout):: FbAO(nBas_AOs,nBas_AOs) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: c(nBas,nOrb) + double precision,intent(inout):: FaAO(nBas,nBas) + double precision,intent(inout):: FbAO(nBas,nBas) ! Local variables @@ -45,11 +45,11 @@ subroutine ROHF_fock_matrix(nBas_AOs, nBas_MOs, nOa, nOb, S, c, FaAO, FbAO, FAO) ! Output variables - double precision,intent(out) :: FAO(nBas_AOs,nBas_AOs) + double precision,intent(out) :: FAO(nBas,nBas) ! Memory allocation - allocate(F(nBas_MOs,nBas_MOs), Fa(nBas_MOs,nBas_MOs), Fb(nBas_MOs,nBas_MOs)) + allocate(F(nOrb,nOrb), Fa(nOrb,nOrb), Fb(nOrb,nOrb)) ! Roothan canonicalization parameters @@ -66,12 +66,12 @@ subroutine ROHF_fock_matrix(nBas_AOs, nBas_MOs, nOa, nOb, S, c, FaAO, FbAO, FAO) nC = min(nOa, nOb) nO = abs(nOa - nOb) - nV = nBas_AOs - nC - nO + nV = nBas - nC - nO ! Block-by-block Fock matrix - call AOtoMO(nBas_AOs, nBas_MOs, c, FaAO, Fa) - call AOtoMO(nBas_AOs, nBas_MOs, c, FbAO, Fb) + call AOtoMO(nBas, nOrb, c, FaAO, Fa) + call AOtoMO(nBas, nOrb, c, FbAO, Fb) F(1:nC, 1:nC ) = aC*Fa(1:nC, 1:nC ) + bC*Fb(1:nC, 1:nC ) F(1:nC, nC+1:nC+nO ) = Fb(1:nC, nC+1:nC+nO ) @@ -85,9 +85,9 @@ subroutine ROHF_fock_matrix(nBas_AOs, nBas_MOs, nOa, nOb, S, c, FaAO, FbAO, FAO) F(nO+nC+1:nC+nO+nV, nC+1:nC+nO ) = Fa(nO+nC+1:nC+nO+nV, nC+1:nC+nO ) F(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) = aV*Fa(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) + bV*Fb(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, F, FAO) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, Fa, FaAO) - call MOtoAO(nBas_AOs, nBas_MOs, S, c, Fb, FbAO) + call MOtoAO(nBas, nOrb, S, c, F, FAO) + call MOtoAO(nBas, nOrb, S, c, Fa, FaAO) + call MOtoAO(nBas, nOrb, S, c, Fb, FbAO) deallocate(F, Fa, Fb) diff --git a/src/HF/core_guess.f90 b/src/HF/core_guess.f90 index c48c3ae..8d34444 100644 --- a/src/HF/core_guess.f90 +++ b/src/HF/core_guess.f90 @@ -1,4 +1,4 @@ -subroutine core_guess(nBas_AOs, nBas_MOs, Hc, X, c) +subroutine core_guess(nBas, nOrb, Hc, X, c) ! Core guess of the molecular orbitals for HF calculation @@ -6,9 +6,9 @@ subroutine core_guess(nBas_AOs, nBas_MOs, Hc, X, c) ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + integer,intent(in) :: nBas, nOrb + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nOrb) ! Local variables @@ -18,17 +18,17 @@ subroutine core_guess(nBas_AOs, nBas_MOs, Hc, X, c) ! Output variables - double precision,intent(out) :: c(nBas_AOs,nBas_MOs) + double precision,intent(out) :: c(nBas,nOrb) ! Memory allocation - allocate(cp(nBas_MOs,nBas_MOs), e(nBas_MOs)) + allocate(cp(nOrb,nOrb), e(nOrb)) ! Core guess cp(:,:) = matmul(transpose(X(:,:)), matmul(Hc(:,:), X(:,:))) - call diagonalize_matrix(nBas_MOs, cp, e) + call diagonalize_matrix(nOrb, cp, e) c(:,:) = matmul(X(:,:), cp(:,:)) deallocate(cp, e) diff --git a/src/HF/huckel_guess.f90 b/src/HF/huckel_guess.f90 index a8e7e52..7afd0a0 100644 --- a/src/HF/huckel_guess.f90 +++ b/src/HF/huckel_guess.f90 @@ -1,4 +1,4 @@ -subroutine huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) +subroutine huckel_guess(nBas, nOrb, S, Hc, X, c) ! Hickel guess @@ -6,10 +6,10 @@ subroutine huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + integer,intent(in) :: nBas, nOrb + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nOrb) ! Local variables @@ -20,11 +20,11 @@ subroutine huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) ! Output variables - double precision,intent(out) :: c(nBas_AOs,nBas_MOs) + double precision,intent(out) :: c(nBas,nOrb) ! Memory allocation - allocate(F(nBas_AOs,nBas_AOs)) + allocate(F(nBas,nBas)) ! Extended Huckel parameter @@ -32,9 +32,9 @@ subroutine huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) ! GWH approximation - do mu = 1, nBas_AOs + do mu = 1, nBas F(mu,mu) = Hc(mu,mu) - do nu = mu+1, nBas_AOs + do nu = mu+1, nBas F(mu,nu) = 0.5d0*a*S(mu,nu)*(Hc(mu,mu) + Hc(nu,nu)) F(nu,mu) = F(mu,nu) @@ -42,7 +42,7 @@ subroutine huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) end do end do - call core_guess(nBas_AOs, nBas_MOs, F, X, c) + call core_guess(nBas, nOrb, F, X, c) deallocate(F) diff --git a/src/HF/mo_guess.f90 b/src/HF/mo_guess.f90 index fd1f20d..2046569 100644 --- a/src/HF/mo_guess.f90 +++ b/src/HF/mo_guess.f90 @@ -1,7 +1,7 @@ ! --- -subroutine mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) +subroutine mo_guess(nBas, nOrb, guess_type, S, Hc, X, c) ! Guess of the molecular orbitals for HF calculation @@ -9,15 +9,15 @@ subroutine mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: guess_type - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nOrb) ! Output variables - double precision,intent(inout) :: c(nBas_AOs,nBas_MOs) + double precision,intent(inout) :: c(nBas,nOrb) if(guess_type == 0) then @@ -27,12 +27,12 @@ subroutine mo_guess(nBas_AOs, nBas_MOs, guess_type, S, Hc, X, c) elseif(guess_type == 1) then write(*,*) 'Core guess...' - call core_guess(nBas_AOs, nBas_MOs, Hc, X, c) + call core_guess(nBas, nOrb, Hc, X, c) elseif(guess_type == 2) then write(*,*) 'Huckel guess...' - call huckel_guess(nBas_AOs, nBas_MOs, S, Hc, X, c) + call huckel_guess(nBas, nOrb, S, Hc, X, c) elseif(guess_type == 3) then diff --git a/src/HF/print_RHF.f90 b/src/HF/print_RHF.f90 index 6790fcf..277db55 100644 --- a/src/HF/print_RHF.f90 +++ b/src/HF/print_RHF.f90 @@ -1,7 +1,7 @@ ! --- -subroutine print_RHF(nBas_AOs, nBas_MOs, nO, eHF, cHF, ENuc, ET, EV, EJ, EK, ERHF, dipole) +subroutine print_RHF(nBas, nOrb, nO, eHF, cHF, ENuc, ET, EV, EJ, EK, ERHF, dipole) ! Print one-electron energies and other stuff for G0W0 @@ -10,10 +10,10 @@ subroutine print_RHF(nBas_AOs, nBas_MOs, nO, eHF, cHF, ENuc, ET, EV, EJ, EK, ERH ! Input variables - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: cHF(nBas_AOs,nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: cHF(nBas,nOrb) double precision,intent(in) :: ENuc double precision,intent(in) :: ET double precision,intent(in) :: EV @@ -78,13 +78,13 @@ subroutine print_RHF(nBas_AOs, nBas_MOs, nO, eHF, cHF, ENuc, ET, EV, EJ, EK, ERH write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' RHF orbital coefficients ' write(*,'(A50)') '---------------------------------------' - call matout(nBas_AOs, nBas_MOs, cHF) + call matout(nBas, nOrb, cHF) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' RHF orbital energies (au) ' write(*,'(A50)') '---------------------------------------' - call vecout(nBas_MOs, eHF) + call vecout(nOrb, eHF) write(*,*) end subroutine diff --git a/src/HF/print_ROHF.f90 b/src/HF/print_ROHF.f90 index 09939f6..0297bb4 100644 --- a/src/HF/print_ROHF.f90 +++ b/src/HF/print_ROHF.f90 @@ -1,17 +1,17 @@ ! --- -subroutine print_ROHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, Ex, EROHF, dipole) +subroutine print_ROHF(nBas, nOrb, nO, eHF, c, ENuc, ET, EV, EJ, Ex, EROHF, dipole) ! Print one- and two-electron energies and other stuff for RoHF calculation implicit none include 'parameters.h' - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO(nspin) - double precision,intent(in) :: eHF(nBas_MOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: c(nBas,nOrb) double precision,intent(in) :: ENuc double precision,intent(in) :: ET(nspin) double precision,intent(in) :: EV(nspin) @@ -34,7 +34,7 @@ subroutine print_ROHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, Ex, EROH do ispin=1,nspin if(nO(ispin) > 0) then HOMO(ispin) = eHF(nO(ispin)) - if(nO(ispin) < nBas_MOs) then + if(nO(ispin) < nOrb) then LUMO(ispin) = eHF(nO(ispin)+1) else LUMO(ispin) = 0d0 @@ -105,13 +105,13 @@ subroutine print_ROHF(nBas_AOs, nBas_MOs, nO, eHF, c, ENuc, ET, EV, EJ, Ex, EROH write(*,'(A50)') '-----------------------------------------' write(*,'(A50)') 'ROHF orbital coefficients ' write(*,'(A50)') '-----------------------------------------' - call matout(nBas_AOs, nBas_MOs, c) + call matout(nBas, nOrb, c) write(*,*) end if write(*,'(A50)') '---------------------------------------' write(*,'(A50)') ' ROHF orbital energies (au) ' write(*,'(A50)') '---------------------------------------' - call vecout(nBas_MOs, eHF) + call vecout(nOrb, eHF) write(*,*) end subroutine diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index 75514f4..c6a77c9 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -15,7 +15,7 @@ program QuAcK logical :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW logical :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh - integer :: nNuc, nBas_AOs, nBas_MOs + integer :: nNuc, nBas, nOrb integer :: nC(nspin) integer :: nO(nspin) integer :: nV(nspin) @@ -69,7 +69,9 @@ program QuAcK logical :: dotest,doRtest,doUtest,doGtest - integer :: i, j + integer :: i, j, j0 + double precision :: acc_d, acc_nd + double precision, allocatable :: tmp1(:,:), tmp2(:,:) !-------------! ! Hello World ! @@ -130,8 +132,8 @@ program QuAcK ! nO = number of occupied orbitals ! ! nV = number of virtual orbitals (see below) ! ! nR = number of Rydberg orbitals ! -! nBas_AOs = number of basis functions in AOs ! -! nBas_MOs = number of basis functions in MOs ! +! nBas = number of basis functions in AOs ! +! nOrb = number of basis functions in MOs ! !---------------------------------------------------! call read_molecule(nNuc,nO,nC,nR) @@ -145,7 +147,7 @@ program QuAcK ! Read basis set information from PySCF ! !---------------------------------------! - call read_basis_pyscf(nBas_AOs, nO, nV) + call read_basis_pyscf(nBas, nO, nV) !--------------------------------------! ! Read one- and two-electron integrals ! @@ -153,19 +155,19 @@ program QuAcK ! Memory allocation for one- and two-electron integrals - allocate(S(nBas_AOs,nBas_AOs)) - allocate(T(nBas_AOs,nBas_AOs)) - allocate(V(nBas_AOs,nBas_AOs)) - allocate(Hc(nBas_AOs,nBas_AOs)) - allocate(ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs)) - allocate(dipole_int_AO(nBas_AOs,nBas_AOs,ncart)) + allocate(S(nBas,nBas)) + allocate(T(nBas,nBas)) + allocate(V(nBas,nBas)) + allocate(Hc(nBas,nBas)) + allocate(ERI_AO(nBas,nBas,nBas,nBas)) + allocate(dipole_int_AO(nBas,nBas,ncart)) ! Read integrals call wall_time(start_int) - call read_integrals(nBas_AOs, S(1,1), T(1,1), V(1,1), Hc(1,1), ERI_AO(1,1,1,1)) - call read_dipole_integrals(nBas_AOs, dipole_int_AO) + call read_integrals(nBas, S(1,1), T(1,1), V(1,1), Hc(1,1), ERI_AO(1,1,1,1)) + call read_dipole_integrals(nBas, dipole_int_AO) call wall_time(end_int) @@ -176,39 +178,61 @@ program QuAcK ! Compute orthogonalization matrix - !call orthogonalization_matrix(nBas_AOs, S, X) + !call orthogonalization_matrix(nBas, S, X) - allocate(Uvec(nBas_AOs,nBas_AOs), Uval(nBas_AOs)) + allocate(Uvec(nBas,nBas), Uval(nBas)) - Uvec(1:nBas_AOs,1:nBas_AOs) = S(1:nBas_AOs,1:nBas_AOs) - call diagonalize_matrix(nBas_AOs, Uvec, Uval) + Uvec(1:nBas,1:nBas) = S(1:nBas,1:nBas) + call diagonalize_matrix(nBas, Uvec, Uval) - nBas_MOs = 0 - do i = 1, nBas_AOs + nOrb = 0 + do i = 1, nBas if(Uval(i) > 1d-6) then Uval(i) = 1d0 / dsqrt(Uval(i)) - nBas_MOs = nBas_MOs + 1 + nOrb = nOrb + 1 else write(*,*) ' Eigenvalue',i,'too small for canonical orthogonalization' end if end do write(*,'(A38)') '--------------------------------------' - write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas_AOs - write(*,'(A38,1X,I16)') 'Number of basis functions (MOs)', nBas_MOs - write(*,'(A38,1X,F9.3)') ' % of discarded orbitals = ', 100.d0 * (1.d0 - dble(nBas_MOs)/dble(nBas_AOs)) + write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas + write(*,'(A38,1X,I16)') 'Number of basis functions (MOs)', nOrb + write(*,'(A38,1X,F9.3)') ' % of discarded orbitals = ', 100.d0 * (1.d0 - dble(nOrb)/dble(nBas)) write(*,'(A38)') '--------------------------------------' write(*,*) - allocate(X(nBas_AOs,nBas_MOs)) - do j = 1, nBas_MOs - do i = 1, nBas_AOs - X(i,j) = Uvec(i,j) * Uval(j) + j0 = nBas - nOrb + allocate(X(nBas,nOrb)) + do j = j0+1, nBas + do i = 1, nBas + X(i,j-j0) = Uvec(i,j) * Uval(j) enddo enddo deallocate(Uvec, Uval) + !! check if X.T S X = 1_(nOrb,nOrb) + !allocate(tmp1(nOrb,nBas), tmp2(nOrb,nOrb)) + !call dgemm("T", "N", nOrb, nBas, nBas, 1.d0, & + ! X(1,1), nBas, S(1,1), nBas, & + ! 0.d0, tmp1(1,1), nOrb) + !call dgemm("N", "N", nOrb, nOrb, nBas, 1.d0, & + ! tmp1(1,1), nOrb, X(1,1), nBas, & + ! 0.d0, tmp2(1,1), nOrb) + !acc_d = 0.d0 + !acc_nd = 0.d0 + !do i = 1, nOrb + ! !write(*,'(1000(F15.7,2X))') (tmp2(i,j), j = 1, nOrb) + ! acc_d = acc_d + tmp2(i,i) + ! do j = 1, nOrb + ! if(j == i) cycle + ! acc_nd = acc_nd + dabs(tmp2(j,i)) + ! enddo + !enddo + !print*, ' diag part: ', dabs(acc_d - dble(nOrb)) / dble(nOrb) + !print*, ' non-diag part: ', acc_nd + !deallocate(tmp1, tmp2) !---------------------! ! Choose QuAcK branch ! @@ -240,7 +264,7 @@ program QuAcK dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas_AOs,nBas_MOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & @@ -256,7 +280,7 @@ program QuAcK dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas_AOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & @@ -271,7 +295,7 @@ program QuAcK call GQuAcK(doGtest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & dodrCCD,dorCCD,docrCCD,dolCCD,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2, & - nNuc,nBas_AOs,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_AO,ERI_AO, & + nNuc,nBas,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_AO,ERI_AO, & maxSCF_HF,max_diis_HF,thresh_HF,level_shift,guess_type,mix,reg_MP, & maxSCF_CC,max_diis_CC,thresh_CC,TDA,maxSCF_GF,max_diis_GF,thresh_GF,lin_GF,reg_GF,eta_GF, & maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index db16eab..1390366 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -2,7 +2,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & - nNuc,nBas_AOs,nBas_MOs,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & + nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift, & guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,singlet,triplet,TDA, & maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & @@ -29,7 +29,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d logical,intent(in) :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp logical,intent(in) :: doG0T0eh,doevGTeh,doqsGTeh - integer,intent(in) :: nNuc,nBas_AOs,nBas_MOs + integer,intent(in) :: nNuc,nBas,nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV @@ -38,13 +38,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d double precision,intent(in) :: ZNuc(nNuc),rNuc(nNuc,ncart) - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: T(nBas_AOs,nBas_AOs) - double precision,intent(in) :: V(nBas_AOs,nBas_AOs) - double precision,intent(in) :: Hc(nBas_AOs,nBas_AOs) - double precision,intent(in) :: X(nBas_AOs,nBas_MOs) - double precision,intent(in) :: dipole_int_AO(nBas_AOs,nBas_AOs,ncart) - double precision,intent(in) :: ERI_AO(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs) + 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,nOrb) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) integer,intent(in) :: maxSCF_HF,max_diis_HF double precision,intent(in) :: thresh_HF,level_shift,mix @@ -109,11 +109,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d ! Memory allocation ! !-------------------! - allocate(cHF(nBas_AOs,nBas_MOs)) - allocate(eHF(nBas_MOs)) - allocate(PHF(nBas_AOs,nBas_AOs)) - allocate(dipole_int_MO(nBas_MOs,nBas_MOs,ncart)) - allocate(ERI_MO(nBas_MOs,nBas_MOs,nBas_MOs,nBas_MOs)) + allocate(cHF(nBas,nOrb)) + allocate(eHF(nOrb)) + allocate(PHF(nBas,nBas)) + allocate(dipole_int_MO(nOrb,nOrb,ncart)) + allocate(ERI_MO(nOrb,nOrb,nOrb,nOrb)) !---------------------! ! Hartree-Fock module ! @@ -123,7 +123,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_HF) call RHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) + nBas, nOrb, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) call wall_time(end_HF) t_HF = end_HF - start_HF @@ -136,7 +136,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_HF) call ROHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) + nBas, nOrb, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF) call wall_time(end_HF) t_HF = end_HF - start_HF @@ -158,12 +158,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d ! Read and transform dipole-related integrals do ixyz = 1, ncart - call AOtoMO(nBas_AOs, nBas_MOs, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) + call AOtoMO(nBas, nOrb, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz)) end do ! 4-index transform - call AOtoMO_ERI_RHF(nBas_AOs, nBas_MOs, cHF, ERI_AO, ERI_MO) + call AOtoMO_ERI_RHF(nBas, nOrb, cHF, ERI_AO, ERI_MO) call wall_time(end_AOtoMO) @@ -180,7 +180,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(dostab) then call wall_time(start_stab) - call RHF_stability(nBas_MOs, nC, nO, nV, nR, nS, eHF, ERI_MO) + call RHF_stability(nOrb, nC, nO, nV, nR, nS, eHF, ERI_MO) call wall_time(end_stab) t_stab = end_stab - start_stab @@ -193,7 +193,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_stab) call RHF_search(maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, & + nBas, nOrb, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, & dipole_int_MO, X, ERHF, eHF, cHF, PHF) call wall_time(end_stab) @@ -212,7 +212,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doMP) then call wall_time(start_MP) - call RMP(dotest, doMP2, doMP3, reg_MP, nBas_MOs, nBas_MOs, nC, nO, nV, nR, ERI_MO, ENuc, ERHF, eHF) + call RMP(dotest, doMP2, doMP3, reg_MP, nOrb, nOrb, nC, nO, nV, nR, ERI_MO, ENuc, ERHF, eHF) call wall_time(end_MP) t_MP = end_MP - start_MP @@ -232,7 +232,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_CC) call RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, docrCCD, dolCCD, & - maxSCF_CC, thresh_CC, max_diis_CC, nBas_AOs, nBas_MOs, nC, nO, nV, nR, Hc, ERI_MO, ENuc, ERHF, eHF, cHF) + maxSCF_CC, thresh_CC, max_diis_CC, nBas, nOrb, nC, nO, nV, nR, Hc, ERI_MO, ENuc, ERHF, eHF, cHF) call wall_time(end_CC) t_CC = end_CC - start_CC @@ -250,7 +250,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doCI) then call wall_time(start_CI) - call RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nBas_MOs, & + call RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nOrb, & nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eHF, ERHF) call wall_time(end_CI) @@ -270,7 +270,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_RPA) call RRPA(dotest, dophRPA, dophRPAx, docrRPA, doppRPA, TDA, doACFDT, exchange_kernel, singlet, triplet, & - nBas_MOs, nC, nO, nV, nR, nS, ENuc, ERHF, ERI_MO, dipole_int_MO, eHF) + nOrb, nC, nO, nV, nR, nS, ENuc, ERHF, ERI_MO, dipole_int_MO, eHF) call wall_time(end_RPA) t_RPA = end_RPA - start_RPA @@ -290,7 +290,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_GF) call RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, renorm_GF, maxSCF_GF, & thresh_GF, max_diis_GF, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, lin_GF, & - eta_GF, reg_GF, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, & + eta_GF, reg_GF, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, & S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GF) @@ -311,7 +311,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call wall_time(start_GW) call RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxSCF_GW, thresh_GW, max_diis_GW, & doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, TDA_W, TDA, dBSE, dTDA, singlet, triplet, & - lin_GW, eta_GW, reg_GW, nNuc, ZNuc, rNuc, ENuc, nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, & + lin_GW, eta_GW, reg_GW, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, & V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GW) @@ -333,7 +333,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d call RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevGTeh, doqsGTeh, & maxSCF_GT, thresh_GT, max_diis_GT, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, & TDA_T, TDA, dBSE, dTDA, singlet, triplet, lin_GT, eta_GT, reg_GT, nNuc, ZNuc, rNuc, ENuc, & - nBas_AOs, nBas_MOs, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, & + nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, & dipole_int_MO, PHF, cHF, eHF) call wall_time(end_GT) diff --git a/src/utils/level_shifting.f90 b/src/utils/level_shifting.f90 index a006622..8b627fa 100644 --- a/src/utils/level_shifting.f90 +++ b/src/utils/level_shifting.f90 @@ -1,4 +1,4 @@ -subroutine level_shifting(level_shift, nBas_AOs, nBas_MOs, nO, S, c, F) +subroutine level_shifting(level_shift, nBas, nOrb, nO, S, c, F) ! Perform level-shifting on the Fock matrix @@ -7,10 +7,10 @@ subroutine level_shifting(level_shift, nBas_AOs, nBas_MOs, nO, S, c, F) ! Input variables double precision,intent(in) :: level_shift - integer,intent(in) :: nBas_AOs, nBas_MOs + integer,intent(in) :: nBas, nOrb integer,intent(in) :: nO - double precision,intent(in) :: S(nBas_AOs,nBas_AOs) - double precision,intent(in) :: c(nBas_AOs,nBas_MOs) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: c(nBas,nOrb) ! Local variables @@ -21,13 +21,13 @@ subroutine level_shifting(level_shift, nBas_AOs, nBas_MOs, nO, S, c, F) ! Output variables - double precision,intent(inout):: F(nBas_AOs,nBas_AOs) + double precision,intent(inout):: F(nBas,nBas) - allocate(F_MO(nBas_MOs,nBas_MOs), Sc(nBas_AOs,nBas_MOs)) + allocate(F_MO(nOrb,nOrb), Sc(nBas,nOrb)) F_MO(:,:) = matmul(transpose(c), matmul(F, c)) - do a = nO+1, nBas_MOs + do a = nO+1, nOrb F_MO(a,a) = F_MO(a,a) + level_shift end do From 4d8adcd6a29d983f6a5d410fafaf4d96f0825c5b Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Sun, 1 Sep 2024 15:07:01 +0200 Subject: [PATCH 44/46] fixed bug in RMP call --- src/MP/RMP.f90 | 12 ++++++------ src/QuAcK/RQuAcK.f90 | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/MP/RMP.f90 b/src/MP/RMP.f90 index daf3f1e..01e2288 100644 --- a/src/MP/RMP.f90 +++ b/src/MP/RMP.f90 @@ -1,4 +1,4 @@ -subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) +subroutine RMP(dotest,doMP2,doMP3,regularize,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) ! Moller-Plesset module @@ -13,15 +13,15 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) logical,intent(in) :: doMP3 logical,intent(in) :: regularize - integer,intent(in) :: nBas + integer,intent(in) :: nOrb integer,intent(in) :: nC integer,intent(in) :: nO integer,intent(in) :: nV integer,intent(in) :: nR double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF - double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) ! Local variables @@ -37,7 +37,7 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) if(doMP2) then call wall_time(start_MP) - call RMP2(dotest,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF,Ec) + call RMP2(dotest,regularize,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF,Ec) call wall_time(end_MP) t_MP = end_MP - start_MP @@ -53,7 +53,7 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) if(doMP3) then call wall_time(start_MP) - call RMP3(nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) + call RMP3(nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF) call wall_time(end_MP) t_MP = end_MP - start_MP diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 5725c4d..2457011 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -212,7 +212,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d if(doMP) then call wall_time(start_MP) - call RMP(dotest, doMP2, doMP3, reg_MP, nOrb, nOrb, nC, nO, nV, nR, ERI_MO, ENuc, ERHF, eHF) + call RMP(dotest, doMP2, doMP3, reg_MP, nOrb, nC, nO, nV, nR, ERI_MO, ENuc, ERHF, eHF) call wall_time(end_MP) t_MP = end_MP - start_MP From 9d2a6eee0b1a6c1f0c814d483f50994b937bcf13 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Sun, 1 Sep 2024 15:29:33 +0200 Subject: [PATCH 45/46] udapted qsRGF2, qsRGTeh, qsRGTpp and qsRGW pour nOrb --- src/GF/qsRGF2.f90 | 20 ++++++++++++++++---- src/GT/qsRGTeh.f90 | 19 +++++++++++++++---- src/GT/qsRGTpp.f90 | 19 +++++++++++++++---- src/GW/qsRGW.f90 | 23 ++++++++++++++++++----- 4 files changed, 64 insertions(+), 17 deletions(-) diff --git a/src/GF/qsRGF2.f90 b/src/GF/qsRGF2.f90 index 651c876..4b74f64 100644 --- a/src/GF/qsRGF2.f90 +++ b/src/GF/qsRGF2.f90 @@ -188,6 +188,10 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Solve the quasi-particle equation F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + SigCp(:,:) + if(nBas .ne. nOrb) then + call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1)) + call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1)) + endif ! Compute commutator and convergence criteria @@ -204,10 +208,18 @@ subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA, & ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X), matmul(F, X)) - cp(:,:) = Fp(:,:) - call diagonalize_matrix(nOrb, cp, eGF) - c = matmul(X, cp) + if(nBas .eq. nOrb) then + Fp = matmul(transpose(X), matmul(F, X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGF) + c = matmul(X, cp) + else + Fp = matmul(transpose(c), matmul(F, c)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGF) + c = matmul(c, cp) + endif + ! Compute new density matrix in the AO basis diff --git a/src/GT/qsRGTeh.f90 b/src/GT/qsRGTeh.f90 index 5f6acab..3cb9f94 100644 --- a/src/GT/qsRGTeh.f90 +++ b/src/GT/qsRGTeh.f90 @@ -221,6 +221,10 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Solve the quasi-particle equation F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + Sigp(:,:) + if(nBas .ne. nOrb) then + call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1)) + call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1)) + endif ! Compute commutator and convergence criteria @@ -237,10 +241,17 @@ subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X),matmul(F,X)) - cp(:,:) = Fp(:,:) - call diagonalize_matrix(nOrb, cp, eGT) - c = matmul(X,cp) + if(nBas .eq. nOrb) then + Fp = matmul(transpose(X), matmul(F, X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGT) + c = matmul(X, cp) + else + Fp = matmul(transpose(c), matmul(F, c)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGT) + c = matmul(c, cp) + endif ! Compute new density matrix in the AO basis diff --git a/src/GT/qsRGTpp.f90 b/src/GT/qsRGTpp.f90 index 15a29dc..43c861d 100644 --- a/src/GT/qsRGTpp.f90 +++ b/src/GT/qsRGTpp.f90 @@ -258,6 +258,10 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Solve the quasi-particle equation F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + Sigp(:,:) + if(nBas .ne. nOrb) then + call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1)) + call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1)) + endif ! Compute commutator and convergence criteria @@ -274,10 +278,17 @@ subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, d ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X), matmul(F, X)) - cp(:,:) = Fp(:,:) - call diagonalize_matrix(nOrb, cp, eGT) - c = matmul(X, cp) + if(nBas .eq. nOrb) then + Fp = matmul(transpose(X), matmul(F, X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGT) + c = matmul(X, cp) + else + Fp = matmul(transpose(c), matmul(F, c)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGT) + c = matmul(c, cp) + endif ! Compute new density matrix in the AO basis diff --git a/src/GW/qsRGW.f90 b/src/GW/qsRGW.f90 index 1756a0b..7f61e0c 100644 --- a/src/GW/qsRGW.f90 +++ b/src/GW/qsRGW.f90 @@ -221,10 +221,14 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Solve the quasi-particle equation F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + SigCp(:,:) + if(nBas .ne. nOrb) then + call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1)) + call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1)) + endif ! Compute commutator and convergence criteria - err = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + err = matmul(F, matmul(P, S)) - matmul(matmul(S, P), F) if(nSCF > 1) Conv = maxval(abs(err)) @@ -259,10 +263,19 @@ subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doX ! Diagonalize Hamiltonian in AO basis - Fp = matmul(transpose(X), matmul(F, X)) - cp(:,:) = Fp(:,:) - call diagonalize_matrix(nOrb, cp, eGW) - c = matmul(X, cp) + if(nBas .eq. nOrb) then + Fp = matmul(transpose(X), matmul(F, X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGW) + c = matmul(X, cp) + else + Fp = matmul(transpose(c), matmul(F, c)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nOrb, cp, eGW) + c = matmul(c, cp) + endif + + call AOtoMO(nBas, nOrb, c, SigCp, SigC) ! Density matrix From 0f9846b4f2c781d9c4c3105f893178e7004e3ec2 Mon Sep 17 00:00:00 2001 From: pfloos Date: Sun, 1 Sep 2024 21:42:10 +0200 Subject: [PATCH 46/46] clean up format --- src/QuAcK/QuAcK.f90 | 22 +++++++++++----------- src/utils/read_basis_pyscf.f90 | 10 +++++----- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index c6a77c9..ab1a2ff 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -125,16 +125,16 @@ program QuAcK doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA) -!---------------------------------------------------! -! Read input information ! -!---------------------------------------------------! -! 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 in AOs ! -! nOrb = number of basis functions in MOs ! -!---------------------------------------------------! +!-----------------------------------------------! +! Read input information ! +!-----------------------------------------------! +! 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 ! +! nOrb = number of orbitals ! +!-----------------------------------------------! call read_molecule(nNuc,nO,nC,nR) allocate(ZNuc(nNuc),rNuc(nNuc,ncart)) @@ -147,7 +147,7 @@ program QuAcK ! Read basis set information from PySCF ! !---------------------------------------! - call read_basis_pyscf(nBas, nO, nV) + call read_basis_pyscf(nBas,nO,nV) !--------------------------------------! ! Read one- and two-electron integrals ! diff --git a/src/utils/read_basis_pyscf.f90 b/src/utils/read_basis_pyscf.f90 index 42dfde2..f44d33b 100644 --- a/src/utils/read_basis_pyscf.f90 +++ b/src/utils/read_basis_pyscf.f90 @@ -1,4 +1,4 @@ -subroutine read_basis_pyscf(nBas_AOs, nO, nV) +subroutine read_basis_pyscf(nBas,nO,nV) ! Read basis set information from PySCF @@ -14,23 +14,23 @@ subroutine read_basis_pyscf(nBas_AOs, nO, nV) ! Output variables integer,intent(out) :: nV(nspin) - integer,intent(out) :: nBas_AOs + integer,intent(out) :: nBas !------------------------------------------------------------------------ ! Primary basis set information !------------------------------------------------------------------------ open(unit=3,file='int/nBas.dat') - read(3, *) nBas_AOs + read(3, *) nBas close(unit=3) ! write(*,'(A38)') '--------------------------------------' -! write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas_AOs +! write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas ! write(*,'(A38)') '--------------------------------------' ! write(*,*) ! Number of virtual orbitals - nV(:) = nBas_AOs - nO(:) + nV(:) = nBas - nO(:) end subroutine