subroutine ADC2(ispin,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,e,ERI) ! Compute ADC(2) excitation energies: see Schirmer, Cederbaum & Walter, PRA, 28 (1983) 1237 implicit none include 'parameters.h' ! Input variables integer,intent(in) :: ispin integer,intent(in) :: maxSCF double precision,intent(in) :: thresh integer,intent(in) :: max_diis integer,intent(in) :: nBas,nC,nO,nV,nR double precision,intent(in) :: e(nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables integer :: nH,nP,nHH,nPP,nSCF,n_diis double precision :: Conv double precision,external :: Kronecker_delta double precision,allocatable :: B_ADC(:,:),X_ADC(:,:),e_ADC(:),SigInf(:,:),G_ADC(:,:) double precision,allocatable :: db_ERI(:,:,:,:),eOld(:),error_diis(:,:),e_diis(:,:) integer :: i,j,k,l integer :: a,b,c,d integer :: p,q,r,s integer :: nADC,iADC,jADC ! Hello world write(*,*) write(*,*)'***********************************' write(*,*)'| 2nd-order ADC calculation |' write(*,*)'***********************************' write(*,*) ! Number of holes nH = nO - nC nHH = nH*(nH+1)/2 ! Number of particles nP = nV - nR nPP = nP*(nP+1)/2 write(*,*) 'Total states: ',nH+nP write(*,*) 'Hole states: ',nH write(*,*) 'Particle states: ',nP ! Size of ADC(2) matrices nADC = nH + nP + nH*nPP + nHH*nP write(*,'(1X,A25,I3,A6,I6)') 'Size of ADC(2) matrices: ',nADC,' x ',nADC ! Memory allocation allocate(db_ERI(nBas,nBas,nBas,nBas),error_diis(nADC,max_diis),e_diis(nADC,max_diis),eOld(nADC), & B_ADC(nADC,nADC),X_ADC(nADC,nADC),e_ADC(nADC),G_ADC(nBas,nBas),SigInf(nBas,nBas)) ! Create double-bar MO integrals call antisymmetrize_ERI(ispin,nBas,ERI,db_ERI) ! Initialization Conv = 1d0 nSCF = 0 n_diis = 0 e_diis(:,:) = 0d0 error_diis(:,:) = 0d0 SigInf(:,:) = 0d0 eOld(:) = 0d0 !------------------------------------------------------------------------ ! Main SCF loop !------------------------------------------------------------------------ ! ! | e + SigInf (U^I)^t (U^II)^t | ! | | ! B = | U^I K^I + C^I 0 | ! | | ! | U^II 0 K^II + C^II | ! ! do while(Conv > thresh .and. nSCF < maxSCF) ! ! Build ADC(2) B matrix -- Eq. (38b) -- ! write(*,'(1X,A7,1X,I4)') 'Cycle: ',nSCF ! ! Diagonal part: static self-energy and epsilon ! B_ADC(:,:) = 0d0 B_ADC(nC+1:nBas-nR,nC+1:nBas-nR) = SigInf(nC+1:nBas-nR,nC+1:nBas-nR) jADC = 0 do p=nC+1,nBas-nR jADC = jADC + 1 B_ADC(jADC,jADC) = e(p) enddo ! ! U matrices -- Eq. (40a) -- ! do p=nC+1,nBas-nR iADC = p - nC jADC = nH + nP ! U^I: 2p-1h -- Eqs. (40a) and (41a) -- do i=nC+1,nO do a=nO+1,nBas-nR do b=a,nBas-nR jADC = jADC + 1 B_ADC(iADC,jADC) = db_ERI(p,i,a,b) enddo enddo enddo ! U^II: 2h-1p -- Eqs. (40a) and (41b) -- do i=nC+1,nO do j=i,nO do a=nO+1,nBas-nR jADC = jADC + 1 B_ADC(iADC,jADC) = db_ERI(p,a,i,j) enddo enddo enddo enddo ! ! K matrices -- Eq. (40b) -- ! ! K^I: 2p-1h -- Eqs. (40b) and (41a) -- jADC = nH + nP do i=nC+1,nO do a=nO+1,nBas-nR do b=a,nBas-nR jADC = jADC + 1 B_ADC(jADC,jADC) = e(a) + e(b) - e(i) enddo enddo enddo ! K^II: 2h-1p -- Eqs. (40b) and (41b) -- do i=nC+1,nO do j=i,nO do a=nO+1,nBas-nR jADC = jADC + 1 B_ADC(jADC,jADC) = e(i) + e(j) - e(a) enddo enddo enddo ! ! C matrices -- Eq. (42c) ! ! C^I: 2p-1h-TDA -- Eqs. (42a) and (42c) -- iADC = nH + nP do i=nC+1,nO do a=nO+1,nBas-nR do b=a,nBas-nR iADC = iADC + 1 jADC = nH + nP do j=nC+1,nO do c=nO+1,nBas-nR do d=c,nBas-nR jADC = jADC + 1 B_ADC(iADC,jADC) = B_ADC(iADC,jADC) & + db_ERI(a,b,c,d)*Kronecker_delta(i,j) & - db_ERI(j,b,i,d)*Kronecker_delta(a,c) & - db_ERI(j,a,i,c)*Kronecker_delta(b,d) & + db_ERI(b,a,c,d)*Kronecker_delta(i,j) & - db_ERI(j,a,i,d)*Kronecker_delta(b,c) & - db_ERI(j,b,i,c)*Kronecker_delta(a,d) enddo enddo enddo enddo enddo enddo ! C^II: 2p-1h-TDA -- Eqs. (42b) and (42c) -- iADC = nH + nP + nH * nPP do i=nC+1,nO do j=i,nO do a=nO+1,nBas-nR iADC = iADC + 1 jADC = nH + nP + nH*nPP do k=nC+1,nO do l=k,nO do b=nO+1,nBas-nR jADC = jADC + 1 B_ADC(iADC,jADC) = B_ADC(iADC,jADC) & - db_ERI(i,j,k,l)*Kronecker_delta(a,b) & + db_ERI(b,j,a,l)*Kronecker_delta(i,k) & + db_ERI(b,i,a,k)*Kronecker_delta(j,l) & - db_ERI(j,i,k,l)*Kronecker_delta(a,b) & + db_ERI(b,i,a,l)*Kronecker_delta(j,k) & + db_ERI(b,j,a,k)*Kronecker_delta(i,l) enddo enddo enddo enddo enddo enddo ! Fold B onto itself do iADC=1,nADC do jADC=iADC+1,nADC B_ADC(jADC,iADC) = B_ADC(iADC,jADC) enddo enddo ! Diagonalize B to obtain X and E -- Eq. (38a) -- X_ADC(:,:) = B_ADC(:,:) call diagonalize_matrix(nADC,X_ADC,e_ADC) ! print results write(*,*) '=================================' write(*,*) 'ADC(2) excitation energies (eV)' do iADC=1,nADC ! if(NORM2(X_ADC(1:nH+nP,iADC)) > 0.1d0 ) & write(*,'(2(2X,F12.6))') e_ADC(iADC)*HaToeV,NORM2(X_ADC(1:nH+nP,iADC)) enddo write(*,*) '=================================' ! Convergence criteria Conv = maxval(abs(e_ADC - eOld)) ! Store result for next iteration eOld(:) = e_ADC(:) ! Compute W -- Eq (11) -- SigInf(:,:) = 0d0 do i=nC+1,nO do p=nC+1,nBas-nR do q=nC+1,nBas-nR SigInf(p,q) = SigInf(p,q) - db_ERI(p,i,q,i) enddo enddo enddo ! Compute the one-particle Greeen function -- Eq. (28) -- G_ADC(:,:) = 0d0 do iADC=1,nADC if(e_ADC(iADC) > 0d0 ) cycle do p=nC+1,nBas-nR do q=nC+1,nBas-nR G_ADC(p,q) = G_ADC(p,q) + X_ADC(p,iADC)*X_ADC(q,iADC) enddo enddo enddo ! Compute static self-energy for next iteration -- Eq. (25) -- do r=nC+1,nBas-nR do s=nC+1,nBas-nR do p=nC+1,nBas-nR do q=nC+1,nBas-nR SigInf(p,q) = SigInf(p,q) + db_ERI(p,r,q,s)*G_ADC(r,s) enddo enddo enddo enddo ! Print results ! call print_ADC2(nBas,nO,nSCF,Conv,e,eADC) ! Increment nSCF = nSCF + 1 enddo !------------------------------------------------------------------------ ! End main SCF loop !------------------------------------------------------------------------ ! Did it actually converge? if(nSCF == maxSCF+1) then write(*,*) write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*)' Convergence failed ' write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) endif end subroutine ADC2