From 3207b3b583a2c8e4351a71909ded5990d75160ef Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Fri, 21 Feb 2025 15:59:50 +0100 Subject: [PATCH 01/71] working on Parquet structure --- input/methods.default | 2 ++ src/QuAcK/GQuAcK.f90 | 20 +++++++++++++++++++- src/QuAcK/QuAcK.f90 | 6 ++++-- src/QuAcK/RQuAcK.f90 | 19 ++++++++++++++++++- src/QuAcK/read_methods.f90 | 10 ++++++++++ 5 files changed, 53 insertions(+), 4 deletions(-) diff --git a/input/methods.default b/input/methods.default index addaf23..84dbf56 100644 --- a/input/methods.default +++ b/input/methods.default @@ -18,5 +18,7 @@ F F F F # G0T0eh evGTeh qsGTeh F F F +# Parquet + F # Rtest Utest Gtest F F F diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index b82f134..0ee9e95 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -1,6 +1,6 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & dodrCCD,dorCCD,docrCCD,dolCCD,dophRPA,dophRPAx,docrRPA,doppRPA, & - doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2,doG0T0pp,doevGTpp,doqsGTpp, & + doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2,doG0T0pp,doevGTpp,doqsGTpp,doParquet,& nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_AO, & maxSCF_HF,max_diis_HF,thresh_HF,level_shift,guess_type,mix,reg_MP, & maxSCF_CC,max_diis_CC,thresh_CC, & @@ -27,6 +27,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop logical,intent(in) :: doG0F2,doevGF2,doqsGF2 logical,intent(in) :: doG0W0,doevGW,doqsGW logical,intent(in) :: doG0T0pp,doevGTpp,doqsGTpp + logical,intent(in) :: doParquet integer,intent(in) :: nNuc,nBas integer,intent(in) :: nC @@ -86,6 +87,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop double precision :: start_GF ,end_GF ,t_GF double precision :: start_GW ,end_GW ,t_GW double precision :: start_GT ,end_GT ,t_GT + double precision :: start_Parquet,end_Parquet ,t_Parquet double precision :: start_int, end_int, t_int double precision,allocatable :: cHF(:,:),eHF(:),PHF(:,:),FHF(:,:) @@ -331,6 +333,22 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GT = ',t_GT,' seconds' write(*,*) + end if + +!------------------------! +! Parquet module ! +!------------------------! + + if(doParquet) then + call wall_time(start_Parquet) + + call wall_time(end_Parquet) + + t_Parquet = end_Parquet - start_Parquet + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for Parquet module = ',t_Parquet,' seconds' + write(*,*) + end if + end subroutine diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index 8fd0214..99ccdc4 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -14,6 +14,7 @@ program QuAcK logical :: doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3 logical :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW logical :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh + logical :: doParquet integer :: nNuc integer :: nBas @@ -119,6 +120,7 @@ program QuAcK doG0W0,doevGW,doqsGW,doufG0W0,doufGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp, & doG0T0eh,doevGTeh,doqsGTeh, & + doParquet, & doRtest,doUtest,doGtest) !--------------------------! @@ -241,7 +243,7 @@ program QuAcK call RQuAcK(working_dir,use_gpu,doRtest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & 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, & - doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & + doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,doParquet, & nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_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, & @@ -273,7 +275,7 @@ program QuAcK if(doGQuAcK) & call GQuAcK(working_dir,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,doG0T0pp,doevGTpp,doqsGTpp, & + doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2,doG0T0pp,doevGTpp,doqsGTpp,doParquet, & nNuc,nBas,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_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, & diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 16b8159..ea706a6 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -1,7 +1,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & 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, & - doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & + doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,doParquet, & nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_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, & @@ -32,6 +32,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, logical,intent(in) :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW logical,intent(in) :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp logical,intent(in) :: doG0T0eh,doevGTeh,doqsGTeh + logical,intent(in) :: doParquet integer,intent(in) :: nNuc,nBas,nOrb integer,intent(in) :: nC @@ -94,6 +95,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, double precision :: start_GF ,end_GF ,t_GF double precision :: start_GW ,end_GW ,t_GW double precision :: start_GT ,end_GT ,t_GT + double precision :: start_Parquet,end_Parquet ,t_Parquet double precision :: start_int, end_int, t_int double precision,allocatable :: eHF(:) @@ -362,6 +364,21 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, end if +!------------------------! +! Parquet module ! +!------------------------! + + if(doParquet) then + call wall_time(start_Parquet) + + call wall_time(end_Parquet) + + t_Parquet = end_Parquet - start_Parquet + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for Parquet module = ',t_Parquet,' seconds' + write(*,*) + + end if + deallocate(eHF) deallocate(cHF) diff --git a/src/QuAcK/read_methods.f90 b/src/QuAcK/read_methods.f90 index bef3305..df13768 100644 --- a/src/QuAcK/read_methods.f90 +++ b/src/QuAcK/read_methods.f90 @@ -10,6 +10,7 @@ subroutine read_methods(working_dir, & doG0W0,doevGW,doqsGW,doufG0W0,doufGW, & doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp, & doG0T0eh,doevGTeh,doqsGTeh, & + doParquet, & doRtest,doUtest,doGtest) ! Read desired methods @@ -32,6 +33,7 @@ subroutine read_methods(working_dir, & logical,intent(out) :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW logical,intent(out) :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp logical,intent(out) :: doG0T0eh,doevGTeh,doqsGTeh + logical,intent(out) :: doParquet logical,intent(out) :: doRtest,doUtest,doGtest @@ -196,6 +198,14 @@ subroutine read_methods(working_dir, & if(ans1 == 'T') doG0T0eh = .true. if(ans2 == 'T') doevGTeh = .true. if(ans3 == 'T') doqsGTeh = .true. + + ! Read coupled channels methods + + doParquet = .false. + + read(1,*) + read(1,*) ans1 + if(ans1 == 'T') doParquet = .true. ! Read test From d80f1760d334c7942c603f8386fbadbb7dda5199 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Sat, 22 Feb 2025 21:45:34 +0100 Subject: [PATCH 02/71] Update README.md --- README.md | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 9ed2498..46b28dd 100644 --- a/README.md +++ b/README.md @@ -4,10 +4,11 @@ **Contributors:** - [Pierre-Francois Loos](https://pfloos.github.io/WEB_LOOS) +- [Anthony Scemama](https://scemama.github.io) - [Enzo Monino](https://enzomonino.github.io) - [Antoine Marie](https://antoine-marie.github.io) - [Abdallah Ammar](https://scholar.google.com/citations?user=y437T5sAAAAJ&hl=en) -- [Anthony Scemama](https://scemama.github.io) +- [Mauricio Rodriguez-Mayorga](https://scholar.google.com/citations?user=OLGOgQgAAAAJ&hl=es) # What is it? @@ -67,6 +68,12 @@ The two most important files are: - `$QUACK_ROOT/input/methods` that gathers the methods you want to use. - `$QUACK_ROOT/input/options` that gathers the different options associated these methods. +Copy the files `methods.default` and `options.default` to `methods.default` `options.default` +``` +cp $QUACK_ROOT/input/methods.default $QUACK_ROOT/input/methods +cp $QUACK_ROOT/input/options.default $QUACK_ROOT/input/options +``` +You can then edit these files to run the methods you'd like with the specific options. These files look like this ``` QuAcK 💩 % cat input/methods From 16321d98fce35597b36d9ae10193b143d3eb3bb1 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Sat, 22 Feb 2025 21:46:05 +0100 Subject: [PATCH 03/71] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 46b28dd..f0be62c 100644 --- a/README.md +++ b/README.md @@ -73,7 +73,7 @@ Copy the files `methods.default` and `options.default` to `methods.default` `opt cp $QUACK_ROOT/input/methods.default $QUACK_ROOT/input/methods cp $QUACK_ROOT/input/options.default $QUACK_ROOT/input/options ``` -You can then edit these files to run the methods you'd like with the specific options. +You can then edit these files to run the methods you'd like with specific options. These files look like this ``` QuAcK 💩 % cat input/methods From 07c2846e38949d983cc25e9d36d0fab136cbc34c Mon Sep 17 00:00:00 2001 From: pfloos Date: Sat, 22 Feb 2025 21:48:55 +0100 Subject: [PATCH 04/71] comment unnecessary code --- src/CC/EE_EOM_CCD_1h1p.f90 | 193 ++++++++++++++++++------------------- 1 file changed, 96 insertions(+), 97 deletions(-) diff --git a/src/CC/EE_EOM_CCD_1h1p.f90 b/src/CC/EE_EOM_CCD_1h1p.f90 index ef3f7f9..6e72c31 100644 --- a/src/CC/EE_EOM_CCD_1h1p.f90 +++ b/src/CC/EE_EOM_CCD_1h1p.f90 @@ -30,19 +30,19 @@ subroutine EE_EOM_CCD_1h1p(nC,nO,nV,nR,eO,eV,OOVV,OVVO,t) double precision,allocatable :: Om(:) double precision,allocatable :: VL(:,:) double precision,allocatable :: VR(:,:) - double precision,allocatable :: Leom(:,:,:) - double precision,allocatable :: Reom(:,:,:) +! double precision,allocatable :: Leom(:,:,:) +! double precision,allocatable :: Reom(:,:,:) - integer :: nstate,m - double precision :: Ex,tmp +! integer :: nstate,m +! double precision :: Ex,tmp integer,allocatable :: order(:) - double precision,allocatable :: rdm1_oo(:,:) - double precision,allocatable :: rdm1_vv(:,:) +! double precision,allocatable :: rdm1_oo(:,:) +! double precision,allocatable :: rdm1_vv(:,:) - double precision,allocatable :: rdm2_oovv(:,:,:,:) - double precision,allocatable :: rdm2_ovvo(:,:,:,:) +! double precision,allocatable :: rdm2_oovv(:,:,:,:) +! double precision,allocatable :: rdm2_ovvo(:,:,:,:) ! Hello world @@ -165,120 +165,119 @@ subroutine EE_EOM_CCD_1h1p(nC,nO,nV,nR,eO,eV,OOVV,OVVO,t) end if - allocate(Leom(nO,nV,nS),Reom(nO,nV,nS)) +! allocate(Leom(nO,nV,nS),Reom(nO,nV,nS)) - do m=1,nS - ia = 0 - do i=1,nO - do a=1,nV - ia = ia + 1 - Leom(i,a,m) = VL(ia,m) - Reom(i,a,m) = VR(ia,m) - end do - end do - end do +! do m=1,nS +! ia = 0 +! do i=1,nO +! do a=1,nV +! ia = ia + 1 +! Leom(i,a,m) = VL(ia,m) +! Reom(i,a,m) = VR(ia,m) +! end do +! end do +! end do - deallocate(VL,VR) +! deallocate(VL,VR) !------------------------------------------------------------------------ ! EOM section !------------------------------------------------------------------------ - allocate(rdm1_oo(nO,nO),rdm1_vv(nV,nV)) - allocate(rdm2_oovv(nO,nO,nV,nV),rdm2_ovvo(nO,nV,nV,nO)) +! allocate(rdm1_oo(nO,nO),rdm1_vv(nV,nV)) +! allocate(rdm2_oovv(nO,nO,nV,nV),rdm2_ovvo(nO,nV,nV,nO)) - nstate = 1 +! nstate = 1 - tmp = 0d0 - do i=1,nO - do a=1,nV - tmp = tmp + Leom(i,a,nstate)*Reom(i,a,nstate) - end do - end do - print*,tmp +! tmp = 0d0 +! do i=1,nO +! do a=1,nV +! tmp = tmp + Leom(i,a,nstate)*Reom(i,a,nstate) +! end do +! end do +! print*,tmp - rdm1_oo(:,:) = 0d0 - do i=1,nO - do j=1,nO - do c=1,nV +! rdm1_oo(:,:) = 0d0 +! do i=1,nO +! do j=1,nO +! do c=1,nV - rdm1_oo(i,j) = rdm1_oo(i,j) - Reom(i,c,nstate)*Leom(j,c,nstate) +! rdm1_oo(i,j) = rdm1_oo(i,j) - Reom(i,c,nstate)*Leom(j,c,nstate) - end do - end do - end do +! end do +! end do +! end do - rdm1_vv(:,:) = 0d0 - do a=1,nV - do b=1,nV - do k=1,nO +! rdm1_vv(:,:) = 0d0 +! do a=1,nV +! do b=1,nV +! do k=1,nO - rdm1_vv(a,b) = rdm1_vv(a,b) + Reom(k,b,nstate)*Leom(k,a,nstate) +! rdm1_vv(a,b) = rdm1_vv(a,b) + Reom(k,b,nstate)*Leom(k,a,nstate) - end do - end do - end do +! end do +! end do +! end do - rdm2_ovvo(:,:,:,:) = 0d0 - do i=1,nO - do a=1,nV - do b=1,nV - do j=1,nO - - rdm2_ovvo(i,a,b,j) = Reom(i,b,nstate)*Leom(j,a,nstate) +! rdm2_ovvo(:,:,:,:) = 0d0 +! do i=1,nO +! do a=1,nV +! do b=1,nV +! do j=1,nO +! +! rdm2_ovvo(i,a,b,j) = Reom(i,b,nstate)*Leom(j,a,nstate) - end do - end do - end do - end do +! end do +! end do +! end do +! end do - rdm2_oovv(:,:,:,:) = 0d0 - do i=1,nO - do j=1,nO - do a=1,nV - do b=1,nV +! rdm2_oovv(:,:,:,:) = 0d0 +! do i=1,nO +! do j=1,nO +! do a=1,nV +! do b=1,nV - do k=1,nO - do c=1,nV - - rdm2_oovv(i,j,a,b) = rdm2_oovv(i,j,a,b) & - + Reom(j,b,nstate)*t(k,i,c,a)*Leom(k,c,nstate) & - - Reom(i,b,nstate)*t(k,j,c,a)*Leom(k,c,nstate) & - - Reom(j,a,nstate)*t(k,i,c,b)*Leom(k,c,nstate) & - + Reom(i,a,nstate)*t(k,j,c,b)*Leom(k,c,nstate) +! do k=1,nO +! do c=1,nV +! +! rdm2_oovv(i,j,a,b) = rdm2_oovv(i,j,a,b) & +! + Reom(j,b,nstate)*t(k,i,c,a)*Leom(k,c,nstate) & +! - Reom(i,b,nstate)*t(k,j,c,a)*Leom(k,c,nstate) & +! - Reom(j,a,nstate)*t(k,i,c,b)*Leom(k,c,nstate) & +! + Reom(i,a,nstate)*t(k,j,c,b)*Leom(k,c,nstate) - end do - end do +! end do +! end do - end do - end do - end do - end do +! end do +! end do +! end do +! end do - Ex = 0d0 +! Ex = 0d0 - do i=1,nO - Ex = Ex + rdm1_oo(i,i)*eO(i) - end do +! do i=1,nO +! Ex = Ex + rdm1_oo(i,i)*eO(i) +! end do - do a=1,nV - Ex = Ex + rdm1_vv(a,a)*eV(a) - end do +! do a=1,nV +! Ex = Ex + rdm1_vv(a,a)*eV(a) +! end do - do i=1,nO - do a=1,nV - do b=1,nV - do j=1,nO - - Ex = Ex + rdm2_ovvo(i,a,b,j)*OVVO(i,a,b,j) + 0.25d0*rdm2_oovv(i,j,a,b)*OOVV(i,j,a,b) - - end do - end do - end do - end do - - print*,'Ex = ',Ex - print*,'Om = ',Om(nstate) +! do i=1,nO +! do a=1,nV +! do b=1,nV +! do j=1,nO +! +! Ex = Ex + rdm2_ovvo(i,a,b,j)*OVVO(i,a,b,j) + 0.25d0*rdm2_oovv(i,j,a,b)*OOVV(i,j,a,b) +! +! end do +! end do +! end do +! end do +! print*,'Ex = ',Ex +! print*,'Om = ',Om(nstate) end subroutine From 14318a217851fd85c370e971688a2e81b4a74764 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 17 Mar 2025 14:56:56 +0100 Subject: [PATCH 05/71] update on Parquet --- input/options.default | 2 + src/LR/ppRLR_C.f90 | 4 +- src/LR/ppRLR_D.f90 | 4 +- src/Parquet/README.md | 22 + src/Parquet/RParquet.f90 | 511 ++++++++++++++++++++ src/Parquet/R_eh_singlet_Gam.f90 | 155 ++++++ src/Parquet/R_eh_triplet_Gam.f90 | 155 ++++++ src/Parquet/R_irred_Parquet_self_energy.f90 | 94 ++++ src/Parquet/R_pp_singlet_Gam.f90 | 225 +++++++++ src/Parquet/R_pp_triplet_Gam.f90 | 217 +++++++++ src/Parquet/R_screened_integrals.f90 | 293 +++++++++++ src/QuAcK/GQuAcK.f90 | 4 +- src/QuAcK/QuAcK.f90 | 10 +- src/QuAcK/RQuAcK.f90 | 14 +- src/QuAcK/read_options.f90 | 16 +- 15 files changed, 1714 insertions(+), 12 deletions(-) create mode 100644 src/Parquet/README.md create mode 100644 src/Parquet/RParquet.f90 create mode 100644 src/Parquet/R_eh_singlet_Gam.f90 create mode 100644 src/Parquet/R_eh_triplet_Gam.f90 create mode 100644 src/Parquet/R_irred_Parquet_self_energy.f90 create mode 100644 src/Parquet/R_pp_singlet_Gam.f90 create mode 100644 src/Parquet/R_pp_triplet_Gam.f90 create mode 100644 src/Parquet/R_screened_integrals.f90 diff --git a/input/options.default b/input/options.default index 1a1be58..2e47df4 100644 --- a/input/options.default +++ b/input/options.default @@ -18,3 +18,5 @@ F F F F T # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F +# Parquet: max_it_macro conv_one_body max_it_micro conv_two_body + 1 0.00001 1 0.00001 diff --git a/src/LR/ppRLR_C.f90 b/src/LR/ppRLR_C.f90 index 658d6c5..e9aec8a 100644 --- a/src/LR/ppRLR_C.f90 +++ b/src/LR/ppRLR_C.f90 @@ -32,8 +32,8 @@ subroutine ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVV,lambda,e,ERI,Cpp) ! Define the chemical potential - eF = e(nO) + e(nO+1) -! eF = 0d0 +! eF = e(nO) + e(nO+1) + eF = 0d0 ! Build C matrix for the singlet manifold diff --git a/src/LR/ppRLR_D.f90 b/src/LR/ppRLR_D.f90 index 6878bf6..bcaca6d 100644 --- a/src/LR/ppRLR_D.f90 +++ b/src/LR/ppRLR_D.f90 @@ -30,8 +30,8 @@ subroutine ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOO,lambda,e,ERI,Dpp) ! Define the chemical potential - eF = e(nO) + e(nO+1) -! eF = 0d0 +! eF = e(nO) + e(nO+1) + eF = 0d0 ! Build the D matrix for the singlet manifold diff --git a/src/Parquet/README.md b/src/Parquet/README.md new file mode 100644 index 0000000..bec4abd --- /dev/null +++ b/src/Parquet/README.md @@ -0,0 +1,22 @@ +# Overview of the Parquet implementation + +## Parameters controling the run + +The parameters provided by the user are: +- `max_it_macro` and `max_it_micro` which set the maximum number of iterations of the macro (one-body) and micro (two-body) self-consistent cycles. +- `conv_one_body` and `conv_two_body` which set the convergence threshold of the macro (one-body) and micro (two-body) self-consistent cycles. +- +- + +The hard-coded parameters are: +- `linearize` which control whether the quasiparticle equation will be linearized or not. Note that the Newton-Raphson has not been implemented yet. +- `TDA` which control whether the Tamm-Dancoff approximation is enforced for the BSE problems or not. +- +- + +## Files and their routines +`RParquet.f90` is the main file for the restricted Parquet calculation, it is called by `RQuack.f90`. The main task of this file is to control the self-consistent cycles. + +## TODO list + +- [ ] Write the TODO list diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 new file mode 100644 index 0000000..cdb1f07 --- /dev/null +++ b/src/Parquet/RParquet.f90 @@ -0,0 +1,511 @@ +subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,nC,nO,nV,nR,nS,eHF,ERI) + +! Spatial orbital Parquet implementation + implicit none + include 'parameters.h' + +! Hard-coded parameters + logical :: linearize = .true. + logical :: TDA = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. + +! Input variables + integer,intent(in) :: max_it_macro,max_it_micro + double precision,intent(in) :: conv_one_body,conv_two_body + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + +! Local variables + integer :: n_it_macro,n_it_micro + double precision :: err_one_body,err_two_body + double precision :: err_eh_sing,err_eh_trip + double precision :: err_hh_sing,err_hh_trip + double precision :: err_ee_sing,err_ee_trip + double precision :: start_t, end_t, t + + integer :: nOOs,nOOt + integer :: nVVs,nVVt + + double precision :: EcRPA + double precision,allocatable :: Aph(:,:) + double precision,allocatable :: Bph(:,:) + double precision,allocatable :: sing_XpY(:,:),trip_XpY(:,:) + double precision,allocatable :: sing_XmY(:,:),trip_XmY(:,:) + double precision,allocatable :: eh_sing_Om(:), old_eh_sing_Om(:) + double precision,allocatable :: eh_trip_Om(:), old_eh_trip_Om(:) + + double precision,allocatable :: Bpp(:,:) + double precision,allocatable :: Cpp(:,:) + double precision,allocatable :: Dpp(:,:) + double precision,allocatable :: X1s(:,:),X1t(:,:) + double precision,allocatable :: Y1s(:,:),Y1t(:,:) + double precision,allocatable :: ee_sing_Om(:), old_ee_sing_Om(:) + double precision,allocatable :: ee_trip_Om(:), old_ee_trip_Om(:) + double precision,allocatable :: X2s(:,:),X2t(:,:) + double precision,allocatable :: Y2s(:,:),Y2t(:,:) + double precision,allocatable :: hh_sing_Om(:), old_hh_sing_Om(:) + double precision,allocatable :: hh_trip_Om(:), old_hh_trip_Om(:) + + double precision,allocatable :: eh_sing_rho(:,:,:),eh_trip_rho(:,:,:) + double precision,allocatable :: ee_sing_rho(:,:,:),hh_sing_rho(:,:,:) + double precision,allocatable :: ee_trip_rho(:,:,:),hh_trip_rho(:,:,:) + + double precision,allocatable :: eh_sing_Gam_A(:,:),eh_sing_Gam_B(:,:) + double precision,allocatable :: eh_trip_Gam_A(:,:),eh_trip_Gam_B(:,:) + double precision,allocatable :: pp_sing_Gam_B(:,:),pp_sing_Gam_C(:,:),pp_sing_Gam_D(:,:) + double precision,allocatable :: pp_trip_Gam_B(:,:),pp_trip_Gam_C(:,:),pp_trip_Gam_D(:,:) + double precision,allocatable :: eh_sing_Gam(:,:,:,:),eh_trip_Gam(:,:,:,:) + double precision,allocatable :: pp_sing_Gam(:,:,:,:),pp_trip_Gam(:,:,:,:) + + double precision,allocatable :: eParquetlin(:),eParquet(:),old_eParquet(:) + double precision,allocatable :: SigC(:) + double precision,allocatable :: Z(:) + double precision :: EcGM + +! Output variables + nOOs = nO*(nO + 1)/2 + nVVs = nV*(nV + 1)/2 + nOOt = nO*(nO - 1)/2 + nVVt = nV*(nV - 1)/2 + + allocate(eParquet(nOrb),old_eParquet(nOrb)) + + write(*,*) + write(*,*)'**********************************' + write(*,*)'* Restricted Parquet Calculation *' + write(*,*)'**********************************' + write(*,*) + +! Print parameters + write(*,*)'Parameters for this run:' + write(*,*)'Maximum number of macro iteration:', max_it_macro + write(*,*)'Convergence threshold for one-body energies:', conv_one_body + write(*,*)'Maximum number of micro iteration:', max_it_micro + write(*,*)'Convergence threshold for two-body energies:', conv_two_body + + if (linearize) then + write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' + write(*,*) + else + write(*,*) ' *** Quasiparticle energies obtained by root search *** ' + write(*,*) + endif + +! Initialization + n_it_macro = 1 + err_one_body = 1d0 + n_it_micro = 1 + err_two_body = 1d0 + old_eParquet(:) = eHF(:) + + write(*,*) + write(*,*)'************ Solving initial linear-response problems ************' + write(*,*)'------------------------------------------------------------------' + + !------------------- + ! Density channel + !------------------- + allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),old_eh_sing_Om(nS)) + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 + call wall_time(start_t) + if(.not.TDA) call phRLR_B(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phRLR_A(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) + call wall_time(end_t) + t = end_t - start_t + write(*,*) + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial singlet phRPA problem =',t,' seconds' + !if (print_phLR) call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) + call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) + + deallocate(Aph,Bph) + + !------------------- + ! Magnetic channel + !------------------- + allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),old_eh_trip_Om(nS)) + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 + call wall_time(start_t) + if(.not.TDA) call phRLR_B(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phRLR_A(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) + call wall_time(end_t) + t = end_t - start_t + write(*,*) + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial triplet phRPA problem =',t,' seconds' + !if (print_phLR) call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) + call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) + + deallocate(Aph,Bph) + + !------------------- + ! Singlet channel + !------------------- + allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & + ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs),old_ee_sing_Om(nVVs), & + hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs),old_hh_sing_Om(nOOs)) + Bpp(:,:)=0d0 + Cpp(:,:)=0d0 + Dpp(:,:)=0d0 + call wall_time(start_t) + if(.not.TDA) call ppRLR_B(1,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) + call ppRLR_C(1,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) + call ppRLR_D(1,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) + call wall_time(end_t) + t = end_t - start_t + write(*,*) + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial singlet ppRPA problem =',t,' seconds' + if (print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (singlets)',nVVs,ee_sing_Om) + if (print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (singlets)',nOOs,hh_sing_Om) + + deallocate(Bpp,Cpp,Dpp) + + !------------------- + ! Triplet channel + !------------------- + allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & + ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt),old_ee_trip_Om(nVVt), & + hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt),old_hh_trip_Om(nOOt)) + Bpp(:,:)=0d0 + Cpp(:,:)=0d0 + Dpp(:,:)=0d0 + call wall_time(start_t) + if(.not.TDA) call ppRLR_B(2,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call ppRLR_C(2,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) + call ppRLR_D(2,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) + call wall_time(end_t) + t = end_t - start_t + write(*,*) + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial triplet ppRPA problem =',t,' seconds' + write(*,*) + if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (triplets)',nVVt,ee_trip_Om) + if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (triplets)',nOOt,hh_trip_Om) + + deallocate(Bpp,Cpp,Dpp) + + !------------------- + ! Updating + !------------------- + old_eh_sing_Om(:) = eh_sing_Om(:) + old_eh_trip_Om(:) = eh_trip_Om(:) + old_ee_sing_Om(:) = ee_sing_Om(:) + old_hh_sing_Om(:) = hh_sing_Om(:) + old_ee_trip_Om(:) = ee_trip_Om(:) + old_hh_trip_Om(:) = hh_trip_Om(:) + + deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) + + allocate(eh_sing_rho(nOrb,nOrb,nS)) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,sing_XpY,eh_sing_rho) + deallocate(sing_XpY,sing_XmY) + + allocate(eh_trip_rho(nOrb,nOrb,nS)) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,trip_XpY,eh_trip_rho) + deallocate(trip_XpY,trip_XmY) + + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + pp_sing_Gam(:,:,:,:) = 0d0 + call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + deallocate(X1s,Y1s,X2s,Y2s) + deallocate(pp_sing_Gam) + + allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + pp_trip_Gam(:,:,:,:) = 0d0 + call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + deallocate(X1t,Y1t,X2t,Y2t) + deallocate(pp_trip_Gam) + +!------------------------------------------------------------------------ +! Loop on one-body energies +!------------------------------------------------------------------------ + + do while(err_one_body > conv_one_body .and. n_it_macro <= max_it_macro) + + write(*,*) + write(*,*)'************ Macro iteration number ',n_it_macro,' ************' + write(*,*)'---------------------------------------------------------------' + write(*,*) + + + do while(err_two_body > conv_two_body .and. n_it_micro <= max_it_micro) + + !TODO add some timers everywhere + write(*,*) + write(*,*)' Micro iteration number ',n_it_micro + write(*,*)' -----------------------------------' + write(*,*) + + !------------------- + ! Density channel + !------------------- + write(*,*)'Diagonalizing singlet ehBSE:' + write(*,*)'----------------------------' + allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 + call wall_time(start_t) + if(.not.TDA) call phRLR_B(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phRLR_A(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + + call R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam_A) + call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam_B) + + Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for singlet phBSE problem =',t,' seconds' + write(*,*) + if (print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) + err_eh_sing = maxval(abs(old_eh_sing_Om - eh_sing_Om)) + deallocate(Aph,Bph,eh_sing_Gam_A,eh_sing_Gam_B) + + !------------------- + ! Magnetic channel + !------------------- + write(*,*)'Diagonalizing triplet ehBSE:' + write(*,*)'----------------------------' + allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 + call wall_time(start_t) + if(.not.TDA) call phRLR_B(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phRLR_A(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + + call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_A) + call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_B) + + Aph(:,:) = Aph(:,:) + eh_trip_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_trip_Gam_B(:,:) + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for triplet phBSE problem =',t,' seconds' + write(*,*) + if (print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) + err_eh_trip = maxval(abs(old_eh_trip_Om - eh_trip_Om)) + deallocate(Aph,Bph,eh_trip_Gam_A,eh_trip_Gam_B) + + !------------------- + ! Singlet channel + !------------------- + write(*,*)'Diagonalizing singlet ppBSE:' + write(*,*)'----------------------------' + allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & + ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & + hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & + pp_sing_Gam_B(nVVs,nOOs),pp_sing_Gam_C(nVVs,nVVs),pp_sing_Gam_D(nOOs,nOOs)) + Bpp(:,:) = 0d0 + Cpp(:,:) = 0d0 + Dpp(:,:) = 0d0 + call wall_time(start_t) + if(.not.TDA) call ppRLR_B(1,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) + call ppRLR_C(1,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) + call ppRLR_D(1,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + + call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_B) + call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_C) + call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_D) + + Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) + + call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for singlet ppBSE problem =',t,' seconds' + write(*,*) + if (print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) + if (print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,hh_sing_Om) + err_ee_sing = maxval(abs(old_ee_sing_Om - ee_sing_Om)) + err_hh_sing = maxval(abs(old_hh_sing_Om - hh_sing_Om)) + deallocate(Bpp,Cpp,Dpp,pp_sing_Gam_B,pp_sing_Gam_C,pp_sing_Gam_D) + + !------------------- + ! Triplet channel + !------------------- + write(*,*)'Diagonalizing triplet ppBSE:' + write(*,*)'----------------------------' + allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & + ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & + hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & + pp_trip_Gam_B(nVVt,nOOt),pp_trip_Gam_C(nVVt,nVVt),pp_trip_Gam_D(nOOt,nOOt)) + Bpp(:,:)=0d0 + Cpp(:,:)=0d0 + Dpp(:,:)=0d0 + call wall_time(start_t) + if(.not.TDA) call ppRLR_B(2,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call ppRLR_C(2,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) + call ppRLR_D(2,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + + call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) + call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) + call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) + + Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) + + call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for triplet ppBSE problem =',t,' seconds' + write(*,*) + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,hh_trip_Om) + err_ee_trip = maxval(abs(old_ee_trip_Om - ee_trip_Om)) + err_hh_trip = maxval(abs(old_hh_trip_Om - hh_trip_Om)) + deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) + + write(*,*) + write(*,*)'Error for density channel:', err_eh_sing + write(*,*)'Error for magnetic channel:',err_eh_trip + write(*,*)'Error for singlet channel:', max(err_ee_sing,err_hh_sing) + write(*,*)'Error for triplet channel:', max(err_ee_trip,err_hh_trip) + write(*,*) + + !------------------- + ! Updating + !------------------- + old_eh_sing_Om(:) = eh_sing_Om(:) + old_eh_trip_Om(:) = eh_trip_Om(:) + old_ee_sing_Om(:) = ee_sing_Om(:) + old_hh_sing_Om(:) = hh_sing_Om(:) + old_ee_trip_Om(:) = ee_trip_Om(:) + old_hh_trip_Om(:) = hh_trip_Om(:) + + allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + call wall_time(start_t) + call R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building pp triplet Gamma =',t,' seconds' + write(*,*) + allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + call wall_time(start_t) + call R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building pp singlet Gamma =',t,' seconds' + write(*,*) + + deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) + deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) + + allocate(eh_sing_rho(nOrb,nOrb,nS)) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,sing_XpY,eh_sing_rho) + deallocate(sing_XpY,sing_XmY) + + allocate(eh_trip_rho(nOrb,nOrb,nS)) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,trip_XpY,eh_trip_rho) + deallocate(trip_XpY,trip_XmY) + + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) + + allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) + + ! Convergence criteria + err_two_body = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) + + n_it_micro = n_it_micro + 1 + end do + !------------------------------------------------------------------------ + ! End main loop + !------------------------------------------------------------------------ + + ! Did it actually converge? + if(n_it_micro == max_it_micro+1) then + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Two-body convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + else + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Two-body convergence success ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + call print_excitation_energies('phBSE@Parquet','singlet',nS,old_eh_sing_Om) + call print_excitation_energies('phBSE@Parquet','triplet',nS,old_eh_trip_Om) + call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,old_ee_sing_Om) + call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,old_hh_sing_Om) + call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,old_ee_trip_Om) + call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,old_hh_trip_Om) + end if + + allocate(eParquetlin(nOrb),Z(nOrb),SigC(nOrb)) + write(*,*) 'Building self-energy' + call wall_time(start_t) + call R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,old_eParquet,EcGM,SigC,Z) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building self energy =',t,' seconds' + write(*,*) + + eParquetlin(:) = eHF(:) !+ Z(:)*SigC(:) + ! Solve the quasi-particle equation + if(linearize) then + eParquet(:) = eParquetlin(:) + else + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Newton-Raphson for Dyson equation not implemented ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + end if + deallocate(eParquetlin,Z,SigC) + + err_one_body = maxval(abs(old_eParquet - eParquet)) + old_eParquet(:) = eParquet(:) + + n_it_macro = n_it_macro + 1 + end do ! End the macro loop + + ! Did it actually converge? + if(n_it_macro == max_it_macro+1) then + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' One-body convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + else + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' One-body convergence success ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + end if + +end subroutine diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 new file mode 100644 index 0000000..546bb5a --- /dev/null +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -0,0 +1,155 @@ +subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & + ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & + hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam_A) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_trip_Om(nVVs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + +! Local variables + integer :: i,a,j,b + integer :: ia,jb + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_sing_Gam_A(nS,nS) + +! Initialization + eh_sing_Gam_A(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nOrb-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,norb-nR + jb = jb + 1 + + do n=1,nS + eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + + eh_sing_rho(a,b,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(a,b,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) + end do + + do n=1,nVVs + eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + + ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) + end do + + do n=1,nOOs + eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + - hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) + end do + + do n=1,nVVt + eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + + 3d0 * ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) + end do + + do n=1,nOOt + eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + - 3d0 * hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_singlet_Gamma_A + +subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & + ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & + hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam_B) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_trip_Om(nVVs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + +! Local variables + integer :: i,a,j,b + integer :: ia,jb + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_sing_Gam_B(nS,nS) + +! Initialization + eh_sing_Gam_B(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nOrb-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,norb-nR + jb = jb + 1 + + do n=1,nS + eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + + eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + end do + + do n=1,nVVs + eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + + ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) + end do + + do n=1,nOOs + eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + - hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) + end do + + do n=1,nVVt + eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + + 3d0 * ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) + end do + + do n=1,nOOt + eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + - 3d0 * hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_singlet_Gamma_B diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 new file mode 100644 index 0000000..eb019c8 --- /dev/null +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -0,0 +1,155 @@ +subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & + ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & + hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_trip_Gam_A) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_trip_Om(nVVs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + +! Local variables + integer :: i,a,j,b + integer :: ia,jb + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_trip_Gam_A(nS,nS) + +! Initialization + eh_trip_Gam_A(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nOrb-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,norb-nR + jb = jb + 1 + + do n=1,nS + eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + + eh_sing_rho(a,b,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + - eh_trip_rho(a,b,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) + end do + + do n=1,nVVs + eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + - ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) + end do + + do n=1,nOOs + eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + + hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) + end do + + do n=1,nVVt + eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + + ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) + end do + + do n=1,nOOt + eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + - hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_triplet_Gamma_A + +subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & + ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & + hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_trip_Gam_B) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_trip_Om(nVVs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + +! Local variables + integer :: i,a,j,b + integer :: ia,jb + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_trip_Gam_B(nS,nS) + +! Initialization + eh_trip_Gam_B(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nOrb-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,norb-nR + jb = jb + 1 + + do n=1,nS + eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + + eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + - eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + end do + + do n=1,nVVs + eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + - ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) + end do + + do n=1,nOOs + eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + + hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) + end do + + do n=1,nVVt + eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + + ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) + end do + + do n=1,nOOt + eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + - hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_triplet_Gamma_B diff --git a/src/Parquet/R_irred_Parquet_self_energy.f90 b/src/Parquet/R_irred_Parquet_self_energy.f90 new file mode 100644 index 0000000..e385ff2 --- /dev/null +++ b/src/Parquet/R_irred_Parquet_self_energy.f90 @@ -0,0 +1,94 @@ +subroutine R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,e,EcGM,SigC,Z) + +! Compute correlation part of the self-energy with only irreducible vertices contribution + implicit none + include 'parameters.h' + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR + double precision,intent(in) :: e(nOrb) +! Local variables + integer :: p,i,j,a,b + double precision :: D2p1h,D2h1p +! Output variables + double precision,intent(out) :: EcGM + double precision,intent(out) :: SigC(nOrb) + double precision,intent(out) :: Z(nOrb) + +!----------------------------! +! Static Parquet self-energy ! +!----------------------------! + SigC(:) = 0d0 + ! 2h1p part of the correlation self-energy + do p=nC+1,nOrb-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nOrb-nR + + D2h1p = e(p) + e(a) - e(i) - e(j) + SigC(p) = SigC(p) !+ 2d0*rho(p,i,m)**2*(1d0-exp(-2d0*s*Dpim*Dpim))/Dpim + + end do + end do + end do + end do + ! 2p1h part of the correlation self-energy + do p=nC+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + + D2p1h = e(p) + e(i) - e(a) - e(b) + SigC(p) = SigC(p) !+ 2d0*rho(p,a,m)**2*(1d0-exp(-2d0*s*Dpam*Dpam))/Dpam + + end do + end do + end do + end do +!------------------------! +! Renormalization factor ! +!------------------------! + Z(:) = 0d0 + ! 2h1p part of the renormlization factor + do p=nC+1,nOrb-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nOrb-nR + + D2h1p = e(p) + e(a) - e(i) - e(j) + Z(p) = Z(p) + + end do + end do + end do + end do + ! 2p1h part of the renormlization factor + do p=nC+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + + D2p1h = e(p) + e(i) - e(a) - e(b) + Z(p) = Z(p) + + end do + end do + end do + end do + + Z(:) = 1d0/(1d0 - Z(:)) + +!-------------------------------------! +! Galitskii-Migdal correlation energy ! +!-------------------------------------! + + EcGM = 0d0 + ! do i=nC+1,nO + ! do a=nO+1,nOrb-nR + ! do m=1,nS + + ! end do + ! end do + ! end do + +end subroutine R_irred_Parquet_self_energy diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 new file mode 100644 index 0000000..9bc0e7b --- /dev/null +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -0,0 +1,225 @@ +subroutine R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nS + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: p,q,r,s + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_sing_Gam(nOrb,nOrb,nOrb,nOrb) + +! Initialization + pp_sing_Gam(:,:,:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(i, j, ij, k, l, kl, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_sing_Gam_D, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nS + pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s) & + - eh_sing_rho(p,r,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(p,r,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + - eh_sing_rho(p,s,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(p,s,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + end do + + pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s)/sqrt((1d0 + Kronecker_delta(p,q))*(1d0 + Kronecker_delta(r,s))) + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine R_pp_singlet_Gamma + +subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_sing_Gam_D) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: i,j,k,l + integer :: ij,kl + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_sing_Gam_D(nOOs,nOOs) + +! Initialization + pp_sing_Gam_D(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(i, j, ij, k, l, kl, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_sing_Gam_D, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ij = 0 + do i=nC+1,nO + do j=i,nO + ij = ij + 1 + + kl = 0 + do k=nC+1,nO + do l=k,nO + kl = kl +1 + + do n=1,nS + pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl) & + - eh_sing_rho(i,k,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(i,k,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + - eh_sing_rho(i,l,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(i,l,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) + end do + + pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_sing_Gam_C) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nVVs + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: a,b,c,d + integer :: ab,cd + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_sing_Gam_C(nVVs,nVVs) + +! Initialization + pp_sing_Gam_C(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, c, d, cd, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_sing_Gam_C, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ab = 0 + do a=nO+1,nOrb - nR + do b=a,nOrb - nR + ab = ab + 1 + + cd = 0 + do c=nO+1,nOrb - nR + do d=c,nOrb - nR + cd = cd +1 + + do n=1,nS + pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd) & + - eh_sing_rho(a,c,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(a,c,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + - eh_sing_rho(a,d,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(a,d,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) + end do + + pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam_B) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: a,b,i,j + integer :: ab,ij + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_sing_Gam_B(nVVs,nOOs) + +! Initialization + pp_sing_Gam_B(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_sing_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ab = 0 + do a=nO+1,nOrb - nR + do b=a,nOrb - nR + ab = ab + 1 + + ij = 0 + do i=nC+1,nO + do j=i,nO + ij = ij +1 + + do n=1,nS + pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij) & + - eh_sing_rho(a,i,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(a,i,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + - eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + end do + + pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine diff --git a/src/Parquet/R_pp_triplet_Gam.f90 b/src/Parquet/R_pp_triplet_Gam.f90 new file mode 100644 index 0000000..7c3efbb --- /dev/null +++ b/src/Parquet/R_pp_triplet_Gam.f90 @@ -0,0 +1,217 @@ +subroutine R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_trip_Gam) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nS + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: p,q,r,s + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_trip_Gam(nOrb,nOrb,nOrb,nOrb) + +! Initialization + pp_trip_Gam(:,:,:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(i, j, ij, k, l, kl, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_D, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nS + pp_trip_Gam(p,q,r,s) = pp_trip_Gam(p,q,r,s) & + - eh_sing_rho(p,r,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + - eh_trip_rho(p,r,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + + eh_sing_rho(p,s,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + eh_trip_rho(p,s,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: i,j,k,l + integer :: ij,kl + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_trip_Gam_D(nOOt,nOOt) + +! Initialization + pp_trip_Gam_D(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(i, j, ij, k, l, kl, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_D, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ij = 0 + do i=nC+1,nO + do j=i+1,nO + ij = ij + 1 + + kl = 0 + do k=nC+1,nO + do l=k+1,nO + kl = kl +1 + + do n=1,nS + pp_trip_Gam_D(ij,kl) = pp_trip_Gam_D(ij,kl) & + - eh_sing_rho(i,k,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + - eh_trip_rho(i,k,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + + eh_sing_rho(i,l,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + + eh_trip_rho(i,l,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: a,b,c,d + integer :: ab,cd + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_trip_Gam_C(nVVt,nVVt) + +! Initialization + pp_trip_Gam_C(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, c, d, cd, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_C, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ab = 0 + do a=nO+1,nOrb - nR + do b=a+1,nOrb - nR + ab = ab + 1 + + cd = 0 + do c=nO+1,nOrb - nR + do d=c+1,nOrb - nR + cd = cd +1 + + do n=1,nS + pp_trip_Gam_C(ab,cd) = pp_trip_Gam_C(ab,cd) & + - eh_sing_rho(a,c,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + - eh_trip_rho(a,c,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + + eh_sing_rho(a,d,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + + eh_trip_rho(a,d,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam_B) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + +! Local variables + integer :: a,b,i,j + integer :: ab,ij + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_trip_Gam_B(nVVt,nOOt) + +! Initialization + pp_trip_Gam_B(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ab = 0 + do a=nO+1,nOrb - nR + do b=a+1,nOrb - nR + ab = ab + 1 + + ij = 0 + do i=nC+1,nO + do j=i+1,nO + ij = ij +1 + + do n=1,nS + pp_trip_Gam_B(ab,ij) = pp_trip_Gam_B(ab,ij) & + - eh_sing_rho(a,i,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + - eh_trip_rho(a,i,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + + eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 new file mode 100644 index 0000000..97c24c6 --- /dev/null +++ b/src/Parquet/R_screened_integrals.f90 @@ -0,0 +1,293 @@ +subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) + +! Compute excitation densities + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: XpY(nS,nS) + +! Local variables + integer :: ia,jb,p,q,j,b + +! Output variables + double precision,intent(out) :: rho(nOrb,nOrb,nS) + + rho(:,:,:) = 0d0 + !$OMP PARALLEL & + !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY) & + !$OMP PRIVATE(q,p,jb,ia) & + !$OMP DEFAULT(NONE) + !$OMP DO + do q=nC+1,nOrb-nR + do p=nC+1,nOrb-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nOrb-nR + jb = jb + 1 + do ia=1,nS + rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) + end do + end do + end do + end do + end do + !$OMP END DO + !$OMP END PARALLEL + +end subroutine R_eh_singlet_screened_integral + +subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) + +! Compute excitation densities + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: XpY(nS,nS) + +! Local variables + integer :: ia,jb,p,q,j,b + +! Output variables + double precision,intent(out) :: rho(nOrb,nOrb,nS) + + rho(:,:,:) = 0d0 + !$OMP PARALLEL & + !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY) & + !$OMP PRIVATE(q,p,jb,ia) & + !$OMP DEFAULT(NONE) + !$OMP DO + do q=nC+1,nOrb-nR + do p=nC+1,nOrb-nR + jb = 0 + do j=nC+1,nO + do b=nO+1,nOrb-nR + jb = jb + 1 + do ia=1,nS + rho(p,q,ia) = rho(p,q,ia) - ERI(p,j,b,q)*XpY(ia,jb) + end do + end do + end do + end do + end do + !$OMP END DO + !$OMP END PARALLEL + +end subroutine R_eh_triplet_screened_integral + + +subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_Gam,X1,Y1,rho1,X2,Y2,rho2) + +! Compute excitation densities in the singlet pp channel + + implicit none + +! Input variables + + + integer,intent(in) :: nOrb,nC,nO,nV,nR + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Gam(nOrb,nOrb,nOrb,nOrb) + integer,intent(in) :: nOO + integer,intent(in) :: nVV + double precision,intent(in) :: X1(nVV,nVV) + double precision,intent(in) :: Y1(nOO,nVV) + double precision,intent(in) :: X2(nVV,nOO) + double precision,intent(in) :: Y2(nOO,nOO) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + integer :: p,q + integer :: ab,cd,ij,kl + double precision,external :: Kronecker_delta + +! Output variables + + double precision,intent(out) :: rho1(nOrb,nOrb,nVV) + double precision,intent(out) :: rho2(nOrb,nOrb,nOO) + + integer :: dim_1, dim_2 + +! Initialization + + rho1(:,:,:) = 0d0 + rho2(:,:,:) = 0d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_sing_Gam, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) + do q=nC+1,nOrb-nR + do p=nC+1,nOrb-nR + + ab = 0 + do a=nO+1,nOrb-nR + do b=a,nOrb-nR + ab = ab + 1 + + cd = 0 + do c=nO+1,nOrb-nR + do d=c,nOrb-nR + cd = cd + 1 + + rho1(p,q,ab) = rho1(p,q,ab) & + + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab)/ & + sqrt(1d0 + Kronecker_delta(c,d)) + end do + end do + + kl = 0 + do k=nC+1,nO + do l=k,nO + kl = kl + 1 + rho1(p,q,ab) = rho1(p,q,ab) & + + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab)/ & + sqrt(1d0 + Kronecker_delta(k,l)) + end do + end do + + end do + end do + + ij = 0 + do i=nC+1,nO + do j=i,nO + ij = ij + 1 + cd = 0 + do c=nO+1,nOrb-nR + do d=c,nOrb-nR + cd = cd + 1 + rho2(p,q,ij) = rho2(p,q,ij) & + + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij)/ & + sqrt(1d0 + Kronecker_delta(c,d)) + end do + end do + + kl = 0 + do k=nC+1,nO + do l=k,nO + kl = kl + 1 + rho2(p,q,ij) = rho2(p,q,ij) & + + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij)/ & + sqrt(1d0 + Kronecker_delta(k,l)) + end do + end do + end do + end do + end do + end do + !$OMP END DO + !$OMP END PARALLEL + +end subroutine R_pp_singlet_screened_integral + + + + +subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_Gam,X1,Y1,rho1,X2,Y2,rho2) + +! Compute excitation densities in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR + integer,intent(in) :: nOO + integer,intent(in) :: nVV + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: X1(nVV,nVV) + double precision,intent(in) :: Y1(nOO,nVV) + double precision,intent(in) :: X2(nVV,nOO) + double precision,intent(in) :: Y2(nOO,nOO) + +! Local variables + integer :: i,j,k,l + integer :: a,b,c,d + integer :: p,q + integer :: ab,cd,ij,kl + double precision,external :: Kronecker_delta + +! Output variables + double precision,intent(out) :: rho1(nOrb,nOrb,nVV) + double precision,intent(out) :: rho2(nOrb,nOrb,nOO) + integer :: dim_1, dim_2 + +! Initialization + rho1(:,:,:) = 0d0 + rho2(:,:,:) = 0d0 + + dim_1 = (nOrb - nO) * (nOrb - nO - 1) / 2 + dim_2 = nO * (nO - 1) / 2 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_trip_Gam, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + ab = 0 + + do a = nO+1, nOrb-nR + do b = a+1, nOrb-nR + ab = ab + 1 + + cd = 0 + do c = nO+1, nOrb-nR + do d = c+1, nOrb-nR + cd = cd + 1 + + rho1(p,q,ab) = rho1(p,q,ab) & + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*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) + 0d0*pp_trip_Gam(p,q,k,l))*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, nOrb-nR + do d = c+1, nOrb-nR + cd = cd + 1 + + rho2(p,q,ij) = rho2(p,q,ij) & + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*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) + 0d0*pp_trip_Gam(p,q,k,l))*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 subroutine R_pp_triplet_screened_integral diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index 0ee9e95..30fa842 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -341,7 +341,9 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) - + write(*,'(A65,1X,F9.3,A8)') 'The Parquet method is not implemented in spin-orbital yet :(' + write(*,'(A65,1X,F9.3,A8)') 'Try running the RHF version!' + write(*,*) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index 50d3a64..a9477ca 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -78,6 +78,10 @@ program QuAcK logical :: restart_hfb double precision :: temperature,sigma + + integer :: max_it_macro,max_it_micro + double precision :: conv_one_body,conv_two_body + character(len=256) :: working_dir ! Check if the right number of arguments is provided @@ -141,7 +145,8 @@ program QuAcK maxSCF_GT,thresh_GT,max_diis_GT,lin_GT,eta_GT,reg_GT,TDA_T, & doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA, & - temperature,sigma,chem_pot_hf,restart_hfb) + temperature,sigma,chem_pot_hf,restart_hfb, & + max_it_macro,conv_one_body,max_it_micro,conv_two_body) !------------------! ! Hardware ! @@ -257,7 +262,8 @@ program QuAcK 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, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & - dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS) + dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & + max_it_macro,conv_one_body,max_it_micro,conv_two_body) endif endif diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index b63f124..63dc813 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -1,13 +1,14 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & 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, & - doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,doParquet, & + doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,doParquet, & nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_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, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & - dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS) + dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & + max_it_macro,conv_one_body,max_it_micro,conv_two_body) ! Restricted branch of QuAcK @@ -81,6 +82,9 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, logical,intent(in) :: dophBSE,dophBSE2,doppBSE,dBSE,dTDA logical,intent(in) :: doACFDT,exchange_kernel,doXBS + integer,intent(in) :: max_it_macro,max_it_micro + double precision,intent(in) :: conv_one_body,conv_two_body + ! Local variables logical :: doMP,doCC,doCI,doRPA,doGF,doGW,doGT @@ -370,11 +374,13 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, if(doParquet) then call wall_time(start_Parquet) - + call RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & + nOrb,nC,nO,nV,nR,nS, & + eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet - write(*,'(A65,1X,F9.3,A8)') 'Total wall time for Parquet module = ',t_Parquet,' seconds' + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for Parquet module = ', t_Parquet, ' seconds' write(*,*) end if diff --git a/src/QuAcK/read_options.f90 b/src/QuAcK/read_options.f90 index 65b9354..27ca5ee 100644 --- a/src/QuAcK/read_options.f90 +++ b/src/QuAcK/read_options.f90 @@ -8,7 +8,8 @@ subroutine read_options(working_dir, maxSCF_GT,thresh_GT,max_diis_GT,lin_GT,eta_GT,reg_GT,TDA_T, & doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA, & - temperature,sigma,chem_pot_hf,restart_hfb) + temperature,sigma,chem_pot_hf,restart_hfb, & + max_it_macro,conv_one_body,max_it_micro,conv_two_body) ! Read desired methods @@ -78,6 +79,9 @@ subroutine read_options(working_dir, double precision,intent(out) :: temperature double precision,intent(out) :: sigma + integer,intent(out) :: max_it_macro,max_it_micro + double precision,intent(out) :: conv_one_body,conv_two_body + ! Local variables character(len=1) :: ans1,ans2,ans3,ans4,ans5 @@ -235,7 +239,17 @@ subroutine read_options(working_dir, if(ans1 == 'T') chem_pot_hf = .true. if(ans2 == 'T') restart_hfb = .true. + + ! Options for Parquet module + max_it_macro = 1 + conv_one_body = 0.01 + max_it_micro = 1 + conv_two_body = 0.01 + + read(1,*) + read(1,*) max_it_macro,conv_one_body,max_it_micro,conv_two_body + endif ! Close file with options From 4774ab082a1296fe0864ce3a14358692fdcbc8a4 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 17 Mar 2025 15:20:21 +0100 Subject: [PATCH 06/71] documentation --- src/Parquet/README.md | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/src/Parquet/README.md b/src/Parquet/README.md index bec4abd..6a0fe5f 100644 --- a/src/Parquet/README.md +++ b/src/Parquet/README.md @@ -5,18 +5,38 @@ The parameters provided by the user are: - `max_it_macro` and `max_it_micro` which set the maximum number of iterations of the macro (one-body) and micro (two-body) self-consistent cycles. - `conv_one_body` and `conv_two_body` which set the convergence threshold of the macro (one-body) and micro (two-body) self-consistent cycles. -- -- The hard-coded parameters are: - `linearize` which control whether the quasiparticle equation will be linearized or not. Note that the Newton-Raphson has not been implemented yet. - `TDA` which control whether the Tamm-Dancoff approximation is enforced for the BSE problems or not. -- +- `print_phLR` and `print_ppLR` control the print of eigenvalues at each diagonalization. - ## Files and their routines -`RParquet.f90` is the main file for the restricted Parquet calculation, it is called by `RQuack.f90`. The main task of this file is to control the self-consistent cycles. + +- `RParquet.f90` is the main file for the restricted Parquet calculation, it is called by `RQuack.f90`. The main task of this file is to control the self-consistent cycles. +- `R_screened_integrals.f90` gathers four subroutines, each one dedicated to the computation of screened integrals in a given channel. +- There are four files dedicated to computed effective interactions in a each channel. For example, `R_eh_singlet_Gam.f90` contains three subroutines: one for the OVOV block, one for the VOVO block and one for the full $N^4$ tensor. ## TODO list -- [ ] Write the TODO list +### Check +- [ ] Comment m,s,t channels and perform ehBSE@$GW$ and ppBSE@$GW$ +- [ ] Comment d,m channels and perform ehBSE@$GT$ and ppBSE@$GT$ + +### Required + +- [ ] Implement diagonal self-energy +- [ ] Implement screened integrals in every channels + +### Improvement + +- [ ] OpenMP pp Gamma +- [ ] OpenMP eh Gamma +- [ ] DGEMM pp Gamma +- [ ] DGEMM eh Gamma + +### Long-term + +- [ ] Implement Newton-Raphson solution of the quasiparticle equation +- [ ] Implement Galitskii-Migdal self-energy From 4e7ce9dbb4d26bd29e3a85dce10cafcb44d7bbec Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 20 Mar 2025 16:27:04 +0100 Subject: [PATCH 07/71] update Parquet --- src/Parquet/README.md | 1 + src/Parquet/RParquet.f90 | 99 ++++++++++++++++++++++++---- src/Parquet/R_eh_singlet_Gam.f90 | 81 +++++++++++++++++++++-- src/Parquet/R_eh_triplet_Gam.f90 | 81 +++++++++++++++++++++-- src/Parquet/R_pp_singlet_Gam.f90 | 32 ++++----- src/Parquet/R_pp_triplet_Gam.f90 | 32 ++++----- src/Parquet/R_screened_integrals.f90 | 88 +++++++++++++------------ 7 files changed, 318 insertions(+), 96 deletions(-) diff --git a/src/Parquet/README.md b/src/Parquet/README.md index 6a0fe5f..ee1ef1e 100644 --- a/src/Parquet/README.md +++ b/src/Parquet/README.md @@ -21,6 +21,7 @@ The hard-coded parameters are: ## TODO list ### Check +- [x] Initial ppRPA@HF eigenvalues checked with Ne DIP in Table 1 of ppBSE paper - [ ] Comment m,s,t channels and perform ehBSE@$GW$ and ppBSE@$GW$ - [ ] Comment d,m channels and perform ehBSE@$GT$ and ppBSE@$GT$ diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index cdb1f07..b909a44 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -103,7 +103,7 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n write(*,*) write(*,*)'************ Solving initial linear-response problems ************' write(*,*)'------------------------------------------------------------------' - + !------------------- ! Density channel !------------------- @@ -118,8 +118,7 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n t = end_t - start_t write(*,*) write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial singlet phRPA problem =',t,' seconds' - !if (print_phLR) call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) - call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) + if (print_phLR) call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) deallocate(Aph,Bph) @@ -137,8 +136,7 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n t = end_t - start_t write(*,*) write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial triplet phRPA problem =',t,' seconds' - !if (print_phLR) call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) - call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) + if (print_phLR) call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) deallocate(Aph,Bph) @@ -202,24 +200,50 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) allocate(eh_sing_rho(nOrb,nOrb,nS)) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,sing_XpY,eh_sing_rho) + allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + eh_sing_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet eh screened integrals =',t,' seconds' + write(*,*) deallocate(sing_XpY,sing_XmY) + deallocate(eh_sing_Gam) allocate(eh_trip_rho(nOrb,nOrb,nS)) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,trip_XpY,eh_trip_rho) + allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + eh_trip_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet eh screened integrals =',t,' seconds' + write(*,*) deallocate(trip_XpY,trip_XmY) + deallocate(eh_trip_Gam) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) pp_sing_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet pp screened integrals =',t,' seconds' + write(*,*) deallocate(X1s,Y1s,X2s,Y2s) deallocate(pp_sing_Gam) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) pp_trip_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet pp screened integrals =',t,' seconds' + write(*,*) deallocate(X1t,Y1t,X2t,Y2t) deallocate(pp_trip_Gam) @@ -398,6 +422,29 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n old_ee_trip_Om(:) = ee_trip_Om(:) old_hh_trip_Om(:) = hh_trip_Om(:) + !------------------- + ! Compute effective interactions + !------------------- + allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + call wall_time(start_t) + call R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building eh singlet Gamma =',t,' seconds' + write(*,*) + allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + call wall_time(start_t) + call R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building eh triplet Gamma =',t,' seconds' + write(*,*) allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) call wall_time(start_t) call R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam) @@ -412,24 +459,50 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n t = end_t - start_t write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building pp singlet Gamma =',t,' seconds' write(*,*) - + + !------------------- + ! Deallocate + !------------------- deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) - + + !------------------- + ! Compute screened integrals + !------------------- allocate(eh_sing_rho(nOrb,nOrb,nS)) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,sing_XpY,eh_sing_rho) - deallocate(sing_XpY,sing_XmY) + call wall_time(start_t) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet eh screened integrals =',t,' seconds' + write(*,*) + deallocate(sing_XpY,sing_XmY,eh_sing_Gam) allocate(eh_trip_rho(nOrb,nOrb,nS)) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,trip_XpY,eh_trip_rho) - deallocate(trip_XpY,trip_XmY) + call wall_time(start_t) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet eh screened integrals =',t,' seconds' + write(*,*) + deallocate(trip_XpY,trip_XmY,eh_trip_Gam) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + call wall_time(start_t) call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet pp screened integrals =',t,' seconds' + write(*,*) deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + call wall_time(start_t) call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet pp screened integrals =',t,' seconds' + write(*,*) deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) ! Convergence criteria diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 index 546bb5a..85e8cb0 100644 --- a/src/Parquet/R_eh_singlet_Gam.f90 +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -1,3 +1,76 @@ +subroutine R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & + ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & + hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_trip_Om(nVVs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + +! Local variables + integer :: p,q,r,s + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_sing_Gam(nOrb,nOrb,nOrb,nOrb) + +! Initialization + eh_sing_Gam(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nS + eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + end do + + do n=1,nVVs + eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + + ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) + end do + + do n=1,nOOs + eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + - hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) + end do + + do n=1,nVVt + eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + + 3d0 * ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) + end do + + do n=1,nOOt + eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + - 3d0 * hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_singlet_Gamma + subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & @@ -45,8 +118,8 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - + eh_sing_rho(a,b,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(a,b,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) + + eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) end do do n=1,nVVs @@ -123,8 +196,8 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - + eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + + eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) end do do n=1,nVVs diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 index eb019c8..13b29d5 100644 --- a/src/Parquet/R_eh_triplet_Gam.f90 +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -1,3 +1,76 @@ +subroutine R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & + ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & + hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_trip_Gam) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_trip_Om(nVVs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + +! Local variables + integer :: p,q,r,s + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_trip_Gam(nOrb,nOrb,nOrb,nOrb) + +! Initialization + eh_trip_Gam(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nS + eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & + + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + - eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + end do + + do n=1,nVVs + eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & + - 0d0*ee_sing_rho(p,q,n) * ee_sing_rho(r,s,n)/ee_sing_Om(n) + end do + + do n=1,nOOs + eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & + + 0d0*hh_sing_rho(p,q,n) * hh_sing_rho(r,s,n)/hh_sing_Om(n) + end do + + do n=1,nVVt + eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & + + 0d0*ee_trip_rho(p,q,n) * ee_trip_rho(r,s,n)/ee_trip_Om(n) + end do + + do n=1,nOOt + eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & + - 0d0*hh_trip_rho(p,q,n) * hh_trip_rho(r,s,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_triplet_Gamma + subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & @@ -45,8 +118,8 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - + eh_sing_rho(a,b,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - - eh_trip_rho(a,b,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) + + eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + - eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) end do do n=1,nVVs @@ -123,8 +196,8 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - + eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - - eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + + eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + - eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) end do do n=1,nVVs diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index 9bc0e7b..83e4826 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -33,10 +33,10 @@ subroutine R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh do n=1,nS pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s) & - - eh_sing_rho(p,r,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(p,r,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - - eh_sing_rho(p,s,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(p,s,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + - eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) end do pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s)/sqrt((1d0 + Kronecker_delta(p,q))*(1d0 + Kronecker_delta(r,s))) @@ -91,10 +91,10 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,eh_sing_Om,eh_sing_rho, do n=1,nS pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl) & - - eh_sing_rho(i,k,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(i,k,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - - eh_sing_rho(i,l,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(i,l,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) + - eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + - eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) end do pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) @@ -149,10 +149,10 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,eh_sing_Om,eh_sing_rho, do n=1,nS pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd) & - - eh_sing_rho(a,c,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(a,c,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - - eh_sing_rho(a,d,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(a,d,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) + - eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + - eh_sing_rho(c,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) end do pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) @@ -207,10 +207,10 @@ subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,eh_sing_Om,eh_sing do n=1,nS pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij) & - - eh_sing_rho(a,i,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(a,i,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - - eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + - eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + - eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 3d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) end do pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) diff --git a/src/Parquet/R_pp_triplet_Gam.f90 b/src/Parquet/R_pp_triplet_Gam.f90 index 7c3efbb..9e12c3c 100644 --- a/src/Parquet/R_pp_triplet_Gam.f90 +++ b/src/Parquet/R_pp_triplet_Gam.f90 @@ -33,10 +33,10 @@ subroutine R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh do n=1,nS pp_trip_Gam(p,q,r,s) = pp_trip_Gam(p,q,r,s) & - - eh_sing_rho(p,r,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - - eh_trip_rho(p,r,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - + eh_sing_rho(p,s,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + eh_trip_rho(p,s,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + - eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) end do end do @@ -89,10 +89,10 @@ subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,eh_sing_Om,eh_sing_rho, do n=1,nS pp_trip_Gam_D(ij,kl) = pp_trip_Gam_D(ij,kl) & - - eh_sing_rho(i,k,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - - eh_trip_rho(i,k,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - + eh_sing_rho(i,l,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - + eh_trip_rho(i,l,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) + - eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + - eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + + eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + + eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) end do end do @@ -145,10 +145,10 @@ subroutine R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,eh_sing_Om,eh_sing_rho, do n=1,nS pp_trip_Gam_C(ab,cd) = pp_trip_Gam_C(ab,cd) & - - eh_sing_rho(a,c,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - - eh_trip_rho(a,c,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - + eh_sing_rho(a,d,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - + eh_trip_rho(a,d,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) + - eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + - eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + + eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + + eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) end do end do @@ -201,10 +201,10 @@ subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,eh_sing_Om,eh_sing do n=1,nS pp_trip_Gam_B(ab,ij) = pp_trip_Gam_B(ab,ij) & - - eh_sing_rho(a,i,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - - eh_trip_rho(a,i,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - + eh_sing_rho(a,j,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + eh_trip_rho(a,j,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + - eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + - eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + + eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) end do end do diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 97c24c6..01b3f87 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -1,4 +1,4 @@ -subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) +subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,rho) ! Compute excitation densities implicit none @@ -6,6 +6,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) ! Input variables integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_sing_Gam(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: XpY(nS,nS) ! Local variables @@ -15,11 +16,11 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) double precision,intent(out) :: rho(nOrb,nOrb,nS) rho(:,:,:) = 0d0 - !$OMP PARALLEL & - !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY) & - !$OMP PRIVATE(q,p,jb,ia) & - !$OMP DEFAULT(NONE) - !$OMP DO +! !$OMP PARALLEL & +! !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY,eh_sing_Gam) & +! !$OMP PRIVATE(q,p,jb,ia) & +! !$OMP DEFAULT(NONE) +! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR jb = 0 @@ -27,18 +28,19 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) do b=nO+1,nOrb-nR jb = jb + 1 do ia=1,nS - rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) + rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & + + 0d0*eh_sing_Gam(p,j,q,b) * XpY(ia,jb) end do end do end do end do end do - !$OMP END DO - !$OMP END PARALLEL +! !$OMP END DO +! !$OMP END PARALLEL end subroutine R_eh_singlet_screened_integral -subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) +subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,rho) ! Compute excitation densities implicit none @@ -46,6 +48,7 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) ! Input variables integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Gam(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: XpY(nS,nS) ! Local variables @@ -55,11 +58,11 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) double precision,intent(out) :: rho(nOrb,nOrb,nS) rho(:,:,:) = 0d0 - !$OMP PARALLEL & - !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY) & - !$OMP PRIVATE(q,p,jb,ia) & - !$OMP DEFAULT(NONE) - !$OMP DO +! !$OMP PARALLEL & +! !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY,eh_trip_Gam) & +! !$OMP PRIVATE(q,p,jb,ia) & +! !$OMP DEFAULT(NONE) +! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR jb = 0 @@ -67,14 +70,14 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,XpY,rho) do b=nO+1,nOrb-nR jb = jb + 1 do ia=1,nS - rho(p,q,ia) = rho(p,q,ia) - ERI(p,j,b,q)*XpY(ia,jb) + rho(p,q,ia) = rho(p,q,ia) - ERI(p,j,b,q)*XpY(ia,jb) + 0d0*eh_trip_Gam(p,j,q,b) * XpY(ia,jb) end do end do end do end do end do - !$OMP END DO - !$OMP END PARALLEL +! !$OMP END DO +! !$OMP END PARALLEL end subroutine R_eh_triplet_screened_integral @@ -118,10 +121,10 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G rho1(:,:,:) = 0d0 rho2(:,:,:) = 0d0 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & - !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_sing_Gam, X1, Y1, X2, Y2) - !$OMP DO COLLAPSE(2) +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & +! !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_sing_Gam, X1, Y1, X2, Y2) +! !$OMP DO COLLAPSE(2) do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR @@ -134,10 +137,9 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do c=nO+1,nOrb-nR do d=c,nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab)/ & - sqrt(1d0 + Kronecker_delta(c,d)) + + (ERI(p,q,c,d) + ERI(p,q,d,c) + pp_sing_Gam(p,q,c,d))*X1(cd,ab) & + /sqrt(1d0 + Kronecker_delta(c,d)) end do end do @@ -146,8 +148,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do l=k,nO kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab)/ & - sqrt(1d0 + Kronecker_delta(k,l)) + + (ERI(p,q,k,l) + ERI(p,q,l,k) + pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & + /sqrt(1d0 + Kronecker_delta(k,l)) end do end do @@ -163,8 +165,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do d=c,nOrb-nR cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij)/ & - sqrt(1d0 + Kronecker_delta(c,d)) + + (ERI(p,q,c,d) + ERI(p,q,d,c) + pp_sing_Gam(p,q,c,d))*X2(cd,ij) & + /sqrt(1d0 + Kronecker_delta(c,d)) end do end do @@ -173,16 +175,16 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do l=k,nO kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij)/ & - sqrt(1d0 + Kronecker_delta(k,l)) + + (ERI(p,q,k,l) + ERI(p,q,l,k) + pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & + /sqrt(1d0 + Kronecker_delta(k,l)) end do end do end do end do end do end do - !$OMP END DO - !$OMP END PARALLEL +! !$OMP END DO +! !$OMP END PARALLEL end subroutine R_pp_singlet_screened_integral @@ -224,10 +226,10 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G dim_1 = (nOrb - nO) * (nOrb - nO - 1) / 2 dim_2 = nO * (nO - 1) / 2 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & - !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_trip_Gam, X1, Y1, X2, Y2) - !$OMP DO COLLAPSE(2) +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & +! !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_trip_Gam, X1, Y1, X2, Y2) +! !$OMP DO COLLAPSE(2) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR ab = 0 @@ -242,7 +244,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) + + (ERI(p,q,c,d) - ERI(p,q,d,c) + pp_trip_Gam(p,q,c,d))*X1(cd,ab) end do ! d end do ! c @@ -253,7 +255,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + 0d0*pp_trip_Gam(p,q,k,l))*Y1(kl,ab) + + (ERI(p,q,k,l) - ERI(p,q,l,k) + pp_trip_Gam(p,q,k,l))*Y1(kl,ab) end do ! l end do ! k end do ! b @@ -270,7 +272,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) + + (ERI(p,q,c,d) - ERI(p,q,d,c) + pp_trip_Gam(p,q,c,d))*X2(cd,ij) end do ! d end do ! c @@ -280,14 +282,14 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + 0d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) + + (ERI(p,q,k,l) - ERI(p,q,l,k) + pp_trip_Gam(p,q,k,l))*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 END DO +! !$OMP END PARALLEL end subroutine R_pp_triplet_screened_integral From a0de15240fab41f236ed3b315c7de5e951d846cb Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 20 Mar 2025 22:29:07 +0100 Subject: [PATCH 08/71] modifs in parquet for Antoine --- src/Parquet/RParquet.f90 | 953 +++++++++++++++++++++++---------------- 1 file changed, 571 insertions(+), 382 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index b909a44..eed2052 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -1,25 +1,31 @@ -subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,nC,nO,nV,nR,nS,eHF,ERI) +subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF,ERI) ! Spatial orbital Parquet implementation + implicit none include 'parameters.h' ! Hard-coded parameters + logical :: linearize = .true. logical :: TDA = .true. logical :: print_phLR = .false. logical :: print_ppLR = .false. ! Input variables - integer,intent(in) :: max_it_macro,max_it_micro - double precision,intent(in) :: conv_one_body,conv_two_body + + integer,intent(in) :: max_it_1b,max_it_2b + double precision,intent(in) :: conv_1b,conv_2b integer,intent(in) :: nOrb,nC,nO,nV,nR,nS double precision,intent(in) :: eHF(nOrb) double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) ! Local variables - integer :: n_it_macro,n_it_micro - double precision :: err_one_body,err_two_body + + integer :: ispin + + integer :: n_it_1b,n_it_2b + double precision :: err_1b,err_2b double precision :: err_eh_sing,err_eh_trip double precision :: err_hh_sing,err_hh_trip double precision :: err_ee_sing,err_ee_trip @@ -65,6 +71,7 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n double precision :: EcGM ! Output variables + nOOs = nO*(nO + 1)/2 nVVs = nV*(nV + 1)/2 nOOt = nO*(nO - 1)/2 @@ -79,13 +86,19 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n write(*,*) ! Print parameters - write(*,*)'Parameters for this run:' - write(*,*)'Maximum number of macro iteration:', max_it_macro - write(*,*)'Convergence threshold for one-body energies:', conv_one_body - write(*,*)'Maximum number of micro iteration:', max_it_micro - write(*,*)'Convergence threshold for two-body energies:', conv_two_body + + write(*,*)'---------------------------------------------------------------' + write(*,*)' Parquet parameters for one-body and two-body self-consistency ' + write(*,*)'---------------------------------------------------------------' + write(*,'(1X,A50,1X,I5)') 'Maximum number for one-body self-consistency:', max_it_1b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:', conv_1b + write(*,*)'---------------------------------------------------------------' + write(*,'(1X,A50,1X,I5)') 'Maximum number for two-body self-consistency:', max_it_2b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:', conv_2b + write(*,*)'---------------------------------------------------------------' + write(*,*) - if (linearize) then + if(linearize) then write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' write(*,*) else @@ -94,102 +107,124 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n endif ! Initialization - n_it_macro = 1 - err_one_body = 1d0 - n_it_micro = 1 - err_two_body = 1d0 + + n_it_1b = 0 + err_1b = 1d0 + n_it_2b = 0 + err_2b = 1d0 old_eParquet(:) = eHF(:) - write(*,*) - write(*,*)'************ Solving initial linear-response problems ************' + write(*,*)'------------------------------------------------------------------' + write(*,*)' Solving initial linear-response problems ' write(*,*)'------------------------------------------------------------------' - !------------------- - ! Density channel - !------------------- + !-----------------! + ! Density channel ! + !-----------------! + allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),old_eh_sing_Om(nS)) + + ispin = 1 Aph(:,:) = 0d0 Bph(:,:) = 0d0 + call wall_time(start_t) - if(.not.TDA) call phRLR_B(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call phRLR_A(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) call wall_time(end_t) t = end_t - start_t - write(*,*) - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial singlet phRPA problem =',t,' seconds' - if (print_phLR) call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial singlet phRPA problem =',t,' seconds' + + if(print_phLR) call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) deallocate(Aph,Bph) - !------------------- - ! Magnetic channel - !------------------- + !------------------! + ! Magnetic channel ! + !------------------! + allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),old_eh_trip_Om(nS)) + + ispin = 2 Aph(:,:) = 0d0 Bph(:,:) = 0d0 + call wall_time(start_t) - if(.not.TDA) call phRLR_B(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call phRLR_A(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) call wall_time(end_t) t = end_t - start_t - write(*,*) - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial triplet phRPA problem =',t,' seconds' - if (print_phLR) call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial triplet phRPA problem =',t,' seconds' + + if(print_phLR) call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) deallocate(Aph,Bph) - !------------------- - ! Singlet channel - !------------------- + !-----------------! + ! Singlet channel ! + !-----------------! + allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs),old_ee_sing_Om(nVVs), & hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs),old_hh_sing_Om(nOOs)) - Bpp(:,:)=0d0 - Cpp(:,:)=0d0 - Dpp(:,:)=0d0 + + ispin = 1 + Bpp(:,:) = 0d0 + Cpp(:,:) = 0d0 + Dpp(:,:) = 0d0 + call wall_time(start_t) - if(.not.TDA) call ppRLR_B(1,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppRLR_C(1,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call ppRLR_D(1,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) call wall_time(end_t) t = end_t - start_t - write(*,*) - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial singlet ppRPA problem =',t,' seconds' - if (print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (singlets)',nVVs,ee_sing_Om) - if (print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (singlets)',nOOs,hh_sing_Om) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial singlet ppRPA problem =',t,' seconds' + + if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (singlets)',nVVs,ee_sing_Om) + if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (singlets)',nOOs,hh_sing_Om) deallocate(Bpp,Cpp,Dpp) - !------------------- - ! Triplet channel - !------------------- + !-----------------! + ! Triplet channel ! + !-----------------! + allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt),old_ee_trip_Om(nVVt), & hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt),old_hh_trip_Om(nOOt)) - Bpp(:,:)=0d0 - Cpp(:,:)=0d0 - Dpp(:,:)=0d0 + + ispin = 2 + Bpp(:,:) = 0d0 + Cpp(:,:) = 0d0 + Dpp(:,:) = 0d0 + call wall_time(start_t) - if(.not.TDA) call ppRLR_B(2,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppRLR_C(2,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call ppRLR_D(2,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) call wall_time(end_t) t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial triplet ppRPA problem =',t,' seconds' write(*,*) - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for initial triplet ppRPA problem =',t,' seconds' - write(*,*) + if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (triplets)',nVVt,ee_trip_Om) if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (triplets)',nOOt,hh_trip_Om) deallocate(Bpp,Cpp,Dpp) - !------------------- - ! Updating - !------------------- + !----------! + ! Updating ! + !----------! + old_eh_sing_Om(:) = eh_sing_Om(:) old_eh_trip_Om(:) = eh_trip_Om(:) old_ee_sing_Om(:) = ee_sing_Om(:) @@ -199,386 +234,540 @@ subroutine RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body,nOrb,n deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) + ! Build singlet eh screened integrals + allocate(eh_sing_rho(nOrb,nOrb,nS)) allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + eh_sing_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet eh screened integrals =',t,' seconds' - write(*,*) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet eh screened integrals =',t,' seconds' + deallocate(sing_XpY,sing_XmY) deallocate(eh_sing_Gam) + ! Build triplet eh screened integrals + allocate(eh_trip_rho(nOrb,nOrb,nS)) allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + eh_trip_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet eh screened integrals =',t,' seconds' - write(*,*) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet eh screened integrals =',t,' seconds' + deallocate(trip_XpY,trip_XmY) deallocate(eh_trip_Gam) - + + ! Build singlet pp screened integrals + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + pp_sing_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet pp screened integrals =',t,' seconds' - write(*,*) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet pp screened integrals =',t,' seconds' + deallocate(X1s,Y1s,X2s,Y2s) deallocate(pp_sing_Gam) - + + ! Build triplet pp screened integrals + allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + pp_trip_Gam(:,:,:,:) = 0d0 + call wall_time(start_t) call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet pp screened integrals =',t,' seconds' - write(*,*) + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet pp screened integrals =',t,' seconds' + deallocate(X1t,Y1t,X2t,Y2t) deallocate(pp_trip_Gam) -!------------------------------------------------------------------------ -! Loop on one-body energies -!------------------------------------------------------------------------ +!-----------------------------------------! +! Main loop for one-body self-consistency ! +!-----------------------------------------! - do while(err_one_body > conv_one_body .and. n_it_macro <= max_it_macro) + do while(err_1b > conv_1b .and. n_it_1b < max_it_1b) - write(*,*) - write(*,*)'************ Macro iteration number ',n_it_macro,' ************' - write(*,*)'---------------------------------------------------------------' - write(*,*) + n_it_1b = n_it_1b + 1 - - do while(err_two_body > conv_two_body .and. n_it_micro <= max_it_micro) + write(*,*) + write(*,*)'-------------------------------------' + write(*,*)' One-body iteration number ',n_it_1b + write(*,*)'-------------------------------------' + write(*,*) - !TODO add some timers everywhere - write(*,*) - write(*,*)' Micro iteration number ',n_it_micro - write(*,*)' -----------------------------------' - write(*,*) + + do while(err_2b > conv_2b .and. n_it_2b < max_it_2b) - !------------------- - ! Density channel - !------------------- - write(*,*)'Diagonalizing singlet ehBSE:' - write(*,*)'----------------------------' - allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) - Aph(:,:) = 0d0 - Bph(:,:) = 0d0 - call wall_time(start_t) - if(.not.TDA) call phRLR_B(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call phRLR_A(1,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + n_it_2b = n_it_2b + 1 - call R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam_A) - call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam_B) - - Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) - Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) - call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for singlet phBSE problem =',t,' seconds' - write(*,*) - if (print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) - err_eh_sing = maxval(abs(old_eh_sing_Om - eh_sing_Om)) - deallocate(Aph,Bph,eh_sing_Gam_A,eh_sing_Gam_B) + !TODO add some timers everywhere + write(*,*)' -----------------------------------' + write(*,*)' Two-Body iteration number ',n_it_2b + write(*,*)' -----------------------------------' + write(*,*) - !------------------- - ! Magnetic channel - !------------------- - write(*,*)'Diagonalizing triplet ehBSE:' - write(*,*)'----------------------------' - allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) - Aph(:,:) = 0d0 - Bph(:,:) = 0d0 - call wall_time(start_t) - if(.not.TDA) call phRLR_B(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call phRLR_A(2,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + !-----------------! + ! Density channel ! + !-----------------! - call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_A) - call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_B) - - Aph(:,:) = Aph(:,:) + eh_trip_Gam_A(:,:) - Bph(:,:) = Bph(:,:) + eh_trip_Gam_B(:,:) - call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for triplet phBSE problem =',t,' seconds' - write(*,*) - if (print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) - err_eh_trip = maxval(abs(old_eh_trip_Om - eh_trip_Om)) - deallocate(Aph,Bph,eh_trip_Gam_A,eh_trip_Gam_B) - - !------------------- - ! Singlet channel - !------------------- - write(*,*)'Diagonalizing singlet ppBSE:' - write(*,*)'----------------------------' - allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & - ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & - hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & - pp_sing_Gam_B(nVVs,nOOs),pp_sing_Gam_C(nVVs,nVVs),pp_sing_Gam_D(nOOs,nOOs)) - Bpp(:,:) = 0d0 - Cpp(:,:) = 0d0 - Dpp(:,:) = 0d0 - call wall_time(start_t) - if(.not.TDA) call ppRLR_B(1,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppRLR_C(1,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call ppRLR_D(1,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing singlet ehBSE |' + write(*,*)' -------------------------------' + write(*,*) - call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_B) - call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_C) - call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_D) - - Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) - Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) - Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) - - call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for singlet ppBSE problem =',t,' seconds' - write(*,*) - if (print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) - if (print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,hh_sing_Om) - err_ee_sing = maxval(abs(old_ee_sing_Om - ee_sing_Om)) - err_hh_sing = maxval(abs(old_hh_sing_Om - hh_sing_Om)) - deallocate(Bpp,Cpp,Dpp,pp_sing_Gam_B,pp_sing_Gam_C,pp_sing_Gam_D) - - !------------------- - ! Triplet channel - !------------------- - write(*,*)'Diagonalizing triplet ppBSE:' - write(*,*)'----------------------------' - allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & - ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & - hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & - pp_trip_Gam_B(nVVt,nOOt),pp_trip_Gam_C(nVVt,nVVt),pp_trip_Gam_D(nOOt,nOOt)) - Bpp(:,:)=0d0 - Cpp(:,:)=0d0 - Dpp(:,:)=0d0 - call wall_time(start_t) - if(.not.TDA) call ppRLR_B(2,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppRLR_C(2,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call ppRLR_D(2,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) - call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) - call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) - call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) - - Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) - Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) - Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) - - call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for triplet ppBSE problem =',t,' seconds' - write(*,*) - if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) - if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,hh_trip_Om) - err_ee_trip = maxval(abs(old_ee_trip_Om - ee_trip_Om)) - err_hh_trip = maxval(abs(old_hh_trip_Om - hh_trip_Om)) - deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) - - write(*,*) - write(*,*)'Error for density channel:', err_eh_sing - write(*,*)'Error for magnetic channel:',err_eh_trip - write(*,*)'Error for singlet channel:', max(err_ee_sing,err_hh_sing) - write(*,*)'Error for triplet channel:', max(err_ee_trip,err_hh_trip) - write(*,*) + ispin = 1 + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 - !------------------- - ! Updating - !------------------- - old_eh_sing_Om(:) = eh_sing_Om(:) - old_eh_trip_Om(:) = eh_trip_Om(:) - old_ee_sing_Om(:) = ee_sing_Om(:) - old_hh_sing_Om(:) = hh_sing_Om(:) - old_ee_trip_Om(:) = ee_trip_Om(:) - old_hh_trip_Om(:) = hh_trip_Om(:) + call wall_time(start_t) - !------------------- - ! Compute effective interactions - !------------------- - allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - call wall_time(start_t) - call R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building eh singlet Gamma =',t,' seconds' - write(*,*) - allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - call wall_time(start_t) - call R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building eh triplet Gamma =',t,' seconds' - write(*,*) - allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - call wall_time(start_t) - call R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building pp triplet Gamma =',t,' seconds' - write(*,*) - allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - call wall_time(start_t) - call R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building pp singlet Gamma =',t,' seconds' - write(*,*) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - !------------------- - ! Deallocate - !------------------- - deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) - deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) + call R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho,eh_sing_Gam_A) - !------------------- - ! Compute screened integrals - !------------------- - allocate(eh_sing_rho(nOrb,nOrb,nS)) - call wall_time(start_t) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet eh screened integrals =',t,' seconds' - write(*,*) - deallocate(sing_XpY,sing_XmY,eh_sing_Gam) + call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho,eh_sing_Gam_B) + + Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) + + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) + + call wall_time(end_t) + + t = end_t - start_t + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet phBSE problem =',t,' seconds' + write(*,*) + + if(print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) + + err_eh_sing = maxval(abs(old_eh_sing_Om - eh_sing_Om)) + + deallocate(Aph,Bph,eh_sing_Gam_A,eh_sing_Gam_B) + + !------------------! + ! Magnetic channel ! + !------------------! + + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing triplet ehBSE |' + write(*,*)' -------------------------------' + write(*,*) + + allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) + + ispin = 2 + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 + + call wall_time(start_t) + + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + + call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_A) + + call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_B) + + Aph(:,:) = Aph(:,:) + eh_trip_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_trip_Gam_B(:,:) + + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) + + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet phBSE problem =',t,' seconds' + write(*,*) + + if(print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) + + err_eh_trip = maxval(abs(old_eh_trip_Om - eh_trip_Om)) + + deallocate(Aph,Bph,eh_trip_Gam_A,eh_trip_Gam_B) + + !-----------------! + ! Singlet channel ! + !-----------------! + + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing singlet ppBSE |' + write(*,*)' -------------------------------' + write(*,*) + + allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & + ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & + hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & + pp_sing_Gam_B(nVVs,nOOs),pp_sing_Gam_C(nVVs,nVVs),pp_sing_Gam_D(nOOs,nOOs)) + + ispin = 1 + Bpp(:,:) = 0d0 + Cpp(:,:) = 0d0 + Dpp(:,:) = 0d0 + + call wall_time(start_t) + if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + + call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_B) + call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_C) + call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_D) + + Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) + + call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet ppBSE problem =',t,' seconds' + write(*,*) + + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,hh_sing_Om) + + err_ee_sing = maxval(abs(old_ee_sing_Om - ee_sing_Om)) + err_hh_sing = maxval(abs(old_hh_sing_Om - hh_sing_Om)) + + deallocate(Bpp,Cpp,Dpp,pp_sing_Gam_B,pp_sing_Gam_C,pp_sing_Gam_D) + + !-----------------! + ! Triplet channel ! + !-----------------! + + write(*,*)' |-----------------------------|' + write(*,*)' | Diagonalizing triplet ppBSE |' + write(*,*)' |-----------------------------|' + write(*,*) + + allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & + ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & + hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & + pp_trip_Gam_B(nVVt,nOOt),pp_trip_Gam_C(nVVt,nVVt),pp_trip_Gam_D(nOOt,nOOt)) + + ispin = 2 + Bpp(:,:) = 0d0 + Cpp(:,:) = 0d0 + Dpp(:,:) = 0d0 + + call wall_time(start_t) + if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + + call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) + call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) + call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) + + Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) + + call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) + + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet ppBSE problem =',t,' seconds' + + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,hh_trip_Om) + + err_ee_trip = maxval(abs(old_ee_trip_Om - ee_trip_Om)) + err_hh_trip = maxval(abs(old_hh_trip_Om - hh_trip_Om)) + + deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) + + write(*,*) + write(*,'(1X,A30,F10.6)')'Error for density channel = ', err_eh_sing + write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eh_trip + write(*,'(1X,A30,F10.6)')'Error for singlet channel = ', max(err_ee_sing,err_hh_sing) + write(*,'(1X,A30,F10.6)')'Error for triplet channel = ', max(err_ee_trip,err_hh_trip) + write(*,*) + + !----------! + ! Updating ! + !----------! + + old_eh_sing_Om(:) = eh_sing_Om(:) + old_eh_trip_Om(:) = eh_trip_Om(:) + old_ee_sing_Om(:) = ee_sing_Om(:) + old_hh_sing_Om(:) = hh_sing_Om(:) + old_ee_trip_Om(:) = ee_trip_Om(:) + old_hh_trip_Om(:) = hh_trip_Om(:) + + !--------------------------------! + ! Compute effective interactions ! + !--------------------------------! + + ! Build singlet eh effective interaction + + write(*,*) 'Computing singlet eh effective interaction...' + + allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + + call wall_time(start_t) + call R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for eh singlet Gamma =',t,' seconds' + write(*,*) + + ! Build triplet eh effective interaction + + write(*,*) 'Computing triplet eh effective interaction...' + + allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + + call wall_time(start_t) + call R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for eh triplet Gamma =',t,' seconds' + write(*,*) + + ! Build singlet pp effective interaction + + write(*,*) 'Computing singlet pp effective interaction...' + + allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + call wall_time(start_t) + call R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for pp singlet Gamma =',t,' seconds' + write(*,*) + + ! Build triplet pp effective interaction + + write(*,*) 'Computing triplet pp effective interaction...' + + allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + + call wall_time(start_t) + call R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for pp triplet Gamma =',t,' seconds' + write(*,*) + + ! Free memory + + deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) + deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) + + !----------------------------! + ! Compute screened integrals ! + !----------------------------! + + ! Build singlet eh screened integrals + + write(*,*) 'Computing singlet eh screened integrals...' + + allocate(eh_sing_rho(nOrb,nOrb,nS)) + + call wall_time(start_t) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for singlet eh integrals =',t,' seconds' + write(*,*) + + deallocate(sing_XpY,sing_XmY,eh_sing_Gam) - allocate(eh_trip_rho(nOrb,nOrb,nS)) - call wall_time(start_t) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet eh screened integrals =',t,' seconds' - write(*,*) - deallocate(trip_XpY,trip_XmY,eh_trip_Gam) - - allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) - call wall_time(start_t) - call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building singlet pp screened integrals =',t,' seconds' - write(*,*) - deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) + ! Build triplet eh screened integrals - allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) - call wall_time(start_t) - call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A51,1X,F9.3,A8)') 'Total wall time for building triplet pp screened integrals =',t,' seconds' - write(*,*) - deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) - - ! Convergence criteria - err_two_body = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) - - n_it_micro = n_it_micro + 1 - end do - !------------------------------------------------------------------------ - ! End main loop - !------------------------------------------------------------------------ + write(*,*) 'Computing triplet eh screened integrals...' - ! Did it actually converge? - if(n_it_micro == max_it_micro+1) then - write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' Two-body convergence failed ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*) - stop - else - write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' Two-body convergence success ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*) - call print_excitation_energies('phBSE@Parquet','singlet',nS,old_eh_sing_Om) - call print_excitation_energies('phBSE@Parquet','triplet',nS,old_eh_trip_Om) - call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,old_ee_sing_Om) - call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,old_hh_sing_Om) - call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,old_ee_trip_Om) - call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,old_hh_trip_Om) - end if + allocate(eh_trip_rho(nOrb,nOrb,nS)) - allocate(eParquetlin(nOrb),Z(nOrb),SigC(nOrb)) - write(*,*) 'Building self-energy' - call wall_time(start_t) - call R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,old_eParquet,EcGM,SigC,Z) - call wall_time(end_t) - t = end_t - start_t - write(*,'(A52,1X,F9.3,A8)') 'Total wall time for building self energy =',t,' seconds' - write(*,*) + call wall_time(start_t) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) + call wall_time(end_t) + t = end_t - start_t - eParquetlin(:) = eHF(:) !+ Z(:)*SigC(:) - ! Solve the quasi-particle equation - if(linearize) then - eParquet(:) = eParquetlin(:) - else - write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' Newton-Raphson for Dyson equation not implemented ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*) - stop - end if - deallocate(eParquetlin,Z,SigC) + write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for triplet eh integrals =',t,' seconds' + write(*,*) + + deallocate(trip_XpY,trip_XmY,eh_trip_Gam) + + ! Build singlet pp screened integrals + + write(*,*) 'Computing singlet pp screened integrals...' + + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + + call wall_time(start_t) + call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for singlet pp integrals =',t,' seconds' + write(*,*) + + deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) + + ! Build triplet pp screened integrals + + write(*,*) 'Computing triplet pp screened integrals...' + + allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + + call wall_time(start_t) + call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for triplet pp integrals =',t,' seconds' + write(*,*) + + deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) + + ! Convergence criteria + + err_2b = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) + + end do + !---------------------------------------------! + ! End main loop for two-body self-consistency ! + !---------------------------------------------! + + ! Did it actually converge? + + if(n_it_2b == max_it_2b) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Two-body convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + + else + + write(*,*) + write(*,*)'****************************************************' + write(*,*)' Two-body convergence success ' + write(*,*)'****************************************************' + write(*,*) + + call print_excitation_energies('phBSE@Parquet','singlet',nS,old_eh_sing_Om) + call print_excitation_energies('phBSE@Parquet','triplet',nS,old_eh_trip_Om) + call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,old_ee_sing_Om) + call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,old_hh_sing_Om) + call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,old_ee_trip_Om) + call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,old_hh_trip_Om) + + end if + + allocate(eParquetlin(nOrb),Z(nOrb),SigC(nOrb)) + + write(*,*) 'Building self-energy' + + call wall_time(start_t) + call R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,old_eParquet,EcGM,SigC,Z) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A50,1X,F9.3,A8)') 'Total wall time for self energy =',t,' seconds' + write(*,*) + + eParquetlin(:) = eHF(:) !+ Z(:)*SigC(:) + + ! Solve the quasi-particle equation + + if(linearize) then + + eParquet(:) = eParquetlin(:) + + else + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Newton-Raphson for Dyson equation not implemented ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + + end if + + deallocate(eParquetlin,Z,SigC) + + err_1b = maxval(abs(old_eParquet - eParquet)) + old_eParquet(:) = eParquet(:) - err_one_body = maxval(abs(old_eParquet - eParquet)) - old_eParquet(:) = eParquet(:) - - n_it_macro = n_it_macro + 1 - end do ! End the macro loop + end do + !---------------------------------------------! + ! End main loop for one-body self-consistency ! + !---------------------------------------------! - ! Did it actually converge? - if(n_it_macro == max_it_macro+1) then - write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' One-body convergence failed ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*) - stop - else - write(*,*) - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*)' One-body convergence success ' - write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' - write(*,*) - end if + ! Did it actually converge? + if(n_it_1b == max_it_1b) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' One-body convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + + else + + write(*,*) + write(*,*)'****************************************************' + write(*,*)' One-body convergence success ' + write(*,*)'****************************************************' + write(*,*) + + end if end subroutine From 9b15b34e4a3aa340da472538835783d839978c73 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 21 Mar 2025 09:48:10 +0100 Subject: [PATCH 09/71] removing initial useless RPA --- src/GW/RGW.f90 | 6 +- src/Parquet/RParquet.f90 | 373 ++++++++++++++------------------------- 2 files changed, 138 insertions(+), 241 deletions(-) diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index e53062d..aac941d 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -162,13 +162,13 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii ! Perform CC-based G0W0 calculation !------------------------------------------------------------------------ - doccG0W0 = .false. + doccG0W0 = .true. if(doccG0W0) then call wall_time(start_GW) - call ccRG0W0(maxSCF,thresh,max_diis,nBas,nOrb,nC,nO,nV,nR,nS,ERI_MO,ENuc,ERHF,eHF) -! call ccRG0W0_TDA(maxSCF,thresh,max_diis,nBas,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) +! call ccRG0W0(maxSCF,thresh,max_diis,nBas,nOrb,nC,nO,nV,nR,nS,ERI_MO,ENuc,ERHF,eHF) + call ccRG0W0_TDA(maxSCF,thresh,max_diis,nBas,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index eed2052..836c084 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -1,6 +1,6 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF,ERI) -! Spatial orbital Parquet implementation +! Parquet approximation based on restricted orbitals implicit none include 'parameters.h' @@ -30,6 +30,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, double precision :: err_hh_sing,err_hh_trip double precision :: err_ee_sing,err_ee_trip double precision :: start_t, end_t, t + double precision :: start_1b, end_1b, t_1b + double precision :: start_2b, end_2b, t_2b integer :: nOOs,nOOt integer :: nVVs,nVVt @@ -65,7 +67,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, double precision,allocatable :: eh_sing_Gam(:,:,:,:),eh_trip_Gam(:,:,:,:) double precision,allocatable :: pp_sing_Gam(:,:,:,:),pp_trip_Gam(:,:,:,:) - double precision,allocatable :: eParquetlin(:),eParquet(:),old_eParquet(:) + double precision,allocatable :: eQPlin(:),eQP(:),eOld(:) double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) double precision :: EcGM @@ -77,7 +79,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, nOOt = nO*(nO - 1)/2 nVVt = nV*(nV - 1)/2 - allocate(eParquet(nOrb),old_eParquet(nOrb)) + allocate(eQP(nOrb),eOld(nOrb)) write(*,*) write(*,*)'**********************************' @@ -105,221 +107,64 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) ' *** Quasiparticle energies obtained by root search *** ' write(*,*) endif + +! Memory allocation + + allocate(old_eh_sing_Om(nS),old_eh_trip_Om(nS)) + allocate(old_ee_sing_Om(nVVs),old_hh_sing_Om(nOOs)) + allocate(old_ee_trip_Om(nVVt),old_hh_trip_Om(nOOt)) + allocate(eh_sing_rho(nOrb,nOrb,nS),eh_trip_rho(nOrb,nOrb,nS)) + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) ! Initialization n_it_1b = 0 err_1b = 1d0 + n_it_2b = 0 err_2b = 1d0 - old_eParquet(:) = eHF(:) - - write(*,*)'------------------------------------------------------------------' - write(*,*)' Solving initial linear-response problems ' - write(*,*)'------------------------------------------------------------------' - - !-----------------! - ! Density channel ! - !-----------------! - allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),old_eh_sing_Om(nS)) + eQP(:) = eHF(:) + eOld(:) = eHF(:) - ispin = 1 - Aph(:,:) = 0d0 - Bph(:,:) = 0d0 + eh_sing_rho(:,:,:) = 0d0 + eh_trip_rho(:,:,:) = 0d0 + ee_sing_rho(:,:,:) = 0d0 + ee_trip_rho(:,:,:) = 0d0 + hh_sing_rho(:,:,:) = 0d0 + hh_trip_rho(:,:,:) = 0d0 - call wall_time(start_t) - call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) - if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial singlet phRPA problem =',t,' seconds' + old_eh_sing_Om(:) = 1d0 + old_eh_trip_Om(:) = 1d0 + old_ee_sing_Om(:) = 1d0 + old_ee_trip_Om(:) = 1d0 + old_hh_sing_Om(:) = 1d0 + old_hh_trip_Om(:) = 1d0 - if(print_phLR) call print_excitation_energies('phRPA@RHF','singlet',nS,eh_sing_Om) - - deallocate(Aph,Bph) - - !------------------! - ! Magnetic channel ! - !------------------! - - allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),old_eh_trip_Om(nS)) - - ispin = 2 - Aph(:,:) = 0d0 - Bph(:,:) = 0d0 - - call wall_time(start_t) - call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) - if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial triplet phRPA problem =',t,' seconds' - - if(print_phLR) call print_excitation_energies('phRPA@RHF','triplet',nS,eh_trip_Om) - - deallocate(Aph,Bph) - - !-----------------! - ! Singlet channel ! - !-----------------! - - allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & - ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs),old_ee_sing_Om(nVVs), & - hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs),old_hh_sing_Om(nOOs)) - - ispin = 1 - Bpp(:,:) = 0d0 - Cpp(:,:) = 0d0 - Dpp(:,:) = 0d0 - - call wall_time(start_t) - if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) - call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial singlet ppRPA problem =',t,' seconds' - - if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (singlets)',nVVs,ee_sing_Om) - if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (singlets)',nOOs,hh_sing_Om) - - deallocate(Bpp,Cpp,Dpp) - - !-----------------! - ! Triplet channel ! - !-----------------! - - allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & - ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt),old_ee_trip_Om(nVVt), & - hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt),old_hh_trip_Om(nOOt)) - - ispin = 2 - Bpp(:,:) = 0d0 - Cpp(:,:) = 0d0 - Dpp(:,:) = 0d0 - - call wall_time(start_t) - if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) - call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for initial triplet ppRPA problem =',t,' seconds' - write(*,*) - - if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2p (triplets)',nVVt,ee_trip_Om) - if(print_ppLR) call print_excitation_energies('ppRPA@RHF','2h (triplets)',nOOt,hh_trip_Om) - - deallocate(Bpp,Cpp,Dpp) - - !----------! - ! Updating ! - !----------! - - old_eh_sing_Om(:) = eh_sing_Om(:) - old_eh_trip_Om(:) = eh_trip_Om(:) - old_ee_sing_Om(:) = ee_sing_Om(:) - old_hh_sing_Om(:) = hh_sing_Om(:) - old_ee_trip_Om(:) = ee_trip_Om(:) - old_hh_trip_Om(:) = hh_trip_Om(:) - - deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) - - ! Build singlet eh screened integrals - - allocate(eh_sing_rho(nOrb,nOrb,nS)) - allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - - eh_sing_Gam(:,:,:,:) = 0d0 - - call wall_time(start_t) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet eh screened integrals =',t,' seconds' - - deallocate(sing_XpY,sing_XmY) - deallocate(eh_sing_Gam) - - ! Build triplet eh screened integrals - - allocate(eh_trip_rho(nOrb,nOrb,nS)) - allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - - eh_trip_Gam(:,:,:,:) = 0d0 - - call wall_time(start_t) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet eh screened integrals =',t,' seconds' - - deallocate(trip_XpY,trip_XmY) - deallocate(eh_trip_Gam) - - ! Build singlet pp screened integrals - - allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) - allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - - pp_sing_Gam(:,:,:,:) = 0d0 - - call wall_time(start_t) - call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet pp screened integrals =',t,' seconds' - - deallocate(X1s,Y1s,X2s,Y2s) - deallocate(pp_sing_Gam) - - ! Build triplet pp screened integrals - - allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) - allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - - pp_trip_Gam(:,:,:,:) = 0d0 - - call wall_time(start_t) - call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet pp screened integrals =',t,' seconds' - - deallocate(X1t,Y1t,X2t,Y2t) - deallocate(pp_trip_Gam) - -!-----------------------------------------! -! Main loop for one-body self-consistency ! -!-----------------------------------------! + !-----------------------------------------! + ! Main loop for one-body self-consistency ! + !-----------------------------------------! do while(err_1b > conv_1b .and. n_it_1b < max_it_1b) n_it_1b = n_it_1b + 1 + call wall_time(start_1b) write(*,*) write(*,*)'-------------------------------------' - write(*,*)' One-body iteration number ',n_it_1b + write(*,'(1X,A30,1X,I4)') 'One-body iteration number ',n_it_1b write(*,*)'-------------------------------------' write(*,*) + !-----------------------------------------! + ! Main loop for two-body self-consistency ! + !-----------------------------------------! do while(err_2b > conv_2b .and. n_it_2b < max_it_2b) n_it_2b = n_it_2b + 1 + call wall_time(start_2b) !TODO add some timers everywhere write(*,*)' -----------------------------------' @@ -347,15 +192,26 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho,eh_sing_Gam_A) + if(n_it_2b == 1) then - call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho,eh_sing_Gam_B) + eh_sing_Gam_A(:,:) = 0d0 + eh_sing_Gam_B(:,:) = 0d0 + + else + + call R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & + eh_sing_Gam_A) + + call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & + eh_sing_Gam_B) + + end if Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) @@ -365,7 +221,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet phBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet phBSE problem =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) @@ -394,15 +250,26 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_A) + if(n_it_2b == 1) then - call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam_B) + eh_trip_Gam_A(:,:) = 0d0 + eh_trip_Gam_B(:,:) = 0d0 + + else + + call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & + eh_trip_Gam_A) + + call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & + eh_trip_Gam_B) + + end if Aph(:,:) = Aph(:,:) + eh_trip_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_trip_Gam_B(:,:) @@ -412,7 +279,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet phBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet phBSE problem =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) @@ -445,10 +312,20 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) - call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_B) - call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_C) - call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_sing_Gam_D) + if(n_it_2b == 1) then + + pp_sing_Gam_B(:,:) = 0d0 + pp_sing_Gam_C(:,:) = 0d0 + pp_sing_Gam_D(:,:) = 0d0 + + else + + call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_B) + call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_C) + call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_D) + + end if Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) @@ -458,7 +335,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for singlet ppBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE problem =',t,' seconds' write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) @@ -493,10 +370,20 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) - call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) - call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) - call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) + if(n_it_2b == 1) then + + pp_trip_Gam_B(:,:) = 0d0 + pp_trip_Gam_C(:,:) = 0d0 + pp_trip_Gam_D(:,:) = 0d0 + + else + + call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) + call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) + call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) + + end if Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) @@ -507,7 +394,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for triplet ppBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet ppBSE problem =',t,' seconds' if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,hh_trip_Om) @@ -553,7 +440,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for eh singlet Gamma =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh singlet Gamma =',t,' seconds' write(*,*) ! Build triplet eh effective interaction @@ -570,7 +457,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for eh triplet Gamma =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh triplet Gamma =',t,' seconds' write(*,*) ! Build singlet pp effective interaction @@ -583,7 +470,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for pp singlet Gamma =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp singlet Gamma =',t,' seconds' write(*,*) ! Build triplet pp effective interaction @@ -597,7 +484,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for pp triplet Gamma =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp triplet Gamma =',t,' seconds' write(*,*) ! Free memory @@ -620,7 +507,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for singlet eh integrals =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh integrals =',t,' seconds' write(*,*) deallocate(sing_XpY,sing_XmY,eh_sing_Gam) @@ -636,7 +523,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for triplet eh integrals =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh integrals =',t,' seconds' write(*,*) deallocate(trip_XpY,trip_XmY,eh_trip_Gam) @@ -652,7 +539,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for singlet pp integrals =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp integrals =',t,' seconds' write(*,*) deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) @@ -668,7 +555,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Total wall time for triplet pp integrals =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp integrals =',t,' seconds' write(*,*) deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) @@ -677,6 +564,10 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, err_2b = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) + call wall_time(end_2b) + t_2b = end_2b - start_2b + write(*,'(A50,1X,F9.3,A8)') 'Wall time for two-body iteration =',t_2b,' seconds' + end do !---------------------------------------------! ! End main loop for two-body self-consistency ! @@ -710,24 +601,24 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - allocate(eParquetlin(nOrb),Z(nOrb),SigC(nOrb)) + allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) write(*,*) 'Building self-energy' call wall_time(start_t) - call R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,old_eParquet,EcGM,SigC,Z) + call R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,eOld,EcGM,SigC,Z) call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Total wall time for self energy =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' write(*,*) - eParquetlin(:) = eHF(:) !+ Z(:)*SigC(:) + eQPlin(:) = eHF(:) !+ Z(:)*SigC(:) ! Solve the quasi-particle equation if(linearize) then - eParquet(:) = eParquetlin(:) + eQP(:) = eQPlin(:) else @@ -740,11 +631,17 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - deallocate(eParquetlin,Z,SigC) + deallocate(eQPlin,Z,SigC) + + ! Check one-body converge + + err_1b = maxval(abs(eOld - eQP)) + eOld(:) = eQP(:) + + call wall_time(end_1b) + t_1b = end_1b - start_1b + write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' - err_1b = maxval(abs(old_eParquet - eParquet)) - old_eParquet(:) = eParquet(:) - end do !---------------------------------------------! ! End main loop for one-body self-consistency ! From 5a8afe1739210ec886f80c13d358bfc64713f143 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 21 Mar 2025 10:04:17 +0100 Subject: [PATCH 10/71] to be done -> rho vs Gam --- src/Parquet/RParquet.f90 | 193 ++++++++++++++++++++------------------- 1 file changed, 99 insertions(+), 94 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 836c084..fbec924 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -152,9 +152,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(start_1b) write(*,*) - write(*,*)'-------------------------------------' - write(*,'(1X,A30,1X,I4)') 'One-body iteration number ',n_it_1b - write(*,*)'-------------------------------------' + write(*,*)'=====================================' + write(*,'(1X,A30,1X,I4)') 'One-body iteration #',n_it_1b + write(*,*)'=====================================' write(*,*) !-----------------------------------------! @@ -167,18 +167,18 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(start_2b) !TODO add some timers everywhere - write(*,*)' -----------------------------------' - write(*,*)' Two-Body iteration number ',n_it_2b - write(*,*)' -----------------------------------' + write(*,*)' ***********************************' + write(*,'(1X,A30,1X,I4)') 'Two-body iteration #',n_it_2b + write(*,*)' ***********************************' write(*,*) !-----------------! ! Density channel ! !-----------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing singlet ehBSE |' - write(*,*)' -------------------------------' + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing singlet ehBSE |' + write(*,*)' -------------------------------' write(*,*) allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) @@ -221,7 +221,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet phBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet phBSE =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) @@ -234,9 +234,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Magnetic channel ! !------------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing triplet ehBSE |' - write(*,*)' -------------------------------' + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing triplet ehBSE |' + write(*,*)' -------------------------------' write(*,*) allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) @@ -279,7 +279,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet phBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet phBSE =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) @@ -292,9 +292,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Singlet channel ! !-----------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing singlet ppBSE |' - write(*,*)' -------------------------------' + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing singlet ppBSE |' + write(*,*)' -------------------------------' write(*,*) allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & @@ -335,7 +335,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE =',t,' seconds' write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) @@ -350,9 +350,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Triplet channel ! !-----------------! - write(*,*)' |-----------------------------|' - write(*,*)' | Diagonalizing triplet ppBSE |' - write(*,*)' |-----------------------------|' + write(*,*)' -------------------------------' + write(*,*)' | Diagonalizing triplet ppBSE |' + write(*,*)' -------------------------------' write(*,*) allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & @@ -394,7 +394,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet ppBSE problem =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet ppBSE =',t,' seconds' + write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,hh_trip_Om) @@ -404,11 +405,14 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) - write(*,*) + write(*,*) '----------------------------------------' + write(*,*) ' Two-body convergence ' + write(*,*) '----------------------------------------' write(*,'(1X,A30,F10.6)')'Error for density channel = ', err_eh_sing write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eh_trip - write(*,'(1X,A30,F10.6)')'Error for singlet channel = ', max(err_ee_sing,err_hh_sing) - write(*,'(1X,A30,F10.6)')'Error for triplet channel = ', max(err_ee_trip,err_hh_trip) + write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_ee_sing,err_hh_sing) + write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_ee_trip,err_hh_trip) + write(*,*) '----------------------------------------' write(*,*) !----------! @@ -422,6 +426,74 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_ee_trip_Om(:) = ee_trip_Om(:) old_hh_trip_Om(:) = hh_trip_Om(:) + !----------------------------! + ! Compute screened integrals ! + !----------------------------! + + ! Build singlet eh screened integrals + + write(*,*) 'Computing singlet eh screened integrals...' + +! allocate(eh_sing_rho(nOrb,nOrb,nS)) + + call wall_time(start_t) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh integrals =',t,' seconds' + write(*,*) + + deallocate(sing_XpY,sing_XmY,eh_sing_Gam) + + ! Build triplet eh screened integrals + + write(*,*) 'Computing triplet eh screened integrals...' + +! allocate(eh_trip_rho(nOrb,nOrb,nS)) + + call wall_time(start_t) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh integrals =',t,' seconds' + write(*,*) + + deallocate(trip_XpY,trip_XmY,eh_trip_Gam) + + ! Build singlet pp screened integrals + + write(*,*) 'Computing singlet pp screened integrals...' + + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + + call wall_time(start_t) + call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp integrals =',t,' seconds' + write(*,*) + + deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) + + ! Build triplet pp screened integrals + + write(*,*) 'Computing triplet pp screened integrals...' + +! allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + + call wall_time(start_t) + call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp integrals =',t,' seconds' + write(*,*) + + deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) + !--------------------------------! ! Compute effective interactions ! !--------------------------------! @@ -491,75 +563,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) - - !----------------------------! - ! Compute screened integrals ! - !----------------------------! - - ! Build singlet eh screened integrals - - write(*,*) 'Computing singlet eh screened integrals...' - - allocate(eh_sing_rho(nOrb,nOrb,nS)) - - call wall_time(start_t) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh integrals =',t,' seconds' - write(*,*) - - deallocate(sing_XpY,sing_XmY,eh_sing_Gam) - - ! Build triplet eh screened integrals - - write(*,*) 'Computing triplet eh screened integrals...' - - allocate(eh_trip_rho(nOrb,nOrb,nS)) - - call wall_time(start_t) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh integrals =',t,' seconds' - write(*,*) - - deallocate(trip_XpY,trip_XmY,eh_trip_Gam) - - ! Build singlet pp screened integrals - - write(*,*) 'Computing singlet pp screened integrals...' - - allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) - - call wall_time(start_t) - call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp integrals =',t,' seconds' - write(*,*) - - deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) - - ! Build triplet pp screened integrals - - write(*,*) 'Computing triplet pp screened integrals...' - - allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) - - call wall_time(start_t) - call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp integrals =',t,' seconds' - write(*,*) - - deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) - + ! Convergence criteria err_2b = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) @@ -567,6 +571,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_2b) t_2b = end_2b - start_2b write(*,'(A50,1X,F9.3,A8)') 'Wall time for two-body iteration =',t_2b,' seconds' + write(*,*) end do !---------------------------------------------! From 806343007ab5409c06ff9e0e315fe9f809b18370 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Fri, 21 Mar 2025 11:00:23 +0100 Subject: [PATCH 11/71] ok with build gamma --- src/Parquet/RParquet.f90 | 165 ++++++++++++--------------- src/Parquet/R_screened_integrals.f90 | 16 +-- 2 files changed, 84 insertions(+), 97 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index fbec924..3c4bd19 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -172,6 +172,66 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*)' ***********************************' write(*,*) + !--------------------------------! + ! Compute effective interactions ! + !--------------------------------! + + ! Memory allocation + allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) + allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) + + ! Build singlet eh effective interaction + write(*,*) 'Computing singlet eh effective interaction...' + + call wall_time(start_t) + call R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh singlet Gamma =',t,' seconds' + write(*,*) + + ! Build triplet eh effective interaction + write(*,*) 'Computing triplet eh effective interaction...' + + call wall_time(start_t) + call R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh triplet Gamma =',t,' seconds' + write(*,*) + + ! Build singlet pp effective interaction + write(*,*) 'Computing singlet pp effective interaction...' + + call wall_time(start_t) + call R_pp_singlet_Gamma(nOrb,nC,nR,nS,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp singlet Gamma =',t,' seconds' + write(*,*) + + ! Build triplet pp effective interaction + write(*,*) 'Computing triplet pp effective interaction...' + + call wall_time(start_t) + call R_pp_triplet_Gamma(nOrb,nC,nR,nS,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp triplet Gamma =',t,' seconds' + write(*,*) + !-----------------! ! Density channel ! !-----------------! @@ -425,144 +485,71 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_hh_sing_Om(:) = hh_sing_Om(:) old_ee_trip_Om(:) = ee_trip_Om(:) old_hh_trip_Om(:) = hh_trip_Om(:) - + deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) + !----------------------------! ! Compute screened integrals ! !----------------------------! + ! Free memory + deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) + ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up + ! Memory allocation + allocate(eh_sing_rho(nOrb,nOrb,nS)) + allocate(eh_trip_rho(nOrb,nOrb,nS)) + allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) + allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + + ! Build singlet eh screened integrals - write(*,*) 'Computing singlet eh screened integrals...' -! allocate(eh_sing_rho(nOrb,nOrb,nS)) - call wall_time(start_t) call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh integrals =',t,' seconds' write(*,*) - + ! Done with eigenvectors and kernel deallocate(sing_XpY,sing_XmY,eh_sing_Gam) ! Build triplet eh screened integrals - write(*,*) 'Computing triplet eh screened integrals...' -! allocate(eh_trip_rho(nOrb,nOrb,nS)) - call wall_time(start_t) call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh integrals =',t,' seconds' write(*,*) - + ! Done with eigenvectors and kernel deallocate(trip_XpY,trip_XmY,eh_trip_Gam) ! Build singlet pp screened integrals - write(*,*) 'Computing singlet pp screened integrals...' - allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) - call wall_time(start_t) call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) call wall_time(end_t) t = end_t - start_t - + ! Done with eigenvectors and kernel write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp integrals =',t,' seconds' write(*,*) deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) ! Build triplet pp screened integrals - write(*,*) 'Computing triplet pp screened integrals...' -! allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) - call wall_time(start_t) call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp integrals =',t,' seconds' write(*,*) - + ! Done with eigenvectors and kernel deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) - - !--------------------------------! - ! Compute effective interactions ! - !--------------------------------! - ! Build singlet eh effective interaction - - write(*,*) 'Computing singlet eh effective interaction...' - - allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - - call wall_time(start_t) - call R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh singlet Gamma =',t,' seconds' - write(*,*) - - ! Build triplet eh effective interaction - - write(*,*) 'Computing triplet eh effective interaction...' - - allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - - call wall_time(start_t) - call R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh triplet Gamma =',t,' seconds' - write(*,*) - - ! Build singlet pp effective interaction - - write(*,*) 'Computing singlet pp effective interaction...' - - allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - call wall_time(start_t) - call R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp singlet Gamma =',t,' seconds' - write(*,*) - - ! Build triplet pp effective interaction - - write(*,*) 'Computing triplet pp effective interaction...' - - allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - - call wall_time(start_t) - call R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp triplet Gamma =',t,' seconds' - write(*,*) - - ! Free memory - - deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) - deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) ! Convergence criteria diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 01b3f87..2d885cc 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -138,7 +138,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do d=c,nOrb-nR cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + pp_sing_Gam(p,q,c,d))*X1(cd,ab) & + + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab) & /sqrt(1d0 + Kronecker_delta(c,d)) end do end do @@ -148,7 +148,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do l=k,nO kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & + + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & /sqrt(1d0 + Kronecker_delta(k,l)) end do end do @@ -165,7 +165,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do d=c,nOrb-nR cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + pp_sing_Gam(p,q,c,d))*X2(cd,ij) & + + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij) & /sqrt(1d0 + Kronecker_delta(c,d)) end do end do @@ -175,7 +175,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do l=k,nO kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & + + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & /sqrt(1d0 + Kronecker_delta(k,l)) end do end do @@ -244,7 +244,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + pp_trip_Gam(p,q,c,d))*X1(cd,ab) + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) end do ! d end do ! c @@ -255,7 +255,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + pp_trip_Gam(p,q,k,l))*Y1(kl,ab) + + (ERI(p,q,k,l) - ERI(p,q,l,k) + 0d0*pp_trip_Gam(p,q,k,l))*Y1(kl,ab) end do ! l end do ! k end do ! b @@ -272,7 +272,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + pp_trip_Gam(p,q,c,d))*X2(cd,ij) + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) end do ! d end do ! c @@ -282,7 +282,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + pp_trip_Gam(p,q,k,l))*Y2(kl,ij) + + (ERI(p,q,k,l) - ERI(p,q,l,k) + 0d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) end do ! l end do ! k end do ! j From ec676b70257c31d3d354c5838c00ab162a961f64 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 21 Mar 2025 11:32:20 +0100 Subject: [PATCH 12/71] convergence issue? --- src/Parquet/RParquet.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 3c4bd19..d24d8d6 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -468,7 +468,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) '----------------------------------------' write(*,*) ' Two-body convergence ' write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for density channel = ', err_eh_sing + write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eh_sing write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eh_trip write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_ee_sing,err_hh_sing) write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_ee_trip,err_hh_trip) @@ -485,6 +485,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_hh_sing_Om(:) = hh_sing_Om(:) old_ee_trip_Om(:) = ee_trip_Om(:) old_hh_trip_Om(:) = hh_trip_Om(:) + deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) !----------------------------! @@ -550,7 +551,6 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Done with eigenvectors and kernel deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) - ! Convergence criteria err_2b = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) From 45fc92b764cf387eaf3a5e2b96be5b6612ba7515 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 21 Mar 2025 11:46:15 +0100 Subject: [PATCH 13/71] time for GParquet --- src/Parquet/R_screened_integrals.f90 | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 2d885cc..2011dd8 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -28,8 +28,9 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,r do b=nO+1,nOrb-nR jb = jb + 1 do ia=1,nS - rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & - + 0d0*eh_sing_Gam(p,j,q,b) * XpY(ia,jb) + rho(p,q,ia) = rho(p,q,ia) & + + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & + + 1d0*eh_sing_Gam(p,j,q,b)*XpY(ia,jb) end do end do end do @@ -70,7 +71,9 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,r do b=nO+1,nOrb-nR jb = jb + 1 do ia=1,nS - rho(p,q,ia) = rho(p,q,ia) - ERI(p,j,b,q)*XpY(ia,jb) + 0d0*eh_trip_Gam(p,j,q,b) * XpY(ia,jb) + rho(p,q,ia) = rho(p,q,ia) & + - ERI(p,j,b,q)*XpY(ia,jb) & + + 1d0*eh_trip_Gam(p,j,q,b)*XpY(ia,jb) end do end do end do @@ -138,7 +141,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do d=c,nOrb-nR cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab) & + + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab) & /sqrt(1d0 + Kronecker_delta(c,d)) end do end do @@ -148,7 +151,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do l=k,nO kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & + + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & /sqrt(1d0 + Kronecker_delta(k,l)) end do end do @@ -165,7 +168,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do d=c,nOrb-nR cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + 0d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij) & + + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij) & /sqrt(1d0 + Kronecker_delta(c,d)) end do end do @@ -175,7 +178,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do l=k,nO kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + 0d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & + + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & /sqrt(1d0 + Kronecker_delta(k,l)) end do end do @@ -244,7 +247,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) end do ! d end do ! c @@ -255,7 +258,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + 0d0*pp_trip_Gam(p,q,k,l))*Y1(kl,ab) + + (ERI(p,q,k,l) - ERI(p,q,l,k) + 1d0*pp_trip_Gam(p,q,k,l))*Y1(kl,ab) end do ! l end do ! k end do ! b @@ -272,7 +275,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 0d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) end do ! d end do ! c @@ -282,7 +285,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + 0d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) + + (ERI(p,q,k,l) - ERI(p,q,l,k) + 1d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) end do ! l end do ! k end do ! j From 36685fcc734d3c2f24b7ed377c23cbf0bc865eba Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Sat, 22 Mar 2025 17:20:56 +0100 Subject: [PATCH 14/71] starting work on G Parquet --- src/AOtoMO/AOtoMO_ERI_RHF.f90 | 3 +- src/GW/RG0W0.f90 | 5 +- src/GW/RGW.f90 | 7 +- src/LR/print_excitation_energies.f90 | 2 +- src/Parquet/GParquet.f90 | 281 +++++++++++++++++++++++++++ src/Parquet/RParquet.f90 | 13 +- src/Parquet/R_screened_integrals.f90 | 1 + src/QuAcK/GQuAcK.f90 | 12 +- src/QuAcK/QuAcK.f90 | 6 +- src/QuAcK/RQuAcK.f90 | 5 +- 10 files changed, 314 insertions(+), 21 deletions(-) create mode 100644 src/Parquet/GParquet.f90 diff --git a/src/AOtoMO/AOtoMO_ERI_RHF.f90 b/src/AOtoMO/AOtoMO_ERI_RHF.f90 index a248ce1..ac57590 100644 --- a/src/AOtoMO/AOtoMO_ERI_RHF.f90 +++ b/src/AOtoMO/AOtoMO_ERI_RHF.f90 @@ -32,6 +32,7 @@ subroutine AOtoMO_ERI_RHF(nBas,nOrb,c,ERI_AO,ERI_MO) , 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*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) @@ -50,5 +51,5 @@ subroutine AOtoMO_ERI_RHF(nBas,nOrb,c,ERI_AO,ERI_MO) , 0.d0, ERI_MO(1,1,1,1), nOrb*nOrb*nOrb) deallocate(a2) - + end subroutine diff --git a/src/GW/RG0W0.f90 b/src/GW/RG0W0.f90 index 5362af0..1be8512 100644 --- a/src/GW/RG0W0.f90 +++ b/src/GW/RG0W0.f90 @@ -1,5 +1,5 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,doSRG,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF) + linearize,eta,doSRG,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF,eGW_out) ! Perform G0W0 calculation @@ -61,6 +61,7 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA double precision,allocatable :: eGWlin(:) double precision,allocatable :: eGW(:) + double precision,intent(inout):: eGW_out(nOrb) ! Output variables @@ -171,6 +172,8 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA call print_RG0W0(nOrb,nO,eHF,ENuc,ERHF,SigC,Z,eGW,EcRPA,EcGM) + eGW_out(:) = eGW(:) + !---------------------------! ! Perform phBSE calculation ! !---------------------------! diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index aac941d..23eadc6 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -1,7 +1,7 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_diis,doACFDT, & exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet, & linearize,eta,doSRG,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) + S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF,eGW) ! Restricted GW module @@ -70,6 +70,9 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii logical :: doccG0W0,doccGW + + double precision,intent(inout) :: eGW(nOrb) + !------------------------------------------------------------------------ ! Perform G0W0 calculation !------------------------------------------------------------------------ @@ -78,7 +81,7 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii call wall_time(start_GW) call RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE,singlet,triplet, & - linearize,eta,doSRG,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + linearize,eta,doSRG,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,eGW) call wall_time(end_GW) t_GW = end_GW - start_GW diff --git a/src/LR/print_excitation_energies.f90 b/src/LR/print_excitation_energies.f90 index 8d1448c..b909f21 100644 --- a/src/LR/print_excitation_energies.f90 +++ b/src/LR/print_excitation_energies.f90 @@ -14,7 +14,7 @@ subroutine print_excitation_energies(method,manifold,nS,Om) ! Local variables - integer,parameter :: maxS = 10 + integer,parameter :: maxS = 25 integer :: m write(*,*) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 new file mode 100644 index 0000000..c49f8b7 --- /dev/null +++ b/src/Parquet/GParquet.f90 @@ -0,0 +1,281 @@ +subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF,ERI) + +! Parquet approximation based on restricted orbitals + + implicit none + include 'parameters.h' + +! Hard-coded parameters + + logical :: linearize = .true. + logical :: TDA = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. + +! Input variables + + integer,intent(in) :: max_it_1b,max_it_2b + double precision,intent(in) :: conv_1b,conv_2b + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + +! Local variables + + integer :: ispin + + integer :: n_it_1b,n_it_2b + double precision :: err_1b,err_2b + double precision :: err_eh, err_hh, err_ee + double precision :: start_t, end_t, t + double precision :: start_1b, end_1b, t_1b + double precision :: start_2b, end_2b, t_2b + + integer :: nOO,nVV + + double precision :: EcRPA + double precision,allocatable :: Aph(:,:), Bph(:,:) + double precision,allocatable :: XpY(:,:),XmY(:,:) + double precision,allocatable :: eh_Om(:), old_eh_Om(:) + + double precision,allocatable :: Bpp(:,:), Cpp(:,:), Dpp(:,:) + double precision,allocatable :: X1(:,:),Y1(:,:) + double precision,allocatable :: ee_Om(:), old_ee_Om(:) + double precision,allocatable :: X2(:,:),Y2(:,:) + double precision,allocatable :: hh_Om(:), old_hh_Om(:) + + double precision,allocatable :: eh_rho(:,:,:), ee_rho(:,:,:), hh_rho(:,:,:) + + double precision,allocatable :: eh_Gam_A(:,:),eh_Gam_B(:,:) + double precision,allocatable :: pp_Gam_B(:,:),pp_Gam_C(:,:),pp_Gam_D(:,:) + double precision,allocatable :: eh_Gam(:,:,:,:),pp_Gam(:,:,:,:) + + double precision,allocatable :: eQPlin(:),eQP(:),eOld(:) + double precision,allocatable :: SigC(:) + double precision,allocatable :: Z(:) + double precision :: EcGM + +! Output variables +! None + + nOO = nO*(nO - 1)/2 + nVV = nV*(nV - 1)/2 + + allocate(eQP(nOrb),eOld(nOrb)) + + write(*,*) + write(*,*)'***********************************' + write(*,*)'* Generalized Parquet Calculation *' + write(*,*)'***********************************' + write(*,*) + + ! Print parameters + + write(*,*)'---------------------------------------------------------------' + write(*,*)' Parquet parameters for one-body and two-body self-consistency ' + write(*,*)'---------------------------------------------------------------' + write(*,'(1X,A50,1X,I5)') 'Maximum number for one-body self-consistency:', max_it_1b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:', conv_1b + write(*,*)'---------------------------------------------------------------' + write(*,'(1X,A50,1X,I5)') 'Maximum number for two-body self-consistency:', max_it_2b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:', conv_2b + write(*,*)'---------------------------------------------------------------' + write(*,*) + + if(linearize) then + write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' + write(*,*) + else + write(*,*) ' *** Quasiparticle energies obtained by root search *** ' + write(*,*) + endif + + ! Memory allocation + + allocate(old_eh_Om(nS),old_ee_Om(nVV),old_hh_Om(nOO)) + allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + +! Initialization + + n_it_1b = 0 + err_1b = 1d0 + + n_it_2b = 0 + err_2b = 1d0 + + eQP(:) = eHF(:) + eOld(:) = eHF(:) + + eh_rho(:,:,:) = 0d0 + ee_rho(:,:,:) = 0d0 + hh_rho(:,:,:) = 0d0 + + old_eh_Om(:) = 1d0 + old_ee_Om(:) = 1d0 + old_hh_Om(:) = 1d0 + + !-----------------------------------------! + ! Main loop for one-body self-consistency ! + !-----------------------------------------! + + do while(err_1b > conv_1b .and. n_it_1b < max_it_1b) + + n_it_1b = n_it_1b + 1 + call wall_time(start_1b) + + write(*,*) + write(*,*)'=====================================' + write(*,'(1X,A30,1X,I4)') 'One-body iteration #',n_it_1b + write(*,*)'=====================================' + write(*,*) + + !-----------------------------------------! + ! Main loop for two-body self-consistency ! + !-----------------------------------------! + + do while(err_2b > conv_2b .and. n_it_2b < max_it_2b) + + n_it_2b = n_it_2b + 1 + call wall_time(start_2b) + + write(*,*)' ***********************************' + write(*,'(1X,A30,1X,I4)') 'Two-body iteration #',n_it_2b + write(*,*)' ***********************************' + write(*,*) + + !--------------------------------! + ! Compute effective interactions ! + !--------------------------------! + + ! Memory allocation + allocate(eh_Gam(nOrb,nOrb,nOrb,nOrb)) + allocate(pp_Gam(nOrb,nOrb,nOrb,nOrb)) + + ! Build eh effective interaction + write(*,*) 'Computing eh effective interaction...' + + call wall_time(start_t) + !call R_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + ! old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & + ! eh_trip_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh Gamma =',t,' seconds' + write(*,*) + + ! Build singlet pp effective interaction + write(*,*) 'Computing pp effective interaction...' + + call wall_time(start_t) + !call R_pp_Gamma(nOrb,nC,nR,nS,old_eh_Om,eh_rho,pp_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp Gamma =',t,' seconds' + write(*,*) + + + + call wall_time(end_2b) + t_2b = end_2b - start_2b + write(*,'(A50,1X,F9.3,A8)') 'Wall time for two-body iteration =',t_2b,' seconds' + write(*,*) + + end do + !---------------------------------------------! + ! End main loop for two-body self-consistency ! + !---------------------------------------------! + + ! Did it actually converge? + + if(n_it_2b == max_it_2b) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Two-body convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + + else + + write(*,*) + write(*,*)'****************************************************' + write(*,*)' Two-body convergence success ' + write(*,*)'****************************************************' + write(*,*) + + call print_excitation_energies('phBSE@Parquet','1h1p',nS,old_eh_Om) + call print_excitation_energies('ppBSE@Parquet','2p',nVV,old_ee_Om) + call print_excitation_energies('ppBSE@Parquet','2h',nOO,old_hh_Om) + + end if + + allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) + + write(*,*) 'Building self-energy' + + call wall_time(start_t) + !call G_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,eOld,EcGM,SigC,Z) + call wall_time(end_t) + t = end_t - start_t + write(*,'(A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' + write(*,*) + + eQPlin(:) = eHF(:) !+ Z(:)*SigC(:) + + ! Solve the quasi-particle equation + + if(linearize) then + + eQP(:) = eQPlin(:) + + else + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Newton-Raphson for Dyson equation not implemented ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + + end if + + deallocate(eQPlin,Z,SigC) + + ! Check one-body converge + + err_1b = maxval(abs(eOld - eQP)) + eOld(:) = eQP(:) + + call wall_time(end_1b) + t_1b = end_1b - start_1b + write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' + + end do + !---------------------------------------------! + ! End main loop for one-body self-consistency ! + !---------------------------------------------! + + ! Did it actually converge? + if(n_it_1b == max_it_1b) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' One-body convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + stop + + else + + write(*,*) + write(*,*)'****************************************************' + write(*,*)' One-body convergence success ' + write(*,*)'****************************************************' + write(*,*) + + end if + +end subroutine GParquet diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index d24d8d6..a146ee0 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -37,16 +37,13 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: nVVs,nVVt double precision :: EcRPA - double precision,allocatable :: Aph(:,:) - double precision,allocatable :: Bph(:,:) + double precision,allocatable :: Aph(:,:), Bph(:,:) double precision,allocatable :: sing_XpY(:,:),trip_XpY(:,:) double precision,allocatable :: sing_XmY(:,:),trip_XmY(:,:) double precision,allocatable :: eh_sing_Om(:), old_eh_sing_Om(:) double precision,allocatable :: eh_trip_Om(:), old_eh_trip_Om(:) - double precision,allocatable :: Bpp(:,:) - double precision,allocatable :: Cpp(:,:) - double precision,allocatable :: Dpp(:,:) + double precision,allocatable :: Bpp(:,:), Cpp(:,:), Dpp(:,:) double precision,allocatable :: X1s(:,:),X1t(:,:) double precision,allocatable :: Y1s(:,:),Y1t(:,:) double precision,allocatable :: ee_sing_Om(:), old_ee_sing_Om(:) @@ -73,7 +70,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, double precision :: EcGM ! Output variables - +! None + nOOs = nO*(nO + 1)/2 nVVs = nV*(nV + 1)/2 nOOt = nO*(nO - 1)/2 @@ -166,7 +164,6 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, n_it_2b = n_it_2b + 1 call wall_time(start_2b) - !TODO add some timers everywhere write(*,*)' ***********************************' write(*,'(1X,A30,1X,I4)') 'Two-body iteration #',n_it_2b write(*,*)' ***********************************' @@ -659,4 +656,4 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if -end subroutine +end subroutine RParquet diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 2011dd8..de2e8f7 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -31,6 +31,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,r rho(p,q,ia) = rho(p,q,ia) & + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & + 1d0*eh_sing_Gam(p,j,q,b)*XpY(ia,jb) + end do end do end do diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index 30fa842..7dcc441 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -7,7 +7,8 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop 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, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & - dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS) + dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & + max_it_macro,conv_one_body,max_it_micro,conv_two_body) implicit none include 'parameters.h' @@ -74,6 +75,9 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop logical,intent(in) :: dophBSE,dophBSE2,doppBSE,dBSE,dTDA logical,intent(in) :: doACFDT,exchange_kernel,doXBS + integer,intent(in) :: max_it_macro,max_it_micro + double precision,intent(in) :: conv_one_body,conv_two_body + ! Local variables logical :: doMP,doCC,doRPA,doGF,doGW,doGT @@ -341,9 +345,9 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) - write(*,'(A65,1X,F9.3,A8)') 'The Parquet method is not implemented in spin-orbital yet :(' - write(*,'(A65,1X,F9.3,A8)') 'Try running the RHF version!' - write(*,*) + call GParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & + nBas,nC,nO,nV,nR,nS, & + eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index a9477ca..03abb0d 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -289,14 +289,14 @@ program QuAcK if(doGQuAcK) & call GQuAcK(working_dir,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,doG0T0pp,doevGTpp,doqsGTpp,doParquet, & + doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2,doG0T0pp,doevGTpp,doqsGTpp,doParquet, & nNuc,nBas,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_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, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & - dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS) - + dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & + max_it_macro,conv_one_body,max_it_micro,conv_two_body) !--------------------------! ! Bogoliubov QuAcK branch ! diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 63dc813..2bf23f7 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -112,6 +112,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, double precision,allocatable :: ERI_MO(:,:,:,:) integer :: ixyz integer :: nS + double precision,allocatable :: eGW(:) write(*,*) write(*,*) '******************************' @@ -130,6 +131,8 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, allocate(dipole_int_MO(nOrb,nOrb,ncart)) allocate(ERI_MO(nOrb,nOrb,nOrb,nOrb)) + allocate(eGW(nOrb)) + allocate(ERI_AO(nBas,nBas,nBas,nBas)) call wall_time(start_int) call read_2e_integrals(working_dir,nBas,ERI_AO) @@ -337,7 +340,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, call RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,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,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) + V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF,eGW) call wall_time(end_GW) t_GW = end_GW - start_GW From e0fe498b51aac26a3c12b1075482c289ee01dda4 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 24 Mar 2025 21:21:44 +0100 Subject: [PATCH 15/71] spin adaptation checked up to screened integrals, ie iteration 3 --- src/GT/RGTeh_SigC.f90 | 4 +- src/GT/RGTeh_dSigC.f90 | 4 +- src/GT/RGTeh_self_energy_diag.f90 | 4 +- src/LR/phGLR_A.f90 | 2 +- src/Parquet/GParquet.f90 | 178 ++++++++++++++- src/Parquet/G_eh_Gam.f90 | 186 +++++++++++++++ src/Parquet/G_pp_Gam.f90 | 211 ++++++++++++++++++ src/Parquet/G_screened_integrals.f90 | 154 +++++++++++++ src/Parquet/RParquet.f90 | 36 ++- src/Parquet/R_eh_singlet_Gam.f90 | 19 +- src/Parquet/R_eh_triplet_Gam.f90 | 26 ++- src/Parquet/R_pp_singlet_Gam.f90 | 48 ++-- src/Parquet/R_pp_triplet_Gam.f90 | 52 +++-- src/Parquet/R_screened_integrals.f90 | 34 ++- .../amarie@HP-EliteBook-830.23187:1742801908 | 0 src/QuAcK/GQuAcK.f90 | 2 +- 16 files changed, 866 insertions(+), 94 deletions(-) create mode 100644 src/Parquet/G_eh_Gam.f90 create mode 100644 src/Parquet/G_pp_Gam.f90 create mode 100644 src/Parquet/G_screened_integrals.f90 create mode 100644 src/Parquet/amarie@HP-EliteBook-830.23187:1742801908 diff --git a/src/GT/RGTeh_SigC.f90 b/src/GT/RGTeh_SigC.f90 index 2f59db3..85f61d5 100644 --- a/src/GT/RGTeh_SigC.f90 +++ b/src/GT/RGTeh_SigC.f90 @@ -35,7 +35,7 @@ double precision function RGTeh_SigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR) do i=nC+1,nO do m=1,nS eps = w - e(i) + Om(m) - num = rhoL(i,p,m)*rhoR(i,p,m) + num = rhoL(i,p,m)*rhoL(i,p,m) RGTeh_SigC = RGTeh_SigC + num*eps/(eps**2 + eta**2) end do end do @@ -45,7 +45,7 @@ double precision function RGTeh_SigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR) do a=nO+1,nBas-nR do m=1,nS eps = w - e(a) - Om(m) - num = rhoL(p,a,m)*rhoR(p,a,m) + num = rhoL(p,a,m)*rhoL(p,a,m) RGTeh_SigC = RGTeh_SigC + num*eps/(eps**2 + eta**2) end do end do diff --git a/src/GT/RGTeh_dSigC.f90 b/src/GT/RGTeh_dSigC.f90 index 850ab38..fbb2215 100644 --- a/src/GT/RGTeh_dSigC.f90 +++ b/src/GT/RGTeh_dSigC.f90 @@ -35,7 +35,7 @@ double precision function RGTeh_dSigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR do i=nC+1,nO do m=1,nS eps = w - e(i) + Om(m) - num = rhoL(i,p,m)*rhoR(i,p,m) + num = rhoL(i,p,m)*rhoL(i,p,m) RGTeh_dSigC = RGTeh_dSigC - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 end do end do @@ -45,7 +45,7 @@ double precision function RGTeh_dSigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR do a=nO+1,nBas-nR do m=1,nS eps = w - e(a) - Om(m) - num = rhoL(p,a,m)*rhoR(p,a,m) + num = rhoL(p,a,m)*rhoL(p,a,m) RGTeh_dSigC = RGTeh_dSigC - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 end do end do diff --git a/src/GT/RGTeh_self_energy_diag.f90 b/src/GT/RGTeh_self_energy_diag.f90 index 14e0055..039e17e 100644 --- a/src/GT/RGTeh_self_energy_diag.f90 +++ b/src/GT/RGTeh_self_energy_diag.f90 @@ -46,7 +46,7 @@ subroutine RGTeh_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR,EcGM,Si do m=1,nS eps = e(p) - e(i) + Om(m) - num = rhoL(i,p,m)*rhoR(i,p,m) + num = rhoL(i,p,m)*rhoL(i,p,m) Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 @@ -61,7 +61,7 @@ subroutine RGTeh_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR,EcGM,Si do m=1,nS eps = e(p) - e(a) - Om(m) - num = rhoL(p,a,m)*rhoR(p,a,m) + num = rhoL(p,a,m)*rhoL(p,a,m) Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 diff --git a/src/LR/phGLR_A.f90 b/src/LR/phGLR_A.f90 index d23a6b8..12d33d5 100644 --- a/src/LR/phGLR_A.f90 +++ b/src/LR/phGLR_A.f90 @@ -52,5 +52,5 @@ subroutine phGLR_A(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,e,ERI,Aph) end do end do end do - + end subroutine diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index c49f8b7..4694444 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -9,8 +9,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, logical :: linearize = .true. logical :: TDA = .true. - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables @@ -22,8 +22,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Local variables - integer :: ispin - integer :: n_it_1b,n_it_2b double precision :: err_1b,err_2b double precision :: err_eh, err_hh, err_ee @@ -155,9 +153,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing eh effective interaction...' call wall_time(start_t) - !call R_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + !call R_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & ! old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & - ! eh_trip_Gam) + ! eh_Gam) call wall_time(end_t) t = end_t - start_t @@ -168,14 +166,180 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing pp effective interaction...' call wall_time(start_t) - !call R_pp_Gamma(nOrb,nC,nR,nS,old_eh_Om,eh_rho,pp_Gam) + call G_pp_Gamma(nOrb,nC,nO,nV,nR,nS,old_eh_Om,eh_rho,pp_Gam) call wall_time(end_t) t = end_t - start_t write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp Gamma =',t,' seconds' write(*,*) + !-----------------! + ! eh channel ! + !-----------------! + write(*,*)' ------------------------------' + write(*,*)' | Diagonalizing ehBSE |' + write(*,*)' ------------------------------' + write(*,*) + + allocate(Aph(nS,nS),Bph(nS,nS),eh_Om(nS),XpY(nS,nS),XmY(nS,nS),eh_Gam_A(nS,nS),eh_Gam_B(nS,nS)) + + + Aph(:,:) = 0d0 + Bph(:,:) = 0d0 + + call wall_time(start_t) + + call phGLR_A(.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDA) call phGLR_B(.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + + if(n_it_2b == 1) then + + eh_Gam_A(:,:) = 0d0 + eh_Gam_B(:,:) = 0d0 + + else + + call G_eh_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & + eh_Gam_A) + + if(.not.TDA) call G_eh_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & + eh_Gam_B) + + end if + + Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) + + call phGLR(TDA,nS,Aph,Bph,EcRPA,eh_Om,XpY,XmY) + + call wall_time(end_t) + + t = end_t - start_t + write(*,'(A50,1X,F9.3,A8)') 'Wall time for phBSE =',t,' seconds' + write(*,*) + + if(print_phLR) call print_excitation_energies('phBSE@Parquet','eh generalized',nS,eh_Om) + + err_eh = maxval(abs(old_eh_Om - eh_Om)) + + deallocate(Aph,Bph,eh_Gam_A,eh_Gam_B) + + !-----------------! + ! pp channel ! + !-----------------! + + write(*,*)' ------------------------------' + write(*,*)' | Diagonalizing ppBSE |' + write(*,*)' ------------------------------' + write(*,*) + + allocate(Bpp(nVV,nOO),Cpp(nVV,nVV),Dpp(nOO,nOO), & + ee_Om(nVV),X1(nVV,nVV),Y1(nOO,nVV), & + hh_Om(nOO),X2(nVV,nOO),Y2(nOO,nOO), & + pp_Gam_B(nVV,nOO),pp_Gam_C(nVV,nVV),pp_Gam_D(nOO,nOO)) + + Bpp(:,:) = 0d0 + Cpp(:,:) = 0d0 + Dpp(:,:) = 0d0 + + call wall_time(start_t) + if(.not.TDA) call ppGLR_B(nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) + call ppGLR_C(nOrb,nC,nO,nV,nR,nVV,1d0,eHF,ERI,Cpp) + call ppGLR_D(nOrb,nC,nO,nV,nR,nOO,1d0,eHF,ERI,Dpp) + + if(n_it_2b == 1) then + + pp_Gam_B(:,:) = 0d0 + pp_Gam_C(:,:) = 0d0 + pp_Gam_D(:,:) = 0d0 + + else + + if(.not.TDA) call G_pp_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV,old_eh_Om,eh_rho,pp_Gam_B) + call G_pp_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVV,old_eh_Om,eh_rho,pp_Gam_C) + call G_pp_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOO,old_eh_Om,eh_rho,pp_Gam_D) + + end if + + Bpp(:,:) = Bpp(:,:) + pp_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) + + call ppGLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,EcRPA) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for ppBSE =',t,' seconds' + write(*,*) + + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p generalized',nVV,ee_Om) + if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h generalized',nOO,hh_Om) + + err_ee = maxval(abs(old_ee_Om - ee_Om)) + err_hh = maxval(abs(old_hh_Om - hh_Om)) + + deallocate(Bpp,Cpp,Dpp,pp_Gam_B,pp_Gam_C,pp_Gam_D) + + + write(*,*) '----------------------------------------' + write(*,*) ' Two-body convergence ' + write(*,*) '----------------------------------------' + write(*,'(1X,A30,F10.6)')'Error for eh channel = ',err_eh + write(*,'(1X,A30,F10.6)')'Error for pp channel = ',max(err_ee,err_hh) + write(*,*) '----------------------------------------' + write(*,*) + + !----------! + ! Updating ! + !----------! + + old_eh_Om(:) = eh_Om(:) + old_ee_Om(:) = ee_Om(:) + old_hh_Om(:) = hh_Om(:) + + deallocate(eh_Om,ee_Om,hh_Om) + + !----------------------------! + ! Compute screened integrals ! + !----------------------------! + + ! Free memory + deallocate(eh_rho,ee_rho,hh_rho) + ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up + ! Memory allocation + allocate(eh_rho(nOrb,nOrb,nS)) + allocate(ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + + ! Build singlet eh integrals + write(*,*) 'Computing eh screened integrals...' + + call wall_time(start_t) + call G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,eh_rho) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for eh integrals =',t,' seconds' + write(*,*) + ! Done with eigenvectors and kernel + deallocate(XpY,XmY,eh_Gam) + + ! Build singlet pp integrals + write(*,*) 'Computing pp screened integrals...' + + call wall_time(start_t) + call G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,ee_rho,X2,Y2,hh_rho) + call wall_time(end_t) + t = end_t - start_t + ! Done with eigenvectors and kernel + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp integrals =',t,' seconds' + write(*,*) + + deallocate(X1,Y1,X2,Y2,pp_Gam) + + ! Convergence criteria + err_2b = max(err_eh,err_ee,err_hh) call wall_time(end_2b) t_2b = end_2b - start_2b diff --git a/src/Parquet/G_eh_Gam.f90 b/src/Parquet/G_eh_Gam.f90 new file mode 100644 index 0000000..b1f1df0 --- /dev/null +++ b/src/Parquet/G_eh_Gam.f90 @@ -0,0 +1,186 @@ +subroutine G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + eh_Om,eh_rho,ee_Om,ee_rho,hh_Om,hh_rho, & + eh_Gam) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_Om(nVV) + double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: hh_Om(nOO) + double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + +! Local variables + integer :: p,q,r,s + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_Gam(nOrb,nOrb,nOrb,nOrb) + +! Initialization + eh_Gam(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + ! do n=1,nS + ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + ! + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + ! + 3d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + ! end do + + ! do n=1,nVVs + ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + ! + ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) + ! end do + + ! do n=1,nOOs + ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + ! - hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) + ! end do + + ! do n=1,nVVt + ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + ! + 3d0 * ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) + ! end do + + ! do n=1,nOOt + ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & + ! - 3d0 * hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) + ! end do + + enddo + enddo + enddo + enddo + +end subroutine G_eh_Gamma + +subroutine G_eh_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + eh_Om,eh_rho,ee_Om,ee_rho,hh_Om,hh_rho, & + eh_Gam_A) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_Om(nVV) + double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: hh_Om(nOO) + double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + +! Local variables + integer :: i,a,j,b + integer :: ia,jb + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_Gam_A(nS,nS) + +! Initialization + eh_Gam_A(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nOrb-nR + ia = ia + 1 + + jb = 0 + do j=nC+1,nO + do b=nO+1,norb-nR + jb = jb + 1 + + do n=1,nS + eh_Gam_A(ia,jb) = eh_Gam_A(ia,jb) & + + eh_rho(b,a,n)*eh_rho(j,i,n)/eh_Om(n) & + + eh_rho(a,b,n)*eh_rho(i,j,n)/eh_Om(n) + end do + + do n=1,nVV + eh_Gam_A(ia,jb) = eh_Gam_A(ia,jb) & + + 2d0 * ee_rho(a,j,n)*ee_rho(i,b,n)/ee_Om(n) + end do + + do n=1,nOO + eh_Gam_A(ia,jb) = eh_Gam_A(ia,jb) & + - 2d0 * hh_rho(a,j,n)*hh_rho(i,b,n)/hh_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine G_eh_Gamma_A + +subroutine G_eh_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + eh_Om,eh_rho,ee_Om,ee_rho,hh_Om,hh_rho, & + eh_Gam_B) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: ee_Om(nVV) + double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: hh_Om(nOO) + double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + +! Local variables + integer :: i,a,j,b + integer :: ia,jb + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: eh_Gam_B(nS,nS) + +! Initialization + eh_Gam_B(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nOrb-nR + ia = ia + 1 + + jb = 0 + do j=nC+1,nO + do b=nO+1,norb-nR + jb = jb + 1 + + do n=1,nS + eh_Gam_B(ia,jb) = eh_Gam_B(ia,jb) & + + eh_rho(j,a,n)*eh_rho(b,i,n)/eh_Om(n) & + + eh_rho(a,j,n)*eh_rho(i,b,n)/eh_Om(n) + end do + + do n=1,nVV + eh_Gam_B(ia,jb) = eh_Gam_B(ia,jb) & + + 2d0 * ee_rho(a,b,n)*ee_rho(i,j,n)/ee_Om(n) + end do + + do n=1,nOO + eh_Gam_B(ia,jb) = eh_Gam_B(ia,jb) & + - 2d0 * hh_rho(a,b,n)*hh_rho(i,j,n)/hh_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine G_eh_Gamma_B diff --git a/src/Parquet/G_pp_Gam.f90 b/src/Parquet/G_pp_Gam.f90 new file mode 100644 index 0000000..5c81d59 --- /dev/null +++ b/src/Parquet/G_pp_Gam.f90 @@ -0,0 +1,211 @@ +subroutine G_pp_Gamma(nOrb,nC,nO,nV,nR,nS,eh_Om,eh_rho,pp_Gam) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + +! Local variables + integer :: p,q,r,s + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_Gam(nOrb,nOrb,nOrb,nOrb) + +! Initialization + pp_Gam(:,:,:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nS + pp_Gam(p,q,r,s) = pp_Gam(p,q,r,s) & + - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & + - eh_rho(p,r,n)*eh_rho(s,q,n)/eh_Om(n) & + + eh_rho(s,p,n)*eh_rho(q,r,n)/eh_Om(n) & + + eh_rho(p,s,n)*eh_rho(r,q,n)/eh_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine G_pp_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOO,eh_Om,eh_rho,pp_Gam_D) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + +! Local variables + integer :: i,j,k,l + integer :: ij,kl + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_Gam_D(nOO,nOO) + +! Initialization + pp_Gam_D(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ij = 0 + do i=nC+1,nO + do j=i+1,nO + ij = ij + 1 + + kl = 0 + do k=nC+1,nO + do l=k+1,nO + kl = kl +1 + + do n=1,nS + pp_Gam_D(ij,kl) = pp_Gam_D(ij,kl) & + - eh_rho(k,i,n)*eh_rho(j,l,n)/eh_Om(n) & + - eh_rho(i,k,n)*eh_rho(l,j,n)/eh_Om(n) & + + eh_rho(l,i,n)*eh_rho(j,k,n)/eh_Om(n) & + + eh_rho(i,l,n)*eh_rho(k,j,n)/eh_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine G_pp_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVV,eh_Om,eh_rho,pp_Gam_C) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nVV + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + +! Local variables + integer :: a,b,c,d + integer :: ab,cd + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_Gam_C(nVV,nVV) + +! Initialization + pp_Gam_C(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ab = 0 + do a=nO+1,nOrb - nR + do b=a+1,nOrb - nR + ab = ab + 1 + + cd = 0 + do c=nO+1,nOrb - nR + do d=c+1,nOrb - nR + cd = cd +1 + + do n=1,nS + + pp_Gam_C(ab,cd) = pp_Gam_C(ab,cd) & + - eh_rho(c,a,n)*eh_rho(b,d,n)/eh_Om(n) & + - eh_rho(a,c,n)*eh_rho(d,b,n)/eh_Om(n) & + + eh_rho(d,a,n)*eh_rho(b,c,n)/eh_Om(n) & + + eh_rho(a,d,n)*eh_rho(c,b,n)/eh_Om(n) + + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine + +subroutine G_pp_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV,eh_Om,eh_rho,pp_Gam_B) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + +! Local variables + integer :: a,b,i,j + integer :: ab,ij + integer :: n + double precision,external :: Kronecker_delta + +! Output variables + double precision, intent(out) :: pp_Gam_B(nVV,nOO) + +! Initialization + pp_Gam_B(:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & +! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) +! !$OMP DO COLLAPSE(2) + + ab = 0 + do a=nO+1,nOrb - nR + do b=a+1,nOrb - nR + ab = ab + 1 + + ij = 0 + do i=nC+1,nO + do j=i+1,nO + ij = ij + 1 + + do n=1,nS + pp_Gam_B(ab,ij) = pp_Gam_B(ab,ij) & + - eh_rho(i,a,n)*eh_rho(b,j,n)/eh_Om(n) & + - eh_rho(a,i,n)*eh_rho(j,b,n)/eh_Om(n) & + + eh_rho(j,a,n)*eh_rho(b,i,n)/eh_Om(n) & + + eh_rho(a,j,n)*eh_rho(i,b,n)/eh_Om(n) + end do + + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 new file mode 100644 index 0000000..4386ed6 --- /dev/null +++ b/src/Parquet/G_screened_integrals.f90 @@ -0,0 +1,154 @@ +subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,rho) + +! Compute excitation densities + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: XpY(nS,nS),XmY(nS,nS) + +! Local variables + integer :: ia,jb,p,q,j,b + double precision :: X,Y + +! Output variables + double precision,intent(out) :: rho(nOrb,nOrb,nS) + + rho(:,:,:) = 0d0 +! !$OMP PARALLEL & +! !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY,eh_sing_Gam) & +! !$OMP PRIVATE(q,p,jb,ia) & +! !$OMP DEFAULT(NONE) +! !$OMP DO + do q=nC+1,nOrb-nR + do p=nC+1,nOrb-nR + + jb = 0 + do j=nC+1,nO + do b=nO+1,nOrb-nR + jb = jb + 1 + + do ia=1,nS + + X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + + rho(p,q,ia) = rho(p,q,ia) & + !+ (ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & + + (ERI(p,j,q,b) - ERI(p,j,b,q))*X & + + (ERI(p,b,q,j) - ERI(p,b,j,q))*Y & + + 0d0*eh_Gam(p,j,q,b)*XpY(ia,jb) + + end do + end do + end do + end do + end do +! !$OMP END DO +! !$OMP END PARALLEL + +end subroutine G_eh_screened_integral + +subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1,X2,Y2,rho2) + +! Compute excitation densities in the singlet pp channel + + implicit none + +! Input variables + + + integer,intent(in) :: nOrb,nC,nO,nV,nR + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_Gam(nOrb,nOrb,nOrb,nOrb) + integer,intent(in) :: nOO + integer,intent(in) :: nVV + double precision,intent(in) :: X1(nVV,nVV) + double precision,intent(in) :: Y1(nOO,nVV) + double precision,intent(in) :: X2(nVV,nOO) + double precision,intent(in) :: Y2(nOO,nOO) + +! Local variables + + integer :: i,j,k,l + integer :: a,b,c,d + integer :: p,q + integer :: ab,cd,ij,kl + double precision,external :: Kronecker_delta + +! Output variables + + double precision,intent(out) :: rho1(nOrb,nOrb,nVV) + double precision,intent(out) :: rho2(nOrb,nOrb,nOO) + + integer :: dim_1, dim_2 + +! Initialization + + rho1(:,:,:) = 0d0 + rho2(:,:,:) = 0d0 + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & +! !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_sing_Gam, X1, Y1, X2, Y2) +! !$OMP DO COLLAPSE(2) + do q=nC+1,nOrb-nR + do p=nC+1,nOrb-nR + + ab = 0 + do a=nO+1,nOrb-nR + do b=a+1,nOrb-nR + ab = ab + 1 + + cd = 0 + do c=nO+1,nOrb-nR + do d=c+1,nOrb-nR + cd = cd + 1 + rho1(p,q,ab) = rho1(p,q,ab) & + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_Gam(p,q,c,d))*X1(cd,ab) + end do + end do + + 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) + 1d0*pp_Gam(p,q,k,l))*Y1(kl,ab) + end do + end do + + end do + end do + + ij = 0 + do i=nC+1,nO + do j=i+1,nO + ij = ij + 1 + cd = 0 + do c=nO+1,nOrb-nR + do d=c+1,nOrb-nR + cd = cd + 1 + rho2(p,q,ij) = rho2(p,q,ij) & + + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_Gam(p,q,c,d))*X2(cd,ij) + end do + end do + + 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) + 1d0*pp_Gam(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 subroutine G_pp_screened_integral diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index a146ee0..af5bcd4 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -9,8 +9,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, logical :: linearize = .true. logical :: TDA = .true. - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables @@ -262,14 +262,13 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & eh_sing_Gam_A) - call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & - eh_sing_Gam_B) + if(.not.TDA) call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & + eh_sing_Gam_B) - end if - + end if Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) @@ -320,11 +319,11 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & eh_trip_Gam_A) - call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & - eh_trip_Gam_B) + if(.not.TDA) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & + old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & + old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & + old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & + eh_trip_Gam_B) end if @@ -377,7 +376,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& + if(.not.TDA) call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_B) call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_C) call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_D) @@ -435,7 +434,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& + if(.not.TDA) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) @@ -503,7 +502,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing singlet eh screened integrals...' call wall_time(start_t) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,eh_sing_rho) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,sing_XmY,eh_sing_rho) call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh integrals =',t,' seconds' @@ -515,7 +514,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing triplet eh screened integrals...' call wall_time(start_t) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,eh_trip_rho) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,trip_XmY,eh_trip_rho) call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh integrals =',t,' seconds' @@ -549,7 +548,6 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) ! Convergence criteria - err_2b = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) call wall_time(end_2b) diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 index 85e8cb0..cea9c9e 100644 --- a/src/Parquet/R_eh_singlet_Gam.f90 +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -3,7 +3,6 @@ subroutine R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam) - ! Compute irreducible vertex in the triplet pp channel implicit none @@ -40,8 +39,10 @@ subroutine R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + + 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) end do do n=1,nVVs @@ -118,8 +119,10 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - + eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) + + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) end do do n=1,nVVs @@ -196,8 +199,10 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - + eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) end do do n=1,nVVs diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 index 13b29d5..b95b61c 100644 --- a/src/Parquet/R_eh_triplet_Gam.f90 +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -40,28 +40,30 @@ subroutine R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - - eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + + 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) end do do n=1,nVVs eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - - 0d0*ee_sing_rho(p,q,n) * ee_sing_rho(r,s,n)/ee_sing_Om(n) + - ee_sing_rho(p,q,n) * ee_sing_rho(r,s,n)/ee_sing_Om(n) end do do n=1,nOOs eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - + 0d0*hh_sing_rho(p,q,n) * hh_sing_rho(r,s,n)/hh_sing_Om(n) + + hh_sing_rho(p,q,n) * hh_sing_rho(r,s,n)/hh_sing_Om(n) end do do n=1,nVVt eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - + 0d0*ee_trip_rho(p,q,n) * ee_trip_rho(r,s,n)/ee_trip_Om(n) + + ee_trip_rho(p,q,n) * ee_trip_rho(r,s,n)/ee_trip_Om(n) end do do n=1,nOOt eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - - 0d0*hh_trip_rho(p,q,n) * hh_trip_rho(r,s,n)/hh_trip_Om(n) + - hh_trip_rho(p,q,n) * hh_trip_rho(r,s,n)/hh_trip_Om(n) end do enddo @@ -118,8 +120,10 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - + eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - - eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) + + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) end do do n=1,nVVs @@ -196,8 +200,10 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do n=1,nS eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - + eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - - eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) end do do n=1,nVVs diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index 83e4826..efe2e5e 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -33,10 +33,14 @@ subroutine R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh do n=1,nS pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s) & - - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - - eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(p,r,n)*eh_sing_rho(s,q,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(p,r,n)*eh_trip_rho(s,q,n)/eh_trip_Om(n) & + - 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) end do pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s)/sqrt((1d0 + Kronecker_delta(p,q))*(1d0 + Kronecker_delta(r,s))) @@ -91,10 +95,14 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,eh_sing_Om,eh_sing_rho, do n=1,nS pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl) & - - eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - - eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & + - 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) end do pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) @@ -149,10 +157,14 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,eh_sing_Om,eh_sing_rho, do n=1,nS pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd) & - - eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - - eh_sing_rho(c,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & + - 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) end do pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) @@ -207,10 +219,14 @@ subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,eh_sing_Om,eh_sing do n=1,nS pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij) & - - eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - - eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 3d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & + - 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) end do pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) diff --git a/src/Parquet/R_pp_triplet_Gam.f90 b/src/Parquet/R_pp_triplet_Gam.f90 index 9e12c3c..ae3f55e 100644 --- a/src/Parquet/R_pp_triplet_Gam.f90 +++ b/src/Parquet/R_pp_triplet_Gam.f90 @@ -32,11 +32,16 @@ subroutine R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh do p = nC+1, nOrb-nR do n=1,nS + pp_trip_Gam(p,q,r,s) = pp_trip_Gam(p,q,r,s) & - - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - - eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(p,r,n)*eh_sing_rho(s,q,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(p,r,n)*eh_trip_rho(s,q,n)/eh_trip_Om(n) & + + 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & + + 0.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & + + 0.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) end do end do @@ -88,11 +93,16 @@ subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,eh_sing_Om,eh_sing_rho, kl = kl +1 do n=1,nS + pp_trip_Gam_D(ij,kl) = pp_trip_Gam_D(ij,kl) & - - eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - - eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - + eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - + eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & + + 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & + + 0.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & + + 0.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) end do end do @@ -144,11 +154,16 @@ subroutine R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,eh_sing_Om,eh_sing_rho, cd = cd +1 do n=1,nS + pp_trip_Gam_C(ab,cd) = pp_trip_Gam_C(ab,cd) & - - eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - - eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - + eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - + eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & + + 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & + + 0.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & + + 0.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) end do end do @@ -200,11 +215,16 @@ subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,eh_sing_Om,eh_sing ij = ij +1 do n=1,nS + pp_trip_Gam_B(ab,ij) = pp_trip_Gam_B(ab,ij) & - - eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - - eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - + eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) + - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & + - 0.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + - 0.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & + + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + + 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + + 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) end do end do diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index de2e8f7..399621d 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -1,4 +1,4 @@ -subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,rho) +subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,XmY,rho) ! Compute excitation densities implicit none @@ -7,10 +7,11 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,r integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_sing_Gam(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: XpY(nS,nS) + double precision,intent(in) :: XpY(nS,nS),XmY(nS,nS) ! Local variables integer :: ia,jb,p,q,j,b + double precision :: X,Y ! Output variables double precision,intent(out) :: rho(nOrb,nOrb,nS) @@ -28,9 +29,14 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,r do b=nO+1,nOrb-nR jb = jb + 1 do ia=1,nS - rho(p,q,ia) = rho(p,q,ia) & - + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & - + 1d0*eh_sing_Gam(p,j,q,b)*XpY(ia,jb) + + X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + + rho(p,q,ia) = rho(p,q,ia) & + + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & + + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & + + 0d0*eh_sing_Gam(p,j,q,b)*XpY(ia,jb) end do end do @@ -42,7 +48,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,r end subroutine R_eh_singlet_screened_integral -subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,rho) +subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,XmY,rho) ! Compute excitation densities implicit none @@ -51,11 +57,12 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,r integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Gam(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: XpY(nS,nS) + double precision,intent(in) :: XpY(nS,nS),XmY(nS,nS) ! Local variables integer :: ia,jb,p,q,j,b - + double precision :: X,Y + ! Output variables double precision,intent(out) :: rho(nOrb,nOrb,nS) @@ -72,9 +79,14 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,r do b=nO+1,nOrb-nR jb = jb + 1 do ia=1,nS - rho(p,q,ia) = rho(p,q,ia) & - - ERI(p,j,b,q)*XpY(ia,jb) & - + 1d0*eh_trip_Gam(p,j,q,b)*XpY(ia,jb) + + X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + + rho(p,q,ia) = rho(p,q,ia) & + - ERI(p,j,b,q)*X & + - ERI(p,b,j,q)*Y & + + 0d0*eh_trip_Gam(p,j,q,b)*XpY(ia,jb) end do end do end do diff --git a/src/Parquet/amarie@HP-EliteBook-830.23187:1742801908 b/src/Parquet/amarie@HP-EliteBook-830.23187:1742801908 new file mode 100644 index 0000000..e69de29 diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index 7dcc441..c166b9d 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -346,7 +346,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) call GParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & - nBas,nC,nO,nV,nR,nS, & + nBas2,nC,nO,nV,nR,nS, & eHF,ERI_MO) call wall_time(end_Parquet) From 86c42b7001a5ef4f159e3a156218921e3af333b0 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 24 Mar 2025 23:24:59 +0100 Subject: [PATCH 16/71] ok with spin adaptation --- src/Parquet/GParquet.f90 | 6 ++--- src/Parquet/G_eh_Gam.f90 | 36 ++++++++++------------------ src/Parquet/G_screened_integrals.f90 | 5 ++-- src/Parquet/R_pp_singlet_Gam.f90 | 2 +- src/Parquet/R_screened_integrals.f90 | 6 +++-- 5 files changed, 24 insertions(+), 31 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 4694444..2e411ff 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -153,9 +153,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing eh effective interaction...' call wall_time(start_t) - !call R_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - ! old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & - ! eh_Gam) + call G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & + eh_Gam) call wall_time(end_t) t = end_t - start_t diff --git a/src/Parquet/G_eh_Gam.f90 b/src/Parquet/G_eh_Gam.f90 index b1f1df0..508ae92 100644 --- a/src/Parquet/G_eh_Gam.f90 +++ b/src/Parquet/G_eh_Gam.f90 @@ -30,31 +30,21 @@ subroutine G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR - ! do n=1,nS - ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - ! + eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - ! + 3d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) - ! end do + do n=1,nS + eh_Gam(p,q,r,s) = eh_Gam(p,q,r,s) & + + eh_rho(s,p,n)*eh_rho(q,r,n)/eh_Om(n) & + + eh_rho(p,s,n)*eh_rho(r,q,n)/eh_Om(n) + end do - ! do n=1,nVVs - ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - ! + ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) - ! end do + do n=1,nVV + eh_Gam(p,q,r,s) = eh_Gam(p,q,r,s) & + + 2d0 * ee_rho(p,q,n)*ee_rho(r,s,n)/ee_Om(n) + end do - ! do n=1,nOOs - ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - ! - hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) - ! end do - - ! do n=1,nVVt - ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - ! + 3d0 * ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) - ! end do - - ! do n=1,nOOt - ! eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - ! - 3d0 * hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) - ! end do + do n=1,nOO + eh_Gam(p,q,r,s) = eh_Gam(p,q,r,s) & + - 2d0 * hh_rho(p,q,n)*hh_rho(r,s,n)/hh_Om(n) + end do enddo enddo diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 4386ed6..9b3d510 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -39,7 +39,9 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,rho) !+ (ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & + (ERI(p,j,q,b) - ERI(p,j,b,q))*X & + (ERI(p,b,q,j) - ERI(p,b,j,q))*Y & - + 0d0*eh_Gam(p,j,q,b)*XpY(ia,jb) + + 1d0*eh_Gam(p,j,q,b)*X & + + 1d0*eh_Gam(p,b,q,j)*Y + end do end do @@ -59,7 +61,6 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1 ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: pp_Gam(nOrb,nOrb,nOrb,nOrb) diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index efe2e5e..afbd50a 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -43,7 +43,7 @@ subroutine R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh + 1.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) end do - pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s)/sqrt((1d0 + Kronecker_delta(p,q))*(1d0 + Kronecker_delta(r,s))) + ! pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s)/sqrt((1d0 + Kronecker_delta(p,q))*(1d0 + Kronecker_delta(r,s))) end do end do diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 399621d..8dc516d 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -36,7 +36,8 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,X rho(p,q,ia) = rho(p,q,ia) & + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & - + 0d0*eh_sing_Gam(p,j,q,b)*XpY(ia,jb) + + 1d0*eh_sing_Gam(p,j,q,b)*X & + + 1d0*eh_sing_Gam(p,b,q,j)*Y end do end do @@ -86,7 +87,8 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,X rho(p,q,ia) = rho(p,q,ia) & - ERI(p,j,b,q)*X & - ERI(p,b,j,q)*Y & - + 0d0*eh_trip_Gam(p,j,q,b)*XpY(ia,jb) + + 1d0*eh_trip_Gam(p,j,q,b)*X & + + 1d0*eh_trip_Gam(p,b,q,j)*Y end do end do end do From 1e0ed28f67a118131955143dfca2612251ef0495 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Tue, 25 Mar 2025 10:31:17 +0100 Subject: [PATCH 17/71] DIIS in parquet - working on it --- src/GW/GG0W0.f90 | 6 ++- src/GW/GGW.f90 | 8 +++- src/GW/RG0W0.f90 | 4 +- src/GW/RGW.f90 | 3 +- src/Parquet/GParquet.f90 | 98 ++++++++++++++++++++++++++++++++-------- src/QuAcK/GQuAcK.f90 | 10 ++-- 6 files changed, 103 insertions(+), 26 deletions(-) diff --git a/src/GW/GG0W0.f90 b/src/GW/GG0W0.f90 index 780ec2e..a58989c 100644 --- a/src/GW/GG0W0.f90 +++ b/src/GW/GG0W0.f90 @@ -1,5 +1,5 @@ subroutine GG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & - linearize,eta,doSRG,nBas,nC,nO,nV,nR,nS,ENuc,EGHF,ERI,dipole_int,eHF) + linearize,eta,doSRG,nBas,nC,nO,nV,nR,nS,ENuc,EGHF,ERI,dipole_int,eHF,eGW_out) ! Perform G0W0 calculation implicit none @@ -58,6 +58,8 @@ subroutine GG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA ! Output variables + double precision,intent(out) :: eGW_out(nBas) + ! Hello world write(*,*) @@ -157,6 +159,8 @@ subroutine GG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA call print_GG0W0(nBas,nO,eHF,ENuc,EGHF,SigC,Z,eGW,EcRPA,EcGM) + eGW_out(:) = eGW(:) + ! Deallocate memory deallocate(SigC,Z,Om,XpY,XmY,rho) diff --git a/src/GW/GGW.f90 b/src/GW/GGW.f90 index adacd18..b4ab3a2 100644 --- a/src/GW/GGW.f90 +++ b/src/GW/GGW.f90 @@ -1,6 +1,6 @@ subroutine GGW(dotest,doG0W0,doevGW,doqsGW,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE, & TDA_W,TDA,dBSE,dTDA,linearize,eta,doSRG,nNuc,ZNuc,rNuc,ENuc,nBas,nBas2,nC,nO,nV,nR,nS,EGHF,S,X,T,V,Hc, & - ERI_AO,ERI,dipole_int_AO,dipole_int,PHF,cHF,eHF) + ERI_AO,ERI,dipole_int_AO,dipole_int,PHF,cHF,eHF,eGW) ! GW module @@ -63,6 +63,10 @@ subroutine GGW(dotest,doG0W0,doevGW,doqsGW,maxSCF,thresh,max_diis,doACFDT,exchan double precision :: start_GW ,end_GW ,t_GW +! Output variables + + double precision,intent(out) :: eGW(nBas2) + !------------------------------------------------------------------------ ! Perform G0W0 calculatiom !------------------------------------------------------------------------ @@ -71,7 +75,7 @@ subroutine GGW(dotest,doG0W0,doevGW,doqsGW,maxSCF,thresh,max_diis,doACFDT,exchan call wall_time(start_GW) call GG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & - linearize,eta,doSRG,nBas2,nC,nO,nV,nR,nS,ENuc,EGHF,ERI,dipole_int,eHF) + linearize,eta,doSRG,nBas2,nC,nO,nV,nR,nS,ENuc,EGHF,ERI,dipole_int,eHF,eGW) call wall_time(end_GW) t_GW = end_GW - start_GW diff --git a/src/GW/RG0W0.f90 b/src/GW/RG0W0.f90 index 1be8512..813322a 100644 --- a/src/GW/RG0W0.f90 +++ b/src/GW/RG0W0.f90 @@ -61,8 +61,10 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA double precision,allocatable :: eGWlin(:) double precision,allocatable :: eGW(:) - double precision,intent(inout):: eGW_out(nOrb) +! Output variables + + double precision,intent(out) :: eGW_out(nOrb) ! Output variables diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index 23eadc6..0c683d6 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -70,8 +70,9 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii logical :: doccG0W0,doccGW +! Output variables - double precision,intent(inout) :: eGW(nOrb) + double precision,intent(out) :: eGW(nOrb) !------------------------------------------------------------------------ ! Perform G0W0 calculation diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 2e411ff..c02269e 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -52,15 +52,38 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) double precision :: EcGM - + + integer :: max_diis,n_diis + double precision :: rcond + double precision,allocatable :: err_diis(:,:) + double precision,allocatable :: Om_diis(:,:) + double precision,allocatable :: err(:) + double precision,allocatable :: Om(:) + ! Output variables ! None +! Useful parameters + nOO = nO*(nO - 1)/2 nVV = nV*(nV - 1)/2 allocate(eQP(nOrb),eOld(nOrb)) +! DIIS parameters + + max_diis = 10 + n_diis = 0 + rcond = 0d0 + + allocate(err_diis(nS+nOO+nVV,max_diis),Om_diis(nS+nOO+nVV,max_diis)) + allocate(err(nS+nOO+nVV),Om(nS+nOO+nVV)) + + err_diis(:,:) = 0d0 + Om_diis(:,:) = 0d0 + +! Start + write(*,*) write(*,*)'***********************************' write(*,*)'* Generalized Parquet Calculation *' @@ -108,9 +131,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ee_rho(:,:,:) = 0d0 hh_rho(:,:,:) = 0d0 - old_eh_Om(:) = 1d0 - old_ee_Om(:) = 1d0 - old_hh_Om(:) = 1d0 + old_eh_Om(:) = 0d0 + old_ee_Om(:) = 0d0 + old_hh_Om(:) = 0d0 !-----------------------------------------! ! Main loop for one-body self-consistency ! @@ -152,26 +175,42 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Build eh effective interaction write(*,*) 'Computing eh effective interaction...' - call wall_time(start_t) - call G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & - eh_Gam) - call wall_time(end_t) - t = end_t - start_t + if(n_it_2b == 1) then + + eh_Gam(:,:,:,:) = 0d0 - write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh Gamma =',t,' seconds' - write(*,*) + else + + call wall_time(start_t) + call G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & + old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & + eh_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh Gamma =',t,' seconds' + write(*,*) + + end if ! Build singlet pp effective interaction write(*,*) 'Computing pp effective interaction...' - call wall_time(start_t) - call G_pp_Gamma(nOrb,nC,nO,nV,nR,nS,old_eh_Om,eh_rho,pp_Gam) - call wall_time(end_t) - t = end_t - start_t + if(n_it_2b == 1) then - write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp Gamma =',t,' seconds' - write(*,*) + pp_Gam(:,:,:,:) = 0d0 + + else + + call wall_time(start_t) + call G_pp_Gamma(nOrb,nC,nO,nV,nR,nS,old_eh_Om,eh_rho,pp_Gam) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp Gamma =',t,' seconds' + write(*,*) + + end if !-----------------! ! eh channel ! @@ -292,6 +331,29 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) '----------------------------------------' write(*,*) + !--------------------! + ! DIIS extrapolation ! + !--------------------! + + err( 1:nS ) = eh_Om(:) - old_eh_Om(:) + err( nS+1:nS+nVV ) = ee_Om(:) - old_ee_Om(:) + err(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - old_hh_Om(:) + + Om( 1:nS ) = eh_Om(:) + Om( nS+1:nS+nVV ) = ee_Om(:) + Om(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) + + if(max_diis > 1) then + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(rcond,nS+nOO+nVV,nS+nOO+nVV,n_diis,err_diis,Om_diis,err,Om) + + end if + + eh_Om(:) = Om( 1:nS ) + ee_Om(:) = Om( nS+1:nS+nVV ) + hh_Om(:) = Om(nVV+nS+1:nS+nVV+nOO) + !----------! ! Updating ! !----------! diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index c166b9d..b6d7534 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -106,6 +106,8 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop integer :: nBas2 integer :: nS + double precision,allocatable :: eGW(:) + write(*,*) write(*,*) '*******************************' write(*,*) '* Generalized Branch of QuAcK *' @@ -121,6 +123,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop allocate(cHF(nBas2,nBas2),eHF(nBas2),PHF(nBas2,nBas2),FHF(nBas2,nBas2), & dipole_int_MO(nBas2,nBas2,ncart),ERI_MO(nBas2,nBas2,nBas2,nBas2)) + allocate(eGW(nBas2)) allocate(ERI_AO(nBas,nBas,nBas,nBas)) call wall_time(start_int) @@ -307,9 +310,10 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doGW) then call wall_time(start_GW) - call GGW(dotest,doG0W0,doevGW,doqsGW,maxSCF_GW,thresh_GW,max_diis_GW,doACFDT,exchange_kernel,doXBS, & - dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc, & - nBas,nBas2,nC,nO,nV,nR,nS,EGHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + call GGW(dotest,doG0W0,doevGW,doqsGW,maxSCF_GW,thresh_GW,max_diis_GW,doACFDT,exchange_kernel,doXBS, & + dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc, & + nBas,nBas2,nC,nO,nV,nR,nS,EGHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF, & + eGW) call wall_time(end_GW) t_GW = end_GW - start_GW From e40af1b54ebfae4946f4dce926b45e8c427336e8 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Tue, 25 Mar 2025 14:54:23 +0100 Subject: [PATCH 18/71] fix read of dipole integrals --- src/GW/RGW.f90 | 2 +- src/LR/phLR_oscillator_strength.f90 | 2 +- src/LR/phLR_transition_vectors.f90 | 12 ++++++------ src/QuAcK/QuAcK.f90 | 2 ++ src/QuAcK/RQuAcK.f90 | 2 +- src/utils/read_dipole_integrals.f90 | 9 ++++++--- 6 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index 0c683d6..aa9098d 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -166,7 +166,7 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii ! Perform CC-based G0W0 calculation !------------------------------------------------------------------------ - doccG0W0 = .true. + doccG0W0 = .false. if(doccG0W0) then diff --git a/src/LR/phLR_oscillator_strength.f90 b/src/LR/phLR_oscillator_strength.f90 index 796a6a2..02ab718 100644 --- a/src/LR/phLR_oscillator_strength.f90 +++ b/src/LR/phLR_oscillator_strength.f90 @@ -1,6 +1,6 @@ subroutine phLR_oscillator_strength(nOrb,nC,nO,nV,nR,nS,maxS,dipole_int,Om,XpY,XmY,os) -! Compute linear response +! Compute oscillator strength from a ph linear response calculation implicit none include 'parameters.h' diff --git a/src/LR/phLR_transition_vectors.f90 b/src/LR/phLR_transition_vectors.f90 index ac65d39..f416d0e 100644 --- a/src/LR/phLR_transition_vectors.f90 +++ b/src/LR/phLR_transition_vectors.f90 @@ -1,4 +1,4 @@ -subroutine phLR_transition_vectors(spin_allowed,nBas,nC,nO,nV,nR,nS,dipole_int,Om,XpY,XmY) +subroutine phLR_transition_vectors(spin_allowed,nOrb,nC,nO,nV,nR,nS,dipole_int,Om,XpY,XmY) ! Print transition vectors for linear response calculation @@ -8,13 +8,13 @@ subroutine phLR_transition_vectors(spin_allowed,nBas,nC,nO,nV,nR,nS,dipole_int,O ! Input variables logical,intent(in) :: spin_allowed - integer,intent(in) :: nBas + 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 :: dipole_int(nBas,nBas,ncart) + double precision :: dipole_int(nOrb,nOrb,ncart) double precision,intent(in) :: Om(nS) double precision,intent(in) :: XpY(nS,nS) double precision,intent(in) :: XmY(nS,nS) @@ -37,7 +37,7 @@ subroutine phLR_transition_vectors(spin_allowed,nBas,nC,nO,nV,nR,nS,dipole_int,O ! Compute oscillator strengths os(:) = 0d0 - if(spin_allowed) call phLR_oscillator_strength(nBas,nC,nO,nV,nR,nS,maxS,dipole_int,Om,XpY,XmY,os) + if(spin_allowed) call phLR_oscillator_strength(nOrb,nC,nO,nV,nR,nS,maxS,dipole_int,Om,XpY,XmY,os) ! Print details about excitations @@ -61,7 +61,7 @@ subroutine phLR_transition_vectors(spin_allowed,nBas,nC,nO,nV,nR,nS,dipole_int,O jb = 0 do j=nC+1,nO - do b=nO+1,nBas-nR + do b=nO+1,nOrb-nR jb = jb + 1 if(abs(X(jb)) > thres_vec) write(*,'(I3,A4,I3,A3,F10.6)') j,' -> ',b,' = ',X(jb)/sqrt(2d0) end do @@ -69,7 +69,7 @@ subroutine phLR_transition_vectors(spin_allowed,nBas,nC,nO,nV,nR,nS,dipole_int,O jb = 0 do j=nC+1,nO - do b=nO+1,nBas-nR + do b=nO+1,nOrb-nR jb = jb + 1 if(abs(Y(jb)) > thres_vec) write(*,'(I3,A4,I3,A3,F10.6)') j,' <- ',b,' = ',Y(jb)/sqrt(2d0) end do diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index 03abb0d..a9e39cc 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -198,6 +198,8 @@ program QuAcK call read_dipole_integrals(working_dir,nBas,dipole_int_AO) call wall_time(end_int) + call matout(nBas,nBas,dipole_int_AO(:,:,1)) + t_int = end_int - start_int write(*,*) write(*,'(A65,1X,F9.3,A8)') 'Total wall time for reading 1e-integrals = ',t_int,' seconds' diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 2bf23f7..bbbdd98 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -183,7 +183,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, write(*,*) ! Read and transform dipole-related integrals - + do ixyz=1,ncart call AOtoMO(nBas,nOrb,cHF,dipole_int_AO(1,1,ixyz),dipole_int_MO(1,1,ixyz)) end do diff --git a/src/utils/read_dipole_integrals.f90 b/src/utils/read_dipole_integrals.f90 index e3ea558..ec80a1b 100644 --- a/src/utils/read_dipole_integrals.f90 +++ b/src/utils/read_dipole_integrals.f90 @@ -39,7 +39,8 @@ subroutine read_dipole_integrals(working_dir,nBas,R) else do - read(21, '(I7, I7, E25.17)', iostat=ios) mu, nu, Dip + read(21, *, iostat=ios) mu, nu, Dip +! read(21, '(I7, I7, E25.17)', iostat=ios) mu, nu, Dip if(ios /= 0) exit R(mu,nu,1) = Dip R(nu,mu,1) = Dip @@ -62,7 +63,8 @@ subroutine read_dipole_integrals(working_dir,nBas,R) else do - read(22, '(I7, I7, E25.17)', iostat=ios) mu, nu, Dip + read(22, *, iostat=ios) mu, nu, Dip +! read(22, '(I7, I7, E25.17)', iostat=ios) mu, nu, Dip if(ios /= 0) exit R(mu,nu,2) = Dip R(nu,mu,2) = Dip @@ -85,7 +87,8 @@ subroutine read_dipole_integrals(working_dir,nBas,R) else do - read(23, '(I7, I7, E25.17)', iostat=ios) mu, nu, Dip + read(23, *, iostat=ios) mu, nu, Dip +! read(23, '(I7, I7, E25.17)', iostat=ios) mu, nu, Dip if(ios /= 0) exit R(mu,nu,3) = Dip R(nu,mu,3) = Dip From 9d8b33dbea501e99c49167dc0de07b072cece0d4 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Tue, 25 Mar 2025 17:20:02 +0100 Subject: [PATCH 19/71] refactor in progress --- src/Parquet/GParquet.f90 | 222 +++++++++++----------- src/Parquet/G_eh_Gam.f90 | 121 ++---------- src/Parquet/G_pp_Gam.f90 | 103 ++-------- src/Parquet/G_screened_integrals.f90 | 38 ++-- src/Parquet/RParquet.f90 | 271 +++++++++++++++------------ src/Parquet/R_eh_singlet_Gam.f90 | 214 ++++++--------------- src/Parquet/R_eh_triplet_Gam.f90 | 213 ++++++--------------- src/Parquet/R_pp_singlet_Gam.f90 | 161 +++++----------- src/Parquet/R_pp_triplet_Gam.f90 | 145 +++++--------- src/Parquet/R_screened_integrals.f90 | 254 +++++++++++++------------ 10 files changed, 649 insertions(+), 1093 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index c02269e..85153b4 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -9,8 +9,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, logical :: linearize = .true. logical :: TDA = .true. - logical :: print_phLR = .true. - logical :: print_ppLR = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. ! Input variables @@ -24,47 +24,50 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: n_it_1b,n_it_2b double precision :: err_1b,err_2b - double precision :: err_eh, err_hh, err_ee + double precision :: err_eh, err_pp + double precision :: err_eig_eh, err_eig_hh, err_eig_ee double precision :: start_t, end_t, t double precision :: start_1b, end_1b, t_1b double precision :: start_2b, end_2b, t_2b integer :: nOO,nVV + ! eh BSE double precision :: EcRPA double precision,allocatable :: Aph(:,:), Bph(:,:) - double precision,allocatable :: XpY(:,:),XmY(:,:) + double precision,allocatable :: XpY(:,:), XmY(:,:) double precision,allocatable :: eh_Om(:), old_eh_Om(:) - + double precision,allocatable :: eh_Gam_A(:,:),eh_Gam_B(:,:) + ! pp BSE double precision,allocatable :: Bpp(:,:), Cpp(:,:), Dpp(:,:) double precision,allocatable :: X1(:,:),Y1(:,:) double precision,allocatable :: ee_Om(:), old_ee_Om(:) double precision,allocatable :: X2(:,:),Y2(:,:) double precision,allocatable :: hh_Om(:), old_hh_Om(:) - - double precision,allocatable :: eh_rho(:,:,:), ee_rho(:,:,:), hh_rho(:,:,:) - - double precision,allocatable :: eh_Gam_A(:,:),eh_Gam_B(:,:) double precision,allocatable :: pp_Gam_B(:,:),pp_Gam_C(:,:),pp_Gam_D(:,:) - double precision,allocatable :: eh_Gam(:,:,:,:),pp_Gam(:,:,:,:) - + ! Effective integrals + double precision,allocatable :: eh_rho(:,:,:), ee_rho(:,:,:), hh_rho(:,:,:) + ! Reducible kernels + double precision,allocatable :: eh_Phi(:,:,:,:), pp_Phi(:,:,:,:) + double precision,allocatable :: old_eh_Phi(:,:,:,:), old_pp_Phi(:,:,:,:) + ! One-body quantities double precision,allocatable :: eQPlin(:),eQP(:),eOld(:) double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) double precision :: EcGM - + ! DIIS integer :: max_diis,n_diis double precision :: rcond double precision,allocatable :: err_diis(:,:) double precision,allocatable :: Om_diis(:,:) double precision,allocatable :: err(:) double precision,allocatable :: Om(:) + double precision :: alpha ! Output variables ! None ! Useful parameters - nOO = nO*(nO - 1)/2 nVV = nV*(nV - 1)/2 @@ -72,15 +75,15 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! DIIS parameters - max_diis = 10 - n_diis = 0 - rcond = 0d0 + ! max_diis = 10 + ! n_diis = 0 + ! rcond = 0d0 - allocate(err_diis(nS+nOO+nVV,max_diis),Om_diis(nS+nOO+nVV,max_diis)) - allocate(err(nS+nOO+nVV),Om(nS+nOO+nVV)) + ! allocate(err_diis(nS+nOO+nVV,max_diis),Om_diis(nS+nOO+nVV,max_diis)) + ! allocate(err(nS+nOO+nVV),Om(nS+nOO+nVV)) - err_diis(:,:) = 0d0 - Om_diis(:,:) = 0d0 + ! err_diis(:,:) = 0d0 + ! Om_diis(:,:) = 0d0 ! Start @@ -115,6 +118,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, allocate(old_eh_Om(nS),old_ee_Om(nVV),old_hh_Om(nOO)) allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + allocate(old_eh_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_Phi(nOrb,nOrb,nOrb,nOrb)) ! Initialization @@ -135,6 +139,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_ee_Om(:) = 0d0 old_hh_Om(:) = 0d0 + old_eh_Phi(:,:,:,:) = 0d0 + old_pp_Phi(:,:,:,:) = 0d0 + !-----------------------------------------! ! Main loop for one-body self-consistency ! !-----------------------------------------! @@ -164,54 +171,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*)' ***********************************' write(*,*) - !--------------------------------! - ! Compute effective interactions ! - !--------------------------------! - - ! Memory allocation - allocate(eh_Gam(nOrb,nOrb,nOrb,nOrb)) - allocate(pp_Gam(nOrb,nOrb,nOrb,nOrb)) - - ! Build eh effective interaction - write(*,*) 'Computing eh effective interaction...' - - if(n_it_2b == 1) then - - eh_Gam(:,:,:,:) = 0d0 - - else - - call wall_time(start_t) - call G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & - eh_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh Gamma =',t,' seconds' - write(*,*) - - end if - - ! Build singlet pp effective interaction - write(*,*) 'Computing pp effective interaction...' - - if(n_it_2b == 1) then - - pp_Gam(:,:,:,:) = 0d0 - - else - - call wall_time(start_t) - call G_pp_Gamma(nOrb,nC,nO,nV,nR,nS,old_eh_Om,eh_rho,pp_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp Gamma =',t,' seconds' - write(*,*) - - end if - !-----------------! ! eh channel ! !-----------------! @@ -239,18 +198,14 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - call G_eh_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & - eh_Gam_A) - - if(.not.TDA) call G_eh_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - old_eh_Om,eh_rho,old_ee_Om,ee_rho,old_hh_Om,hh_rho, & - eh_Gam_B) - + call G_eh_Gamma_A(nOrb,nC,nO,nR,nS,old_eh_Phi,old_pp_Phi,eh_Gam_A) + if(.not.TDA) call G_eh_Gamma_B(nOrb,nC,nO,nR,nS,old_eh_Phi,old_pp_Phi,eh_Gam_B) + end if - Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) - Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) + Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) + call phGLR(TDA,nS,Aph,Bph,EcRPA,eh_Om,XpY,XmY) @@ -262,7 +217,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, if(print_phLR) call print_excitation_energies('phBSE@Parquet','eh generalized',nS,eh_Om) - err_eh = maxval(abs(old_eh_Om - eh_Om)) + err_eig_eh = maxval(abs(old_eh_Om - eh_Om)) deallocate(Aph,Bph,eh_Gam_A,eh_Gam_B) @@ -297,9 +252,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - if(.not.TDA) call G_pp_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV,old_eh_Om,eh_rho,pp_Gam_B) - call G_pp_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVV,old_eh_Om,eh_rho,pp_Gam_C) - call G_pp_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOO,old_eh_Om,eh_rho,pp_Gam_D) + if(.not.TDA) call G_pp_Gamma_B(nOrb,nC,nO,nR,nOO,nVV,old_eh_Phi,pp_Gam_B) + call G_pp_Gamma_C(nOrb,nO,nR,nVV,old_eh_Phi,pp_Gam_C) + call G_pp_Gamma_D(nOrb,nC,nO,nOO,old_eh_Phi,pp_Gam_D) end if @@ -317,17 +272,17 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p generalized',nVV,ee_Om) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h generalized',nOO,hh_Om) - err_ee = maxval(abs(old_ee_Om - ee_Om)) - err_hh = maxval(abs(old_hh_Om - hh_Om)) + err_eig_ee = maxval(abs(old_ee_Om - ee_Om)) + err_eig_hh = maxval(abs(old_hh_Om - hh_Om)) deallocate(Bpp,Cpp,Dpp,pp_Gam_B,pp_Gam_C,pp_Gam_D) write(*,*) '----------------------------------------' - write(*,*) ' Two-body convergence ' + write(*,*) ' Two-body (eigenvalue) convergence ' write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for eh channel = ',err_eh - write(*,'(1X,A30,F10.6)')'Error for pp channel = ',max(err_ee,err_hh) + write(*,'(1X,A30,F10.6)')'Error for eh channel = ',err_eig_eh + write(*,'(1X,A30,F10.6)')'Error for pp channel = ',max(err_eig_ee,err_eig_hh) write(*,*) '----------------------------------------' write(*,*) @@ -335,24 +290,24 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! DIIS extrapolation ! !--------------------! - err( 1:nS ) = eh_Om(:) - old_eh_Om(:) - err( nS+1:nS+nVV ) = ee_Om(:) - old_ee_Om(:) - err(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - old_hh_Om(:) + ! err( 1:nS ) = eh_Om(:) - old_eh_Om(:) + ! err( nS+1:nS+nVV ) = ee_Om(:) - old_ee_Om(:) + ! err(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - old_hh_Om(:) - Om( 1:nS ) = eh_Om(:) - Om( nS+1:nS+nVV ) = ee_Om(:) - Om(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) + ! Om( 1:nS ) = eh_Om(:) + ! Om( nS+1:nS+nVV ) = ee_Om(:) + ! Om(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - if(max_diis > 1) then + ! if(max_diis > 1) then - n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nS+nOO+nVV,nS+nOO+nVV,n_diis,err_diis,Om_diis,err,Om) + ! n_diis = min(n_diis+1,max_diis) + ! call DIIS_extrapolation(rcond,nS+nOO+nVV,nS+nOO+nVV,n_diis,err_diis,Om_diis,err,Om) - end if + ! end if - eh_Om(:) = Om( 1:nS ) - ee_Om(:) = Om( nS+1:nS+nVV ) - hh_Om(:) = Om(nVV+nS+1:nS+nVV+nOO) + ! eh_Om(:) = Om( 1:nS ) + ! ee_Om(:) = Om( nS+1:nS+nVV ) + ! hh_Om(:) = Om(nVV+nS+1:nS+nVV+nOO) !----------! ! Updating ! @@ -379,35 +334,90 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing eh screened integrals...' call wall_time(start_t) - call G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,eh_rho) + call G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,old_eh_Phi,old_pp_Phi,XpY,XmY,eh_rho) call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for eh integrals =',t,' seconds' write(*,*) ! Done with eigenvectors and kernel - deallocate(XpY,XmY,eh_Gam) + deallocate(XpY,XmY) ! Build singlet pp integrals write(*,*) 'Computing pp screened integrals...' call wall_time(start_t) - call G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,ee_rho,X2,Y2,hh_rho) + call G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,old_eh_Phi,X1,Y1,ee_rho,X2,Y2,hh_rho) call wall_time(end_t) t = end_t - start_t ! Done with eigenvectors and kernel write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp integrals =',t,' seconds' write(*,*) - deallocate(X1,Y1,X2,Y2,pp_Gam) + deallocate(X1,Y1,X2,Y2) + !----------------------------! + ! Compute reducible kernels ! + !----------------------------! + + ! Memory allocation + allocate(eh_Phi(nOrb,nOrb,nOrb,nOrb)) + allocate(pp_Phi(nOrb,nOrb,nOrb,nOrb)) + + ! Build eh reducible kernels + write(*,*) 'Computing eh reducible kernel ...' + + call wall_time(start_t) + call G_eh_Phi(nOrb,nC,nR,nS,old_eh_Om,eh_rho,eh_Phi) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for eh reducible kernel =',t,' seconds' + write(*,*) + + ! Build pp reducible kernels + write(*,*) 'Computing pp reducible kernel ...' + + call wall_time(start_t) + call G_pp_Phi(nOrb,nC,nR,nOO,nVV,old_ee_Om,ee_rho,old_hh_Om,hh_rho,pp_Phi) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp reducible kernel =',t,' seconds' + write(*,*) + + ! alpha = 0.01d0 + ! eh_Phi(:,:,:,:) = alpha * eh_Phi(:,:,:,:) + (1d0 - alpha) * old_eh_Phi(:,:,:,:) + ! pp_Phi(:,:,:,:) = alpha * pp_Phi(:,:,:,:) + (1d0 - alpha) * old_pp_Phi(:,:,:,:) + + err_eh = maxval(abs(old_eh_Phi - eh_Phi)) + err_pp = maxval(abs(old_pp_Phi - pp_Phi)) + + old_eh_Phi(:,:,:,:) = eh_Phi(:,:,:,:) + old_pp_Phi(:,:,:,:) = pp_Phi(:,:,:,:) + + ! Free memory + deallocate(eh_Phi,pp_Phi) + + !--------------------! + ! DIIS extrapolation ! + !--------------------! + + + write(*,*) '----------------------------------------' + write(*,*) ' Two-body (kernel) convergence ' + write(*,*) '----------------------------------------' + write(*,'(1X,A30,F10.6)')'Error for eh channel = ',err_eh + write(*,'(1X,A30,F10.6)')'Error for pp channel = ',err_pp + write(*,*) '----------------------------------------' + write(*,*) + + ! Convergence criteria - err_2b = max(err_eh,err_ee,err_hh) + err_2b = max(err_eh,err_pp) call wall_time(end_2b) t_2b = end_2b - start_2b write(*,'(A50,1X,F9.3,A8)') 'Wall time for two-body iteration =',t_2b,' seconds' write(*,*) - + end do !---------------------------------------------! ! End main loop for two-body self-consistency ! diff --git a/src/Parquet/G_eh_Gam.f90 b/src/Parquet/G_eh_Gam.f90 index 508ae92..af8d235 100644 --- a/src/Parquet/G_eh_Gam.f90 +++ b/src/Parquet/G_eh_Gam.f90 @@ -1,79 +1,16 @@ -subroutine G_eh_Gamma(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - eh_Om,eh_rho,ee_Om,ee_rho,hh_Om,hh_rho, & - eh_Gam) +subroutine G_eh_Gamma_A(nOrb,nC,nO,nR,nS,eh_Phi,pp_Phi,eh_Gam_A) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_Om(nVV) - double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) - double precision,intent(in) :: hh_Om(nOO) - double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) - -! Local variables - integer :: p,q,r,s - integer :: n - double precision,external :: Kronecker_delta - -! Output variables - double precision, intent(out) :: eh_Gam(nOrb,nOrb,nOrb,nOrb) - -! Initialization - eh_Gam(:,:,:,:) = 0d0 - - do s = nC+1, nOrb-nR - do r = nC+1, nOrb-nR - do q = nC+1, nOrb-nR - do p = nC+1, nOrb-nR - - do n=1,nS - eh_Gam(p,q,r,s) = eh_Gam(p,q,r,s) & - + eh_rho(s,p,n)*eh_rho(q,r,n)/eh_Om(n) & - + eh_rho(p,s,n)*eh_rho(r,q,n)/eh_Om(n) - end do - - do n=1,nVV - eh_Gam(p,q,r,s) = eh_Gam(p,q,r,s) & - + 2d0 * ee_rho(p,q,n)*ee_rho(r,s,n)/ee_Om(n) - end do - - do n=1,nOO - eh_Gam(p,q,r,s) = eh_Gam(p,q,r,s) & - - 2d0 * hh_rho(p,q,n)*hh_rho(r,s,n)/hh_Om(n) - end do - - enddo - enddo - enddo - enddo - -end subroutine G_eh_Gamma - -subroutine G_eh_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - eh_Om,eh_rho,ee_Om,ee_rho,hh_Om,hh_rho, & - eh_Gam_A) - -! Compute irreducible vertex in the triplet pp channel - implicit none - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_Om(nVV) - double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) - double precision,intent(in) :: hh_Om(nOO) - double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,a,j,b integer :: ia,jb - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: eh_Gam_A(nS,nS) @@ -91,21 +28,7 @@ subroutine G_eh_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & do b=nO+1,norb-nR jb = jb + 1 - do n=1,nS - eh_Gam_A(ia,jb) = eh_Gam_A(ia,jb) & - + eh_rho(b,a,n)*eh_rho(j,i,n)/eh_Om(n) & - + eh_rho(a,b,n)*eh_rho(i,j,n)/eh_Om(n) - end do - - do n=1,nVV - eh_Gam_A(ia,jb) = eh_Gam_A(ia,jb) & - + 2d0 * ee_rho(a,j,n)*ee_rho(i,b,n)/ee_Om(n) - end do - - do n=1,nOO - eh_Gam_A(ia,jb) = eh_Gam_A(ia,jb) & - - 2d0 * hh_rho(a,j,n)*hh_rho(i,b,n)/hh_Om(n) - end do + eh_Gam_A(ia,jb) = - eh_Phi(a,j,b,i) + pp_Phi(a,j,i,b) enddo enddo @@ -114,27 +37,19 @@ subroutine G_eh_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & end subroutine G_eh_Gamma_A -subroutine G_eh_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & - eh_Om,eh_rho,ee_Om,ee_rho,hh_Om,hh_rho, & - eh_Gam_B) +subroutine G_eh_Gamma_B(nOrb,nC,nO,nR,nS,eh_Phi,pp_Phi,eh_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_Om(nVV) - double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) - double precision,intent(in) :: hh_Om(nOO) - double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) - + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_Phi(nOrb,nOrb,nOrb,nOrb) + ! Local variables integer :: i,a,j,b integer :: ia,jb - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: eh_Gam_B(nS,nS) @@ -152,21 +67,7 @@ subroutine G_eh_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV, & do b=nO+1,norb-nR jb = jb + 1 - do n=1,nS - eh_Gam_B(ia,jb) = eh_Gam_B(ia,jb) & - + eh_rho(j,a,n)*eh_rho(b,i,n)/eh_Om(n) & - + eh_rho(a,j,n)*eh_rho(i,b,n)/eh_Om(n) - end do - - do n=1,nVV - eh_Gam_B(ia,jb) = eh_Gam_B(ia,jb) & - + 2d0 * ee_rho(a,b,n)*ee_rho(i,j,n)/ee_Om(n) - end do - - do n=1,nOO - eh_Gam_B(ia,jb) = eh_Gam_B(ia,jb) & - - 2d0 * hh_rho(a,b,n)*hh_rho(i,j,n)/hh_Om(n) - end do + eh_Gam_B(ia,jb) = - eh_Phi(a,b,j,i) + pp_Phi(a,b,i,j) enddo enddo diff --git a/src/Parquet/G_pp_Gam.f90 b/src/Parquet/G_pp_Gam.f90 index 5c81d59..3b55e4a 100644 --- a/src/Parquet/G_pp_Gam.f90 +++ b/src/Parquet/G_pp_Gam.f90 @@ -1,66 +1,15 @@ -subroutine G_pp_Gamma(nOrb,nC,nO,nV,nR,nS,eh_Om,eh_rho,pp_Gam) +subroutine G_pp_Gamma_D(nOrb,nC,nO,nOO,eh_Phi,pp_Gam_D) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) - -! Local variables - integer :: p,q,r,s - integer :: n - double precision,external :: Kronecker_delta - -! Output variables - double precision, intent(out) :: pp_Gam(nOrb,nOrb,nOrb,nOrb) - -! Initialization - pp_Gam(:,:,:,:) = 0d0 - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(a, b, ab, i, j, ij, n) & -! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_B, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) -! !$OMP DO COLLAPSE(2) - - do s = nC+1, nOrb-nR - do r = nC+1, nOrb-nR - do q = nC+1, nOrb-nR - do p = nC+1, nOrb-nR - - do n=1,nS - pp_Gam(p,q,r,s) = pp_Gam(p,q,r,s) & - - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & - - eh_rho(p,r,n)*eh_rho(s,q,n)/eh_Om(n) & - + eh_rho(s,p,n)*eh_rho(q,r,n)/eh_Om(n) & - + eh_rho(p,s,n)*eh_rho(r,q,n)/eh_Om(n) - end do - - end do - end do - end do - end do -! !$OMP END DO -! !$OMP END PARALLEL - -end subroutine - -subroutine G_pp_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOO,eh_Om,eh_rho,pp_Gam_D) - -! Compute irreducible vertex in the triplet pp channel - implicit none - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nC,nO,nOO + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,j,k,l integer :: ij,kl - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_Gam_D(nOO,nOO) @@ -82,15 +31,9 @@ subroutine G_pp_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOO,eh_Om,eh_rho,pp_Gam_D) do k=nC+1,nO do l=k+1,nO kl = kl +1 - - do n=1,nS - pp_Gam_D(ij,kl) = pp_Gam_D(ij,kl) & - - eh_rho(k,i,n)*eh_rho(j,l,n)/eh_Om(n) & - - eh_rho(i,k,n)*eh_rho(l,j,n)/eh_Om(n) & - + eh_rho(l,i,n)*eh_rho(j,k,n)/eh_Om(n) & - + eh_rho(i,l,n)*eh_rho(k,j,n)/eh_Om(n) - end do - + + pp_Gam_D(ij,kl) = eh_Phi(i,j,k,l) - eh_Phi(i,j,l,k) + end do end do end do @@ -100,21 +43,18 @@ subroutine G_pp_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOO,eh_Om,eh_rho,pp_Gam_D) end subroutine -subroutine G_pp_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVV,eh_Om,eh_rho,pp_Gam_C) +subroutine G_pp_Gamma_C(nOrb,nO,nR,nVV,eh_Phi,pp_Gam_C) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nVV - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nO,nR,nVV + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,c,d integer :: ab,cd - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_Gam_C(nVV,nVV) @@ -137,15 +77,7 @@ subroutine G_pp_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVV,eh_Om,eh_rho,pp_Gam_C) do d=c+1,nOrb - nR cd = cd +1 - do n=1,nS - - pp_Gam_C(ab,cd) = pp_Gam_C(ab,cd) & - - eh_rho(c,a,n)*eh_rho(b,d,n)/eh_Om(n) & - - eh_rho(a,c,n)*eh_rho(d,b,n)/eh_Om(n) & - + eh_rho(d,a,n)*eh_rho(b,c,n)/eh_Om(n) & - + eh_rho(a,d,n)*eh_rho(c,b,n)/eh_Om(n) - - end do + pp_Gam_C(ab,cd) = eh_Phi(a,b,c,d) - eh_Phi(a,b,d,c) end do end do @@ -156,15 +88,14 @@ subroutine G_pp_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVV,eh_Om,eh_rho,pp_Gam_C) end subroutine -subroutine G_pp_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV,eh_Om,eh_rho,pp_Gam_B) +subroutine G_pp_Gamma_B(nOrb,nC,nO,nR,nOO,nVV,eh_Phi,pp_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOO,nVV - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nC,nO,nR,nOO,nVV + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,i,j @@ -193,13 +124,7 @@ subroutine G_pp_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOO,nVV,eh_Om,eh_rho,pp_Gam_B) do j=i+1,nO ij = ij + 1 - do n=1,nS - pp_Gam_B(ab,ij) = pp_Gam_B(ab,ij) & - - eh_rho(i,a,n)*eh_rho(b,j,n)/eh_Om(n) & - - eh_rho(a,i,n)*eh_rho(j,b,n)/eh_Om(n) & - + eh_rho(j,a,n)*eh_rho(b,i,n)/eh_Om(n) & - + eh_rho(a,j,n)*eh_rho(i,b,n)/eh_Om(n) - end do + pp_Gam_B(ab,ij) = eh_Phi(a,b,i,j) - eh_Phi(a,b,j,i) end do end do diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 9b3d510..9652306 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -1,4 +1,4 @@ -subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,rho) +subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho) ! Compute excitation densities implicit none @@ -6,7 +6,8 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,rho) ! Input variables integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: eh_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: XpY(nS,nS),XmY(nS,nS) ! Local variables @@ -35,13 +36,10 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,rho) X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = rho(p,q,ia) & - !+ (ERI(p,j,q,b) - ERI(p,j,b,q))*XpY(ia,jb) & - + (ERI(p,j,q,b) - ERI(p,j,b,q))*X & - + (ERI(p,b,q,j) - ERI(p,b,j,q))*Y & - + 1d0*eh_Gam(p,j,q,b)*X & - + 1d0*eh_Gam(p,b,q,j)*Y - + rho(p,q,ia) = (ERI(q,j,p,b) - ERI(q,j,b,p)) * X & + + (- eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & + + (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + + (- eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y end do end do @@ -53,7 +51,7 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Gam,XpY,XmY,rho) end subroutine G_eh_screened_integral -subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1,X2,Y2,rho2) +subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2,Y2,rho2) ! Compute excitation densities in the singlet pp channel @@ -61,9 +59,9 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1 ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR + integer,intent(in) :: nOrb,nC,nO,nR double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: pp_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) integer,intent(in) :: nOO integer,intent(in) :: nVV double precision,intent(in) :: X1(nVV,nVV) @@ -107,8 +105,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_Gam(p,q,c,d))*X1(cd,ab) + rho1(p,q,ab) = ( ERI(p,q,c,d) - ERI(p,q,d,c) ) * X1(cd,ab) & + + ( eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X1(cd,ab) end do end do @@ -116,8 +114,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1 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) + 1d0*pp_Gam(p,q,k,l))*Y1(kl,ab) + rho1(p,q,ab) = ( ERI(p,q,k,l) - ERI(p,q,l,k) ) * Y1(kl,ab) & + + ( eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do end do @@ -132,8 +130,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_Gam(p,q,c,d))*X2(cd,ij) + rho2(p,q,ij) = ( ERI(p,q,c,d) - ERI(p,q,d,c) ) * X2(cd,ij) & + + ( eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X2(cd,ij) end do end do @@ -141,8 +139,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_Gam,X1,Y1,rho1 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) + 1d0*pp_Gam(p,q,k,l))*Y2(kl,ij) + rho2(p,q,ij) = ( ERI(p,q,k,l) - ERI(p,q,l,k) ) * Y2(kl,ij) & + + ( eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do end do end do diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index af5bcd4..a8acfa8 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -26,23 +26,28 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: n_it_1b,n_it_2b double precision :: err_1b,err_2b - double precision :: err_eh_sing,err_eh_trip - double precision :: err_hh_sing,err_hh_trip - double precision :: err_ee_sing,err_ee_trip + double precision :: err_eig_eh_sing,err_eig_eh_trip + double precision :: err_eig_hh_sing,err_eig_hh_trip + double precision :: err_eig_ee_sing,err_eig_ee_trip + double precision :: err_eh_sing, err_eh_trip + double precision :: err_pp_sing, err_pp_trip double precision :: start_t, end_t, t double precision :: start_1b, end_1b, t_1b double precision :: start_2b, end_2b, t_2b integer :: nOOs,nOOt integer :: nVVs,nVVt - + + ! eh BSE double precision :: EcRPA double precision,allocatable :: Aph(:,:), Bph(:,:) double precision,allocatable :: sing_XpY(:,:),trip_XpY(:,:) double precision,allocatable :: sing_XmY(:,:),trip_XmY(:,:) double precision,allocatable :: eh_sing_Om(:), old_eh_sing_Om(:) double precision,allocatable :: eh_trip_Om(:), old_eh_trip_Om(:) - + double precision,allocatable :: eh_sing_Gam_A(:,:),eh_sing_Gam_B(:,:) + double precision,allocatable :: eh_trip_Gam_A(:,:),eh_trip_Gam_B(:,:) + ! pp BSE double precision,allocatable :: Bpp(:,:), Cpp(:,:), Dpp(:,:) double precision,allocatable :: X1s(:,:),X1t(:,:) double precision,allocatable :: Y1s(:,:),Y1t(:,:) @@ -52,18 +57,18 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, double precision,allocatable :: Y2s(:,:),Y2t(:,:) double precision,allocatable :: hh_sing_Om(:), old_hh_sing_Om(:) double precision,allocatable :: hh_trip_Om(:), old_hh_trip_Om(:) - + double precision,allocatable :: pp_sing_Gam_B(:,:),pp_sing_Gam_C(:,:),pp_sing_Gam_D(:,:) + double precision,allocatable :: pp_trip_Gam_B(:,:),pp_trip_Gam_C(:,:),pp_trip_Gam_D(:,:) + ! Effective integrals double precision,allocatable :: eh_sing_rho(:,:,:),eh_trip_rho(:,:,:) double precision,allocatable :: ee_sing_rho(:,:,:),hh_sing_rho(:,:,:) double precision,allocatable :: ee_trip_rho(:,:,:),hh_trip_rho(:,:,:) - - double precision,allocatable :: eh_sing_Gam_A(:,:),eh_sing_Gam_B(:,:) - double precision,allocatable :: eh_trip_Gam_A(:,:),eh_trip_Gam_B(:,:) - double precision,allocatable :: pp_sing_Gam_B(:,:),pp_sing_Gam_C(:,:),pp_sing_Gam_D(:,:) - double precision,allocatable :: pp_trip_Gam_B(:,:),pp_trip_Gam_C(:,:),pp_trip_Gam_D(:,:) - double precision,allocatable :: eh_sing_Gam(:,:,:,:),eh_trip_Gam(:,:,:,:) - double precision,allocatable :: pp_sing_Gam(:,:,:,:),pp_trip_Gam(:,:,:,:) - + ! Reducible kernels + double precision,allocatable :: eh_sing_Phi(:,:,:,:), eh_trip_Phi(:,:,:,:) + double precision,allocatable :: old_eh_sing_Phi(:,:,:,:), old_eh_trip_Phi(:,:,:,:) + double precision,allocatable :: pp_sing_Phi(:,:,:,:), pp_trip_Phi(:,:,:,:) + double precision,allocatable :: old_pp_sing_Phi(:,:,:,:), old_pp_trip_Phi(:,:,:,:) + ! One-body quantities double precision,allocatable :: eQPlin(:),eQP(:),eOld(:) double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) @@ -71,7 +76,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Output variables ! None - + +! Useful parameters nOOs = nO*(nO + 1)/2 nVVs = nV*(nV + 1)/2 nOOt = nO*(nO - 1)/2 @@ -114,6 +120,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, allocate(eh_sing_rho(nOrb,nOrb,nS),eh_trip_rho(nOrb,nOrb,nS)) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) + allocate(old_eh_sing_Phi(nOrb,nOrb,nOrb,nOrb),old_eh_trip_Phi(nOrb,nOrb,nOrb,nOrb)) + allocate(old_pp_sing_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_trip_Phi(nOrb,nOrb,nOrb,nOrb)) ! Initialization @@ -139,6 +147,11 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_ee_trip_Om(:) = 1d0 old_hh_sing_Om(:) = 1d0 old_hh_trip_Om(:) = 1d0 + + old_eh_sing_Phi(:,:,:,:) = 0d0 + old_eh_trip_Phi(:,:,:,:) = 0d0 + old_pp_sing_Phi(:,:,:,:) = 0d0 + old_pp_trip_Phi(:,:,:,:) = 0d0 !-----------------------------------------! ! Main loop for one-body self-consistency ! @@ -169,66 +182,6 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*)' ***********************************' write(*,*) - !--------------------------------! - ! Compute effective interactions ! - !--------------------------------! - - ! Memory allocation - allocate(eh_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - allocate(eh_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - allocate(pp_sing_Gam(nOrb,nOrb,nOrb,nOrb)) - allocate(pp_trip_Gam(nOrb,nOrb,nOrb,nOrb)) - - ! Build singlet eh effective interaction - write(*,*) 'Computing singlet eh effective interaction...' - - call wall_time(start_t) - call R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_sing_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh singlet Gamma =',t,' seconds' - write(*,*) - - ! Build triplet eh effective interaction - write(*,*) 'Computing triplet eh effective interaction...' - - call wall_time(start_t) - call R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, eh_trip_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for eh triplet Gamma =',t,' seconds' - write(*,*) - - ! Build singlet pp effective interaction - write(*,*) 'Computing singlet pp effective interaction...' - - call wall_time(start_t) - call R_pp_singlet_Gamma(nOrb,nC,nR,nS,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp singlet Gamma =',t,' seconds' - write(*,*) - - ! Build triplet pp effective interaction - write(*,*) 'Computing triplet pp effective interaction...' - - call wall_time(start_t) - call R_pp_triplet_Gamma(nOrb,nC,nR,nS,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_trip_Gam) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for pp triplet Gamma =',t,' seconds' - write(*,*) - !-----------------! ! Density channel ! !-----------------! @@ -256,17 +209,13 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - call R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & - eh_sing_Gam_A) + call R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS, & + old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + eh_sing_Gam_A) - if(.not.TDA) call R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & - eh_sing_Gam_B) + if(.not.TDA) call R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS, & + old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + eh_sing_Gam_B) end if Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) @@ -282,7 +231,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, if(print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) - err_eh_sing = maxval(abs(old_eh_sing_Om - eh_sing_Om)) + err_eig_eh_sing = maxval(abs(old_eh_sing_Om - eh_sing_Om)) deallocate(Aph,Bph,eh_sing_Gam_A,eh_sing_Gam_B) @@ -313,17 +262,13 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & - eh_trip_Gam_A) + call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS, & + old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + eh_trip_Gam_A) - if(.not.TDA) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, & - old_ee_sing_Om,ee_sing_rho,old_ee_trip_Om,ee_trip_rho, & - old_hh_sing_Om,hh_sing_rho,old_hh_trip_Om,hh_trip_rho, & - eh_trip_Gam_B) + if(.not.TDA) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS, & + old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + eh_trip_Gam_B) end if @@ -340,7 +285,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, if(print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) - err_eh_trip = maxval(abs(old_eh_trip_Om - eh_trip_Om)) + err_eig_eh_trip = maxval(abs(old_eh_trip_Om - eh_trip_Om)) deallocate(Aph,Bph,eh_trip_Gam_A,eh_trip_Gam_B) @@ -376,10 +321,10 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - if(.not.TDA) call R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,& - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_B) - call R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_C) - call R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho,pp_sing_Gam_D) + if(.not.TDA) call R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nOOs,nVVs,& + old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_B) + call R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_C) + call R_pp_singlet_Gamma_D(nOrb,nC,nO,nOOs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_D) end if @@ -397,8 +342,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,hh_sing_Om) - err_ee_sing = maxval(abs(old_ee_sing_Om - ee_sing_Om)) - err_hh_sing = maxval(abs(old_hh_sing_Om - hh_sing_Om)) + err_eig_ee_sing = maxval(abs(old_ee_sing_Om - ee_sing_Om)) + err_eig_hh_sing = maxval(abs(old_hh_sing_Om - hh_sing_Om)) deallocate(Bpp,Cpp,Dpp,pp_sing_Gam_B,pp_sing_Gam_C,pp_sing_Gam_D) @@ -434,10 +379,10 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - if(.not.TDA) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,& - old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_B) - call R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) - call R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,old_eh_sing_Om,eh_sing_rho,old_eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) + if(.not.TDA) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nS,nOOt,nVVt,& + old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_B) + call R_pp_triplet_Gamma_C(nOrb,nO,nR,nS,nVVt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_C) + call R_pp_triplet_Gamma_D(nOrb,nC,nO,nS,nOOt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_D) end if @@ -456,18 +401,18 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (triplets)',nOOt,hh_trip_Om) - err_ee_trip = maxval(abs(old_ee_trip_Om - ee_trip_Om)) - err_hh_trip = maxval(abs(old_hh_trip_Om - hh_trip_Om)) + err_eig_ee_trip = maxval(abs(old_ee_trip_Om - ee_trip_Om)) + err_eig_hh_trip = maxval(abs(old_hh_trip_Om - hh_trip_Om)) deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) write(*,*) '----------------------------------------' write(*,*) ' Two-body convergence ' write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eh_sing - write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eh_trip - write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_ee_sing,err_hh_sing) - write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_ee_trip,err_hh_trip) + write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eig_eh_sing + write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eig_eh_trip + write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_eig_ee_sing,err_eig_hh_sing) + write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_eig_ee_trip,err_eig_hh_trip) write(*,*) '----------------------------------------' write(*,*) @@ -502,53 +447,135 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Computing singlet eh screened integrals...' call wall_time(start_t) - call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,sing_XpY,sing_XmY,eh_sing_rho) + call R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + sing_XpY,sing_XmY,eh_sing_rho) call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh integrals =',t,' seconds' write(*,*) ! Done with eigenvectors and kernel - deallocate(sing_XpY,sing_XmY,eh_sing_Gam) + deallocate(sing_XpY,sing_XmY) ! Build triplet eh screened integrals write(*,*) 'Computing triplet eh screened integrals...' call wall_time(start_t) - call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,trip_XpY,trip_XmY,eh_trip_rho) + call R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + trip_XpY,trip_XmY,eh_trip_rho) call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh integrals =',t,' seconds' write(*,*) ! Done with eigenvectors and kernel - deallocate(trip_XpY,trip_XmY,eh_trip_Gam) + deallocate(trip_XpY,trip_XmY) ! Build singlet pp screened integrals write(*,*) 'Computing singlet pp screened integrals...' call wall_time(start_t) - call R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI,pp_sing_Gam,X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) + call R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOOs,nVVs,ERI,old_eh_sing_Phi,old_eh_trip_Phi, & + X1s,Y1s,ee_sing_rho,X2s,Y2s,hh_sing_rho) call wall_time(end_t) t = end_t - start_t ! Done with eigenvectors and kernel write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp integrals =',t,' seconds' write(*,*) - deallocate(X1s,Y1s,X2s,Y2s,pp_sing_Gam) + deallocate(X1s,Y1s,X2s,Y2s) ! Build triplet pp screened integrals write(*,*) 'Computing triplet pp screened integrals...' call wall_time(start_t) - call R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI,pp_trip_Gam,X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) + call R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOOt,nVVt,ERI,old_eh_sing_Phi,old_eh_trip_Phi, & + X1t,Y1t,ee_trip_rho,X2t,Y2t,hh_trip_rho) call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp integrals =',t,' seconds' write(*,*) ! Done with eigenvectors and kernel - deallocate(X1t,Y1t,X2t,Y2t,pp_trip_Gam) + deallocate(X1t,Y1t,X2t,Y2t) + !----------------------------! + ! Compute reducible kernels ! + !----------------------------! + + ! Memory allocation + allocate(eh_sing_Phi(nOrb,nOrb,nOrb,nOrb)) + allocate(eh_trip_Phi(nOrb,nOrb,nOrb,nOrb)) + allocate(pp_sing_Phi(nOrb,nOrb,nOrb,nOrb)) + allocate(pp_trip_Phi(nOrb,nOrb,nOrb,nOrb)) + + ! Build singlet eh reducible kernels + write(*,*) 'Computing singlet eh reducible kernel ...' + + call wall_time(start_t) + call R_eh_singlet_Phi(nOrb,nC,nR,nS,old_eh_sing_Om,eh_sing_rho,eh_sing_Phi) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh reducible kernel =',t,' seconds' + write(*,*) + + ! Build triplet eh reducible kernels + write(*,*) 'Computing triplet eh reducible kernel ...' + + call wall_time(start_t) + call R_eh_triplet_Phi(nOrb,nC,nR,nS,old_eh_trip_Om,eh_trip_rho,eh_trip_Phi) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh reducible kernel =',t,' seconds' + write(*,*) + + ! Build singlet pp reducible kernels + write(*,*) 'Computing singlet pp reducible kernel ...' + + call wall_time(start_t) + call R_pp_singlet_Phi(nOrb,nC,nR,nOOs,nVVs,old_ee_sing_Om,ee_sing_rho,old_hh_sing_Om,hh_sing_rho,pp_sing_Phi) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp reducible kernel =',t,' seconds' + write(*,*) + + ! Build triplet pp reducible kernels + write(*,*) 'Computing triplet pp reducible kernel ...' + + call wall_time(start_t) + call R_pp_triplet_Phi(nOrb,nC,nR,nOOt,nVVt,old_ee_trip_Om,ee_trip_rho,old_hh_trip_Om,hh_trip_rho,pp_trip_Phi) + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp reducible kernel =',t,' seconds' + write(*,*) + + err_eh_sing = maxval(abs(old_eh_sing_Phi - eh_sing_Phi)) + err_eh_trip = maxval(abs(old_eh_trip_Phi - eh_trip_Phi)) + err_pp_sing = maxval(abs(old_pp_sing_Phi - pp_sing_Phi)) + err_pp_trip = maxval(abs(old_pp_trip_Phi - pp_trip_Phi)) + + old_eh_sing_Phi(:,:,:,:) = eh_sing_Phi(:,:,:,:) + old_eh_trip_Phi(:,:,:,:) = eh_trip_Phi(:,:,:,:) + old_pp_sing_Phi(:,:,:,:) = pp_sing_Phi(:,:,:,:) + old_pp_trip_Phi(:,:,:,:) = pp_trip_Phi(:,:,:,:) + + ! Free memory + deallocate(eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi) + + !--------------------! + ! DIIS extrapolation ! + !--------------------! + + + write(*,*) '----------------------------------------' + write(*,*) ' Two-body (kernel) convergence ' + write(*,*) '----------------------------------------' + write(*,'(1X,A30,F10.6)')'Error for singlet eh channel = ',err_eh_sing + write(*,'(1X,A30,F10.6)')'Error for triplet eh channel = ',err_eh_trip + write(*,'(1X,A30,F10.6)')'Error for singlet pp channel = ',err_pp_sing + write(*,'(1X,A30,F10.6)')'Error for triplet pp channel = ',err_pp_trip + write(*,*) '----------------------------------------' + write(*,*) + ! Convergence criteria - err_2b = max(err_eh_sing,err_eh_trip,err_ee_sing,err_ee_trip,err_hh_sing,err_hh_trip) + err_2b = max(err_eh_sing,err_eh_trip,err_pp_sing,err_pp_trip) call wall_time(end_2b) t_2b = end_2b - start_2b diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 index cea9c9e..3fe4930 100644 --- a/src/Parquet/R_eh_singlet_Gam.f90 +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -1,106 +1,20 @@ -subroutine R_eh_singlet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & - ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & - hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam) - -! Compute irreducible vertex in the triplet pp channel - implicit none - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_sing_Om(nVVs) - double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) - double precision,intent(in) :: ee_trip_Om(nVVt) - double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) - double precision,intent(in) :: hh_sing_Om(nOOs) - double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) - double precision,intent(in) :: hh_trip_Om(nVVs) - double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) - -! Local variables - integer :: p,q,r,s - integer :: n - double precision,external :: Kronecker_delta - -! Output variables - double precision, intent(out) :: eh_sing_Gam(nOrb,nOrb,nOrb,nOrb) - -! Initialization - eh_sing_Gam(:,:,:,:) = 0d0 - - do s = nC+1, nOrb-nR - do r = nC+1, nOrb-nR - do q = nC+1, nOrb-nR - do p = nC+1, nOrb-nR - - do n=1,nS - eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - + 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) - end do - - do n=1,nVVs - eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - + ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) - end do - - do n=1,nOOs - eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - - hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) - end do - - do n=1,nVVt - eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - + 3d0 * ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) - end do - - do n=1,nOOt - eh_sing_Gam(p,q,r,s) = eh_sing_Gam(p,q,r,s) & - - 3d0 * hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) - end do - - enddo - enddo - enddo - enddo - -end subroutine R_eh_singlet_Gamma - -subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & - ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & - hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam_A) +subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_sing_Gam_A) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_sing_Om(nVVs) - double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) - double precision,intent(in) :: ee_trip_Om(nVVt) - double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) - double precision,intent(in) :: hh_sing_Om(nOOs) - double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) - double precision,intent(in) :: hh_trip_Om(nVVs) - double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,a,j,b integer :: ia,jb integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: eh_sing_Gam_A(nS,nS) @@ -117,33 +31,33 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do b=nO+1,norb-nR jb = jb + 1 - do n=1,nS - eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + ! + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) + ! end do - do n=1,nVVs - eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - + ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) - end do + ! do n=1,nVVs + ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + ! + ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) + ! end do - do n=1,nOOs - eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - - hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) - end do + ! do n=1,nOOs + ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + ! - hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) + ! end do - do n=1,nVVt - eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - + 3d0 * ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) - end do + ! do n=1,nVVt + ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + ! + 3d0 * ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) + ! end do - do n=1,nOOt - eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - - 3d0 * hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) - end do + ! do n=1,nOOt + ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & + ! - 3d0 * hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) + ! end do enddo enddo @@ -152,35 +66,23 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & end subroutine R_eh_singlet_Gamma_A -subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & - ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & - hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_sing_Gam_B) +subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_sing_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_sing_Om(nVVs) - double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) - double precision,intent(in) :: ee_trip_Om(nVVt) - double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) - double precision,intent(in) :: hh_sing_Om(nOOs) - double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) - double precision,intent(in) :: hh_trip_Om(nVVs) - double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + integer,intent(in) :: nOrb,nC,nO,nR,nS + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,a,j,b integer :: ia,jb integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: eh_sing_Gam_B(nS,nS) @@ -197,33 +99,33 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do b=nO+1,norb-nR jb = jb + 1 - do n=1,nS - eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + ! + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) + ! end do - do n=1,nVVs - eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - + ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) - end do + ! do n=1,nVVs + ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + ! + ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) + ! end do - do n=1,nOOs - eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - - hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) - end do + ! do n=1,nOOs + ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + ! - hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) + ! end do - do n=1,nVVt - eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - + 3d0 * ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) - end do + ! do n=1,nVVt + ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + ! + 3d0 * ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) + ! end do - do n=1,nOOt - eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - - 3d0 * hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) - end do + ! do n=1,nOOt + ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & + ! - 3d0 * hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) + ! end do enddo enddo diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 index b95b61c..796b810 100644 --- a/src/Parquet/R_eh_triplet_Gam.f90 +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -1,101 +1,15 @@ -subroutine R_eh_triplet_Gamma(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & - ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & - hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_trip_Gam) +subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_A) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_sing_Om(nVVs) - double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) - double precision,intent(in) :: ee_trip_Om(nVVt) - double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) - double precision,intent(in) :: hh_sing_Om(nOOs) - double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) - double precision,intent(in) :: hh_trip_Om(nVVs) - double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) - -! Local variables - integer :: p,q,r,s - integer :: n - double precision,external :: Kronecker_delta - -! Output variables - double precision, intent(out) :: eh_trip_Gam(nOrb,nOrb,nOrb,nOrb) - -! Initialization - eh_trip_Gam(:,:,:,:) = 0d0 - - do s = nC+1, nOrb-nR - do r = nC+1, nOrb-nR - do q = nC+1, nOrb-nR - do p = nC+1, nOrb-nR - - do n=1,nS - eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - + 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) - end do - - do n=1,nVVs - eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - - ee_sing_rho(p,q,n) * ee_sing_rho(r,s,n)/ee_sing_Om(n) - end do - - do n=1,nOOs - eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - + hh_sing_rho(p,q,n) * hh_sing_rho(r,s,n)/hh_sing_Om(n) - end do - - do n=1,nVVt - eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - + ee_trip_rho(p,q,n) * ee_trip_rho(r,s,n)/ee_trip_Om(n) - end do - - do n=1,nOOt - eh_trip_Gam(p,q,r,s) = eh_trip_Gam(p,q,r,s) & - - hh_trip_rho(p,q,n) * hh_trip_rho(r,s,n)/hh_trip_Om(n) - end do - - enddo - enddo - enddo - enddo - -end subroutine R_eh_triplet_Gamma - -subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & - ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & - hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_trip_Gam_A) - - -! Compute irreducible vertex in the triplet pp channel - implicit none - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_sing_Om(nVVs) - double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) - double precision,intent(in) :: ee_trip_Om(nVVt) - double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) - double precision,intent(in) :: hh_sing_Om(nOOs) - double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) - double precision,intent(in) :: hh_trip_Om(nVVs) - double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,a,j,b @@ -118,33 +32,33 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do b=nO+1,norb-nR jb = jb + 1 - do n=1,nS - eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + ! + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) + ! end do - do n=1,nVVs - eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - - ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) - end do + ! do n=1,nVVs + ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + ! - ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) + ! end do - do n=1,nOOs - eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - + hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) - end do + ! do n=1,nOOs + ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + ! + hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) + ! end do - do n=1,nVVt - eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - + ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) - end do + ! do n=1,nVVt + ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + ! + ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) + ! end do - do n=1,nOOt - eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - - hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) - end do + ! do n=1,nOOt + ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & + ! - hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) + ! end do enddo enddo @@ -153,29 +67,18 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & end subroutine R_eh_triplet_Gamma_A -subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & - eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, & - ee_sing_Om,ee_sing_rho,ee_trip_Om,ee_trip_rho, & - hh_sing_Om,hh_sing_rho,hh_trip_Om,hh_trip_rho, eh_trip_Gam_B) +subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - double precision,intent(in) :: ee_sing_Om(nVVs) - double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) - double precision,intent(in) :: ee_trip_Om(nVVt) - double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) - double precision,intent(in) :: hh_sing_Om(nOOs) - double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) - double precision,intent(in) :: hh_trip_Om(nVVs) - double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nVVs) + integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,a,j,b @@ -198,33 +101,33 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, & do b=nO+1,norb-nR jb = jb + 1 - do n=1,nS - eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + ! + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) + ! end do - do n=1,nVVs - eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - - ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) - end do + ! do n=1,nVVs + ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + ! - ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) + ! end do - do n=1,nOOs - eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - + hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) - end do + ! do n=1,nOOs + ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + ! + hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) + ! end do - do n=1,nVVt - eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - + ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) - end do + ! do n=1,nVVt + ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + ! + ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) + ! end do - do n=1,nOOt - eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - - hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) - end do + ! do n=1,nOOt + ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & + ! - hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) + ! end do enddo enddo diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index afbd50a..2a9fe2f 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -1,76 +1,17 @@ -subroutine R_pp_singlet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam) +subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nS,nOOs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_D) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nR,nS - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - -! Local variables - integer :: p,q,r,s - integer :: n - double precision,external :: Kronecker_delta - -! Output variables - double precision, intent(out) :: pp_sing_Gam(nOrb,nOrb,nOrb,nOrb) - -! Initialization - pp_sing_Gam(:,:,:,:) = 0d0 - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(i, j, ij, k, l, kl, n) & -! !$OMP SHARED(nC, nOrb, nO, nS, pp_sing_Gam_D, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) -! !$OMP DO COLLAPSE(2) - - do s = nC+1, nOrb-nR - do r = nC+1, nOrb-nR - do q = nC+1, nOrb-nR - do p = nC+1, nOrb-nR - - do n=1,nS - pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s) & - - 0.5d0 * eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(p,r,n)*eh_sing_rho(s,q,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(p,r,n)*eh_trip_rho(s,q,n)/eh_trip_Om(n) & - - 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) - end do - - ! pp_sing_Gam(p,q,r,s) = pp_sing_Gam(p,q,r,s)/sqrt((1d0 + Kronecker_delta(p,q))*(1d0 + Kronecker_delta(r,s))) - - end do - end do - end do - end do -! !$OMP END DO -! !$OMP END PARALLEL - -end subroutine R_pp_singlet_Gamma - -subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_sing_Gam_D) - -! Compute irreducible vertex in the triplet pp channel - implicit none - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nC,nO,nS,nOOs + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,j,k,l integer :: ij,kl integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_sing_Gam_D(nOOs,nOOs) @@ -93,19 +34,19 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,eh_sing_Om,eh_sing_rho, do l=k,nO kl = kl +1 - do n=1,nS - pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl) & - - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & - - 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl) & + ! - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) + ! end do - pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) + ! pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) end do end do @@ -116,23 +57,20 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOs,eh_sing_Om,eh_sing_rho, end subroutine -subroutine R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_sing_Gam_C) +subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nS,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_C) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nVVs - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nO,nR,nS,nVVs + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,c,d integer :: ab,cd integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_sing_Gam_C(nVVs,nVVs) @@ -155,19 +93,19 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,eh_sing_Om,eh_sing_rho, do d=c,nOrb - nR cd = cd +1 - do n=1,nS - pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd) & - - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & - - 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd) & + ! - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) + ! end do - pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) + ! pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) end do end do @@ -178,23 +116,20 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVs,eh_sing_Om,eh_sing_rho, end subroutine -subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_sing_Gam_B) +subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nS,nOOs,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOs,nVVs - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nC,nO,nR,nS,nOOs,nVVs + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,i,j integer :: ab,ij integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_sing_Gam_B(nVVs,nOOs) @@ -217,19 +152,19 @@ subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,eh_sing_Om,eh_sing do j=i,nO ij = ij +1 - do n=1,nS - pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij) & - - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & - - 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - end do + ! do n=1,nS + ! pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij) & + ! - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + ! + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + ! + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) + ! end do - pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) + ! pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) end do end do diff --git a/src/Parquet/R_pp_triplet_Gam.f90 b/src/Parquet/R_pp_triplet_Gam.f90 index ae3f55e..973589f 100644 --- a/src/Parquet/R_pp_triplet_Gam.f90 +++ b/src/Parquet/R_pp_triplet_Gam.f90 @@ -1,75 +1,17 @@ -subroutine R_pp_triplet_Gamma(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_trip_Gam) +subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nS,nOOt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_D) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nR,nS - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) - -! Local variables - integer :: p,q,r,s - integer :: n - double precision,external :: Kronecker_delta - -! Output variables - double precision, intent(out) :: pp_trip_Gam(nOrb,nOrb,nOrb,nOrb) - -! Initialization - pp_trip_Gam(:,:,:,:) = 0d0 - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(i, j, ij, k, l, kl, n) & -! !$OMP SHARED(nC, nOrb, nO, nS, pp_trip_Gam_D, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) -! !$OMP DO COLLAPSE(2) - - do s = nC+1, nOrb-nR - do r = nC+1, nOrb-nR - do q = nC+1, nOrb-nR - do p = nC+1, nOrb-nR - - do n=1,nS - - pp_trip_Gam(p,q,r,s) = pp_trip_Gam(p,q,r,s) & - - 0.5d0 * eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(p,r,n)*eh_sing_rho(s,q,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(p,r,n)*eh_trip_rho(s,q,n)/eh_trip_Om(n) & - + 0.5d0 * eh_sing_rho(s,p,n)*eh_sing_rho(q,r,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(p,s,n)*eh_sing_rho(r,q,n)/eh_sing_Om(n) & - + 0.5d0 * eh_trip_rho(s,p,n)*eh_trip_rho(q,r,n)/eh_trip_Om(n) & - + 0.5d0 * eh_trip_rho(p,s,n)*eh_trip_rho(r,q,n)/eh_trip_Om(n) - end do - - end do - end do - end do - end do -! !$OMP END DO -! !$OMP END PARALLEL - -end subroutine - -subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_trip_Gam_D) - -! Compute irreducible vertex in the triplet pp channel - implicit none - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nC,nO,nS,nOOt + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,j,k,l integer :: ij,kl integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_trip_Gam_D(nOOt,nOOt) @@ -94,15 +36,16 @@ subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,eh_sing_Om,eh_sing_rho, do n=1,nS - pp_trip_Gam_D(ij,kl) = pp_trip_Gam_D(ij,kl) & - - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & - + 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & - + 0.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & - + 0.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) + ! pp_trip_Gam_D(ij,kl) = pp_trip_Gam_D(ij,kl) & + ! - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & + ! + 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & + ! + 0.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) + end do end do @@ -114,23 +57,20 @@ subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nV,nR,nS,nOOt,eh_sing_Om,eh_sing_rho, end subroutine -subroutine R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho, pp_trip_Gam_C) +subroutine R_pp_triplet_Gamma_C(nOrb,nO,nR,nS,nVVt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_C) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nO,nR,nS,nVVt + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,c,d integer :: ab,cd integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_trip_Gam_C(nVVt,nVVt) @@ -155,15 +95,16 @@ subroutine R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,eh_sing_Om,eh_sing_rho, do n=1,nS - pp_trip_Gam_C(ab,cd) = pp_trip_Gam_C(ab,cd) & - - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & - + 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & - + 0.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & - + 0.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) + ! pp_trip_Gam_C(ab,cd) = pp_trip_Gam_C(ab,cd) & + ! - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & + ! + 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & + ! + 0.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) + end do end do @@ -175,23 +116,20 @@ subroutine R_pp_triplet_Gamma_C(nOrb,nC,nO,nV,nR,nS,nVVt,eh_sing_Om,eh_sing_rho, end subroutine -subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,eh_sing_Om,eh_sing_rho,eh_trip_Om,eh_trip_rho,pp_trip_Gam_B) +subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nS,nOOt,nVVt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS,nOOt,nVVt - double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + integer,intent(in) :: nOrb,nC,nO,nR,nS,nOOt,nVVt + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,i,j integer :: ab,ij integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_trip_Gam_B(nVVt,nOOt) @@ -216,15 +154,16 @@ subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,nOOt,nVVt,eh_sing_Om,eh_sing do n=1,nS - pp_trip_Gam_B(ab,ij) = pp_trip_Gam_B(ab,ij) & - - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & - - 0.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - - 0.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & - + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - + 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - + 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) + ! pp_trip_Gam_B(ab,ij) = pp_trip_Gam_B(ab,ij) & + ! - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & + ! - 0.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & + ! - 0.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & + ! + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & + ! + 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & + ! + 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) + end do end do diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 8dc516d..e1a7e99 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -1,4 +1,4 @@ -subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,XmY,rho) +subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,XpY,XmY,rho) ! Compute excitation densities implicit none @@ -6,7 +6,10 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,X ! Input variables integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: eh_sing_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: XpY(nS,nS),XmY(nS,nS) ! Local variables @@ -24,24 +27,28 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,X ! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR + jb = 0 do j=nC+1,nO do b=nO+1,nOrb-nR jb = jb + 1 + do ia=1,nS - X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) - Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + ! X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + ! Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = rho(p,q,ia) & - + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & - + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & - + 1d0*eh_sing_Gam(p,j,q,b)*X & - + 1d0*eh_sing_Gam(p,b,q,j)*Y + ! rho(p,q,ia) = rho(p,q,ia) & + ! + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & + ! + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & + ! + 1d0*eh_sing_Gam(p,j,q,b)*X & + ! + 1d0*eh_sing_Gam(p,b,q,j)*Y end do + end do end do + end do end do ! !$OMP END DO @@ -49,7 +56,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Gam,XpY,X end subroutine R_eh_singlet_screened_integral -subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,XmY,rho) +subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,XpY,XmY,rho) ! Compute excitation densities implicit none @@ -57,7 +64,10 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,X ! Input variables integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: eh_trip_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: XpY(nS,nS),XmY(nS,nS) ! Local variables @@ -81,14 +91,15 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,X jb = jb + 1 do ia=1,nS - X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) - Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + ! X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + ! Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + + ! rho(p,q,ia) = rho(p,q,ia) & + ! - ERI(p,j,b,q)*X & + ! - ERI(p,b,j,q)*Y & + ! + 1d0*eh_trip_Gam(p,j,q,b)*X & + ! + 1d0*eh_trip_Gam(p,b,q,j)*Y - rho(p,q,ia) = rho(p,q,ia) & - - ERI(p,j,b,q)*X & - - ERI(p,b,j,q)*Y & - + 1d0*eh_trip_Gam(p,j,q,b)*X & - + 1d0*eh_trip_Gam(p,b,q,j)*Y end do end do end do @@ -100,7 +111,7 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_trip_Gam,XpY,X end subroutine R_eh_triplet_screened_integral -subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_Gam,X1,Y1,rho1,X2,Y2,rho2) +subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi,eh_trip_Phi,X1,Y1,rho1,X2,Y2,rho2) ! Compute excitation densities in the singlet pp channel @@ -109,11 +120,11 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR + integer,intent(in) :: nOrb,nC,nO,nR + integer,intent(in) :: nOO,nVV double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: pp_sing_Gam(nOrb,nOrb,nOrb,nOrb) - integer,intent(in) :: nOO - integer,intent(in) :: nVV + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: X1(nVV,nVV) double precision,intent(in) :: Y1(nOO,nVV) double precision,intent(in) :: X2(nVV,nOO) @@ -146,59 +157,62 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_sing_G do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR - ab = 0 - do a=nO+1,nOrb-nR - do b=a,nOrb-nR - ab = ab + 1 + ! ab = 0 + ! do a=nO+1,nOrb-nR + ! do b=a,nOrb-nR + ! ab = ab + 1 - cd = 0 - do c=nO+1,nOrb-nR - do d=c,nOrb-nR - cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab) & - /sqrt(1d0 + Kronecker_delta(c,d)) - end do - end do + ! cd = 0 + ! do c=nO+1,nOrb-nR + ! do d=c,nOrb-nR + ! cd = cd + 1 + ! rho1(p,q,ab) = rho1(p,q,ab) & + ! + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab) & + ! /sqrt(1d0 + Kronecker_delta(c,d)) + ! end do + ! end do - kl = 0 - do k=nC+1,nO - do l=k,nO - kl = kl + 1 - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & - /sqrt(1d0 + Kronecker_delta(k,l)) - end do - end do + ! kl = 0 + ! do k=nC+1,nO + ! do l=k,nO + ! kl = kl + 1 + ! rho1(p,q,ab) = rho1(p,q,ab) & + ! + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & + ! /sqrt(1d0 + Kronecker_delta(k,l)) + ! end do + ! end do - end do - end do + ! end do + ! end do - ij = 0 - do i=nC+1,nO - do j=i,nO - ij = ij + 1 - cd = 0 - do c=nO+1,nOrb-nR - do d=c,nOrb-nR - cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij) & - /sqrt(1d0 + Kronecker_delta(c,d)) - end do - end do + ! ij = 0 + ! do i=nC+1,nO + ! do j=i,nO + ! ij = ij + 1 - kl = 0 - do k=nC+1,nO - do l=k,nO - kl = kl + 1 - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & - /sqrt(1d0 + Kronecker_delta(k,l)) - end do - end do - end do - end do + ! cd = 0 + ! do c=nO+1,nOrb-nR + ! do d=c,nOrb-nR + ! cd = cd + 1 + ! rho2(p,q,ij) = rho2(p,q,ij) & + ! + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij) & + ! /sqrt(1d0 + Kronecker_delta(c,d)) + ! end do + ! end do + + ! kl = 0 + ! do k=nC+1,nO + ! do l=k,nO + ! kl = kl + 1 + ! rho2(p,q,ij) = rho2(p,q,ij) & + ! + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & + ! /sqrt(1d0 + Kronecker_delta(k,l)) + ! end do + ! end do + + ! end do + ! end do + end do end do ! !$OMP END DO @@ -209,17 +223,17 @@ end subroutine R_pp_singlet_screened_integral -subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_Gam,X1,Y1,rho1,X2,Y2,rho2) +subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi,eh_trip_Phi,X1,Y1,rho1,X2,Y2,rho2) ! Compute excitation densities in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR - integer,intent(in) :: nOO - integer,intent(in) :: nVV + integer,intent(in) :: nOrb,nC,nO,nR + integer,intent(in) :: nOO,nVV double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: pp_trip_Gam(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: X1(nVV,nVV) double precision,intent(in) :: Y1(nOO,nVV) double precision,intent(in) :: X2(nVV,nOO) @@ -252,59 +266,61 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nV,nR,nOO,nVV,ERI,pp_trip_G do p = nC+1, nOrb-nR ab = 0 - do a = nO+1, nOrb-nR - do b = a+1, nOrb-nR - ab = ab + 1 + ! do a = nO+1, nOrb-nR + ! do b = a+1, nOrb-nR + ! ab = ab + 1 - cd = 0 - do c = nO+1, nOrb-nR - do d = c+1, nOrb-nR - cd = cd + 1 + ! cd = 0 + ! do c = nO+1, nOrb-nR + ! do d = c+1, nOrb-nR + ! cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) - end do ! d - end do ! c + ! rho1(p,q,ab) = rho1(p,q,ab) & + ! + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) + ! end do ! d + ! end do ! c - kl = 0 - do k = nC+1, nO - do l = k+1, nO + ! kl = 0 + ! do k = nC+1, nO + ! do l = k+1, nO - kl = kl + 1 + ! kl = kl + 1 - rho1(p,q,ab) = rho1(p,q,ab) & - + (ERI(p,q,k,l) - ERI(p,q,l,k) + 1d0*pp_trip_Gam(p,q,k,l))*Y1(kl,ab) - end do ! l - end do ! k - end do ! b - end do ! a + ! rho1(p,q,ab) = rho1(p,q,ab) & + ! + (ERI(p,q,k,l) - ERI(p,q,l,k) + 1d0*pp_trip_Gam(p,q,k,l))*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 + ! ij = 0 + ! do i = nC+1, nO + ! do j = i+1, nO + ! ij = ij + 1 - cd = 0 - do c = nO+1, nOrb-nR - do d = c+1, nOrb-nR - cd = cd + 1 + ! cd = 0 + ! do c = nO+1, nOrb-nR + ! do d = c+1, nOrb-nR + ! cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) & - + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) - end do ! d - end do ! c + ! rho2(p,q,ij) = rho2(p,q,ij) & + ! + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) + ! end do ! d + ! end do ! c - kl = 0 - do k = nC+1, nO - do l = k+1, nO - kl = kl + 1 + ! 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) + 1d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) - end do ! l - end do ! k - end do ! j - end do ! i + ! rho2(p,q,ij) = rho2(p,q,ij) & + ! + (ERI(p,q,k,l) - ERI(p,q,l,k) + 1d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) + ! end do ! l + ! end do ! k + + ! end do ! j + ! end do ! i + end do ! p end do ! q ! !$OMP END DO From 767257d10703f9b9146d98ecbcc30cd68dda70bd Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 26 Mar 2025 10:52:23 +0100 Subject: [PATCH 20/71] spin orbital parquet converging ! --- src/Parquet/GParquet.f90 | 4 ++-- src/Parquet/G_screened_integrals.f90 | 7 ++++--- src/Parquet/RParquet.f90 | 2 +- src/Parquet/R_screened_integrals.f90 | 18 +++++++++--------- 4 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 85153b4..f1ac68f 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -117,7 +117,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Memory allocation allocate(old_eh_Om(nS),old_ee_Om(nVV),old_hh_Om(nOO)) - allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + allocate(eh_rho(nOrb,nOrb,nS+nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) allocate(old_eh_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_Phi(nOrb,nOrb,nOrb,nOrb)) ! Initialization @@ -327,7 +327,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_rho,ee_rho,hh_rho) ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation - allocate(eh_rho(nOrb,nOrb,nS)) + allocate(eh_rho(nOrb,nOrb,nS+nS)) allocate(ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) ! Build singlet eh integrals diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 9652306..4d7a6b0 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -15,7 +15,7 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) rho(:,:,:) = 0d0 ! !$OMP PARALLEL & @@ -37,8 +37,9 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = (ERI(q,j,p,b) - ERI(q,j,b,p)) * X & - + (- eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & - + (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + + (- eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X + + rho(p,q,nS+ia) = (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + (- eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y end do diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index a8acfa8..d419c3c 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -407,7 +407,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) write(*,*) '----------------------------------------' - write(*,*) ' Two-body convergence ' + write(*,*) ' Two-body (eigenvalue) convergence ' write(*,*) '----------------------------------------' write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eig_eh_sing write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eig_eh_trip diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index e1a7e99..c9c5a74 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -33,18 +33,18 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr do b=nO+1,nOrb-nR jb = jb + 1 - do ia=1,nS + ! do ia=1,nS - ! X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) - ! Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + ! X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + ! Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - ! rho(p,q,ia) = rho(p,q,ia) & - ! + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & - ! + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & - ! + 1d0*eh_sing_Gam(p,j,q,b)*X & - ! + 1d0*eh_sing_Gam(p,b,q,j)*Y + ! rho(p,q,ia) = rho(p,q,ia) & + ! + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & + ! + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & + ! + 1d0*eh_sing_Gam(p,j,q,b)*X & + ! + 1d0*eh_sing_Gam(p,b,q,j)*Y - end do + ! end do end do end do From d9fa986edbe2b40633e9e4fca275604c14888cf6 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 26 Mar 2025 11:00:33 +0100 Subject: [PATCH 21/71] spin orbital parquet converging ! --- src/Parquet/GParquet.f90 | 1 - src/Parquet/RParquet.f90 | 5 ++--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index f1ac68f..3d23baf 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -400,7 +400,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! DIIS extrapolation ! !--------------------! - write(*,*) '----------------------------------------' write(*,*) ' Two-body (kernel) convergence ' write(*,*) '----------------------------------------' diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index d419c3c..17a79af 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -117,7 +117,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, allocate(old_eh_sing_Om(nS),old_eh_trip_Om(nS)) allocate(old_ee_sing_Om(nVVs),old_hh_sing_Om(nOOs)) allocate(old_ee_trip_Om(nVVt),old_hh_trip_Om(nOOt)) - allocate(eh_sing_rho(nOrb,nOrb,nS),eh_trip_rho(nOrb,nOrb,nS)) + allocate(eh_sing_rho(nOrb,nOrb,nS+nS),eh_trip_rho(nOrb,nOrb,nS+nS)) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) allocate(old_eh_sing_Phi(nOrb,nOrb,nOrb,nOrb),old_eh_trip_Phi(nOrb,nOrb,nOrb,nOrb)) @@ -437,8 +437,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation - allocate(eh_sing_rho(nOrb,nOrb,nS)) - allocate(eh_trip_rho(nOrb,nOrb,nS)) + allocate(eh_sing_rho(nOrb,nOrb,nS+nS),eh_trip_rho(nOrb,nOrb,nS+nS)) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) From bf95acc34bbd184efc64b0dd25c3b8acdca1d6c0 Mon Sep 17 00:00:00 2001 From: pfloos Date: Wed, 26 Mar 2025 15:49:16 +0100 Subject: [PATCH 22/71] include parquet method in UQuAcK --- PyDuck.py | 14 ++++++------ .../amarie@HP-EliteBook-830.23187:1742801908 | 0 src/QuAcK/QuAcK.f90 | 2 +- src/QuAcK/RQuAcK.f90 | 2 +- src/QuAcK/UQuAcK.f90 | 22 ++++++++++++++++++- 5 files changed, 30 insertions(+), 10 deletions(-) delete mode 100644 src/Parquet/amarie@HP-EliteBook-830.23187:1742801908 diff --git a/PyDuck.py b/PyDuck.py index b8706d6..44ff479 100644 --- a/PyDuck.py +++ b/PyDuck.py @@ -20,16 +20,16 @@ QuAcK_dir=os.environ.get('QUACK_ROOT','./') parser = argparse.ArgumentParser(description='This script is the main script of QuAcK, it is used to run the calculation.\n If $QUACK_ROOT is not set, $QUACK_ROOT is replaces by the current directory.') #Initialize all the options for the script -parser.add_argument('-b', '--basis', type=str, required=True, help='Name of the file containing the basis set in the $QUACK_ROOT/basis/ directory') +parser.add_argument('-b', '--basis', type=str, required=True, help='Name of the file containing the basis set information in the $QUACK_ROOT/basis/ directory') 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=True, action='store_true', help='If True, print 2e-integrals to disk.') -parser.add_argument('--formatted_2e', default=False, action='store_true', help='Add this option if you want to print formatted 2e-integrals.') -parser.add_argument('--mmap_2e', default=False, action='store_true', help='If True, avoid using DRAM when generating 2e-integrals.') -parser.add_argument('--aosym_2e', default=False, action='store_true', help='If True, use 8-fold symmetry 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('--print_2e', default=True, action='store_true', help='If True, print ERIs to disk.') +parser.add_argument('--formatted_2e', default=False, action='store_true', help='Add this option if you want to print formatted ERIs.') +parser.add_argument('--mmap_2e', default=False, action='store_true', help='If True, avoid using DRAM when generating ERIs.') +parser.add_argument('--aosym_2e', default=False, action='store_true', help='If True, use 8-fold symmetry in ERIs.') +parser.add_argument('-fc', '--frozen_core', type=bool, default=False, help='Freeze core orbitals. Default is false') +parser.add_argument('-m', '--multiplicity', type=int, default=1, help='Spin multiplicity. Default is 1 (singlet)') parser.add_argument('--working_dir', type=str, default=QuAcK_dir, help='Set a working directory to run the calculation.') parser.add_argument('-x', '--xyz', type=str, required=True, help='Name of the file containing the nuclear coordinates in xyz format in the $QUACK_ROOT/mol/ directory without the .xyz extension') diff --git a/src/Parquet/amarie@HP-EliteBook-830.23187:1742801908 b/src/Parquet/amarie@HP-EliteBook-830.23187:1742801908 deleted file mode 100644 index e69de29..0000000 diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index a9e39cc..bf66039 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -277,7 +277,7 @@ program QuAcK call UQuAcK(working_dir,doUtest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & 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, & - doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & + doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,doParquet, & nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_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, & diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index bbbdd98..4275944 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -387,9 +387,9 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, write(*,*) end if - ! Memory deallocation + deallocate(eHF) deallocate(cHF) deallocate(PHF) diff --git a/src/QuAcK/UQuAcK.f90 b/src/QuAcK/UQuAcK.f90 index 0ff1759..cb408da 100644 --- a/src/QuAcK/UQuAcK.f90 +++ b/src/QuAcK/UQuAcK.f90 @@ -1,7 +1,7 @@ subroutine UQuAcK(working_dir,dotest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT, & 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, & - doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh, & + doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,doParquet, & nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc, & S,T,V,Hc,X,dipole_int_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, & @@ -28,6 +28,7 @@ subroutine UQuAcK(working_dir,dotest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dop logical,intent(in) :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW logical,intent(in) :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp logical,intent(in) :: doG0T0eh,doevGTeh,doqsGTeh + logical,intent(in) :: doParquet integer,intent(in) :: nNuc,nBas integer,intent(in) :: nC(nspin) @@ -90,6 +91,7 @@ subroutine UQuAcK(working_dir,dotest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dop double precision :: start_GF ,end_GF ,t_GF double precision :: start_GW ,end_GW ,t_GW double precision :: start_GT ,end_GT ,t_GT + double precision :: start_Parquet,end_Parquet ,t_Parquet double precision :: start_int, end_int, t_int double precision,allocatable :: cHF(:,:,:),eHF(:,:),PHF(:,:,:),FHF(:,:,:) @@ -367,4 +369,22 @@ subroutine UQuAcK(working_dir,dotest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dop end if +!------------------------! +! Parquet module ! +!------------------------! + + if(doParquet) then + call wall_time(start_Parquet) +! call RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & +! nOrb,nC,nO,nV,nR,nS, & +! eHF,ERI_MO) + write(*,*) 'Unrestricted version of parquet not yet implemented. Sorry.' + call wall_time(end_Parquet) + + t_Parquet = end_Parquet - start_Parquet + write(*,'(A65,1X,F9.3,A8)') 'Total wall time for Parquet module = ', t_Parquet, ' seconds' + write(*,*) + + end if + end subroutine From b3859c744642d06e81c51f39221712f23390130e Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 26 Mar 2025 16:19:23 +0100 Subject: [PATCH 23/71] saving work but not fully debugged yet --- src/Parquet/GParquet.f90 | 15 +- src/Parquet/G_eh_Phi.f90 | 37 ++++ src/Parquet/G_pp_Gam.f90 | 2 - src/Parquet/G_pp_Phi.f90 | 43 +++++ src/Parquet/G_screened_integrals.f90 | 1 + src/Parquet/RParquet.f90 | 40 +++-- src/Parquet/R_eh_singlet_Gam.f90 | 61 +------ src/Parquet/R_eh_singlet_Phi.f90 | 38 ++++ src/Parquet/R_eh_triplet_Gam.f90 | 71 +------- src/Parquet/R_eh_triplet_Phi.f90 | 38 ++++ src/Parquet/R_pp_singlet_Gam.f90 | 64 ++----- src/Parquet/R_pp_singlet_Phi.f90 | 44 +++++ src/Parquet/R_pp_triplet_Gam.f90 | 62 ++----- src/Parquet/R_pp_triplet_Phi.f90 | 44 +++++ src/Parquet/R_screened_integrals.f90 | 252 +++++++++++++++------------ 15 files changed, 457 insertions(+), 355 deletions(-) create mode 100644 src/Parquet/G_eh_Phi.f90 create mode 100644 src/Parquet/G_pp_Phi.f90 create mode 100644 src/Parquet/R_eh_singlet_Phi.f90 create mode 100644 src/Parquet/R_eh_triplet_Phi.f90 create mode 100644 src/Parquet/R_pp_singlet_Phi.f90 create mode 100644 src/Parquet/R_pp_triplet_Phi.f90 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 3d23baf..1fcf56d 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -9,8 +9,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, logical :: linearize = .true. logical :: TDA = .true. - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables @@ -203,8 +203,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) - Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) + Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) + Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) + call phGLR(TDA,nS,Aph,Bph,EcRPA,eh_Om,XpY,XmY) @@ -258,9 +259,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - Bpp(:,:) = Bpp(:,:) + pp_Gam_B(:,:) - Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) - Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) + ! Bpp(:,:) = Bpp(:,:) + pp_Gam_B(:,:) + ! Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) + ! Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) call ppGLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,EcRPA) call wall_time(end_t) diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 new file mode 100644 index 0000000..5ec86d3 --- /dev/null +++ b/src/Parquet/G_eh_Phi.f90 @@ -0,0 +1,37 @@ +subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nS + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS+nS) + +! Local variables + integer :: p,q,r,s + integer :: n + +! Output variables + double precision, intent(out) :: eh_Phi(nOrb,nOrb,nOrb,nOrb) + +! Initialization + eh_Phi(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + ! do n=1,nS + ! eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & + ! - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & + ! - eh_rho(p,r,nS+n)*eh_rho(s,q,nS+n)/eh_Om(n) + ! end do + + enddo + enddo + enddo + enddo + +end subroutine G_eh_Phi diff --git a/src/Parquet/G_pp_Gam.f90 b/src/Parquet/G_pp_Gam.f90 index 3b55e4a..03d99f8 100644 --- a/src/Parquet/G_pp_Gam.f90 +++ b/src/Parquet/G_pp_Gam.f90 @@ -100,8 +100,6 @@ subroutine G_pp_Gamma_B(nOrb,nC,nO,nR,nOO,nVV,eh_Phi,pp_Gam_B) ! Local variables integer :: a,b,i,j integer :: ab,ij - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_Gam_B(nVV,nOO) diff --git a/src/Parquet/G_pp_Phi.f90 b/src/Parquet/G_pp_Phi.f90 new file mode 100644 index 0000000..12aad4d --- /dev/null +++ b/src/Parquet/G_pp_Phi.f90 @@ -0,0 +1,43 @@ +subroutine G_pp_Phi(nOrb,nC,nR,nOO,nVV,ee_Om,ee_rho,hh_Om,hh_rho,pp_Phi) + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nOO,nVV + double precision,intent(in) :: ee_Om(nVV) + double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: hh_Om(nOO) + double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + +! Local variables + integer :: p,q,r,s + integer :: n + +! Output variables + double precision, intent(out) :: pp_Phi(nOrb,nOrb,nOrb,nOrb) + +! Initialization + pp_Phi(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nVV + pp_Phi(p,q,r,s) = pp_Phi(p,q,r,s) & + + 2d0 * ee_rho(p,q,n)*ee_rho(r,s,n)/ee_Om(n) + end do + + do n=1,nOO + pp_Phi(p,q,r,s) = pp_Phi(p,q,r,s) & + - 2d0 * hh_rho(p,q,n)*hh_rho(r,s,n)/hh_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine G_pp_Phi diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 4d7a6b0..f6c52bf 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -146,6 +146,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 end do end do end do + end do end do ! !$OMP END DO diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 17a79af..dbe8e42 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -141,12 +141,12 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, hh_sing_rho(:,:,:) = 0d0 hh_trip_rho(:,:,:) = 0d0 - old_eh_sing_Om(:) = 1d0 - old_eh_trip_Om(:) = 1d0 - old_ee_sing_Om(:) = 1d0 - old_ee_trip_Om(:) = 1d0 - old_hh_sing_Om(:) = 1d0 - old_hh_trip_Om(:) = 1d0 + old_eh_sing_Om(:) = 0d0 + old_eh_trip_Om(:) = 0d0 + old_ee_sing_Om(:) = 0d0 + old_ee_trip_Om(:) = 0d0 + old_hh_sing_Om(:) = 0d0 + old_hh_trip_Om(:) = 0d0 old_eh_sing_Phi(:,:,:,:) = 0d0 old_eh_trip_Phi(:,:,:,:) = 0d0 @@ -217,9 +217,11 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & eh_sing_Gam_B) - end if + end if + Aph(:,:) = Aph(:,:) + eh_sing_Gam_A(:,:) - Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) + Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) + call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) @@ -262,11 +264,11 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - call R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS, & + call R_eh_triplet_Gamma_A(nOrb,nC,nO,nR,nS, & old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & eh_trip_Gam_A) - if(.not.TDA) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS, & + if(.not.TDA) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS, & old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & eh_trip_Gam_B) @@ -328,9 +330,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) - Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) - Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) + ! Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) + ! Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) + ! Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) call wall_time(end_t) @@ -379,16 +381,16 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - if(.not.TDA) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nS,nOOt,nVVt,& + if(.not.TDA) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nOOt,nVVt,& old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_B) - call R_pp_triplet_Gamma_C(nOrb,nO,nR,nS,nVVt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_C) - call R_pp_triplet_Gamma_D(nOrb,nC,nO,nS,nOOt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_D) + call R_pp_triplet_Gamma_C(nOrb,nO,nR,nVVt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_C) + call R_pp_triplet_Gamma_D(nOrb,nC,nO,nOOt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_D) end if - Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) - Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) - Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) + ! Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) + ! Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) + ! Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 index 3fe4930..7855ff6 100644 --- a/src/Parquet/R_eh_singlet_Gam.f90 +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -14,8 +14,6 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing ! Local variables integer :: i,a,j,b integer :: ia,jb - integer :: n - ! Output variables double precision, intent(out) :: eh_sing_Gam_A(nS,nS) @@ -31,33 +29,8 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing do b=nO+1,norb-nR jb = jb + 1 - ! do n=1,nS - ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - ! + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) - ! end do - - ! do n=1,nVVs - ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - ! + ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) - ! end do - - ! do n=1,nOOs - ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - ! - hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) - ! end do - - ! do n=1,nVVt - ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - ! + 3d0 * ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) - ! end do - - ! do n=1,nOOt - ! eh_sing_Gam_A(ia,jb) = eh_sing_Gam_A(ia,jb) & - ! - 3d0 * hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) - ! end do + eh_sing_Gam_A(ia,jb) = - 0.5d0*eh_sing_Phi(a,j,b,i) - 1.5d0*eh_trip_Phi(a,j,b,i) & + + 0.5d0*pp_sing_Phi(a,j,i,b) + 1.5d0*pp_trip_Phi(a,j,i,b) enddo enddo @@ -82,7 +55,6 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing ! Local variables integer :: i,a,j,b integer :: ia,jb - integer :: n ! Output variables double precision, intent(out) :: eh_sing_Gam_B(nS,nS) @@ -99,33 +71,8 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing do b=nO+1,norb-nR jb = jb + 1 - ! do n=1,nS - ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - ! + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - ! end do - - ! do n=1,nVVs - ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - ! + ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) - ! end do - - ! do n=1,nOOs - ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - ! - hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) - ! end do - - ! do n=1,nVVt - ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - ! + 3d0 * ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) - ! end do - - ! do n=1,nOOt - ! eh_sing_Gam_B(ia,jb) = eh_sing_Gam_B(ia,jb) & - ! - 3d0 * hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) - ! end do + eh_sing_Gam_B(ia,jb) = - 0.5d0*eh_sing_Phi(a,b,j,i) - 1.5d0*eh_trip_Phi(a,b,j,i) & + + 0.5d0*pp_sing_Phi(a,b,i,j) + 1.5d0*pp_trip_Phi(a,b,i,j) enddo enddo diff --git a/src/Parquet/R_eh_singlet_Phi.f90 b/src/Parquet/R_eh_singlet_Phi.f90 new file mode 100644 index 0000000..5971e26 --- /dev/null +++ b/src/Parquet/R_eh_singlet_Phi.f90 @@ -0,0 +1,38 @@ +subroutine R_eh_singlet_Phi(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_sing_Phi) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nS + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS+nS) + +! Local variables + integer :: p,q,r,s + integer :: n + +! Output variables + double precision,intent(out) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) + +! Initialization + eh_sing_Phi(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + ! do n=1,nS + ! eh_sing_Phi(p,q,r,s) = eh_sing_Phi(p,q,r,s) & + ! - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + ! - eh_sing_rho(p,r,n+nS)*eh_sing_rho(s,q,n+nS)/eh_sing_Om(n) + ! end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_singlet_Phi diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 index 796b810..a0e9ae3 100644 --- a/src/Parquet/R_eh_triplet_Gam.f90 +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -1,11 +1,11 @@ -subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_A) +subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_A) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) @@ -14,8 +14,6 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_s ! Local variables integer :: i,a,j,b integer :: ia,jb - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: eh_trip_Gam_A(nS,nS) @@ -32,33 +30,8 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_s do b=nO+1,norb-nR jb = jb + 1 - ! do n=1,nS - ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - ! + 0.5d0 * eh_sing_rho(b,a,n)*eh_sing_rho(j,i,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(a,b,n)*eh_sing_rho(i,j,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_trip_rho(b,a,n)*eh_trip_rho(j,i,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_trip_rho(a,b,n)*eh_trip_rho(i,j,n)/eh_trip_Om(n) - ! end do - - ! do n=1,nVVs - ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - ! - ee_sing_rho(a,j,n)*ee_sing_rho(i,b,n)/ee_sing_Om(n) - ! end do - - ! do n=1,nOOs - ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - ! + hh_sing_rho(a,j,n)*hh_sing_rho(i,b,n)/hh_sing_Om(n) - ! end do - - ! do n=1,nVVt - ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - ! + ee_trip_rho(a,j,n)*ee_trip_rho(i,b,n)/ee_trip_Om(n) - ! end do - - ! do n=1,nOOt - ! eh_trip_Gam_A(ia,jb) = eh_trip_Gam_A(ia,jb) & - ! - hh_trip_rho(a,j,n)*hh_trip_rho(i,b,n)/hh_trip_Om(n) - ! end do + eh_trip_Gam_A(ia,jb) = - 0.5d0*eh_sing_Phi(a,j,b,i) + 0.5d0*eh_trip_Phi(a,j,b,i) & + - 0.5d0*pp_sing_Phi(a,j,i,b) + 0.5d0*pp_trip_Phi(a,j,i,b) enddo enddo @@ -67,14 +40,13 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_s end subroutine R_eh_triplet_Gamma_A -subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_B) - +subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR,nS + integer,intent(in) :: nOrb,nC,nO,nR,nS double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) @@ -83,8 +55,6 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_s ! Local variables integer :: i,a,j,b integer :: ia,jb - integer :: n - double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: eh_trip_Gam_B(nS,nS) @@ -101,33 +71,8 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nV,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_s do b=nO+1,norb-nR jb = jb + 1 - ! do n=1,nS - ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - ! + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - ! end do - - ! do n=1,nVVs - ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - ! - ee_sing_rho(a,b,n)*ee_sing_rho(i,j,n)/ee_sing_Om(n) - ! end do - - ! do n=1,nOOs - ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - ! + hh_sing_rho(a,b,n)*hh_sing_rho(i,j,n)/hh_sing_Om(n) - ! end do - - ! do n=1,nVVt - ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - ! + ee_trip_rho(a,b,n)*ee_trip_rho(i,j,n)/ee_trip_Om(n) - ! end do - - ! do n=1,nOOt - ! eh_trip_Gam_B(ia,jb) = eh_trip_Gam_B(ia,jb) & - ! - hh_trip_rho(a,b,n)*hh_trip_rho(i,j,n)/hh_trip_Om(n) - ! end do + eh_trip_Gam_B(ia,jb) = - 0.5d0*eh_sing_Phi(a,b,j,i) + 0.5d0*eh_trip_Phi(a,b,j,i) & + - 0.5d0*pp_sing_Phi(a,b,i,j) + 0.5d0*pp_trip_Phi(a,b,i,j) enddo enddo diff --git a/src/Parquet/R_eh_triplet_Phi.f90 b/src/Parquet/R_eh_triplet_Phi.f90 new file mode 100644 index 0000000..a6ec43f --- /dev/null +++ b/src/Parquet/R_eh_triplet_Phi.f90 @@ -0,0 +1,38 @@ +subroutine R_eh_triplet_Phi(nOrb,nC,nR,nS,eh_trip_Om,eh_trip_rho,eh_trip_Phi) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nS + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS+nS) + +! Local variables + integer :: p,q,r,s + integer :: n + +! Output variables + double precision,intent(out) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) + +! Initialization + eh_trip_Phi(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + ! do n=1,nS + ! eh_trip_Phi(p,q,r,s) = eh_trip_Phi(p,q,r,s) & + ! - eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + ! - eh_trip_rho(p,r,n+nS)*eh_trip_rho(s,q,n+nS)/eh_trip_Om(n) + ! end do + + enddo + enddo + enddo + enddo + +end subroutine R_eh_triplet_Phi diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index 2a9fe2f..cd9987c 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -1,17 +1,17 @@ -subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nS,nOOs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_D) +subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nOOs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_D) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nS,nOOs + integer,intent(in) :: nOrb,nC,nO,nOOs double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: i,j,k,l integer :: ij,kl - integer :: n + double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_sing_Gam_D(nOOs,nOOs) @@ -34,19 +34,10 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nS,nOOs,eh_sing_Phi,eh_trip_Phi,pp_si do l=k,nO kl = kl +1 - ! do n=1,nS - ! pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl) & - ! - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) - ! end do + pp_sing_Gam_D(ij,kl) = 0.5d0*eh_sing_Phi(i,j,k,l) - 1.5d0*eh_trip_Phi(i,j,k,l) & + - 1.5d0*eh_sing_Phi(i,j,l,k) + 0.5d0*eh_trip_Phi(i,j,l,k) - ! pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) + pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) end do end do @@ -57,20 +48,20 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nS,nOOs,eh_sing_Phi,eh_trip_Phi,pp_si end subroutine -subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nS,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_C) +subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_C) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nO,nR,nS,nVVs + integer,intent(in) :: nOrb,nO,nR,nVVs double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,c,d integer :: ab,cd - integer :: n + double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_sing_Gam_C(nVVs,nVVs) @@ -93,19 +84,11 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nS,nVVs,eh_sing_Phi,eh_trip_Phi,pp_si do d=c,nOrb - nR cd = cd +1 - ! do n=1,nS - ! pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd) & - ! - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) - ! end do - ! pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) + pp_sing_Gam_C(ab,cd) = 0.5d0*eh_sing_Phi(a,b,c,d) - 1.5d0*eh_trip_Phi(a,b,c,d) & + - 1.5d0*eh_sing_Phi(a,b,d,c) + 0.5d0*eh_trip_Phi(a,b,d,c) + + pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) end do end do @@ -116,20 +99,20 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nS,nVVs,eh_sing_Phi,eh_trip_Phi,pp_si end subroutine -subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nS,nOOs,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_B) +subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nOOs,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nR,nS,nOOs,nVVs + integer,intent(in) :: nOrb,nC,nO,nR,nOOs,nVVs double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) ! Local variables integer :: a,b,i,j integer :: ab,ij - integer :: n + double precision,external :: Kronecker_delta ! Output variables double precision, intent(out) :: pp_sing_Gam_B(nVVs,nOOs) @@ -152,19 +135,10 @@ subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nS,nOOs,nVVs,eh_sing_Phi,eh_trip_P do j=i,nO ij = ij +1 - ! do n=1,nS - ! pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij) & - ! - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - ! + 1.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - ! + 1.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - ! end do + pp_sing_Gam_B(ab,ij) = 0.5d0*eh_sing_Phi(a,b,i,j) - 1.5d0*eh_trip_Phi(a,b,i,j) & + - 1.5d0*eh_sing_Phi(a,b,j,i) + 0.5d0*eh_trip_Phi(a,b,j,i) - ! pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) + pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) end do end do diff --git a/src/Parquet/R_pp_singlet_Phi.f90 b/src/Parquet/R_pp_singlet_Phi.f90 new file mode 100644 index 0000000..9a0f245 --- /dev/null +++ b/src/Parquet/R_pp_singlet_Phi.f90 @@ -0,0 +1,44 @@ +subroutine R_pp_singlet_Phi(nOrb,nC,nR,nOO,nVV,ee_sing_Om,ee_sing_rho,hh_sing_Om,hh_sing_rho,pp_sing_Phi) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nOO,nVV + double precision,intent(in) :: ee_sing_Om(nVV) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: hh_sing_Om(nOO) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOO) + +! Local variables + integer :: p,q,r,s + integer :: n + +! Output variables + double precision,intent(out) :: pp_sing_Phi(nOrb,nOrb,nOrb,nOrb) + +! Initialization + pp_sing_Phi(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nVV + pp_sing_Phi(p,q,r,s) = pp_sing_Phi(p,q,r,s) & + + ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) + end do + + do n=1,nOO + pp_sing_Phi(p,q,r,s) = pp_sing_Phi(p,q,r,s) & + - hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_pp_singlet_Phi diff --git a/src/Parquet/R_pp_triplet_Gam.f90 b/src/Parquet/R_pp_triplet_Gam.f90 index 973589f..75bdc24 100644 --- a/src/Parquet/R_pp_triplet_Gam.f90 +++ b/src/Parquet/R_pp_triplet_Gam.f90 @@ -1,10 +1,10 @@ -subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nS,nOOt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_D) +subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nOOt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_D) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nS,nOOt + integer,intent(in) :: nOrb,nC,nO,nOOt double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) @@ -34,20 +34,9 @@ subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nS,nOOt,eh_sing_Phi,eh_trip_Phi,pp_tr do l=k+1,nO kl = kl +1 - do n=1,nS - - ! pp_trip_Gam_D(ij,kl) = pp_trip_Gam_D(ij,kl) & - ! - 0.5d0 * eh_sing_rho(k,i,n)*eh_sing_rho(j,l,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(i,k,n)*eh_sing_rho(l,j,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_trip_rho(k,i,n)*eh_trip_rho(j,l,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_trip_rho(i,k,n)*eh_trip_rho(l,j,n)/eh_trip_Om(n) & - ! + 0.5d0 * eh_sing_rho(l,i,n)*eh_sing_rho(j,k,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(i,l,n)*eh_sing_rho(k,j,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_trip_rho(l,i,n)*eh_trip_rho(j,k,n)/eh_trip_Om(n) & - ! + 0.5d0 * eh_trip_rho(i,l,n)*eh_trip_rho(k,j,n)/eh_trip_Om(n) - - end do - + pp_trip_Gam_D(ij,kl) = 0.5d0*eh_sing_Phi(i,j,k,l) + 0.5d0*eh_trip_Phi(i,j,k,l) & + - 0.5d0*eh_sing_Phi(i,j,l,k) - 0.5d0*eh_trip_Phi(i,j,l,k) + end do end do end do @@ -57,13 +46,13 @@ subroutine R_pp_triplet_Gamma_D(nOrb,nC,nO,nS,nOOt,eh_sing_Phi,eh_trip_Phi,pp_tr end subroutine -subroutine R_pp_triplet_Gamma_C(nOrb,nO,nR,nS,nVVt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_C) +subroutine R_pp_triplet_Gamma_C(nOrb,nO,nR,nVVt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_C) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nO,nR,nS,nVVt + integer,intent(in) :: nOrb,nO,nR,nVVt double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) @@ -92,23 +81,13 @@ subroutine R_pp_triplet_Gamma_C(nOrb,nO,nR,nS,nVVt,eh_sing_Phi,eh_trip_Phi,pp_tr do c=nO+1,nOrb - nR do d=c+1,nOrb - nR cd = cd +1 - - do n=1,nS - - ! pp_trip_Gam_C(ab,cd) = pp_trip_Gam_C(ab,cd) & - ! - 0.5d0 * eh_sing_rho(c,a,n)*eh_sing_rho(b,d,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(a,c,n)*eh_sing_rho(d,b,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_trip_rho(c,a,n)*eh_trip_rho(b,d,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_trip_rho(a,c,n)*eh_trip_rho(d,b,n)/eh_trip_Om(n) & - ! + 0.5d0 * eh_sing_rho(d,a,n)*eh_sing_rho(b,c,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(a,d,n)*eh_sing_rho(c,b,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_trip_rho(d,a,n)*eh_trip_rho(b,c,n)/eh_trip_Om(n) & - ! + 0.5d0 * eh_trip_rho(a,d,n)*eh_trip_rho(c,b,n)/eh_trip_Om(n) - - end do + + pp_trip_Gam_C(ab,cd) = 0.5d0*eh_sing_Phi(a,b,c,d) + 0.5d0*eh_trip_Phi(a,b,c,d) & + - 0.5d0*eh_sing_Phi(a,b,d,c) - 0.5d0*eh_trip_Phi(a,b,d,c) end do end do + end do end do ! !$OMP END DO @@ -116,13 +95,13 @@ subroutine R_pp_triplet_Gamma_C(nOrb,nO,nR,nS,nVVt,eh_sing_Phi,eh_trip_Phi,pp_tr end subroutine -subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nS,nOOt,nVVt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_B) +subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nOOt,nVVt,eh_sing_Phi,eh_trip_Phi,pp_trip_Gam_B) ! Compute irreducible vertex in the triplet pp channel implicit none ! Input variables - integer,intent(in) :: nOrb,nC,nO,nR,nS,nOOt,nVVt + integer,intent(in) :: nOrb,nC,nO,nR,nOOt,nVVt double precision,intent(in) :: eh_sing_Phi(nOrb,nOrb,nOrb,nOrb) double precision,intent(in) :: eh_trip_Phi(nOrb,nOrb,nOrb,nOrb) @@ -152,19 +131,8 @@ subroutine R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nS,nOOt,nVVt,eh_sing_Phi,eh_trip_P do j=i+1,nO ij = ij +1 - do n=1,nS - - ! pp_trip_Gam_B(ab,ij) = pp_trip_Gam_B(ab,ij) & - ! - 0.5d0 * eh_sing_rho(i,a,n)*eh_sing_rho(b,j,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_sing_rho(a,i,n)*eh_sing_rho(j,b,n)/eh_sing_Om(n) & - ! - 0.5d0 * eh_trip_rho(i,a,n)*eh_trip_rho(b,j,n)/eh_trip_Om(n) & - ! - 0.5d0 * eh_trip_rho(a,i,n)*eh_trip_rho(j,b,n)/eh_trip_Om(n) & - ! + 0.5d0 * eh_sing_rho(j,a,n)*eh_sing_rho(b,i,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_sing_rho(a,j,n)*eh_sing_rho(i,b,n)/eh_sing_Om(n) & - ! + 0.5d0 * eh_trip_rho(j,a,n)*eh_trip_rho(b,i,n)/eh_trip_Om(n) & - ! + 0.5d0 * eh_trip_rho(a,j,n)*eh_trip_rho(i,b,n)/eh_trip_Om(n) - - end do + pp_trip_Gam_B(ab,ij) = 0.5d0*eh_sing_Phi(a,b,i,j) + 0.5d0*eh_trip_Phi(a,b,i,j) & + - 0.5d0*eh_sing_Phi(a,b,j,i) - 0.5d0*eh_trip_Phi(a,b,j,i) end do end do diff --git a/src/Parquet/R_pp_triplet_Phi.f90 b/src/Parquet/R_pp_triplet_Phi.f90 new file mode 100644 index 0000000..5af9613 --- /dev/null +++ b/src/Parquet/R_pp_triplet_Phi.f90 @@ -0,0 +1,44 @@ +subroutine R_pp_triplet_Phi(nOrb,nC,nR,nOO,nVV,ee_trip_Om,ee_trip_rho,hh_trip_Om,hh_trip_rho,pp_trip_Phi) + + +! Compute irreducible vertex in the triplet pp channel + implicit none + +! Input variables + integer,intent(in) :: nOrb,nC,nR,nOO,nVV + double precision,intent(in) :: ee_trip_Om(nVV) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: hh_trip_Om(nOO) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nOO) + +! Local variables + integer :: p,q,r,s + integer :: n + +! Output variables + double precision,intent(out) :: pp_trip_Phi(nOrb,nOrb,nOrb,nOrb) + +! Initialization + pp_trip_Phi(:,:,:,:) = 0d0 + + do s = nC+1, nOrb-nR + do r = nC+1, nOrb-nR + do q = nC+1, nOrb-nR + do p = nC+1, nOrb-nR + + do n=1,nVV + pp_trip_Phi(p,q,r,s) = pp_trip_Phi(p,q,r,s) & + + ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) + end do + + do n=1,nOO + pp_trip_Phi(p,q,r,s) = pp_trip_Phi(p,q,r,s) & + - hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) + end do + + enddo + enddo + enddo + enddo + +end subroutine R_pp_triplet_Phi diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index c9c5a74..4e2ad64 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -17,7 +17,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) rho(:,:,:) = 0d0 ! !$OMP PARALLEL & @@ -33,18 +33,20 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr do b=nO+1,nOrb-nR jb = jb + 1 - ! do ia=1,nS + do ia=1,nS - ! X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) - ! Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - ! rho(p,q,ia) = rho(p,q,ia) & - ! + (2d0*ERI(p,j,q,b) - ERI(p,j,b,q))*X & - ! + (2d0*ERI(p,b,q,j) - ERI(p,b,j,q))*Y & - ! + 1d0*eh_sing_Gam(p,j,q,b)*X & - ! + 1d0*eh_sing_Gam(p,b,q,j)*Y + rho(p,q,ia) = (2d0*ERI(q,j,p,b) - ERI(q,j,b,p) & + - 0.5d0*eh_sing_Phi(q,j,b,p) - 1.5d0*eh_trip_Phi(q,j,b,p) & + + 0.5d0*pp_sing_Phi(q,j,p,b) + 1.5d0*pp_trip_Phi(q,j,p,b)) * X - ! end do + rho(p,q,nS+ia) = (2d0*ERI(q,b,p,j) - ERI(q,b,j,p) & + - 0.5d0*eh_sing_Phi(q,b,j,p) - 1.5d0*eh_trip_Phi(q,b,j,p) & + + 0.5d0*pp_sing_Phi(q,b,p,j) + 1.5d0*pp_trip_Phi(q,b,p,j)) * Y + + end do end do end do @@ -75,7 +77,7 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) rho(:,:,:) = 0d0 ! !$OMP PARALLEL & @@ -85,24 +87,30 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr ! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR + jb = 0 do j=nC+1,nO do b=nO+1,nOrb-nR jb = jb + 1 + do ia=1,nS - ! X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) - ! Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) + X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) + Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - ! rho(p,q,ia) = rho(p,q,ia) & - ! - ERI(p,j,b,q)*X & - ! - ERI(p,b,j,q)*Y & - ! + 1d0*eh_trip_Gam(p,j,q,b)*X & - ! + 1d0*eh_trip_Gam(p,b,q,j)*Y + rho(p,q,ia) = (- ERI(q,j,b,p) & + - 0.5d0*eh_sing_Phi(q,j,b,p) + 0.5d0*eh_trip_Phi(q,j,b,p) & + - 0.5d0*pp_sing_Phi(q,j,p,b) + 0.5d0*pp_trip_Phi(q,j,p,b)) * X + + rho(p,q,nS+ia) = (- ERI(q,b,j,p) & + - 0.5d0*eh_sing_Phi(q,b,j,p) + 0.5d0*eh_trip_Phi(q,b,j,p) & + - 0.5d0*pp_sing_Phi(q,b,p,j) + 0.5d0*pp_trip_Phi(q,b,p,j)) * Y end do + end do end do + end do end do ! !$OMP END DO @@ -156,62 +164,71 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, ! !$OMP DO COLLAPSE(2) do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR - - ! ab = 0 - ! do a=nO+1,nOrb-nR - ! do b=a,nOrb-nR - ! ab = ab + 1 - ! cd = 0 - ! do c=nO+1,nOrb-nR - ! do d=c,nOrb-nR - ! cd = cd + 1 - ! rho1(p,q,ab) = rho1(p,q,ab) & - ! + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X1(cd,ab) & - ! /sqrt(1d0 + Kronecker_delta(c,d)) - ! end do - ! end do - - ! kl = 0 - ! do k=nC+1,nO - ! do l=k,nO - ! kl = kl + 1 - ! rho1(p,q,ab) = rho1(p,q,ab) & - ! + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y1(kl,ab) & - ! /sqrt(1d0 + Kronecker_delta(k,l)) - ! end do - ! end do + ab=0 + do a = nO+1, nOrb-nR + do b = a, nOrb-nR + ab = ab + 1 - ! end do - ! end do - - ! ij = 0 - ! do i=nC+1,nO - ! do j=i,nO - ! ij = ij + 1 + cd = 0 + do c = nO+1, nOrb-nR + do d = c, nOrb-nR + cd = cd + 1 + + rho1(p,q,ab) = (ERI(p,q,c,d) + ERI(p,q,d,c) & + + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & + - 1.5d0*eh_sing_Phi(p,q,d,c) + 0.5d0*eh_trip_Phi(p,q,d,c))& + *X1(cd,ab)/sqrt(1d0 + Kronecker_delta(c,d)) + + end do ! d + end do ! c + + kl = 0 + do k = nC+1, nO + do l = k, nO + + kl = kl + 1 + + rho1(p,q,ab) = (ERI(p,q,k,l) + ERI(p,q,l,k) & + + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & + - 1.5d0*eh_sing_Phi(p,q,l,k) + 0.5d0*eh_trip_Phi(p,q,l,k))& + *Y1(kl,ab)/sqrt(1d0 + Kronecker_delta(k,l)) + end do ! l + end do ! k + end do ! b + end do ! a + + ij = 0 + do i = nC+1, nO + do j = i, nO + ij = ij + 1 + + cd = 0 + do c = nO+1, nOrb-nR + do d = c, nOrb-nR + cd = cd + 1 + + rho2(p,q,ij) = (ERI(p,q,c,d) + ERI(p,q,d,c) & + + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & + - 1.5d0*eh_sing_Phi(p,q,d,c) + 0.5d0*eh_trip_Phi(p,q,d,c))& + *X2(cd,ij)/sqrt(1d0 + Kronecker_delta(c,d)) + end do ! d + end do ! c + + kl = 0 + do k = nC+1, nO + do l = k, nO + kl = kl + 1 + + rho2(p,q,ij) = (ERI(p,q,k,l) + ERI(p,q,l,k) & + + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & + - 1.5d0*eh_sing_Phi(p,q,l,k) + 0.5d0*eh_trip_Phi(p,q,l,k))& + *Y2(kl,ij)/sqrt(1d0 + Kronecker_delta(k,l)) + end do ! l + end do ! k - ! cd = 0 - ! do c=nO+1,nOrb-nR - ! do d=c,nOrb-nR - ! cd = cd + 1 - ! rho2(p,q,ij) = rho2(p,q,ij) & - ! + (ERI(p,q,c,d) + ERI(p,q,d,c) + 1d0*pp_sing_Gam(p,q,c,d))*X2(cd,ij) & - ! /sqrt(1d0 + Kronecker_delta(c,d)) - ! end do - ! end do - - ! kl = 0 - ! do k=nC+1,nO - ! do l=k,nO - ! kl = kl + 1 - ! rho2(p,q,ij) = rho2(p,q,ij) & - ! + (ERI(p,q,k,l) + ERI(p,q,l,k) + 1d0*pp_sing_Gam(p,q,k,l))*Y2(kl,ij) & - ! /sqrt(1d0 + Kronecker_delta(k,l)) - ! end do - ! end do - - ! end do - ! end do + end do ! j + end do ! i end do end do @@ -264,62 +281,67 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, ! !$OMP DO COLLAPSE(2) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR + ab = 0 - - ! do a = nO+1, nOrb-nR - ! do b = a+1, nOrb-nR - ! ab = ab + 1 + do a = nO+1, nOrb-nR + do b = a+1, nOrb-nR + ab = ab + 1 - ! cd = 0 - ! do c = nO+1, nOrb-nR - ! do d = c+1, nOrb-nR - ! cd = cd + 1 + cd = 0 + do c = nO+1, nOrb-nR + do d = c+1, nOrb-nR + cd = cd + 1 - ! rho1(p,q,ab) = rho1(p,q,ab) & - ! + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X1(cd,ab) - ! end do ! d - ! end do ! c + rho1(p,q,ab) = (ERI(p,q,c,d) - ERI(p,q,d,c) & + + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & + - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(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 = 0 + do k = nC+1, nO + do l = k+1, nO - ! kl = kl + 1 + kl = kl + 1 - ! rho1(p,q,ab) = rho1(p,q,ab) & - ! + (ERI(p,q,k,l) - ERI(p,q,l,k) + 1d0*pp_trip_Gam(p,q,k,l))*Y1(kl,ab) - ! end do ! l - ! end do ! k - ! end do ! b - ! end do ! a + rho1(p,q,ab) = (ERI(p,q,k,l) - ERI(p,q,l,k) & + + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & + - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(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 + ij = 0 + do i = nC+1, nO + do j = i+1, nO + ij = ij + 1 - ! cd = 0 - ! do c = nO+1, nOrb-nR - ! do d = c+1, nOrb-nR - ! cd = cd + 1 + cd = 0 + do c = nO+1, nOrb-nR + do d = c+1, nOrb-nR + cd = cd + 1 - ! rho2(p,q,ij) = rho2(p,q,ij) & - ! + (ERI(p,q,c,d) - ERI(p,q,d,c) + 1d0*pp_trip_Gam(p,q,c,d))*X2(cd,ij) - ! end do ! d - ! end do ! c + rho2(p,q,ij) = (ERI(p,q,c,d) - ERI(p,q,d,c) & + + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & + - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(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 + 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) + 1d0*pp_trip_Gam(p,q,k,l))*Y2(kl,ij) - ! end do ! l - ! end do ! k + rho2(p,q,ij) = (ERI(p,q,k,l) - ERI(p,q,l,k) & + + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & + - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) + end do ! l + end do ! k - ! end do ! j - ! end do ! i + end do ! j + end do ! i end do ! p end do ! q From 7e1ea324b714803f74d291ab4a80684860e42230 Mon Sep 17 00:00:00 2001 From: pfloos Date: Wed, 26 Mar 2025 17:14:52 +0100 Subject: [PATCH 24/71] trying to fix tests --- tests/inp/methods.RHF | 10 ++++++---- tests/inp/options.RHF | 12 ++++++++---- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/tests/inp/methods.RHF b/tests/inp/methods.RHF index 2ddb2bb..f449c96 100644 --- a/tests/inp/methods.RHF +++ b/tests/inp/methods.RHF @@ -1,5 +1,5 @@ -# RHF UHF GHF ROHF - T F F F +# RHF UHF GHF ROHF HFB + T F F F F # MP2 MP3 T T # CCD pCCD DCD CCSD CCSD(T) @@ -12,11 +12,13 @@ T T T T # G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3 T F F F F F -# G0W0 evGW qsGW SRG-qsGW ufG0W0 ufGW - T T F F F F +# G0W0 evGW qsGW ufG0W0 ufGW + T T F F F # G0T0pp evGTpp qsGTpp ufG0T0pp T F F F # G0T0eh evGTeh qsGTeh F F F +# Parquet + F # Rtest Utest Gtest T F F diff --git a/tests/inp/options.RHF b/tests/inp/options.RHF index 92084cd..85ba948 100644 --- a/tests/inp/options.RHF +++ b/tests/inp/options.RHF @@ -1,11 +1,11 @@ -# HF: maxSCF thresh DIIS guess mix shift stab search - 10000 0.0000001 5 1 0.0 0.0 F F +# 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 +# LR: 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 @@ -16,3 +16,7 @@ F F T # BSE: phBSE phBSE2 ppBSE dBSE dTDA F F F F T +# HFB: temperature sigma chem_pot_HF restart_HFB + 0.05 1.00 T F +# Parquet: max_it_macro conv_one_body max_it_micro conv_two_body + 1 0.00001 1 0 0.00001 From 65a84fcb5bb108bb0232cbb92d6103446470d548 Mon Sep 17 00:00:00 2001 From: pfloos Date: Wed, 26 Mar 2025 17:24:49 +0100 Subject: [PATCH 25/71] remove unnecessary files --- GoHu | 13 -- input/basis.Hu | 6 - input/molecule.Hu | 5 - input/sph | 2 - scripts/PyDuck | 321 -------------------------------- scripts/PyOptions.json | 145 --------------- scripts/PyOptions.template.json | 145 --------------- scripts/extract.sh | 229 ----------------------- scripts/run_sph.sh | 41 ---- scripts/scan_w.sh | 119 ------------ utils/fsplit | Bin 31968 -> 0 bytes 11 files changed, 1026 deletions(-) delete mode 100755 GoHu delete mode 100644 input/basis.Hu delete mode 100644 input/molecule.Hu delete mode 100644 input/sph delete mode 100755 scripts/PyDuck delete mode 100644 scripts/PyOptions.json delete mode 100644 scripts/PyOptions.template.json delete mode 100755 scripts/extract.sh delete mode 100755 scripts/run_sph.sh delete mode 100755 scripts/scan_w.sh delete mode 100755 utils/fsplit diff --git a/GoHu b/GoHu deleted file mode 100755 index f795b6b..0000000 --- a/GoHu +++ /dev/null @@ -1,13 +0,0 @@ -#! /bin/bash - -cp input/molecule.Hu input/molecule -cp input/basis.Hu input/basis -cp int/nBas.Hu.dat int/nBas.dat -cp int/ERI.Hu.dat int/ERI.dat -cp int/Kin.Hu.dat int/Kin.dat -cp int/Nuc.Hu.dat int/Nuc.dat -cp int/Ov.Hu.dat int/Ov.dat -cp int/x.Hu.dat int/x.dat -cp int/y.Hu.dat int/y.dat -cp int/z.Hu.dat int/z.dat -./bin/QuAcK diff --git a/input/basis.Hu b/input/basis.Hu deleted file mode 100644 index bbcbbde..0000000 --- a/input/basis.Hu +++ /dev/null @@ -1,6 +0,0 @@ -1 1 -S 1 - 1 1.0000000000e+00 1.0000000000e+00 -2 1 -S 1 - 1 1.0000000000e+00 1.0000000000e+00 diff --git a/input/molecule.Hu b/input/molecule.Hu deleted file mode 100644 index 17c73c7..0000000 --- a/input/molecule.Hu +++ /dev/null @@ -1,5 +0,0 @@ -# nAt nEla nElb nCore nRyd - 2 1 1 0 0 -# Znuc x y z - X 0.0000000000 0.0000000000 0.0000000000 - X 0.0000000000 0.0000000000 1.0000000000 diff --git a/input/sph b/input/sph deleted file mode 100644 index d60b6fd..0000000 --- a/input/sph +++ /dev/null @@ -1,2 +0,0 @@ -# rs - 1.0 diff --git a/scripts/PyDuck b/scripts/PyDuck deleted file mode 100755 index 25016c9..0000000 --- a/scripts/PyDuck +++ /dev/null @@ -1,321 +0,0 @@ -#!/usr/bin/env python2 -import sys -from termcolor import colored -import shlex -from subprocess import Popen, PIPE -import itertools -import re -import numpy as np -import os -from shutil import copy2 -import matplotlib.pyplot as plt -import json -from math import * -from collections import OrderedDict -import csv -import argparse -def GetDuckDir(): - return os.path.dirname(os.path.realpath(__file__)) - -def nNucl(molbaselines): - return float(molbaselines[1].split()[0]) - -def isMononucle(molbaselines): - return nNucl(molbaselines)==1 - -def openfileindir(path,readwrite): - mydir=os.path.dirname(path) - if not os.path.exists(mydir) and mydir!="": - os.makedirs(mydir) - return open(path,readwrite) -def outfile(Outdic,item,index=None): - itemdata=Outdic[item] - if itemdata["Enabled"]: - fmt=itemdata["Format"] - if index is not None: - filename=fmt.format(index) - else: - filename=fmt - if "Parent" in Outdic: - path=os.path.join(Outdic["Parent"],filename) - else: - path=filename - return openfileindir(path,'w') - else: - return - -def runDuck(mol,basis,x,molbaselines,molbase,basisbase): - #gennerate molecule file - currdir=os.getcwd() - os.chdir(GetDuckDir()) - molname='.'.join([mol,str(x)]) - lstw=list() - for i,line in enumerate(molbaselines): - if i<3: - lstw.append(line) - else: - if isMononucle(molbaselines): - if i==3: - lstw.append(' '.join([str(x)]+line.split()[1:])) - else: - v=[float(abs(x))/float(2),float(-abs(x)/float(2))] - val=v[i-3] - lstw.append(' '.join([line.split()[0],'0.','0.',str(val)])) - junkfiles=list() - with open(molbase+molname,'w') as n: - junkfiles.append(n.name) - n.write(os.linesep.join(lstw)) - #Copy basis - basisfile=basisbase+'.'.join([mol,basis]) - newbasisfile=basisbase+'.'.join([molname,basis]) - copy2(basisfile,newbasisfile) - junkfiles.append(newbasisfile) - #start child process Goduck - cmd=" ".join(["./GoDuck",molname, basis]) - Duck=Popen(shlex.split(cmd),stdout=PIPE) - (DuckOut, DuckErr) = Duck.communicate() - excode=Duck.wait() - for junk in junkfiles: - os.remove(junk) - os.chdir(currdir) - return (excode,DuckOut,DuckErr) - -def addvalue(dic,key,x,y): - if key not in dic: - dic[key]=list() - dic[key].append(y) - print(key) - print(x,y) - -def main(mol): - #get basepath for files - molbase='examples/molecule.' - basisbase=molbase.replace('molecule','basis') - with open('PyOptions.json','r') as jfile: - options=json.loads(jfile.read()) - basis=str(options['Basis']) - #Get mehtod to analyse - methodsdic=options['Methods'] - #Get datas to analyse in this method - scandic=options['Scan'] - scan=np.arange(scandic['Start'],scandic['Stop']+scandic['Step'],scandic['Step']) - print(scan) - mymethods=dict() - alllabels=list() - for method,methoddatas in methodsdic.iteritems(): - if methoddatas['Enabled']: - mymethods[method]=methoddatas - for label,labeldatas in methoddatas['Labels'].iteritems(): - if type(labeldatas) is dict: - enabled=labeldatas['Enabled'] - else: - enabled=labeldatas - if enabled and label not in alllabels: - alllabels.append(label) - graphdic=dict() - errorconvstring="Convergence failed" - with open(os.path.join(GetDuckDir(),molbase+mol),'r') as b: - molbaselines=b.read().splitlines() - if isMononucle(molbaselines): - print('monoatomic system: variation of the nuclear charge') - else: - print('polyatomic system: variation is on the distance') - for x in scan: - (DuckExit,DuckOut,DuckErr)=runDuck(mol,basis,x,molbaselines,molbase,basisbase) - #print DuckOut on file or not - if "Outputs" in options: - outdat=options["Outputs"] - if 'DuckOutput' in outdat: - outopt=outdat["DuckOutput"] - if outopt['Enabled']: - if outopt['Multiple']: - duckoutf=outfile(outopt,"DuckOutput",x) - else: - if x==scan[0]: - duckoutf=outfile(outdat,"DuckOutput") - duckoutf.write('Z' if isMononucle(molbaselines) else 'Distance'+' '+str(x)+os.linesep+os.linesep) - duckoutf.write(DuckOut) - if outopt['Multiple']: - duckoutf.close() - print("GoDuk exit code " + str(DuckExit)) - if DuckExit !=0: - #if GoDuck is not happy - print(DuckErr) - sys.exit(-1) - #get all data for the method - for method,methoddatas in mymethods.iteritems(): - isnan=False - if '{0}' in method: - if "index" in methoddatas: - methodheaders=[method.format(str(x)) for x in methoddatas['Index']] - else: - try: - print(method) - reglist=re.findall('(\d+)'.join([re.escape(s) for s in method.split('{0}')]),DuckOut) - print(reglist) - final=max([(int(i[0]) if type(i) is tuple else int(i)) for i in reglist]) - print(final) - methodheaders=[method.format(str(final))] - except: - isnan=True - methodheaders=[None] - method=method.replace('{0}','') - else: - methodheaders=list([method]) - for methodheader in methodheaders: - if len(methodheaders)!=1: - method=methodheader - lbldic=methoddatas['Labels'] - print(methodheader) - if methodheader is None: - methodtxt='' - else: - it=itertools.dropwhile(lambda line: methodheader + ' calculation' not in line , DuckOut.splitlines()) - it=itertools.takewhile(lambda line: 'Total CPU time for ' not in line, it) - methodtxt=os.linesep.join(it) - if errorconvstring in methodtxt: - print(colored(' '.join([method, errorconvstring, '!!!!!']),'red')) - isnan=True - if methodtxt=='': - print(colored('No data' +os.linesep+ 'RHF scf not converged or method not enabled','red')) - isnan=True - #find the expected values - for label,labeldatas in lbldic.iteritems(): - if type(labeldatas) is dict: - indexed=('Index' in labeldatas) - enabled=labeldatas['Enabled'] - graph=labeldatas['Graph'] if 'Graph' in labeldatas else 1 - else: - enabled=labeldatas - graph=1 - indexed=False - if enabled: - if graph not in graphdic: - graphdic[graph]=OrderedDict() - y=graphdic[graph] - if not indexed: - v=np.nan - print(method) - print(label) - if not isnan: - try: - m=re.search('\s+'.join([re.escape(w) for w in label.split()]) + "\s+(?:"+re.escape("(eV):")+"\s+)?(?:=\s+)?(-?\d+.?\d*)",methodtxt) - v=m.group(1) - except: - v=np.nan - addvalue(y,(method,label),x,v) - else: - startindex=-1 - columnindex=-1 - linedtxt=methodtxt.split(os.linesep) - for n,line in enumerate(linedtxt): - if all(x in line for x in ['|',' '+label+' ','#']): - startindex=n+2 - columnindex=[s.strip() for s in line.split('|')].index(label) - break - with open(os.path.join(GetDuckDir(),'input','molecule'),'r') as molfile: - molfile.readline() - line=molfile.readline() - nel=int(line.split()[1]) - print(nel) - HOMO=int(nel/2) - HO=HOMO - LUMO=HOMO+1 - BV=LUMO - for i in labeldatas['Index']: - v=np.nan - if type(i) is str or type(i) is unicode: - ival=eval(i) - if type(ival) is not int: - print('Index '+ str(i) + 'must be integer') - sys.exit(-2) - else: - ival=i - v=np.nan - if not isnan: - try: - if startindex!=-1 and columnindex!=-1: - line=linedtxt[startindex+ival-1] - v=float(line.split('|')[columnindex].split()[0]) - print(method) - print(label) - print(i) - else: - v=np.nan - except: - v=np.nan - key=(method,label,i) - addvalue(y,key,x,v) - tpl=(x,scan.tolist().index(x)+1,len(y[key])) - print(tpl) - if tpl[1]-tpl[2]: - sys.exit() - #define graph grid - maxgraph=max(graphdic.keys()) - maxrow=int(round(sqrt(maxgraph))) - maxcol=int(ceil(float(maxgraph)/float(maxrow))) - #define label ls - for graph,y in graphdic.iteritems(): - datas=list() - datas.append(["#x"]+scan.tolist()) - if len(y.keys())!=0: - plt.subplot(maxrow,maxcol,graph) - plt.xlabel('Z' if isMononucle(molbaselines) else 'Distance '+mol) - ylbls=list([basis]) - for i in range(0,2): - lst=list(set([key[i] for key in y.keys()])) - if len(lst)==1: - ylbls.append(lst[0]) - plt.ylabel(' '.join(ylbls)) - print('Legend') - print(list(y.keys())) - for key,values in y.iteritems(): - legend=list() - for el in key[0:2]: - if el not in ylbls: - legend.append(el) - if len(key)>2: - legend.append(str(key[2])) - #plot curves - lbl=' '.join(legend) - plt.plot(scan,y[key],'-o',label=lbl) - #print("min",x[y.index(min(y))]/2) - #generate legends - plt.legend() - dataout=False - if "Outputs" in options: - outputs=options['Outputs'] - if "DataOutput" in outputs: - DataOutput=outputs['DataOutput'] - dataout=DataOutput['Enabled'] - if dataout: - fmtlegendf='{0}({1})' - datas.append([fmtlegendf.format("y",lbl)]+y[key]) - if dataout: - csvdatas=zip(*datas) - with outfile(outputs,"DataOutput",graph) as csvf: - writer = csv.writer(csvf, delimiter=' ') - writer.writerow(['#']+ylbls) - writer.writerows(csvdatas) - #show graph - if "Outputs" in options: - outputs=options['Outputs'] - if "FigureOutput" in outputs: - figout=outputs["FigureOutput"] - if figout["Enabled"]: - plt.savefig(figout['Path']) - plt.show() -if __name__ == '__main__': - parser=argparse.ArgumentParser() - parser.add_argument("mol",nargs='?', help="molecule to compute",type=str) - parser.add_argument("-c,--copy", help="Copy sample option file",action="store_true",dest="copy") - args = parser.parse_args() - if len(sys.argv)==1: - parser.print_help() - else: - if args.copy: - copy2(os.path.join(GetDuckDir(),"PyOptions.template.json"),"PyOptions.json") - if args.mol is not None: - os.system("vim PyOptions.json") - if args.mol is not None: - main(args.mol) diff --git a/scripts/PyOptions.json b/scripts/PyOptions.json deleted file mode 100644 index 055b3aa..0000000 --- a/scripts/PyOptions.json +++ /dev/null @@ -1,145 +0,0 @@ -{ - "Scan": { - "Start":1.8, - "Stop":1.9, - "Step":0.1 - }, - "Basis":"VDZ", - "Outputs": { - "DataOutput": { - "Enabled":true, - "Format":"Duck{0}.dat" - }, - "DuckOutput": { - "Enabled":true, - "Multiple":false, - "Format":"DuckOut.out" - }, - "FigureOutput":{ - "Enabled":false, - "Path":"Figure.png" - } - }, - "Methods": { - "RHF":{ - "Enabled": true, - "Labels": { - "One-electron energy":false, - "Kinetic energy":false, - "Potential energy":false, - "Two-electron energy":false, - "Coulomb energy":false, - "Exchange energy":false, - "Electronic energy":false, - "Nuclear repulsion":false, - "Hartree-Fock energy":true, - "HF HOMO energy":false, - "HF LUMO energy":false, - "HF HOMO-LUMO gap":false - } - }, - "One-shot G0W0": { - "Enabled": true, - "Labels": { - "G0W0 HOMO energy":true, - "G0W0 LUMO energy":true, - "G0W0 HOMO-LUMO gap":false, - "G0W0 total energy":false, - "RPA correlation energy" :false, - "Z": { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":1 - }, - "Sigma_c (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":2 - }, - "e_QP (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO+1","LUMO+2"], - "Graph":3 - }, - "e_HF (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":4 - } - } - }, - "Self-consistent evG{0}W{0}": { - "Enabled":false, - "Labels": { - "evGW HOMO energy":false, - "evGW LUMO energy":false, - "evGW HOMO-LUMO gap":false, - "evGW total energy":false, - "RPA correlation energy" :false, - "Z": { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":1 - }, - "Sigma_c (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":2 - }, - "e_QP (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":3 - }, - "e_HF (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":4 - } - } - }, - "Self-consistent qsG{0}W{0}": { - "Enabled": false, - "Labels": { - "qsGW HOMO energy":false, - "qsGW LUMO energy":false, - "qsGW HOMO-LUMO gap":false, - "qsGW total energy":false, - "qsGW exchange energy":false, - "qsGW correlation energy":false, - "RPA correlation energy":{ - "Enabled":false, - "Graph":2 - }, - "Z": { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":4 - }, - "e_QP-e_HF (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":5 - }, - "e_QP (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":6 - } - } - }, - "MP2": { - "Enabled": false, - "Labels": { - "MP2 correlation energy": { - "Enabled":true, - "Graph":4 - }, - "Direct part":false, - "Exchange part":false, - "MP2 total energy":true, - "MP2 energy":false - } - } - } -} diff --git a/scripts/PyOptions.template.json b/scripts/PyOptions.template.json deleted file mode 100644 index 055b3aa..0000000 --- a/scripts/PyOptions.template.json +++ /dev/null @@ -1,145 +0,0 @@ -{ - "Scan": { - "Start":1.8, - "Stop":1.9, - "Step":0.1 - }, - "Basis":"VDZ", - "Outputs": { - "DataOutput": { - "Enabled":true, - "Format":"Duck{0}.dat" - }, - "DuckOutput": { - "Enabled":true, - "Multiple":false, - "Format":"DuckOut.out" - }, - "FigureOutput":{ - "Enabled":false, - "Path":"Figure.png" - } - }, - "Methods": { - "RHF":{ - "Enabled": true, - "Labels": { - "One-electron energy":false, - "Kinetic energy":false, - "Potential energy":false, - "Two-electron energy":false, - "Coulomb energy":false, - "Exchange energy":false, - "Electronic energy":false, - "Nuclear repulsion":false, - "Hartree-Fock energy":true, - "HF HOMO energy":false, - "HF LUMO energy":false, - "HF HOMO-LUMO gap":false - } - }, - "One-shot G0W0": { - "Enabled": true, - "Labels": { - "G0W0 HOMO energy":true, - "G0W0 LUMO energy":true, - "G0W0 HOMO-LUMO gap":false, - "G0W0 total energy":false, - "RPA correlation energy" :false, - "Z": { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":1 - }, - "Sigma_c (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":2 - }, - "e_QP (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO+1","LUMO+2"], - "Graph":3 - }, - "e_HF (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":4 - } - } - }, - "Self-consistent evG{0}W{0}": { - "Enabled":false, - "Labels": { - "evGW HOMO energy":false, - "evGW LUMO energy":false, - "evGW HOMO-LUMO gap":false, - "evGW total energy":false, - "RPA correlation energy" :false, - "Z": { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":1 - }, - "Sigma_c (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":2 - }, - "e_QP (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":3 - }, - "e_HF (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":4 - } - } - }, - "Self-consistent qsG{0}W{0}": { - "Enabled": false, - "Labels": { - "qsGW HOMO energy":false, - "qsGW LUMO energy":false, - "qsGW HOMO-LUMO gap":false, - "qsGW total energy":false, - "qsGW exchange energy":false, - "qsGW correlation energy":false, - "RPA correlation energy":{ - "Enabled":false, - "Graph":2 - }, - "Z": { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":4 - }, - "e_QP-e_HF (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":5 - }, - "e_QP (eV)" : { - "Enabled":true, - "Index":["HOMO","LUMO","LUMO+1","LUMO+2"], - "Graph":6 - } - } - }, - "MP2": { - "Enabled": false, - "Labels": { - "MP2 correlation energy": { - "Enabled":true, - "Graph":4 - }, - "Direct part":false, - "Exchange part":false, - "MP2 total energy":true, - "MP2 energy":false - } - } - } -} diff --git a/scripts/extract.sh b/scripts/extract.sh deleted file mode 100755 index 824fdfc..0000000 --- a/scripts/extract.sh +++ /dev/null @@ -1,229 +0,0 @@ -#! /bin/bash - -INPUT=$1 - - echo - echo '******************************************' - echo '*** Extracting information of' $INPUT ' ***' - echo '******************************************' - echo - - echo - echo '*** WFT information ***' - echo - grep "Hartree-Fock energy" $INPUT - EHF=`grep "Hartree-Fock energy" $INPUT | cut -f2 -d"="` - grep "MP2 correlation energy" $INPUT - EcMP2=`grep "MP2 correlation energy" $INPUT | cut -f2 -d"="` - grep "Ec(MP2) =" $INPUT - grep "Ec(CCD) =" $INPUT - grep "Ec(CCSD) =" $INPUT - grep "Ec(CCSD(T)) =" $INPUT - -# echo -# echo '*** Gap information: HF, G0F2, GF2, G0W0 & evGW ***' -# HF=`grep "HF HOMO-LUMO gap (eV):" $INPUT | cut -f2 -d":"` -# G0F2=`grep "GF2 HOMO-LUMO gap (eV):" $INPUT | head -1 | cut -f2 -d":"` -# GF2=`grep "GF2 HOMO-LUMO gap (eV):" $INPUT | tail -1 | cut -f2 -d":"` -# G0W0=`grep "G0W0 HOMO-LUMO gap (eV):" $INPUT | cut -f2 -d":"` -# evGW=`grep "evGW HOMO-LUMO gap (eV):" $INPUT | tail -1 | cut -f2 -d":"` - -# echo -e "\t" $HF "\t" $G0F2 "\t" $GF2 "\t" $G0W0 "\t" $evGW - - echo - echo '*** RPA information: Tr@RPA (singlet), Tr@RPA (triplet), AC@RPA (singlet), AC@RPA (triplet) ***' - echo - Tr_RPA_1=`grep "Tr@RPA correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_RPA_3=`grep "Tr@RPA correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - AC_RPA_1=`grep "AC@RPA correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - AC_RPA_3=`grep "AC@RPA correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - - echo -e "\t" $Tr_RPA_1 "\t" $Tr_RPA_3 "\t" $AC_RPA_1 "\t" $AC_RPA_3 - - echo - echo '*** RPAx information: Tr@RPAx (singlet), Tr@RPAx (triplet), AC@RPAx (singlet), AC@RPAx (triplet) ***' - echo - Tr_RPAx_1=`grep "Tr@RPAx correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_RPAx_3=`grep "Tr@RPAx correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - AC_RPAx_1=`grep "AC@RPAx correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - AC_RPAx_3=`grep "AC@RPAx correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - - echo -e "\t" $Tr_RPAx_1 "\t" $Tr_RPAx_3 "\t" $AC_RPAx_1 "\t" $AC_RPAx_3 - - echo - echo '*** G0W0 information: Tr@RPA (singlet), Tr@RPA (triplet), Tr@BSE (singlet), Tr@BSE (triplet), AC@BSE (singlet), AC@BSE (triplet) ***' - echo - Tr_RPA_G0W0_1=`grep "Tr@RPA@G0W0 correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_RPA_G0W0_3=`grep "Tr@RPA@G0W0 correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - Tr_BSE_G0W0_1=`grep "Tr@BSE@G0W0 correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_BSE_G0W0_3=`grep "Tr@BSE@G0W0 correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - AC_BSE_G0W0_1=`grep "AC@BSE@G0W0 correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - AC_BSE_G0W0_3=`grep "AC@BSE@G0W0 correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - - echo -e "\t" $Tr_RPA_G0W0_1 "\t" $Tr_RPA_G0W0_3 "\t" $Tr_BSE_G0W0_1 "\t" $Tr_BSE_G0W0_3 "\t" $AC_BSE_G0W0_1 "\t" $AC_BSE_G0W0_3 - - echo - echo '*** evGW information: Tr@RPA (singlet), Tr@RPA (triplet), Tr@BSE (singlet), Tr@BSE (triplet), AC@BSE (singlet), AC@BSE (triplet) ***' - echo - Tr_RPA_evGW_1=`grep "Tr@RPA@evGW correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_RPA_evGW_3=`grep "Tr@RPA@evGW correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - Tr_BSE_evGW_1=`grep "Tr@BSE@evGW correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_BSE_evGW_3=`grep "Tr@BSE@evGW correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - AC_BSE_evGW_1=`grep "AC@BSE@evGW correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - AC_BSE_evGW_3=`grep "AC@BSE@evGW correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - - echo -e "\t" $Tr_RPA_evGW_1 "\t" $Tr_RPA_evGW_3 "\t" $Tr_BSE_evGW_1 "\t" $Tr_BSE_evGW_3 "\t" $AC_BSE_evGW_1 "\t" $AC_BSE_evGW_3 - - - echo - echo '*** qsGW information: Tr@RPA (singlet), Tr@RPA (triplet), Tr@BSE (singlet), Tr@BSE (triplet), AC@BSE (singlet), AC@BSE (triplet) ***' - echo - Tr_RPA_qsGW_1=`grep "Tr@RPA@qsGW correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_RPA_qsGW_3=`grep "Tr@RPA@qsGW correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - Tr_BSE_qsGW_1=`grep "Tr@BSE@qsGW correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - Tr_BSE_qsGW_3=`grep "Tr@BSE@qsGW correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - AC_BSE_qsGW_1=`grep "AC@BSE@qsGW correlation energy (singlet) =" $INPUT| cut -f2 -d"="` - AC_BSE_qsGW_3=`grep "AC@BSE@qsGW correlation energy (triplet) =" $INPUT| cut -f2 -d"="` - - echo -e "\t" $Tr_RPA_qsGW_1 "\t" $Tr_RPA_qsGW_3 "\t" $Tr_BSE_qsGW_1 "\t" $Tr_BSE_qsGW_3 "\t" $AC_BSE_qsGW_1 "\t" $AC_BSE_qsGW_3 - - echo - echo '*** CIS excitation energy (singlet & triplet) ***' - echo - - CIS_1_1=`grep "| 1 |" $INPUT | head -1 | cut -f3 -d"|"` - CIS_1_2=`grep "| 2 |" $INPUT | head -1 | cut -f3 -d"|"` - CIS_1_3=`grep "| 3 |" $INPUT | head -1 | cut -f3 -d"|"` - CIS_1_4=`grep "| 4 |" $INPUT | head -1 | cut -f3 -d"|"` - CIS_1_5=`grep "| 5 |" $INPUT | head -1 | cut -f3 -d"|"` - - CIS_3_1=`grep "| 1 |" $INPUT | head -2 | tail -1 | cut -f3 -d"|"` - CIS_3_2=`grep "| 2 |" $INPUT | head -2 | tail -1 | cut -f3 -d"|"` - CIS_3_3=`grep "| 3 |" $INPUT | head -2 | tail -1 | cut -f3 -d"|"` - CIS_3_4=`grep "| 4 |" $INPUT | head -2 | tail -1 | cut -f3 -d"|"` - CIS_3_5=`grep "| 5 |" $INPUT | head -2 | tail -1 | cut -f3 -d"|"` - - echo -e "\t" $CIS_1_1 "\t" $CIS_3_1 - echo -e "\t" $CIS_1_2 "\t" $CIS_3_2 - echo -e "\t" $CIS_1_3 "\t" $CIS_3_3 - echo -e "\t" $CIS_1_4 "\t" $CIS_3_4 - echo -e "\t" $CIS_1_5 "\t" $CIS_3_5 - - echo - echo '*** RPA excitation energy (singlet & triplet) ***' - echo - - RPA_1_1=`grep "| 1 |" $INPUT | head -3 | tail -1 | cut -f3 -d"|"` - RPA_1_2=`grep "| 2 |" $INPUT | head -3 | tail -1 | cut -f3 -d"|"` - RPA_1_3=`grep "| 3 |" $INPUT | head -3 | tail -1 | cut -f3 -d"|"` - RPA_1_4=`grep "| 4 |" $INPUT | head -3 | tail -1 | cut -f3 -d"|"` - RPA_1_5=`grep "| 5 |" $INPUT | head -3 | tail -1 | cut -f3 -d"|"` - - RPA_3_1=`grep "| 1 |" $INPUT | head -4 | tail -1 | cut -f3 -d"|"` - RPA_3_2=`grep "| 2 |" $INPUT | head -4 | tail -1 | cut -f3 -d"|"` - RPA_3_3=`grep "| 3 |" $INPUT | head -4 | tail -1 | cut -f3 -d"|"` - RPA_3_4=`grep "| 4 |" $INPUT | head -4 | tail -1 | cut -f3 -d"|"` - RPA_3_5=`grep "| 5 |" $INPUT | head -4 | tail -1 | cut -f3 -d"|"` - - echo -e "\t" $RPA_1_1 "\t" $RPA_3_1 - echo -e "\t" $RPA_1_2 "\t" $RPA_3_2 - echo -e "\t" $RPA_1_3 "\t" $RPA_3_3 - echo -e "\t" $RPA_1_4 "\t" $RPA_3_4 - echo -e "\t" $RPA_1_5 "\t" $RPA_3_5 - - echo - echo '*** RPAx excitation energy (singlet & triplet) ***' - echo - - RPAx_1_1=`grep "| 1 |" $INPUT | head -5 | tail -1 | cut -f3 -d"|"` - RPAx_1_2=`grep "| 2 |" $INPUT | head -5 | tail -1 | cut -f3 -d"|"` - RPAx_1_3=`grep "| 3 |" $INPUT | head -5 | tail -1 | cut -f3 -d"|"` - RPAx_1_4=`grep "| 4 |" $INPUT | head -5 | tail -1 | cut -f3 -d"|"` - RPAx_1_5=`grep "| 5 |" $INPUT | head -5 | tail -1 | cut -f3 -d"|"` - - RPAx_3_1=`grep "| 1 |" $INPUT | head -6 | tail -1 | cut -f3 -d"|"` - RPAx_3_2=`grep "| 2 |" $INPUT | head -6 | tail -1 | cut -f3 -d"|"` - RPAx_3_3=`grep "| 3 |" $INPUT | head -6 | tail -1 | cut -f3 -d"|"` - RPAx_3_4=`grep "| 4 |" $INPUT | head -6 | tail -1 | cut -f3 -d"|"` - RPAx_3_5=`grep "| 5 |" $INPUT | head -6 | tail -1 | cut -f3 -d"|"` - - echo -e "\t" $RPAx_1_1 "\t" $RPAx_3_1 - echo -e "\t" $RPAx_1_2 "\t" $RPAx_3_2 - echo -e "\t" $RPAx_1_3 "\t" $RPAx_3_3 - echo -e "\t" $RPAx_1_4 "\t" $RPAx_3_4 - echo -e "\t" $RPAx_1_5 "\t" $RPAx_3_5 - - echo - echo '*** BSE@G0W0 excitation energy (singlet & triplet) ***' - echo - - G0W0_1_1=`grep "| 1 |" $INPUT | head -7 | tail -1 | cut -f3 -d"|"` - G0W0_1_2=`grep "| 2 |" $INPUT | head -7 | tail -1 | cut -f3 -d"|"` - G0W0_1_3=`grep "| 3 |" $INPUT | head -7 | tail -1 | cut -f3 -d"|"` - G0W0_1_4=`grep "| 4 |" $INPUT | head -7 | tail -1 | cut -f3 -d"|"` - G0W0_1_5=`grep "| 5 |" $INPUT | head -7 | tail -1 | cut -f3 -d"|"` - - G0W0_3_1=`grep "| 1 |" $INPUT | head -8 | tail -1 | cut -f3 -d"|"` - G0W0_3_2=`grep "| 2 |" $INPUT | head -8 | tail -1 | cut -f3 -d"|"` - G0W0_3_3=`grep "| 3 |" $INPUT | head -8 | tail -1 | cut -f3 -d"|"` - G0W0_3_4=`grep "| 4 |" $INPUT | head -8 | tail -1 | cut -f3 -d"|"` - G0W0_3_5=`grep "| 5 |" $INPUT | head -8 | tail -1 | cut -f3 -d"|"` - - echo -e "\t" $G0W0_1_1 "\t" $G0W0_3_1 - echo -e "\t" $G0W0_1_2 "\t" $G0W0_3_2 - echo -e "\t" $G0W0_1_3 "\t" $G0W0_3_3 - echo -e "\t" $G0W0_1_4 "\t" $G0W0_3_4 - echo -e "\t" $G0W0_1_5 "\t" $G0W0_3_5 - - echo - echo '*** BSE@evGW excitation energy (singlet & triplet) ***' - echo - - evGW_1_1=`grep "| 1 |" $INPUT | head -9 | tail -1 | cut -f3 -d"|"` - evGW_1_2=`grep "| 2 |" $INPUT | head -9 | tail -1 | cut -f3 -d"|"` - evGW_1_3=`grep "| 3 |" $INPUT | head -9 | tail -1 | cut -f3 -d"|"` - evGW_1_4=`grep "| 4 |" $INPUT | head -9 | tail -1 | cut -f3 -d"|"` - evGW_1_5=`grep "| 5 |" $INPUT | head -9 | tail -1 | cut -f3 -d"|"` - - evGW_3_1=`grep "| 1 |" $INPUT | head -10 | tail -1 | cut -f3 -d"|"` - evGW_3_2=`grep "| 2 |" $INPUT | head -10 | tail -1 | cut -f3 -d"|"` - evGW_3_3=`grep "| 3 |" $INPUT | head -10 | tail -1 | cut -f3 -d"|"` - evGW_3_4=`grep "| 4 |" $INPUT | head -10 | tail -1 | cut -f3 -d"|"` - evGW_3_5=`grep "| 5 |" $INPUT | head -10 | tail -1 | cut -f3 -d"|"` - - echo -e "\t" $evGW_1_1 "\t" $evGW_3_1 - echo -e "\t" $evGW_1_2 "\t" $evGW_3_2 - echo -e "\t" $evGW_1_3 "\t" $evGW_3_3 - echo -e "\t" $evGW_1_4 "\t" $evGW_3_4 - echo -e "\t" $evGW_1_5 "\t" $evGW_3_5 - - echo - echo '*** BSE@qsGW excitation energy (singlet & triplet) ***' - echo - - qsGW_1_1=`grep "| 1 |" $INPUT | head -11 | tail -1 | cut -f3 -d"|"` - qsGW_1_2=`grep "| 2 |" $INPUT | head -11 | tail -1 | cut -f3 -d"|"` - qsGW_1_3=`grep "| 3 |" $INPUT | head -11 | tail -1 | cut -f3 -d"|"` - qsGW_1_4=`grep "| 4 |" $INPUT | head -11 | tail -1 | cut -f3 -d"|"` - qsGW_1_5=`grep "| 5 |" $INPUT | head -11 | tail -1 | cut -f3 -d"|"` - - qsGW_3_1=`grep "| 1 |" $INPUT | head -12 | tail -1 | cut -f3 -d"|"` - qsGW_3_2=`grep "| 2 |" $INPUT | head -12 | tail -1 | cut -f3 -d"|"` - qsGW_3_3=`grep "| 3 |" $INPUT | head -12 | tail -1 | cut -f3 -d"|"` - qsGW_3_4=`grep "| 4 |" $INPUT | head -12 | tail -1 | cut -f3 -d"|"` - qsGW_3_5=`grep "| 5 |" $INPUT | head -12 | tail -1 | cut -f3 -d"|"` - - echo -e "\t" $qsGW_1_1 "\t" $qsGW_3_1 - echo -e "\t" $qsGW_1_2 "\t" $qsGW_3_2 - echo -e "\t" $qsGW_1_3 "\t" $qsGW_3_3 - echo -e "\t" $qsGW_1_4 "\t" $qsGW_3_4 - echo -e "\t" $qsGW_1_5 "\t" $qsGW_3_5 - - echo - echo '*** MATHEMATICA OUTPUT ***' - echo - echo -e "\t" $EHF "\t" $EcMP2 "\t" $Tr_RPA_1 "\t" $Tr_RPA_3 "\t" $AC_RPA_1 "\t" $AC_RPA_3 "\t" $Tr_RPAx_1 "\t" $Tr_RPAx_3 "\t" $AC_RPAx_1 "\t" $AC_RPAx_3 "\t" $Tr_RPA_G0W0_1 "\t" $Tr_RPA_G0W0_3 "\t" $Tr_BSE_G0W0_1 "\t" $Tr_BSE_G0W0_3 "\t" $AC_BSE_G0W0_1 "\t" $AC_BSE_G0W0_3 "\t" $CIS_1_1 "\t" $CIS_1_2 "\t" $CIS_1_3 "\t" $CIS_1_4 "\t" $CIS_1_5 "\t" $CIS_3_1 "\t" $CIS_3_2 "\t" $CIS_3_3 "\t" $CIS_3_4 "\t" $CIS_3_5 "\t" $RPA_1_1 "\t" $RPA_1_2 "\t" $RPA_1_3 "\t" $RPA_1_4 "\t" $RPA_1_5 "\t" $RPA_3_1 "\t" $RPA_3_2 "\t" $RPA_3_3 "\t" $RPA_3_4 "\t" $RPA_3_5 "\t" $RPAx_1_1 "\t" $RPAx_1_2 "\t" $RPAx_1_3 "\t" $RPAx_1_4 "\t" $RPAx_1_5 "\t" $RPAx_3_1 "\t" $RPAx_3_2 "\t" $RPAx_3_3 "\t" $RPAx_3_4 "\t" $RPAx_3_5 "\t" $G0W0_1_1 "\t" $G0W0_1_2 "\t" $G0W0_1_3 "\t" $G0W0_1_4 "\t" $G0W0_1_5 "\t" $G0W0_3_1 "\t" $G0W0_3_2 "\t" $G0W0_3_3 "\t" $G0W0_3_4 "\t" $G0W0_3_5 "\t" $Tr_RPA_evGW_1 "\t" $Tr_RPA_evGW_3 "\t" $Tr_BSE_evGW_1 "\t" $Tr_BSE_evGW_3 "\t" $AC_BSE_evGW_1 "\t" $AC_BSE_evGW_3 "\t" $evGW_1_1 "\t" $evGW_1_2 "\t" $evGW_1_3 "\t" $evGW_1_4 "\t" $evGW_1_5 "\t" $evGW_3_1 "\t" $evGW_3_2 "\t" $evGW_3_3 "\t" $evGW_3_4 "\t" $evGW_3_5 "\t" $Tr_RPA_qsGW_1 "\t" $Tr_RPA_qsGW_3 "\t" $Tr_BSE_qsGW_1 "\t" $Tr_BSE_qsGW_3 "\t" $AC_BSE_qsGW_1 "\t" $AC_BSE_qsGW_3 "\t" $qsGW_1_1 "\t" $qsGW_1_2 "\t" $qsGW_1_3 "\t" $qsGW_1_4 "\t" $qsGW_1_5 "\t" $qsGW_3_1 "\t" $qsGW_3_2 "\t" $qsGW_3_3 "\t" $qsGW_3_4 "\t" $qsGW_3_5 - echo - echo '*** DONE ***' - echo - diff --git a/scripts/run_sph.sh b/scripts/run_sph.sh deleted file mode 100755 index fd1cc87..0000000 --- a/scripts/run_sph.sh +++ /dev/null @@ -1,41 +0,0 @@ -#! /bin/bash - -Lmin=1 -Lmax=1 -Mmax=10 -rs=$1 - -if [ $# != 1 ] -then - echo "Please, specify rs value" -else - - echo "------------------------" - echo "Maxmium L value = " $Lmax - echo "Maxmium M value = " $Mmax - echo "------------------------" - echo - - for (( L=$Lmin ; L<=$Lmax ; L++ )) ; do - - ne=$(bc -l <<< "(2*($L+1)*($L+1))") - echo - echo "------------------------" - echo "Number of electrons = " $ne - echo "------------------------" - echo - - for (( M=$L+1 ; M<=$Mmax ; M++ )) ; do - - nb=$(bc -l <<< "(($M+1)*($M+1))") - echo "Number of basis functions = " $nb - echo -e "# rs \n" $rs > input/sph - ./GoSph $ne $M > out/Sph_${ne}_${nb}.out - grep "Total CPU time for QuAcK =" out/Sph_${ne}_${nb}.out - - done - - done - -fi - diff --git a/scripts/scan_w.sh b/scripts/scan_w.sh deleted file mode 100755 index e79e50a..0000000 --- a/scripts/scan_w.sh +++ /dev/null @@ -1,119 +0,0 @@ -#! /bin/bash - -MOL=$1 -BASIS=$2 - -w_start=0.00 -w_end=1.05 -dw=0.05 - -w1=0.00 - -XF=$3 -CF=$4 - -# for H -#aw1="1.49852 7.79815 25.1445" -#aw2="0.424545 -0.0382349 -0.32472" - - -# for He -#aw1="0.429447 0.053506 -0.339391" -#aw2="0.254939 -0.0893396 0.00765453" - -# for H2 -aw1="0.445525 0.0901503 -0.286898" -aw2="0.191734 -0.0364788 -0.017035" - -# for Li -#aw1="0.055105 -0.00943825 -0.0267771" -#aw2="0.0359827 0.0096623 -0.0173542" - -# for Li+ -#aw1="0.503566, 0.137076, -0.348529" -#aw2="0.0553828, 0.00830375, -0.0234602" - - -# for B -#aw1="0.052676 -0.00624118 -0.000368825" -#aw2="0.0385558 -0.0015764 -0.000894297" - -# for O -#aw1="-0.0187067 -0.0141017 -0.0100849" -#aw2="0.00544868 -0.0000118236 -0.000163245" - -# for Al -#aw1="-0.00201219 -0.00371002 -0.00212719" -#aw2="-0.00117715 0.00188738 -0.000414761" - -# for Be -#aw1="0.0663282, -0.0117682, -0.0335909" -#aw2="0.0479262, 0.00966351, -0.0208712" - - -DATA=${MOL}_${BASIS}_${XF}_${CF}_${w2}.dat -rm $DATA -touch $DATA - -for w2 in $(seq $w_start $dw $w_end) -do - ## w2=${w1} - echo "# Restricted or unrestricted KS calculation" > input/dft - echo " eDFT-UKS" >> input/dft - echo "# exchange rung:" >> input/dft - echo "# Hartree = 0" >> input/dft - echo "# LDA = 1: RS51,RMFL20" >> input/dft - echo "# GGA = 2: RB88" >> input/dft - echo "# Hybrid = 4" >> input/dft - echo "# Hartree-Fock = 666" >> input/dft - echo " 1 $XF " >> input/dft - echo "# correlation rung: " >> input/dft - echo "# Hartree = 0" >> input/dft - echo "# LDA = 1: RVWN5,RMFL20" >> input/dft - echo "# GGA = 2: " >> input/dft - echo "# Hybrid = 4: " >> input/dft - echo "# Hartree-Fock = 666" >> input/dft - echo " 0 $CF " >> input/dft - echo "# quadrature grid SG-n" >> input/dft - echo " 1" >> input/dft - echo "# Number of states in ensemble (nEns)" >> input/dft - echo " 3" >> input/dft - echo "# occupation numbers of orbitals nO and nO+1" >> input/dft - echo " 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 " >> input/dft - echo " 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 " >> input/dft - echo " " >> input/dft - echo " 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 " >> input/dft - echo " 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 " >> input/dft - echo " " >> input/dft - echo " 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 " >> input/dft - echo " 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 " >> input/dft - echo "# Ensemble weights: wEns(1),...,wEns(nEns-1)" >> input/dft - echo " ${w1} ${w2} " >> input/dft - echo "# Ncentered ? 0 for NO " >> input/dft - echo " 0 " >> input/dft - echo "# Parameters for CC weight-dependent exchange functional" >> input/dft - echo ${aw1} >> input/dft - echo ${aw2} >> input/dft - echo "# choice of UCC exchange coefficient : 1 for Cx1, 2 for Cx2, 3 for Cx1*Cx2" >> input/dft - echo "2" >> input/dft - echo "# GOK-DFT: maxSCF thresh DIIS n_diis guess_type ortho_type" >> input/dft - echo " 1000 0.00001 T 5 1 1" >> input/dft - OUTPUT=${MOL}_${BASIS}_${XF}_${CF}_${w2}.out - ./GoXC $MOL $BASIS > ${OUTPUT} - Ew=`grep "Ensemble energy:" ${OUTPUT} | cut -d":" -f 2 | sed 's/au//'` - E0=`grep "Individual energy state 1:" ${OUTPUT} | cut -d":" -f 2 | sed 's/au//'` - E1=`grep "Individual energy state 2:" ${OUTPUT} | cut -d":" -f 2 | sed 's/au//'` - E2=`grep "Individual energy state 3:" ${OUTPUT} | cut -d":" -f 2 | sed 's/au//'` - IP=`grep "Ionization Potential" ${OUTPUT} | grep " au" | tail -1 | cut -d":" -f 2 | sed 's/au//'` - EA=`grep "Electronic Affinity" ${OUTPUT} | grep " au" | tail -1 | cut -d":" -f 2 | sed 's/au//'` - FG=`grep "Fundamental Gap" ${OUTPUT} | grep " au" | tail -1 | cut -d":" -f 2 | sed 's/au//'` - Ex=`grep "Exchange energy:" ${OUTPUT} | cut -d":" -f 2 | sed 's/au//'` - HOMOa=`grep "HOMO a energy:" ${OUTPUT} | cut -d":" -f 2 | sed 's/eV//'` - LUMOa=`grep "LUMO a energy:" ${OUTPUT} | cut -d":" -f 2 | sed 's/eV//'` - HOMOb=`grep "HOMO a energy:" ${OUTPUT} | cut -d":" -f 2 | sed 's/eV//'` - LUMOb=`grep "LUMO b energy:" ${OUTPUT} | cut -d":" -f 2 | sed 's/eV//'` - - echo $w1 $w2 $Ew $E0 $E1 $E2 $IP $EA $FG $Ex $HOMOa $LUMOa $HOMOb $LUMOb - echo $w1 $w2 $Ew $E0 $E1 $E2 $IP $EA $FG $Ex $HOMOa $LUMOa $HOMOb $LUMOb >> ${DATA} -done - diff --git a/utils/fsplit b/utils/fsplit deleted file mode 100755 index e967b1506ee802e2321697ca82f0c372059251c7..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 31968 zcmeHwdwf*I`S;n7ML=+ag3{K@a?u7shzd2aP!nbKL=%ik)T+3IWFfI38k;;-@2mbUgMwn9T*s}Uj_Ev@lVO%);aMctTaX`xCjn)mxWGv~5rcVpm> z_mB6@`DD+TnddssJTvpm%-QTKpMU)2af;#^p(tyz6h%1^pEV;DC8~IlQk1XZqvGTD zmla*+yTNz$l~kI1xstPKbHpbX0{s3(zUvnyqcHuF^u$(Yp7Te5LixrJ(AxfsTAc6RqcF@H2FyrY~%MYC|Xoxl;XKW z=%wVyGUWM^dGZtDn=MK~UsvmIynV&eV6DGC)R2*%!H)Rb^`iDXRq~>T-(OoX7{8n) zLcbnD#zlEMKhp1X0?5nnuc`=D7`fE?9#|sy8TFyO)AklM(JyUmJkKg|+V7BqA7R@0 zNq00ESpB}Fc;OYk1;s|6t#`Bo@^tl#6;G%&^70~o0E*-^ zDoP6oNhgAL!{zhwEW91%Fy!$_m*GPfxe|R&#^)ROoQ6-P>-trSa$y?a2`Ka8Lu$_s zH#W?!tywy|>h{_y5q=)O;fyZmNe*5l6o;bbZvyCsEJq=|!_>3Go2E=2Ovt=F+ zzH(7tqU-d@0{I|0q(8xg-9;^g>|kX@?d)KEX!i2TO4fv)7f@>XvS34~p`vcqoLSJW zW~pSydgt5tWzBmNuHv%l0^DnEZwv)i%(~c4NqQ98=tOH7bgTzi!jfNE>2I8MuE`>` z9@N@N^l9s{GF(x$q9Rm1E6-#FIz>4PAF}5bv^Q+0OqY3T|KV%c0>c&D7vW3jfQ=zozVbYCas+KaYRF7E50 zhpLx%6Pos>7Ef$L466AODC;6*E_;m2_D5DHl<-Jk0v=htpVOV1Z@=zKeA~BwwOjY~ z^wlF1X?M-=?bmk3ef<>Y6)f)e{Iq>td$>$5@7I0%U0sm`5c+}EM&hIGo?^)AN2yxb zsp`INH8#(smr}Az)pjMkj1)Q^IGV4Aq>PDxb>GjMkyaxe`8O`!Y1Cdt?V)wJT`PZ9 zD{a+%&nDHr)mD4JP!ZkNDymR`DvW@75E1uvlVbW}q>`(!6n240S=Wu8ZP{5(zI`Za zPcGW4#(evpqq?iG=x^v5^X)YYHle_?t$d$nn{RLaj?gI7xOXkexKa;MrDA0+*ikF* zFYv*3JJ!7xo~*(kuwUdO80j_7wh80ceC`dwI9S`xgTPqd|^j7m~yX$!;WRt%qc%Q5y5Lt6FpmvM6oE zgDy2DN+SKEZc&6E7qJ?u_5%CUbEMPrbmQVg^TpsA>B!N2sKm3nuLD(qYiqs(@Gs2= zmwbagpqrg*5Bo%a?P%;#76Iy7Xj1DH^Dvt+3nLx0N*BQpB7T= zY33u5;)w=in_uD)xM z4-f=guRRljq69(jQK3W^lIVSZM1{C7Z~=8dRokJqQXiyi`x#9C)QbKgT&HsR7)mFYWx7k$l^;dwFon)XLe@!M+U>q5J=pR_Q2bIQRR3p{Z`J5MEs`9`Bp*n2})n}rUFu9i03^3UO$Sq;~ zn{a1+WA5uOVm{SeUXS|-<}>MY!6zQgLz#Dk;?h|IEjkBzaHnEY=hFFPdJ>D-eci1z z@Wd1xMqRasfF+#ap$x(%l`=Bhe*|*;~+%*_Y;e+nc$N~MwZ$?8U7qG-G7S+IlD`WL{(T8FB~h+f}7h$ecm z_EHf>)!4W&v}>CTO-r;7Ky<$+NY)pYXVr+b_)KnvdM;^sU@*- z=R-tME8GJz{-$bs!R?(3Df40C3X^NBY^vFwdrAFi%yC~Lm!6i>^@8#_uo9Dhq6b+q zw@_I;`s5LgAK+t~krHJTTX4#^Upx}x!BHPrZvm#NPrQ$sQOm(-v>vHtTG=SiwuuoW zo65!*SdsSQll$%IV5MqF1CtfS#G}ue@r-+w=xtWV*a6avy*B3l1J^%ohw)-U&Cn-X z3&>hA3csY$q`UB}`Z7b!4tzhdW(SV`3Dc;~(={(8fPjyC6%8po*bw$~J}(>A zZ3Z8N=+tI9&qu5t2aK@|f_f_tx`I~`ODSq4h0S^A!Q~HN#DSwdQ9So(T&@qkiby_%ihK)aQ^d|x!F*ME+ARaP0T%> zaGk_jpCtwst2Q5^Hkmz2SUSx-&_Z6JMXh;&j%wo3bn^gdkTMT^2inE4MfM3A zcK|(aJc)K+Cpx^
    yyoUCe^=6sc$WoXSw8l*I5a4t1xf-K(qC}wF#r;}aLa{aIB zdq3vtvG+Ykosz2jXB@tx%2lG@SydhdsVIMe40MzY`0^YgHTvTc(SSEO8gM6&^bK69 z$0Uxe0k;r1N?_T5i~@ZhXXa)DR&mz-GtqG@^~bXMMn`ML>>ZD8#GR{+;fWhOdOequ z*foXJ(J1nPU7)=w;QjMS5yI!t3T$=X9vb(2dtjb(oN~ttv;7xZ?r6>SAS794D-&ib zahPpAt3#!c_LEa5e;r^EX%M}>fe`hmL^mUiLTJ}^GU_QJjczOu1(LKi%Z9BlunC)# zD(rMpm?910A1gcA5Htyq#!F}yN2IY5Vkpx1n<*|kJzji(?VlFC%WCseVEbbjbZ3wY4Xu}w1}VMtrE|?em$vCV>vpjRxyL*8n<9Lp zj?I=foS^ty=gB2SN*Ge$9U`3AT1cjdMdz_atWmKJNcsjY)ngLJ)~RkJFcZm!W)xU- zAu~69-h*uK9#M-c!~kGfd77xjW^SrMYLRwCdn(Ufi#$<_nT}d)29mykOZAwHHo{@Nn9utYbT=~hSMQAn8#mjkJ$X9aiJSL)(efBGKy`2+>40$M8p?UE6rLhFHc;FnP*O z!Lm`wMiUS#8*h%OJldA9pnZuldRn9Hc+R@779HGblS_nI3Y=!KJT>F?LF-IYLfbb; z=h)oCWPIosXHbl~sno%~`S_GYNXWNx*8O|YSuE8S2-W_ZdD_OLA*gnmCBaZ_l~iq} zP>puN)2KGVA|%z`nL*WZpXyZ2CsZ48465D3EJZgmtj0|iPu$O-7%ghksCK(WNU9YI z)z*s6WLfP}p;|TbJUXj=h4T+V+EQC49lb zi~^p==9shWPBx^F6dQL0e$hr-rZ_8op7cpP@J)&wLT5<2wy^|^&3%*n33m8`!Rb$^ z!Y0x2g6KDrsB=g}qXkh!5J9i~RFqvnU_kfX>0(xP%Y?1=Q|(t)!U?!dXCKEy1LlnG`n7 zaYZ1d?N(VzgNbpE z0?Q}auS=okd2<&a=+^nvc6yW^ai~av@DZvy4zeq`K|Ikvh^#wAr`sblSe{^`Gr(?z zxp<7!qAJOWmf?O7T{rGKOd{2o?=Z%^C8P=+BWuxmMk~bK3uSPgsYMqsG)iS;$0Jjz z{4gAJlI}ai+gqU%WJUDyBU(=1@e$OdcMdiYn&kmphGY9eKDNJMuw(o7^vCu^*A-oB zxcc?rz8UXUw5VG7My>Rr1)8sUfmXU+_dP_fRqQHyo~o+*nkm;&L`Fq!z3l}I`0QrA z{2?4bcESuDRLc_762&cgc{7SzQTz-Q&!x(jqgOox2TM7>AZW4nqN;~m_0nhHLg-E% z3-HlbKeNCUFV_B1q``?_)pnF8%t@l%0(l}CSsPXeif zFQE>8rK5wxZ@Sp8sAI1on~RS9*<>VT$Nq+a#2xxQvqSF#j{XQ~LriIgQPa$OJ zt~X1j;v6(}-eXkTymuGj$D&kh&U+hi)F{ig)2w1Fol2&W?(xL&d&CA<7pWs?F%XT$ zvDITRw7FsYDZq()ygbg=*^TsB^c~N-gP0JgPCRWz4v$uOCbwB?uVtw}fr+rxXwSVA zrdie+U7}gmdK!4WKL%Xiz)d0zAB%CVW4Dhk(q1j%*Jrkqa&%@Cn|n9pB({R6cL{M8 z_1R9VDY2xA&Apj5i6>5ahw2@=Fa!7T7WYp~?vsi8b;Lc(#@$2Q=?3}ZCHJjw56azR zaX(;k-wAss{yhTRpTNz~{S@L(H*ntp3~ICM2Iqc?#hrE#gk=K6{U^lzQXBVC#GP*7 zP92N5|NF0l>ORWi{+Y@BIO0B^xF@oR8T;UNyJgOl+ND+Bj8 z$@8K6{A1vL1#w?X+-KUj(}JXpZm`S`B=>#YgIZ>!Wto4QmigEV?o)~TpIw$^jw9}L z1NYgI``W>|A7^o=sZg})4~hGWVBA}8<4$p^5v+CtgDf+3aPDI*?gvfo=Mwkj#Qj7Y zcYANTS8{*xtwAl5wl}?g2DsA;Y`xErMCmgW#J155mMM_jmkaI}Waz77EZzS_gc^+m zVdDO4Wc$8rus#X7Ho5_v0GP}&Rwc5<*NJr*Wp$om#3UkLo{NoZ0hq^4 zu>Td-(0IL!PHRIGuzy5zhm62B?#j;cBGg*jL35V5j|Dgp&evv>_)h|N%M8$)zkuCC%wgqxBD2Y6}3g6w_EWP`*s&;9Z7j@Cnm}(98-L0tE&4Dc?9U&P*>#~6DPM-h9!i<-(QdJ#AqQ?xzy269U5JqNfP2CI%J11l9T zS_MI9_yAfZp_T5(fvi1%D5sY_4{t}ClAkSN`SC;$S@@;yJAn5Uao4ey2$dn?I!xsJ zcJR8dNtA>{A;g5P6zm9}Oe7-crZSQ0J5?~kORkilIMxEnIF?pcM=%bgL|H@_Ni_G-?ukj+Yd<$5<$h@cTF6fImXhymhnei$mU|E38 z@bN3jSEfbx8l;N36W zL4%!(1HcpepofqWGXodWFtPnO8{?JCCZ2fS0uknV&bt3}szW$7Wl8wi#~}QC zOM(&IT_c5GY=KC)M+h%-3dcq{3I7e6^=NCp4abc}&E?qILLCj#UbH}zeSov>*SSa7 z%#QO35}tPq!V4@3ZP=p%o4NT?xN3n&_(UQ6TBmRv29faJkztOq&7Yk}q@v9sl!Wh> zX8)rFBHr#?SE@VIm}`M3 zo5fl8B~IaZ1CLD7!c<4s4SqSnGKt*6dPxdzwLm01%31d=;qF!+yhsS2dJMv6S`yl@ z|3U51$UYTMeA@z%@KHi|u~T@V5dL#A%vU*sn{mwn;BolAYOGC!PYe)-nE$pi)I`2h zWW_>e+=UQluCs_J@pZs4qIqmD;oXR$IQxy5Sdtfcov#lJ^nF)7=mBpl52WQ=Gr)oC{)s|8dAEjNsXGt*Zayqk#C+@I7B>XZVyh+sG zvdfJ^`1@3mqZIy0j#)ip5;;K%|H1;1@RvF3KHe$(CLz4~7=*91BvAZEjWQrTVvPkN z;iW?OeWHt6HNRO1?<2z;Wz7#^nQFARjM{#|Y~qO#$-=vUnYe8?c2^)xz8$**W%Q*f z1X?-T>LVN%>gD)K43ZQo)iU?FFQ7Wl(}FKiK}>2t8yMjJC*Jo*gq8qhk5;}%<(Mzp zzUoAg!fr~2?Z!zGp*^q3H-Ik+VRP2k)0ERUik`cavyCqdiEkiLn7I*4qwStM!iGVA?-%Bz#+Ye%s9UtF6@?QvN z69+rWu56bVuz$|;hVhcG?;tkiGj7D=TLs&~2L<(E+eSP#Wmod1>{sl4>xp|}x2{%+H`Gv!_pNM8H*eC?EjMZDR*tXTJtVxS8pkwP zn4x8{7Tl$;&PiO$C1MG8T->*tJeRhFb*vT`2ZgD0|$>3AbQ?GF6_wrzUv2NG}p?{;-z6TuTZ3a@JggUoeK^126sIz+E~ z8?}(GaTTZr^}2b?*6wvLz%w#>-Q5=JPZ94*)}DLU6HywkdlyK(LGm^9$pl{FZlj?B zD}my!BJGVK^vj3AV2Bo42~?vYAWPdZqr8K^r8NVx&GSq{GWp|mNn1EVMRArX{lf6g zoI$ln^36VME*n}5#XCcbhUA&|fo*0xB%K@8kOnmB+QuaQ@=iYSpu?~7&46pW=y2)B zn4&R6P7+O#a%{C(9$R?^6`$m&AAuur?!Z&`VYqjy@iYKJjTXR#8Yc-gykeY4Q3JCM zpPn@lX~xsDq;{wTDycCaPu+)k#;L~H#EY%55pbc#dc@PPMlO#VnGf+?gQ}6#7<<5x z)Yyh69pY6xw%5eF0C|{YyAcm{VTY|#EA7C(XFJ@HCdZvc&r+AccaSOfLJ@bMUB152 z=x&{~speVtIN)*jdW3N3Xw(fm<3xfKMFco3rLgQ2D4@B6K+@ecxJTRXt`n$4q%Uqa zrvlHqFxGmhLjaVciRVsKUXCsY1s)yld+sfy41Mw5G4Z^O^4_Vq>F$paUD9`t-3cV{ z4fVUicDd=MASrW{CG&1eCQm^r@@^4&zy@3~_nnXhl~8vidLN}Z)e$KnQadBLY(f?y zxITQvK5YaS9!)`0?_7%1lIgOu=1rk(@8n2qUT*p~MZ&3=(}#@t{UKwn9x~>QL&jX3 z9y3&z)S%9@WEq~y|JA@VFB+I<|NlW`B4?BI&H5k^k7aIirEz?pmazL)Pke1DJc`}zI>-xGZQi0}P;|Ag-c`2J76AL9F`d_T9=Xw@%Jir)IG?xNItldIdA5< zt7cZvt!B>5^Kd_JX2rR<&q{utKkIx(oPOb~S<8a8Rk;<@y_Xi`T~k(4yvTcw_fq^< z&suMwp&{5X8Fo>;-b;ev+A42dFysx^2kN|`>VUVVu09;{E~}{xc&AL6RTuQv;s2-3 zT2_$P5U8)Ms0?_$3&QoaHI)^ifOkc(Dh#~&-YHdq+CV5^$hy$$y*f})SskeI2I{K3 z!DZguikUU})4kr3nz}%vw;@nb1)SuoBv`jR&=~U80>xV!s9PSYHgJ+b_(zbTnqZv( zE`)YfQjtb)B{+uylDCl67^n+*LqYGtEByzi<@6tC>#7>VOB;gW5NdMYtjX}6iMaWC- z?)8T2fLGH9Z}QfJ8oj~W>e!`bk=udKb%Y5pIUM;Hxk$3}T|^!;2OhI9ykcpffe^?i z8@<&Pbyc-!^7-(dg~5gu=sr3N5az3mIybA)AB0=?9fDfOB z;)&6LKX@p3;Xy$MY9!-PPogrqu;yE1x*Qy*>&e-EdHG^;tN@?$X0}XJvz7%Nq z2g1blgdFVJAiPn=jm$>yszgR)AHoB)M7Ic^8@CF&5<;gd6CHiwN7AhaT5y}7yNZd@ z(UqVO1QJg2I`CKstiY+%_Taci1ZDD}@fTgR*`^Bs=>FpqLCu z?mVczxl7RJW5DDqg`PBpeP#dw)Fd}VbTqBtqKSa76gn*6mDq^&*%5d4WML!1Be~BY z`y-tH(6y2Z=}MuO?Xny&$R)ad&~-_=Pl<-E6uN()(5xoQn+DbI!+|_qLv0tT=S`sd zg```Wv7QLWlpl_`FFWR5KQeM$cA2Ov(Qg9%OMek^<5&#xm7=fNKCM786({;Vpf96| z9M?~WDnBOVlf6!b$2|3}pnpn8Ph+oN0b+_}do2RpS$hTD*o<;z`(z1uGr?s&=suTp zHyaL~QeWXuq~Ei^&;3xyq2p-2QtE zg{}&8|69^g_{3L=p3)vG0EN2T{-B$Z5cR9YdOAIw!+&l7qNLvg`h|ZN^iwkW4>9Kc zeX`wuq_mVr0*9*9r2mx9Bl0=&T2Y=OpI?{HY4SNsKJ(@CV)-nQ&uis#iG1E7pCS3Y zOFoQg3k+Le*aE{A z7`DK$1%@p!Y=L153|nB>0>c*gf7k-!r{pX-74>si|8Tu4!P{5+{t#c1TvW6F}!M1gK93@K@nvgP^ON(AyenLJV2sN((Y6o1E}q zz0JzaPAIjGpW1g7iQSkMjDsORnsEhTw4}u_pqrDS^h0Hh%K{C4^ZbQaZ22lAzggMV z45;!z#zJg&omhyU9SpFEIw^xg3LG1eye`fLR#dL2r);;8t-qbJJu44EyoJ#4xvWBvZ}J$uRQA_Cv6N>tf==Zue!uxiC=lswM==( z1yA+U!Hi#dIcr5lO`Y=Ztg4#j$cKWkieDMXx-HmH<*&n!So+B|{K}6;U>g@dC?^`_ zF;`$^jbHh_YpD{;stw-eS6vpZ+!pt zeUyIehjhR1zj^C!!x>+?c4uAn{&BxMr#1Vjtd*a-u6i#kKJKR@o^q|v+M6@~rk7o} z_2UhbrPu>L0Tj1jRJ$IFdN9M8F@QJht8s$vm}@$A$Nm za1p8pGHm)hZSLTi1TkVzk*;3zs$oylH|9@mY4`0n7`r~k;`kip4$WKCA`~iq- zh9gh^>dX$m*^$4^k%#{z;XmTYKkdkOI`Z^ye#D>9=bw(e8xCQIPjck*9Qg%~{9;Ew z- zDfJI8K9lj8g3nZZrr~oYK4;r$=V?Uk7iy_)? z%`1Lm!oie>`NiMpU+Ng1sfY${b67SCtbrOOLO*(9bVi=%9Xxp+lCz7E#f*cbs7Rw< zPDLE6$!XBLpWP;n%HensEozZ;Uq_E zB1|*lGye(^nDG-489g}^qXflZDa#OlX;JY)KOAsHunxZ;d;Z*lxr$#l+pPS&S?A~H X7bqN1&6<;!m#_Fy=}JoSknn#1FvX?d From 3c694d779a24de83ebe9fd55b793ce6716564bd8 Mon Sep 17 00:00:00 2001 From: pfloos Date: Wed, 26 Mar 2025 21:14:56 +0100 Subject: [PATCH 26/71] remove eomgw --- src/GW/RGW.f90 | 3 - src/GW/eomRG0W0.f90 | 315 ------------------------------------- src/utils/non_sym_diag.f90 | 5 - 3 files changed, 323 deletions(-) delete mode 100644 src/GW/eomRG0W0.f90 diff --git a/src/GW/RGW.f90 b/src/GW/RGW.f90 index aa9098d..7c59ac7 100644 --- a/src/GW/RGW.f90 +++ b/src/GW/RGW.f90 @@ -134,9 +134,7 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii if(doufG0W0) then call wall_time(start_GW) - ! TODO call ufRG0W0(dotest,TDA_W,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) -! call eomRG0W0(dotest,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GW) t_GW = end_GW - start_GW @@ -152,7 +150,6 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,maxSCF,thresh,max_dii if(doufGW) then call wall_time(start_GW) - ! TODO call ufRGW(dotest,TDA_W,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF) call wall_time(end_GW) diff --git a/src/GW/eomRG0W0.f90 b/src/GW/eomRG0W0.f90 deleted file mode 100644 index cfa6b6f..0000000 --- a/src/GW/eomRG0W0.f90 +++ /dev/null @@ -1,315 +0,0 @@ -subroutine eomRG0W0(dotest,nBas,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,eHF) - -! EOM version of G0W0 - - implicit none - include 'parameters.h' - -! Input variables - - logical,intent(in) :: dotest - - integer,intent(in) :: nBas - 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) :: ENuc - double precision,intent(in) :: ERHF - double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: eHF(nOrb) - -! Local variables - - integer :: p - integer :: s - integer :: i,j,k,l - integer :: a,b,c,d - integer :: jb,kc,ia,ja - integer :: klc,kcd,ija,ijb,iab,jab - - logical :: print_W = .false. - logical :: dRPA - integer :: isp_W - double precision :: EcRPA - integer :: n2h1p,n2p1h,nH - double precision,external :: Kronecker_delta - double precision,allocatable :: H(:,:) - double precision,allocatable :: cGW(:,:) - double precision,allocatable :: eGW(:) - double precision,allocatable :: Z(:) - integer,allocatable :: order(:) - - logical :: verbose = .false. - double precision,parameter :: cutoff1 = 0.01d0 - double precision,parameter :: cutoff2 = 0.01d0 - double precision :: eF - double precision,parameter :: window = 2.5d0 - - double precision :: start_timing,end_timing,timing - -! Output variables - -! Hello world - - write(*,*) - write(*,*)'***********************************' - write(*,*)'* Restricted EOM-G0W0 Calculation *' - write(*,*)'***********************************' - write(*,*) - -! Dimension of the supermatrix - - n2h1p = nO*nO*nV - n2p1h = nV*nV*nO - nH = 1 + n2h1p + n2p1h - -! Memory allocation - - allocate(H(nH,nH),eGW(nH),cGW(nH,nH),Z(nH),order(nH)) - -! Initialization - - dRPA = .true. - EcRPA = 0d0 - - eF = 0.5d0*(eHF(nO+1) + eHF(nO)) - -!-------------------------! -! Main loop over orbitals ! -!-------------------------! - - do p=nO,nO+1 - - H(:,:) = 0d0 - -!-----------------------------------------! -! Compute BSE supermatrix ! -!-----------------------------------------! -! ! -! | A V2h1p V2p1h 0 0 | ! -! | | ! -! | V2h1p A2h2p 0 B2h1p 0 | ! -! | | ! -! H = | V2p1h 0 A2p2h 0 B2p1h | ! -! | | ! -! | 0 0 0 0 0 | ! -! | | ! -! | 0 0 0 0 0 | ! -! ! -!-----------------------------------------! - - call wall_time(start_timing) - - !---------! - ! Block F ! - !---------! - - H(1,1) = eHF(p) - - !-------------! - ! Block V2h1p ! - !-------------! - - ija = 0 - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nOrb-nR - ija = ija + 1 - - H(1 ,1+ija) = sqrt(2d0)*ERI(p,a,i,j) - H(1+ija,1 ) = sqrt(2d0)*ERI(p,a,i,j) -! H(1+n2h1p+n2p1h+ija,1 ) = sqrt(2d0)*ERI(p,a,i,j) -! H(1+ija,1+n2h1p+n2p1h ) = sqrt(2d0)*ERI(p,a,i,j) - - end do - end do - end do - - !-------------! - ! Block V2p1h ! - !-------------! - - iab = 0 - do i=nC+1,nO - do a=nO+1,nOrb-nR - do b=nO+1,nOrb-nR - iab = iab + 1 - - H(1 ,1+n2h1p+iab) = sqrt(2d0)*ERI(p,i,b,a) - H(1+n2h1p+iab,1 ) = sqrt(2d0)*ERI(p,i,b,a) -! H(1 ,1+2*n2h1p+n2p1h+iab) = sqrt(2d0)*ERI(p,i,b,a) -! H(1+2*n2h1p+n2p1h+iab,1 ) = sqrt(2d0)*ERI(p,i,b,a) - - end do - end do - end do - - !-------------! - ! Block A2h1p ! - !-------------! - - ija = 0 - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nOrb-nR - ija = ija + 1 - - klc = 0 - do k=nC+1,nO - do l=nC+1,nO - do c=nO+1,nOrb-nR - klc = klc + 1 - - H(1+ija,1+klc) & - = ((eHF(i) + eHF(j) - eHF(a))*Kronecker_delta(j,l)*Kronecker_delta(a,c) & - - 2d0*ERI(j,c,a,l) - 2d0*ERI(j,l,a,c))*Kronecker_delta(i,k) - -! H(1+n2h1p+n2p1h+ija,1+n2h1p+n2p1h+klc) & -! = ((eHF(i) + eHF(j) - eHF(a))*Kronecker_delta(j,l)*Kronecker_delta(a,c) & -! - 2d0*ERI(j,c,a,l))*Kronecker_delta(i,k) - - end do - end do - end do - - end do - end do - end do - - !-------------! - ! Block A2p1h ! - !-------------! - - iab = 0 - do i=nC+1,nO - do a=nO+1,nOrb-nR - do b=nO+1,nOrb-nR - iab = iab + 1 - - kcd = 0 - do k=nC+1,nO - do c=nO+1,nOrb-nR - do d=nO+1,nOrb-nR - kcd = kcd + 1 - - H(1+n2h1p+iab,1+n2h1p+kcd) & - = ((eHF(a) + eHF(b) - eHF(i))*Kronecker_delta(i,k)*Kronecker_delta(a,c) & - + 2d0*ERI(a,k,i,c) + 2d0*ERI(a,c,i,k))*Kronecker_delta(b,d) -! H(1+2*n2h1p+n2p1h+iab,1+2*n2h1p+n2p1h+kcd) & -! = ((eHF(a) + eHF(b) - eHF(i))*Kronecker_delta(i,k)*Kronecker_delta(a,c) & -! + 2d0*ERI(a,k,i,c))*Kronecker_delta(b,d) - - end do - end do - end do - - end do - end do - end do - - !-------------! - ! Block B2h1p ! - !-------------! - -! ija = 0 -! do i=nC+1,nO -! do j=nC+1,nO -! do a=nO+1,nOrb-nR -! ija = ija + 1 - -! kcd = 0 -! do k=nC+1,nO -! do c=nO+1,nOrb-nR -! do d=nO+1,nOrb-nR -! kcd = kcd + 1 -! -! H(1+ija,1+n2h1p+kcd) = - 2d0*ERI(j,k,a,c) -! -! end do -! end do -! end do -! -! end do -! end do -! end do - - !-------------! - ! Block B2p1h ! - !-------------! - -! iab = 0 -! do i=nC+1,nO -! do a=nO+1,nOrb-nR -! do b=nO+1,nOrb-nR -! iab = iab + 1 - -! klc = 0 -! do k=nC+1,nO -! do l=nC+1,nO -! do c=nO+1,nOrb-nR -! klc = klc + 1 - -! H(1+n2h1p+iab,1+klc) = - 2d0*ERI(a,c,i,l) -! -! end do -! end do -! end do -! -! end do -! end do -! end do - - !-------------------------! - ! Diagonalize supermatrix ! - !-------------------------! - - call wall_time(start_timing) - - call diagonalize_general_matrix(nH,H,eGW,cGW) - - do s=1,nH - order(s) = s - end do - - call quick_sort(eGW,order,nH) - call set_order(cGW,order,nH,nH) - - call wall_time(end_timing) - timing = end_timing - start_timing - - write(*,*) - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for construction of supermatrix = ',timing,' seconds' - write(*,*) - - !-----------------! - ! Compute weights ! - !-----------------! - - do s=1,nH - Z(s) = cGW(1,s)**2 - end do - - write(*,*)'-------------------------------------------' - write(*,'(1X,A32,I3,A8)')'| G0W0 energies (eV) for orbital',p,' |' - write(*,*)'-------------------------------------------' - write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X)') & - '|','#','|','e_QP','|','Z','|' - write(*,*)'-------------------------------------------' - - do s=1,nH -! if(eGW(s) < eF .and. eGW(s) > eF - window) then - if(Z(s) > cutoff1) then - write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & - '|',s,'|',eGW(s)*HaToeV,'|',Z(s),'|' - end if - end do - - write(*,*)'-------------------------------------------' - write(*,*) - - end do ! Loop on the orbital in the e block - -end subroutine diff --git a/src/utils/non_sym_diag.f90 b/src/utils/non_sym_diag.f90 index 82d368d..3f11abe 100644 --- a/src/utils/non_sym_diag.f90 +++ b/src/utils/non_sym_diag.f90 @@ -1,6 +1,3 @@ - -! --- - subroutine diagonalize_nonsym_matrix(N, A, L, e_re, thr_d, thr_nd, thr_deg, imp_bio, verbose) ! Diagonalize a non-symmetric matrix A @@ -626,5 +623,3 @@ subroutine svd_local(A, LDA, U, LDU, D, Vt, LDVt, m, n) enddo end - - From 9a571c5b106b1ee1cabc6bb128b19979389a9b39 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 26 Mar 2025 22:47:31 +0100 Subject: [PATCH 27/71] saving work but still not debug --- src/Parquet/GParquet.f90 | 12 ++-- src/Parquet/G_eh_Phi.f90 | 14 ++-- src/Parquet/G_screened_integrals.f90 | 43 +++++------ src/Parquet/RParquet.f90 | 16 ++--- src/Parquet/R_eh_singlet_Phi.f90 | 12 ++-- src/Parquet/R_eh_triplet_Phi.f90 | 12 ++-- src/Parquet/R_pp_singlet_Gam.f90 | 6 +- src/Parquet/R_screened_integrals.f90 | 104 +++++++++++++-------------- 8 files changed, 109 insertions(+), 110 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 1fcf56d..3e40966 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -117,7 +117,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Memory allocation allocate(old_eh_Om(nS),old_ee_Om(nVV),old_hh_Om(nOO)) - allocate(eh_rho(nOrb,nOrb,nS+nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) allocate(old_eh_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_Phi(nOrb,nOrb,nOrb,nOrb)) ! Initialization @@ -259,9 +259,9 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - ! Bpp(:,:) = Bpp(:,:) + pp_Gam_B(:,:) - ! Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) - ! Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) + Bpp(:,:) = Bpp(:,:) + pp_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) call ppGLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,EcRPA) call wall_time(end_t) @@ -328,7 +328,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_rho,ee_rho,hh_rho) ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation - allocate(eh_rho(nOrb,nOrb,nS+nS)) + allocate(eh_rho(nOrb,nOrb,nS)) allocate(ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) ! Build singlet eh integrals @@ -384,7 +384,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp reducible kernel =',t,' seconds' write(*,*) - ! alpha = 0.01d0 + ! alpha = 0.1d0 ! eh_Phi(:,:,:,:) = alpha * eh_Phi(:,:,:,:) + (1d0 - alpha) * old_eh_Phi(:,:,:,:) ! pp_Phi(:,:,:,:) = alpha * pp_Phi(:,:,:,:) + (1d0 - alpha) * old_pp_Phi(:,:,:,:) diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 index 5ec86d3..d81c6fc 100644 --- a/src/Parquet/G_eh_Phi.f90 +++ b/src/Parquet/G_eh_Phi.f90 @@ -1,12 +1,12 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) -! Compute irreducible vertex in the triplet pp channel +! Compute irreducible vertex in the eh channel implicit none ! Input variables integer,intent(in) :: nOrb,nC,nR,nS double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS+nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) ! Local variables integer :: p,q,r,s @@ -23,11 +23,11 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR - ! do n=1,nS - ! eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & - ! - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & - ! - eh_rho(p,r,nS+n)*eh_rho(s,q,nS+n)/eh_Om(n) - ! end do + do n=1,nS + eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & + - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & + - eh_rho(p,r,n)*eh_rho(s,q,n)/eh_Om(n) + end do enddo enddo diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index f6c52bf..9358173 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -15,7 +15,7 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS) rho(:,:,:) = 0d0 ! !$OMP PARALLEL & @@ -25,26 +25,28 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho ! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR - - jb = 0 - do j=nC+1,nO - do b=nO+1,nOrb-nR - jb = jb + 1 - do ia=1,nS + do ia=1,nS + + jb = 0 + do j=nC+1,nO + do b=nO+1,nOrb-nR + jb = jb + 1 X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = (ERI(q,j,p,b) - ERI(q,j,b,p)) * X & - + (- eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X - - rho(p,q,nS+ia) = (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & - + (- eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y + rho(p,q,ia) = rho(p,q,ia) & + + (ERI(q,j,p,b) - ERI(q,j,b,p) & + - 0d0*eh_Phi(q,j,b,p) + 0d0*pp_Phi(q,j,p,b)) * X & + + (ERI(q,b,p,j) - ERI(q,b,j,p) & + - 0d0*eh_Phi(q,b,j,p) + 0d0*pp_Phi(q,b,p,j)) * Y end do end do + end do + end do end do ! !$OMP END DO @@ -76,7 +78,6 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 integer :: a,b,c,d integer :: p,q integer :: ab,cd,ij,kl - double precision,external :: Kronecker_delta ! Output variables @@ -106,8 +107,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho1(p,q,ab) = ( ERI(p,q,c,d) - ERI(p,q,d,c) ) * X1(cd,ab) & - + ( eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X1(cd,ab) + rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & + + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) end do end do @@ -115,8 +116,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do k=nC+1,nO do l=k+1,nO kl = kl + 1 - rho1(p,q,ab) = ( ERI(p,q,k,l) - ERI(p,q,l,k) ) * Y1(kl,ab) & - + ( eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y1(kl,ab) + rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,k,l) - ERI(p,q,l,k) & + + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do end do @@ -131,8 +132,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho2(p,q,ij) = ( ERI(p,q,c,d) - ERI(p,q,d,c) ) * X2(cd,ij) & - + ( eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X2(cd,ij) + rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & + + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) end do end do @@ -140,8 +141,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do k=nC+1,nO do l=k+1,nO kl = kl + 1 - rho2(p,q,ij) = ( ERI(p,q,k,l) - ERI(p,q,l,k) ) * Y2(kl,ij) & - + ( eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y2(kl,ij) + rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,k,l) - ERI(p,q,l,k) & + + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do end do end do diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index dbe8e42..cb0e02f 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -117,7 +117,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, allocate(old_eh_sing_Om(nS),old_eh_trip_Om(nS)) allocate(old_ee_sing_Om(nVVs),old_hh_sing_Om(nOOs)) allocate(old_ee_trip_Om(nVVt),old_hh_trip_Om(nOOt)) - allocate(eh_sing_rho(nOrb,nOrb,nS+nS),eh_trip_rho(nOrb,nOrb,nS+nS)) + allocate(eh_sing_rho(nOrb,nOrb,nS),eh_trip_rho(nOrb,nOrb,nS)) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) allocate(old_eh_sing_Phi(nOrb,nOrb,nOrb,nOrb),old_eh_trip_Phi(nOrb,nOrb,nOrb,nOrb)) @@ -330,9 +330,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - ! Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) - ! Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) - ! Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) + Bpp(:,:) = Bpp(:,:) + pp_sing_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) call wall_time(end_t) @@ -388,9 +388,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - ! Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) - ! Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) - ! Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) + Bpp(:,:) = Bpp(:,:) + pp_trip_Gam_B(:,:) + Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) + Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) @@ -439,7 +439,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_sing_rho,eh_trip_rho,ee_sing_rho,ee_trip_rho,hh_sing_rho,hh_trip_rho) ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation - allocate(eh_sing_rho(nOrb,nOrb,nS+nS),eh_trip_rho(nOrb,nOrb,nS+nS)) + allocate(eh_sing_rho(nOrb,nOrb,nS),eh_trip_rho(nOrb,nOrb,nS)) allocate(ee_sing_rho(nOrb,nOrb,nVVs),hh_sing_rho(nOrb,nOrb,nOOs)) allocate(ee_trip_rho(nOrb,nOrb,nVVt),hh_trip_rho(nOrb,nOrb,nOOt)) diff --git a/src/Parquet/R_eh_singlet_Phi.f90 b/src/Parquet/R_eh_singlet_Phi.f90 index 5971e26..91bb865 100644 --- a/src/Parquet/R_eh_singlet_Phi.f90 +++ b/src/Parquet/R_eh_singlet_Phi.f90 @@ -7,7 +7,7 @@ subroutine R_eh_singlet_Phi(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_sing_Phi) ! Input variables integer,intent(in) :: nOrb,nC,nR,nS double precision,intent(in) :: eh_sing_Om(nS) - double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS+nS) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) ! Local variables integer :: p,q,r,s @@ -24,11 +24,11 @@ subroutine R_eh_singlet_Phi(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_sing_Phi) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR - ! do n=1,nS - ! eh_sing_Phi(p,q,r,s) = eh_sing_Phi(p,q,r,s) & - ! - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & - ! - eh_sing_rho(p,r,n+nS)*eh_sing_rho(s,q,n+nS)/eh_sing_Om(n) - ! end do + do n=1,nS + eh_sing_Phi(p,q,r,s) = eh_sing_Phi(p,q,r,s) & + - eh_sing_rho(r,p,n)*eh_sing_rho(q,s,n)/eh_sing_Om(n) & + - eh_sing_rho(p,r,n)*eh_sing_rho(s,q,n)/eh_sing_Om(n) + end do enddo enddo diff --git a/src/Parquet/R_eh_triplet_Phi.f90 b/src/Parquet/R_eh_triplet_Phi.f90 index a6ec43f..e6d8587 100644 --- a/src/Parquet/R_eh_triplet_Phi.f90 +++ b/src/Parquet/R_eh_triplet_Phi.f90 @@ -7,7 +7,7 @@ subroutine R_eh_triplet_Phi(nOrb,nC,nR,nS,eh_trip_Om,eh_trip_rho,eh_trip_Phi) ! Input variables integer,intent(in) :: nOrb,nC,nR,nS double precision,intent(in) :: eh_trip_Om(nS) - double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS+nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) ! Local variables integer :: p,q,r,s @@ -24,11 +24,11 @@ subroutine R_eh_triplet_Phi(nOrb,nC,nR,nS,eh_trip_Om,eh_trip_rho,eh_trip_Phi) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR - ! do n=1,nS - ! eh_trip_Phi(p,q,r,s) = eh_trip_Phi(p,q,r,s) & - ! - eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & - ! - eh_trip_rho(p,r,n+nS)*eh_trip_rho(s,q,n+nS)/eh_trip_Om(n) - ! end do + do n=1,nS + eh_trip_Phi(p,q,r,s) = eh_trip_Phi(p,q,r,s) & + - eh_trip_rho(r,p,n)*eh_trip_rho(q,s,n)/eh_trip_Om(n) & + - eh_trip_rho(p,r,n)*eh_trip_rho(s,q,n)/eh_trip_Om(n) + end do enddo enddo diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index cd9987c..4bf6f88 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -35,7 +35,7 @@ subroutine R_pp_singlet_Gamma_D(nOrb,nC,nO,nOOs,eh_sing_Phi,eh_trip_Phi,pp_sing_ kl = kl +1 pp_sing_Gam_D(ij,kl) = 0.5d0*eh_sing_Phi(i,j,k,l) - 1.5d0*eh_trip_Phi(i,j,k,l) & - - 1.5d0*eh_sing_Phi(i,j,l,k) + 0.5d0*eh_trip_Phi(i,j,l,k) + + 0.5d0*eh_sing_Phi(i,j,l,k) - 1.5d0*eh_trip_Phi(i,j,l,k) pp_sing_Gam_D(ij,kl) = pp_sing_Gam_D(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) @@ -86,7 +86,7 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_ pp_sing_Gam_C(ab,cd) = 0.5d0*eh_sing_Phi(a,b,c,d) - 1.5d0*eh_trip_Phi(a,b,c,d) & - - 1.5d0*eh_sing_Phi(a,b,d,c) + 0.5d0*eh_trip_Phi(a,b,d,c) + + 0.5d0*eh_sing_Phi(a,b,d,c) - 1.5d0*eh_trip_Phi(a,b,d,c) pp_sing_Gam_C(ab,cd) = pp_sing_Gam_C(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) @@ -136,7 +136,7 @@ subroutine R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nOOs,nVVs,eh_sing_Phi,eh_trip_Phi, ij = ij +1 pp_sing_Gam_B(ab,ij) = 0.5d0*eh_sing_Phi(a,b,i,j) - 1.5d0*eh_trip_Phi(a,b,i,j) & - - 1.5d0*eh_sing_Phi(a,b,j,i) + 0.5d0*eh_trip_Phi(a,b,j,i) + + 0.5d0*eh_sing_Phi(a,b,j,i) - 1.5d0*eh_trip_Phi(a,b,j,i) pp_sing_Gam_B(ab,ij) = pp_sing_Gam_B(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 4e2ad64..0b619d3 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -17,7 +17,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS) rho(:,:,:) = 0d0 ! !$OMP PARALLEL & @@ -27,24 +27,23 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr ! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR - - jb = 0 - do j=nC+1,nO - do b=nO+1,nOrb-nR - jb = jb + 1 - do ia=1,nS + do ia=1,nS + + jb = 0 + do j=nC+1,nO + do b=nO+1,nOrb-nR + jb = jb + 1 X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = (2d0*ERI(q,j,p,b) - ERI(q,j,b,p) & - - 0.5d0*eh_sing_Phi(q,j,b,p) - 1.5d0*eh_trip_Phi(q,j,b,p) & - + 0.5d0*pp_sing_Phi(q,j,p,b) + 1.5d0*pp_trip_Phi(q,j,p,b)) * X - - rho(p,q,nS+ia) = (2d0*ERI(q,b,p,j) - ERI(q,b,j,p) & - - 0.5d0*eh_sing_Phi(q,b,j,p) - 1.5d0*eh_trip_Phi(q,b,j,p) & - + 0.5d0*pp_sing_Phi(q,b,p,j) + 1.5d0*pp_trip_Phi(q,b,p,j)) * Y + rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(q,j,p,b) - ERI(q,j,b,p) & + - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) - 0d0*1.5d0*eh_trip_Phi(q,j,b,p) & + + 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*1.5d0*pp_trip_Phi(q,j,p,b)) * X & + + (2d0*ERI(q,b,p,j) - ERI(q,b,j,p) & + - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) - 0d0*1.5d0*eh_trip_Phi(q,b,j,p) & + + 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*1.5d0*pp_trip_Phi(q,b,p,j)) * Y end do @@ -77,7 +76,7 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS) rho(:,:,:) = 0d0 ! !$OMP PARALLEL & @@ -87,28 +86,27 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr ! !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR - - jb = 0 - do j=nC+1,nO - do b=nO+1,nOrb-nR - jb = jb + 1 - do ia=1,nS + do ia=1,nS + + jb = 0 + do j=nC+1,nO + do b=nO+1,nOrb-nR + jb = jb + 1 X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = (- ERI(q,j,b,p) & - - 0.5d0*eh_sing_Phi(q,j,b,p) + 0.5d0*eh_trip_Phi(q,j,b,p) & - - 0.5d0*pp_sing_Phi(q,j,p,b) + 0.5d0*pp_trip_Phi(q,j,p,b)) * X - - rho(p,q,nS+ia) = (- ERI(q,b,j,p) & - - 0.5d0*eh_sing_Phi(q,b,j,p) + 0.5d0*eh_trip_Phi(q,b,j,p) & - - 0.5d0*pp_sing_Phi(q,b,p,j) + 0.5d0*pp_trip_Phi(q,b,p,j)) * Y + rho(p,q,ia) = rho(p,q,ia) + (- ERI(q,j,b,p) & + - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) + 0d0*0.5d0*eh_trip_Phi(q,j,b,p) & + - 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*0.5d0*pp_trip_Phi(q,j,p,b)) * X & + + (- ERI(q,b,j,p) & + - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) + 0d0*0.5d0*eh_trip_Phi(q,b,j,p) & + - 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*0.5d0*pp_trip_Phi(q,b,p,j)) * Y end do - end do + end do end do @@ -175,9 +173,9 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do d = c, nOrb-nR cd = cd + 1 - rho1(p,q,ab) = (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & - - 1.5d0*eh_sing_Phi(p,q,d,c) + 0.5d0*eh_trip_Phi(p,q,d,c))& + rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) + ERI(p,q,d,c) & + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & + + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& *X1(cd,ab)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d @@ -189,9 +187,9 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 - rho1(p,q,ab) = (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & - - 1.5d0*eh_sing_Phi(p,q,l,k) + 0.5d0*eh_trip_Phi(p,q,l,k))& + rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) + ERI(p,q,l,k) & + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & + + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& *Y1(kl,ab)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -208,9 +206,9 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do d = c, nOrb-nR cd = cd + 1 - rho2(p,q,ij) = (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & - - 1.5d0*eh_sing_Phi(p,q,d,c) + 0.5d0*eh_trip_Phi(p,q,d,c))& + rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) + ERI(p,q,d,c) & + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & + + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& *X2(cd,ij)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d end do ! c @@ -220,9 +218,9 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do l = k, nO kl = kl + 1 - rho2(p,q,ij) = (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & - - 1.5d0*eh_sing_Phi(p,q,l,k) + 0.5d0*eh_trip_Phi(p,q,l,k))& + rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) + ERI(p,q,l,k) & + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & + + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& *Y2(kl,ij)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -292,9 +290,9 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do d = c+1, nOrb-nR cd = cd + 1 - rho1(p,q,ab) = (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & - - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) + rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) - ERI(p,q,d,c) & + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & + - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) end do ! d end do ! c @@ -305,9 +303,9 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 - rho1(p,q,ab) = (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & - - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) + rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) - ERI(p,q,l,k) & + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & + - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) end do ! l end do ! k end do ! b @@ -323,9 +321,9 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do d = c+1, nOrb-nR cd = cd + 1 - rho2(p,q,ij) = (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & - - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) + rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) - ERI(p,q,d,c) & + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & + - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) end do ! d end do ! c @@ -334,9 +332,9 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do l = k+1, nO kl = kl + 1 - rho2(p,q,ij) = (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & - - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) + rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) - ERI(p,q,l,k) & + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & + - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) end do ! l end do ! k From 3ddb7802a3f3fe79224e9c98710f02d604eefed6 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 27 Mar 2025 09:58:01 +0100 Subject: [PATCH 28/71] spin adaptation and refactoring done --- src/Parquet/G_eh_Phi.f90 | 2 +- src/Parquet/G_screened_integrals.f90 | 12 +++---- src/Parquet/R_eh_singlet_Gam.f90 | 4 +++ src/Parquet/R_eh_triplet_Gam.f90 | 4 +++ src/Parquet/R_pp_singlet_Phi.f90 | 4 +-- src/Parquet/R_pp_triplet_Phi.f90 | 4 +-- src/Parquet/R_screened_integrals.f90 | 48 ++++++++++++++-------------- 7 files changed, 43 insertions(+), 35 deletions(-) diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 index d81c6fc..b264938 100644 --- a/src/Parquet/G_eh_Phi.f90 +++ b/src/Parquet/G_eh_Phi.f90 @@ -24,7 +24,7 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) do p = nC+1, nOrb-nR do n=1,nS - eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & + eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & - eh_rho(p,r,n)*eh_rho(s,q,n)/eh_Om(n) end do diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 9358173..594c887 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -38,9 +38,9 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho rho(p,q,ia) = rho(p,q,ia) & + (ERI(q,j,p,b) - ERI(q,j,b,p) & - - 0d0*eh_Phi(q,j,b,p) + 0d0*pp_Phi(q,j,p,b)) * X & + - eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & + (ERI(q,b,p,j) - ERI(q,b,j,p) & - - 0d0*eh_Phi(q,b,j,p) + 0d0*pp_Phi(q,b,p,j)) * Y + - eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y end do end do @@ -108,7 +108,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) + + eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X1(cd,ab) end do end do @@ -117,7 +117,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & - + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) + + eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do end do @@ -133,7 +133,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) + + eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X2(cd,ij) end do end do @@ -142,7 +142,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & - + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) + + eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do end do end do diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 index 7855ff6..6a82d1d 100644 --- a/src/Parquet/R_eh_singlet_Gam.f90 +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -24,6 +24,7 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing do i=nC+1,nO do a=nO+1,nOrb-nR ia = ia + 1 + jb = 0 do j=nC+1,nO do b=nO+1,norb-nR @@ -34,6 +35,7 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo + enddo enddo @@ -66,6 +68,7 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing do i=nC+1,nO do a=nO+1,nOrb-nR ia = ia + 1 + jb = 0 do j=nC+1,nO do b=nO+1,norb-nR @@ -76,6 +79,7 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo + enddo enddo diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 index a0e9ae3..acf03bc 100644 --- a/src/Parquet/R_eh_triplet_Gam.f90 +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -25,6 +25,7 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing do i=nC+1,nO do a=nO+1,nOrb-nR ia = ia + 1 + jb = 0 do j=nC+1,nO do b=nO+1,norb-nR @@ -35,6 +36,7 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo + enddo enddo @@ -66,6 +68,7 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing do i=nC+1,nO do a=nO+1,nOrb-nR ia = ia + 1 + jb = 0 do j=nC+1,nO do b=nO+1,norb-nR @@ -76,6 +79,7 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo + enddo enddo diff --git a/src/Parquet/R_pp_singlet_Phi.f90 b/src/Parquet/R_pp_singlet_Phi.f90 index 9a0f245..740bb5a 100644 --- a/src/Parquet/R_pp_singlet_Phi.f90 +++ b/src/Parquet/R_pp_singlet_Phi.f90 @@ -28,12 +28,12 @@ subroutine R_pp_singlet_Phi(nOrb,nC,nR,nOO,nVV,ee_sing_Om,ee_sing_rho,hh_sing_Om do n=1,nVV pp_sing_Phi(p,q,r,s) = pp_sing_Phi(p,q,r,s) & - + ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) + + 2d0 * ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) end do do n=1,nOO pp_sing_Phi(p,q,r,s) = pp_sing_Phi(p,q,r,s) & - - hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) + - 2d0 * hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) end do enddo diff --git a/src/Parquet/R_pp_triplet_Phi.f90 b/src/Parquet/R_pp_triplet_Phi.f90 index 5af9613..6dd7b1e 100644 --- a/src/Parquet/R_pp_triplet_Phi.f90 +++ b/src/Parquet/R_pp_triplet_Phi.f90 @@ -28,12 +28,12 @@ subroutine R_pp_triplet_Phi(nOrb,nC,nR,nOO,nVV,ee_trip_Om,ee_trip_rho,hh_trip_Om do n=1,nVV pp_trip_Phi(p,q,r,s) = pp_trip_Phi(p,q,r,s) & - + ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) + + 2d0 * ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) end do do n=1,nOO pp_trip_Phi(p,q,r,s) = pp_trip_Phi(p,q,r,s) & - - hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) + - 2d0 * hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) end do enddo diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 0b619d3..2ebb263 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -39,11 +39,11 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(q,j,p,b) - ERI(q,j,b,p) & - - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) - 0d0*1.5d0*eh_trip_Phi(q,j,b,p) & - + 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*1.5d0*pp_trip_Phi(q,j,p,b)) * X & + - 0.5d0*eh_sing_Phi(q,j,b,p) - 1.5d0*eh_trip_Phi(q,j,b,p) & + + 0.5d0*pp_sing_Phi(q,j,p,b) + 1.5d0*pp_trip_Phi(q,j,p,b)) * X & + (2d0*ERI(q,b,p,j) - ERI(q,b,j,p) & - - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) - 0d0*1.5d0*eh_trip_Phi(q,b,j,p) & - + 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*1.5d0*pp_trip_Phi(q,b,p,j)) * Y + - 0.5d0*eh_sing_Phi(q,b,j,p) - 1.5d0*eh_trip_Phi(q,b,j,p) & + + 0.5d0*pp_sing_Phi(q,b,p,j) + 1.5d0*pp_trip_Phi(q,b,p,j)) * Y end do @@ -98,11 +98,11 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) + (- ERI(q,j,b,p) & - - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) + 0d0*0.5d0*eh_trip_Phi(q,j,b,p) & - - 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*0.5d0*pp_trip_Phi(q,j,p,b)) * X & + - 0.5d0*eh_sing_Phi(q,j,b,p) + 0.5d0*eh_trip_Phi(q,j,b,p) & + - 0.5d0*pp_sing_Phi(q,j,p,b) + 0.5d0*pp_trip_Phi(q,j,p,b)) * X & + (- ERI(q,b,j,p) & - - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) + 0d0*0.5d0*eh_trip_Phi(q,b,j,p) & - - 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*0.5d0*pp_trip_Phi(q,b,p,j)) * Y + - 0.5d0*eh_sing_Phi(q,b,j,p) + 0.5d0*eh_trip_Phi(q,b,j,p) & + - 0.5d0*pp_sing_Phi(q,b,p,j) + 0.5d0*pp_trip_Phi(q,b,p,j)) * Y end do end do @@ -174,8 +174,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & - + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& + + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & + + 0.5d0*eh_sing_Phi(p,q,d,c) - 1.5d0*eh_trip_Phi(p,q,d,c))& *X1(cd,ab)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d @@ -188,8 +188,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & - + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& + + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & + + 0.5d0*eh_sing_Phi(p,q,l,k) - 1.5d0*eh_trip_Phi(p,q,l,k))& *Y1(kl,ab)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -207,8 +207,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & - + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& + + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & + + 0.5d0*eh_sing_Phi(p,q,d,c) - 1.5d0*eh_trip_Phi(p,q,d,c))& *X2(cd,ij)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d end do ! c @@ -219,8 +219,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & - + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& + + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & + + 0.5d0*eh_sing_Phi(p,q,l,k) - 1.5d0*eh_trip_Phi(p,q,l,k))& *Y2(kl,ij)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -291,8 +291,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & - - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) + + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & + - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) end do ! d end do ! c @@ -304,8 +304,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & - - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) + + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & + - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) end do ! l end do ! k end do ! b @@ -322,8 +322,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & - - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) + + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & + - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) end do ! d end do ! c @@ -333,8 +333,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & - - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) + + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & + - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) end do ! l end do ! k From b3178e8a080c52e51fc7e88a3f9eb8d109f96ede Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 27 Mar 2025 10:07:36 +0100 Subject: [PATCH 29/71] saving work --- src/Parquet/GParquet.f90 | 48 ++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 26 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 3e40966..7e9b976 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -9,8 +9,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, logical :: linearize = .true. logical :: TDA = .true. - logical :: print_phLR = .true. - logical :: print_ppLR = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. ! Input variables @@ -287,29 +287,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) '----------------------------------------' write(*,*) - !--------------------! - ! DIIS extrapolation ! - !--------------------! - - ! err( 1:nS ) = eh_Om(:) - old_eh_Om(:) - ! err( nS+1:nS+nVV ) = ee_Om(:) - old_ee_Om(:) - ! err(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - old_hh_Om(:) - - ! Om( 1:nS ) = eh_Om(:) - ! Om( nS+1:nS+nVV ) = ee_Om(:) - ! Om(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - - ! if(max_diis > 1) then - - ! n_diis = min(n_diis+1,max_diis) - ! call DIIS_extrapolation(rcond,nS+nOO+nVV,nS+nOO+nVV,n_diis,err_diis,Om_diis,err,Om) - - ! end if - - ! eh_Om(:) = Om( 1:nS ) - ! ee_Om(:) = Om( nS+1:nS+nVV ) - ! hh_Om(:) = Om(nVV+nS+1:nS+nVV+nOO) - !----------! ! Updating ! !----------! @@ -384,7 +361,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp reducible kernel =',t,' seconds' write(*,*) - ! alpha = 0.1d0 + ! alpha = 0.05d0 ! eh_Phi(:,:,:,:) = alpha * eh_Phi(:,:,:,:) + (1d0 - alpha) * old_eh_Phi(:,:,:,:) ! pp_Phi(:,:,:,:) = alpha * pp_Phi(:,:,:,:) + (1d0 - alpha) * old_pp_Phi(:,:,:,:) @@ -401,6 +378,25 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! DIIS extrapolation ! !--------------------! + ! err( 1:nS ) = eh_Om(:) - old_eh_Om(:) + ! err( nS+1:nS+nVV ) = ee_Om(:) - old_ee_Om(:) + ! err(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - old_hh_Om(:) + + ! Om( 1:nS ) = eh_Om(:) + ! Om( nS+1:nS+nVV ) = ee_Om(:) + ! Om(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) + + ! if(max_diis > 1) then + + ! n_diis = min(n_diis+1,max_diis) + ! call DIIS_extrapolation(rcond,nS+nOO+nVV,nS+nOO+nVV,n_diis,err_diis,Om_diis,err,Om) + + ! end if + + ! eh_Om(:) = Om( 1:nS ) + ! ee_Om(:) = Om( nS+1:nS+nVV ) + ! hh_Om(:) = Om(nVV+nS+1:nS+nVV+nOO) + write(*,*) '----------------------------------------' write(*,*) ' Two-body (kernel) convergence ' write(*,*) '----------------------------------------' From ea26528afcb1a788745b0a350e3c95dcabc82383 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Thu, 27 Mar 2025 11:14:13 +0100 Subject: [PATCH 30/71] diis on Phis --- mol/H2O.xyz | 4 +- src/Parquet/GParquet.f90 | 97 ++++++++++++++++++---------- src/Parquet/G_screened_integrals.f90 | 12 ++-- src/QuAcK/QuAcK.f90 | 2 - 4 files changed, 70 insertions(+), 45 deletions(-) diff --git a/mol/H2O.xyz b/mol/H2O.xyz index 00a490d..2e291f6 100644 --- a/mol/H2O.xyz +++ b/mol/H2O.xyz @@ -1,5 +1,5 @@ 3 O 0.0000 0.0000 0.0000 -H 0.9591 0.0000 0.0000 -H -0.2373 0.9293 0.0000 +H 0.7571 0.0000 0.5861 +H -0.7571 0.0000 0.5861 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 7e9b976..ddda574 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -59,11 +59,13 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: max_diis,n_diis double precision :: rcond double precision,allocatable :: err_diis(:,:) - double precision,allocatable :: Om_diis(:,:) + double precision,allocatable :: Phi_diis(:,:) double precision,allocatable :: err(:) - double precision,allocatable :: Om(:) + double precision,allocatable :: Phi(:) double precision :: alpha + integer ::p,q,r,s,pqrs + ! Output variables ! None @@ -75,15 +77,15 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! DIIS parameters - ! max_diis = 10 - ! n_diis = 0 - ! rcond = 0d0 + max_diis = 1 + n_diis = 0 + rcond = 1d0 - ! allocate(err_diis(nS+nOO+nVV,max_diis),Om_diis(nS+nOO+nVV,max_diis)) - ! allocate(err(nS+nOO+nVV),Om(nS+nOO+nVV)) + allocate(err_diis(2*nOrb**4,max_diis),Phi_diis(2*nOrb**4,max_diis)) + allocate(err(2*nOrb**4),Phi(2*nOrb**4)) - ! err_diis(:,:) = 0d0 - ! Om_diis(:,:) = 0d0 + err_diis(:,:) = 0d0 + Phi_diis(:,:) = 0d0 ! Start @@ -365,38 +367,64 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! eh_Phi(:,:,:,:) = alpha * eh_Phi(:,:,:,:) + (1d0 - alpha) * old_eh_Phi(:,:,:,:) ! pp_Phi(:,:,:,:) = alpha * pp_Phi(:,:,:,:) + (1d0 - alpha) * old_pp_Phi(:,:,:,:) - err_eh = maxval(abs(old_eh_Phi - eh_Phi)) - err_pp = maxval(abs(old_pp_Phi - pp_Phi)) + err_eh = maxval(abs(eh_Phi - old_eh_Phi)) + err_pp = maxval(abs(pp_Phi - old_pp_Phi)) + + call matout(nOrb**2,nOrb**2,eh_Phi - old_eh_Phi) + call matout(nOrb**2,nOrb**2,pp_Phi - old_pp_Phi) + + !--------------------! + ! DIIS extrapolation ! + !--------------------! + + pqrs = 0 + do p=1,nOrb + do q=1,nOrb + do r=1,nOrb + do s=1,nOrb + pqrs = pqrs + 1 + + err( pqrs) = eh_Phi(p,q,r,s) - old_eh_Phi(p,q,r,s) + err(nOrb**4+pqrs) = pp_Phi(p,q,r,s) - old_pp_Phi(p,q,r,s) + + Phi( pqrs) = eh_Phi(p,q,r,s) + Phi(nOrb**4+pqrs) = pp_Phi(p,q,r,s) + + end do + end do + end do + end do + + if(max_diis > 1) then + + n_diis = min(n_diis+1,max_diis) + call DIIS_extrapolation(rcond,2*nOrb**4,2*nOrb**4,n_diis,err_diis,Phi_diis,err,Phi) + print*,rcond + + end if + + pqrs = 0 + do p=1,nOrb + do q=1,nOrb + do r=1,nOrb + do s=1,nOrb + pqrs = pqrs + 1 + + eh_Phi(p,q,r,s) = Phi( pqrs) + pp_Phi(p,q,r,s) = Phi(nOrb**4+pqrs) + + end do + end do + end do + end do old_eh_Phi(:,:,:,:) = eh_Phi(:,:,:,:) old_pp_Phi(:,:,:,:) = pp_Phi(:,:,:,:) ! Free memory + deallocate(eh_Phi,pp_Phi) - !--------------------! - ! DIIS extrapolation ! - !--------------------! - - ! err( 1:nS ) = eh_Om(:) - old_eh_Om(:) - ! err( nS+1:nS+nVV ) = ee_Om(:) - old_ee_Om(:) - ! err(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - old_hh_Om(:) - - ! Om( 1:nS ) = eh_Om(:) - ! Om( nS+1:nS+nVV ) = ee_Om(:) - ! Om(nVV+nS+1:nS+nVV+nOO) = hh_Om(:) - - ! if(max_diis > 1) then - - ! n_diis = min(n_diis+1,max_diis) - ! call DIIS_extrapolation(rcond,nS+nOO+nVV,nS+nOO+nVV,n_diis,err_diis,Om_diis,err,Om) - - ! end if - - ! eh_Om(:) = Om( 1:nS ) - ! ee_Om(:) = Om( nS+1:nS+nVV ) - ! hh_Om(:) = Om(nVV+nS+1:nS+nVV+nOO) - write(*,*) '----------------------------------------' write(*,*) ' Two-body (kernel) convergence ' write(*,*) '----------------------------------------' @@ -404,7 +432,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,'(1X,A30,F10.6)')'Error for pp channel = ',err_pp write(*,*) '----------------------------------------' write(*,*) - ! Convergence criteria err_2b = max(err_eh,err_pp) diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 594c887..9d40221 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -38,9 +38,9 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho rho(p,q,ia) = rho(p,q,ia) & + (ERI(q,j,p,b) - ERI(q,j,b,p) & - - eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & + - 1d0*eh_Phi(q,j,b,p) + 1d0*pp_Phi(q,j,p,b)) * X & + (ERI(q,b,p,j) - ERI(q,b,j,p) & - - eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y + - 1d0*eh_Phi(q,b,j,p) + 1d0*pp_Phi(q,b,p,j)) * Y end do end do @@ -108,7 +108,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & - + eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X1(cd,ab) + + 1d0*eh_Phi(p,q,c,d) - 1d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) end do end do @@ -117,7 +117,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & - + eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y1(kl,ab) + + 1d0*eh_Phi(p,q,k,l) - 1d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do end do @@ -133,7 +133,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & - + eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X2(cd,ij) + + 1d0*eh_Phi(p,q,c,d) - 1d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) end do end do @@ -142,7 +142,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & - + eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y2(kl,ij) + + 1d0*eh_Phi(p,q,k,l) - 1d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do end do end do diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index bf66039..fe78983 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -198,8 +198,6 @@ program QuAcK call read_dipole_integrals(working_dir,nBas,dipole_int_AO) call wall_time(end_int) - call matout(nBas,nBas,dipole_int_AO(:,:,1)) - t_int = end_int - start_int write(*,*) write(*,'(A65,1X,F9.3,A8)') 'Total wall time for reading 1e-integrals = ',t_int,' seconds' From 1c279e528e72eb28aa005e235f67a683e55b23e6 Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 27 Mar 2025 22:25:49 +0100 Subject: [PATCH 31/71] small modifs in GParquet --- mol/MgO.xyz | 2 +- src/Parquet/GParquet.f90 | 82 +++++++++++----------------- src/Parquet/G_screened_integrals.f90 | 12 ++-- 3 files changed, 40 insertions(+), 56 deletions(-) diff --git a/mol/MgO.xyz b/mol/MgO.xyz index 091c39f..78b1186 100644 --- a/mol/MgO.xyz +++ b/mol/MgO.xyz @@ -1,4 +1,4 @@ 2 Mg 0.0000 0.0000 0.0000 -O 0.0000 0.0000 1.728 +O 0.0000 0.0000 1.749 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index ddda574..cf5ff1c 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -7,8 +7,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Hard-coded parameters - logical :: linearize = .true. - logical :: TDA = .true. + logical :: TDA = .true. + logical :: linearize = .true. logical :: print_phLR = .false. logical :: print_ppLR = .false. @@ -25,10 +25,10 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: n_it_1b,n_it_2b double precision :: err_1b,err_2b double precision :: err_eh, err_pp - double precision :: err_eig_eh, err_eig_hh, err_eig_ee - double precision :: start_t, end_t, t - double precision :: start_1b, end_1b, t_1b - double precision :: start_2b, end_2b, t_2b + double precision :: err_eig_eh,err_eig_pp,err_eig_hh,err_eig_ee + double precision :: start_t,end_t,t + double precision :: start_1b,end_1b,t_1b + double precision :: start_2b,end_2b,t_2b integer :: nOO,nVV @@ -100,11 +100,11 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*)'---------------------------------------------------------------' write(*,*)' Parquet parameters for one-body and two-body self-consistency ' write(*,*)'---------------------------------------------------------------' - write(*,'(1X,A50,1X,I5)') 'Maximum number for one-body self-consistency:', max_it_1b - write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:', conv_1b + write(*,'(1X,A50,1X,I5)') 'Maximum number of one-body iteration:',max_it_1b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:',conv_1b write(*,*)'---------------------------------------------------------------' - write(*,'(1X,A50,1X,I5)') 'Maximum number for two-body self-consistency:', max_it_2b - write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:', conv_2b + write(*,'(1X,A50,1X,I5)') 'Maximum number of two-body iteration:',max_it_2b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:',conv_2b write(*,*)'---------------------------------------------------------------' write(*,*) @@ -177,14 +177,10 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! eh channel ! !-----------------! - write(*,*)' ------------------------------' - write(*,*)' | Diagonalizing ehBSE |' - write(*,*)' ------------------------------' - write(*,*) + write(*,*) 'Diagonalizing eh BSE problem...' allocate(Aph(nS,nS),Bph(nS,nS),eh_Om(nS),XpY(nS,nS),XmY(nS,nS),eh_Gam_A(nS,nS),eh_Gam_B(nS,nS)) - Aph(:,:) = 0d0 Bph(:,:) = 0d0 @@ -208,14 +204,12 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) - - call phGLR(TDA,nS,Aph,Bph,EcRPA,eh_Om,XpY,XmY) call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for phBSE =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for phBSE problem =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','eh generalized',nS,eh_Om) @@ -228,10 +222,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! pp channel ! !-----------------! - write(*,*)' ------------------------------' - write(*,*)' | Diagonalizing ppBSE |' - write(*,*)' ------------------------------' - write(*,*) + write(*,*) 'Diagonalizing pp BSE problem...' + allocate(Bpp(nVV,nOO),Cpp(nVV,nVV),Dpp(nOO,nOO), & ee_Om(nVV),X1(nVV,nVV),Y1(nOO,nVV), & @@ -256,8 +248,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else if(.not.TDA) call G_pp_Gamma_B(nOrb,nC,nO,nR,nOO,nVV,old_eh_Phi,pp_Gam_B) - call G_pp_Gamma_C(nOrb,nO,nR,nVV,old_eh_Phi,pp_Gam_C) - call G_pp_Gamma_D(nOrb,nC,nO,nOO,old_eh_Phi,pp_Gam_D) + call G_pp_Gamma_C(nOrb,nO,nR,nVV,old_eh_Phi,pp_Gam_C) + call G_pp_Gamma_D(nOrb,nC,nO,nOO,old_eh_Phi,pp_Gam_D) end if @@ -269,7 +261,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for ppBSE =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for ppBSE problem =',t,' seconds' write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p generalized',nVV,ee_Om) @@ -277,18 +269,10 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, err_eig_ee = maxval(abs(old_ee_Om - ee_Om)) err_eig_hh = maxval(abs(old_hh_Om - hh_Om)) + err_eig_pp = max(err_eig_ee,err_eig_hh) deallocate(Bpp,Cpp,Dpp,pp_Gam_B,pp_Gam_C,pp_Gam_D) - - write(*,*) '----------------------------------------' - write(*,*) ' Two-body (eigenvalue) convergence ' - write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for eh channel = ',err_eig_eh - write(*,'(1X,A30,F10.6)')'Error for pp channel = ',max(err_eig_ee,err_eig_hh) - write(*,*) '----------------------------------------' - write(*,*) - !----------! ! Updating ! !----------! @@ -344,7 +328,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, allocate(pp_Phi(nOrb,nOrb,nOrb,nOrb)) ! Build eh reducible kernels - write(*,*) 'Computing eh reducible kernel ...' + write(*,*) 'Computing eh reducible kernel...' call wall_time(start_t) call G_eh_Phi(nOrb,nC,nR,nS,old_eh_Om,eh_rho,eh_Phi) @@ -354,7 +338,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) ! Build pp reducible kernels - write(*,*) 'Computing pp reducible kernel ...' + write(*,*) 'Computing pp reducible kernel...' call wall_time(start_t) call G_pp_Phi(nOrb,nC,nR,nOO,nVV,old_ee_Om,ee_rho,old_hh_Om,hh_rho,pp_Phi) @@ -363,15 +347,15 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp reducible kernel =',t,' seconds' write(*,*) - ! alpha = 0.05d0 - ! eh_Phi(:,:,:,:) = alpha * eh_Phi(:,:,:,:) + (1d0 - alpha) * old_eh_Phi(:,:,:,:) - ! pp_Phi(:,:,:,:) = alpha * pp_Phi(:,:,:,:) + (1d0 - alpha) * old_pp_Phi(:,:,:,:) - err_eh = maxval(abs(eh_Phi - old_eh_Phi)) err_pp = maxval(abs(pp_Phi - old_pp_Phi)) - call matout(nOrb**2,nOrb**2,eh_Phi - old_eh_Phi) - call matout(nOrb**2,nOrb**2,pp_Phi - old_pp_Phi) +! alpha = 0.05d0 +! eh_Phi(:,:,:,:) = alpha * eh_Phi(:,:,:,:) + (1d0 - alpha) * old_eh_Phi(:,:,:,:) +! pp_Phi(:,:,:,:) = alpha * pp_Phi(:,:,:,:) + (1d0 - alpha) * old_pp_Phi(:,:,:,:) + +! call matout(nOrb**2,nOrb**2,eh_Phi - old_eh_Phi) +! call matout(nOrb**2,nOrb**2,pp_Phi - old_pp_Phi) !--------------------! ! DIIS extrapolation ! @@ -425,12 +409,12 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_Phi,pp_Phi) - write(*,*) '----------------------------------------' - write(*,*) ' Two-body (kernel) convergence ' - write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for eh channel = ',err_eh - write(*,'(1X,A30,F10.6)')'Error for pp channel = ',err_pp - write(*,*) '----------------------------------------' + write(*,*) '----------------------------------------------' + write(*,*) ' Two-body (frequency/kernel) convergence ' + write(*,*) '----------------------------------------------' + write(*,'(1X,A24,F10.6,1X,F10.6)')'Error for eh channel = ',err_eig_eh,err_eh + write(*,'(1X,A24,F10.6,1X,F10.6)')'Error for pp channel = ',err_eig_pp,err_pp + write(*,*) '----------------------------------------------' write(*,*) ! Convergence criteria @@ -438,7 +422,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(end_2b) t_2b = end_2b - start_2b - write(*,'(A50,1X,F9.3,A8)') 'Wall time for two-body iteration =',t_2b,' seconds' + write(*,'(A50,1X,I4,A2,F9.3,A8)') 'Wall time for two-body iteration #',n_it_2b,' =',t_2b,' seconds' write(*,*) end do diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 9d40221..e921bbb 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -37,9 +37,9 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) & - + (ERI(q,j,p,b) - ERI(q,j,b,p) & + + (1d0*ERI(q,j,p,b) - 1d0*ERI(q,j,b,p) & - 1d0*eh_Phi(q,j,b,p) + 1d0*pp_Phi(q,j,p,b)) * X & - + (ERI(q,b,p,j) - ERI(q,b,j,p) & + + (1d0*ERI(q,b,p,j) - 1d0*ERI(q,b,j,p) & - 1d0*eh_Phi(q,b,j,p) + 1d0*pp_Phi(q,b,p,j)) * Y end do @@ -107,7 +107,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & + rho1(p,q,ab) = rho1(p,q,ab) + ( 1d0*ERI(p,q,c,d) - 1d0*ERI(p,q,d,c) & + 1d0*eh_Phi(p,q,c,d) - 1d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) end do end do @@ -116,7 +116,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & + rho1(p,q,ab) = rho1(p,q,ab) + ( 1d0*ERI(p,q,k,l) - 1d0*ERI(p,q,l,k) & + 1d0*eh_Phi(p,q,k,l) - 1d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do end do @@ -132,7 +132,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & + rho2(p,q,ij) = rho2(p,q,ij) + ( 1d0*ERI(p,q,c,d) - 1d0*ERI(p,q,d,c) & + 1d0*eh_Phi(p,q,c,d) - 1d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) end do end do @@ -141,7 +141,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & + rho2(p,q,ij) = rho2(p,q,ij) + ( 1d0*ERI(p,q,k,l) - 1d0*ERI(p,q,l,k) & + 1d0*eh_Phi(p,q,k,l) - 1d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do end do From a45f109a962e45d8c252d22b0e28ef1364d6d875 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 31 Mar 2025 15:56:05 +0200 Subject: [PATCH 32/71] spin-orbital implementation of self-energy --- src/LR/print_excitation_energies.f90 | 2 +- src/Parquet/GParquet.f90 | 40 +-- src/Parquet/G_eh_Phi.f90 | 2 +- src/Parquet/G_irred_Parquet_self_energy.f90 | 297 ++++++++++++++++++++ src/Parquet/G_pp_Phi.f90 | 2 +- src/Parquet/G_screened_integrals.f90 | 22 +- src/Parquet/R_screened_integrals.f90 | 48 ++-- src/QuAcK/RQuAcK.f90 | 2 +- 8 files changed, 364 insertions(+), 51 deletions(-) create mode 100644 src/Parquet/G_irred_Parquet_self_energy.f90 diff --git a/src/LR/print_excitation_energies.f90 b/src/LR/print_excitation_energies.f90 index b909f21..fc8b71e 100644 --- a/src/LR/print_excitation_energies.f90 +++ b/src/LR/print_excitation_energies.f90 @@ -14,7 +14,7 @@ subroutine print_excitation_energies(method,manifold,nS,Om) ! Local variables - integer,parameter :: maxS = 25 + integer,parameter :: maxS = 50 integer :: m write(*,*) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index cf5ff1c..a53244c 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -11,7 +11,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, logical :: linearize = .true. logical :: print_phLR = .false. logical :: print_ppLR = .false. - + double precision :: eta = 100d0 + ! Input variables integer,intent(in) :: max_it_1b,max_it_2b @@ -77,7 +78,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! DIIS parameters - max_diis = 1 + max_diis = 2 n_diis = 0 rcond = 1d0 @@ -126,21 +127,18 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, n_it_1b = 0 err_1b = 1d0 - - n_it_2b = 0 - err_2b = 1d0 - + eQP(:) = eHF(:) eOld(:) = eHF(:) - + eh_rho(:,:,:) = 0d0 ee_rho(:,:,:) = 0d0 hh_rho(:,:,:) = 0d0 - + old_eh_Om(:) = 0d0 old_ee_Om(:) = 0d0 old_hh_Om(:) = 0d0 - + old_eh_Phi(:,:,:,:) = 0d0 old_pp_Phi(:,:,:,:) = 0d0 @@ -159,6 +157,11 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*)'=====================================' write(*,*) +! Initialization + + n_it_2b = 0 + err_2b = 1d0 + !-----------------------------------------! ! Main loop for two-body self-consistency ! !-----------------------------------------! @@ -186,7 +189,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(start_t) - call phGLR_A(.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phGLR_A(.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) if(.not.TDA) call phGLR_B(.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) if(n_it_2b == 1) then @@ -236,8 +239,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(start_t) if(.not.TDA) call ppGLR_B(nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) - call ppGLR_C(nOrb,nC,nO,nV,nR,nVV,1d0,eHF,ERI,Cpp) - call ppGLR_D(nOrb,nC,nO,nV,nR,nOO,1d0,eHF,ERI,Dpp) + call ppGLR_C(nOrb,nC,nO,nV,nR,nVV,1d0,eOld,ERI,Cpp) + call ppGLR_D(nOrb,nC,nO,nV,nR,nOO,1d0,eOld,ERI,Dpp) if(n_it_2b == 1) then @@ -383,7 +386,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, n_diis = min(n_diis+1,max_diis) call DIIS_extrapolation(rcond,2*nOrb**4,2*nOrb**4,n_diis,err_diis,Phi_diis,err,Phi) - print*,rcond end if @@ -439,7 +441,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*)' Two-body convergence failed ' write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) - stop + !stop else @@ -459,15 +461,19 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) 'Building self-energy' + call wall_time(start_t) - !call G_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,eOld,EcGM,SigC,Z) + call G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eOld,ERI, & + eh_rho,old_eh_Om,ee_rho,old_ee_Om,hh_rho,old_hh_Om,EcGM,SigC,Z) call wall_time(end_t) t = end_t - start_t write(*,'(A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' write(*,*) - - eQPlin(:) = eHF(:) !+ Z(:)*SigC(:) + eQPlin(:) = eHF(:) + Z(:)*SigC(:) + + call print_RG0F2(nOrb,nO,eHF,SigC,eQPlin,Z,0d0,0d0,0d0) + ! Solve the quasi-particle equation if(linearize) then diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 index b264938..99f76f8 100644 --- a/src/Parquet/G_eh_Phi.f90 +++ b/src/Parquet/G_eh_Phi.f90 @@ -23,7 +23,7 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR - do n=1,nS + do n=1,nS eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & - eh_rho(p,r,n)*eh_rho(s,q,n)/eh_Om(n) diff --git a/src/Parquet/G_irred_Parquet_self_energy.f90 b/src/Parquet/G_irred_Parquet_self_energy.f90 new file mode 100644 index 0000000..e75de75 --- /dev/null +++ b/src/Parquet/G_irred_Parquet_self_energy.f90 @@ -0,0 +1,297 @@ +subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& + eh_rho,eh_Om,ee_rho,ee_Om,hh_rho,hh_Om,EcGM,SigC,Z) + +! Compute correlation part of the self-energy coming from irreducible vertices contribution + implicit none + include 'parameters.h' + +! Input variables + double precision,intent(in) :: eta + integer,intent(in) :: nOrb + integer,intent(in) :: nC, nO, nV, nR + integer,intent(in) :: nS, nOO, nVV + double precision,intent(in) :: eQP(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: ee_Om(nVV) + double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + double precision,intent(in) :: hh_Om(nOO) + +! Local variables + integer :: i,j,k,a,b,c + integer :: p,n + double precision :: eps,dem1,dem2,reg,reg1,reg2 + double precision :: num + +! Output variables + double precision,intent(out) :: SigC(nOrb) + double precision,intent(out) :: Z(nOrb) + double precision,intent(out) :: EcGM + + ! Initialize + + SigC(:) = 0d0 + Z(:) = 0d0 + EcGM = 0d0 + +!-----------------------------! +! GF2 part of the self-energy ! +!-----------------------------! + do p=nC+1,nOrb-nR + ! 2h1p sum + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nOrb-nR + + eps = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg = (1d0 - exp(- 2d0 * eta * eps * eps)) + num = 0.5d0*(ERI(p,a,i,j) - ERI(p,a,j,i))**2 + + SigC(p) = SigC(p) + num*reg/eps + Z(p) = Z(p) - num*reg/eps**2 + + end do + end do + end do + ! 2p1h sum + do i=nC+1,nO + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + + eps = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg = (1d0 - exp(- 2d0 * eta * eps * eps)) + num = 0.5d0*(ERI(p,i,a,b) - ERI(p,i,b,a))**2 + + SigC(p) = SigC(p) + num*reg/eps + Z(p) = Z(p) - num*reg/eps**2 + + end do + end do + end do + end do + +!-----------------------------! +! eh part of the self-energy ! +!-----------------------------! + + do p=nC+1,nOrb-nR + + do i=nC+1,nO + do a=nO+1,nOrb-nR + + do n=1,nS + !3h2p + do j=nC+1,nO + num = ERI(p,a,j,i) * & + (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,a,j,i) * & + (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,i,j,a) * & + (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,a,j,i) * & + (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = ERI(p,a,b,i) * & + (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(b,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,i,b,a) * & + (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,i,b,a) * & + (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,i,b,a) * & + (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + + end do ! b + + end do ! n + + end do ! a + end do ! i + + end do ! p + +!-----------------------------! +! pp part of the self-energy ! +!-----------------------------! + + do p=nC+1,nOrb-nR + + do i=nC+1,nO + do j=nC+1,nO + do n=1,nVV + ! 4h1p + do k=nC+1,nO + num = ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) + dem1 = ee_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(k) - ee_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + end do ! k + ! 3h2p + do c=nO+1,nOrb-nR + + num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) + dem1 = ee_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + end do ! a + end do ! n + do n=1,nOO + ! 3h2p + do c=nO+1,nOrb-nR + + num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - hh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + + end do ! c + end do ! n + end do ! j + end do ! i + + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + do n=1,nOO + ! 4p1h + do c=nO+1,nOrb-nR + + num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) + dem1 = hh_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(c) - hh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + end do ! c + ! 3p2h + do k=nC+1,nO + + num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) + dem1 = hh_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + end do ! k + end do ! n + do n=1,nVV + ! 3p2h + do k=nC+1,nO + + num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - ee_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + + num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + + end do ! c + end do ! n + end do ! b + end do ! a + + end do ! p + +!-----------------------------! +! Renormalization factor ! +!-----------------------------! + + Z(:) = 1d0/(1d0 - Z(:)) + +end subroutine G_Parquet_self_energy diff --git a/src/Parquet/G_pp_Phi.f90 b/src/Parquet/G_pp_Phi.f90 index 12aad4d..b4c9853 100644 --- a/src/Parquet/G_pp_Phi.f90 +++ b/src/Parquet/G_pp_Phi.f90 @@ -30,7 +30,7 @@ subroutine G_pp_Phi(nOrb,nC,nR,nOO,nVV,ee_Om,ee_rho,hh_Om,hh_rho,pp_Phi) + 2d0 * ee_rho(p,q,n)*ee_rho(r,s,n)/ee_Om(n) end do - do n=1,nOO + do n=1,nOO pp_Phi(p,q,r,s) = pp_Phi(p,q,r,s) & - 2d0 * hh_rho(p,q,n)*hh_rho(r,s,n)/hh_Om(n) end do diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index e921bbb..5f55898 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -37,10 +37,12 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) & + + (1d0*ERI(q,j,p,b) - 1d0*ERI(q,j,b,p) & - - 1d0*eh_Phi(q,j,b,p) + 1d0*pp_Phi(q,j,p,b)) * X & + - 0d0*eh_Phi(q,j,b,p) + 0d0*pp_Phi(q,j,p,b)) * X & + (1d0*ERI(q,b,p,j) - 1d0*ERI(q,b,j,p) & - - 1d0*eh_Phi(q,b,j,p) + 1d0*pp_Phi(q,b,p,j)) * Y + - 0d0*eh_Phi(q,b,j,p) + 0d0*pp_Phi(q,b,p,j)) * Y + end do end do @@ -107,8 +109,10 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 + rho1(p,q,ab) = rho1(p,q,ab) + ( 1d0*ERI(p,q,c,d) - 1d0*ERI(p,q,d,c) & - + 1d0*eh_Phi(p,q,c,d) - 1d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) + + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) + end do end do @@ -116,8 +120,10 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do k=nC+1,nO do l=k+1,nO kl = kl + 1 + rho1(p,q,ab) = rho1(p,q,ab) + ( 1d0*ERI(p,q,k,l) - 1d0*ERI(p,q,l,k) & - + 1d0*eh_Phi(p,q,k,l) - 1d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) + + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) + end do end do @@ -132,8 +138,10 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 + rho2(p,q,ij) = rho2(p,q,ij) + ( 1d0*ERI(p,q,c,d) - 1d0*ERI(p,q,d,c) & - + 1d0*eh_Phi(p,q,c,d) - 1d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) + + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) + end do end do @@ -141,8 +149,10 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do k=nC+1,nO do l=k+1,nO kl = kl + 1 + rho2(p,q,ij) = rho2(p,q,ij) + ( 1d0*ERI(p,q,k,l) - 1d0*ERI(p,q,l,k) & - + 1d0*eh_Phi(p,q,k,l) - 1d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) + + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) + end do end do end do diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 2ebb263..0b619d3 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -39,11 +39,11 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(q,j,p,b) - ERI(q,j,b,p) & - - 0.5d0*eh_sing_Phi(q,j,b,p) - 1.5d0*eh_trip_Phi(q,j,b,p) & - + 0.5d0*pp_sing_Phi(q,j,p,b) + 1.5d0*pp_trip_Phi(q,j,p,b)) * X & + - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) - 0d0*1.5d0*eh_trip_Phi(q,j,b,p) & + + 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*1.5d0*pp_trip_Phi(q,j,p,b)) * X & + (2d0*ERI(q,b,p,j) - ERI(q,b,j,p) & - - 0.5d0*eh_sing_Phi(q,b,j,p) - 1.5d0*eh_trip_Phi(q,b,j,p) & - + 0.5d0*pp_sing_Phi(q,b,p,j) + 1.5d0*pp_trip_Phi(q,b,p,j)) * Y + - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) - 0d0*1.5d0*eh_trip_Phi(q,b,j,p) & + + 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*1.5d0*pp_trip_Phi(q,b,p,j)) * Y end do @@ -98,11 +98,11 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) + (- ERI(q,j,b,p) & - - 0.5d0*eh_sing_Phi(q,j,b,p) + 0.5d0*eh_trip_Phi(q,j,b,p) & - - 0.5d0*pp_sing_Phi(q,j,p,b) + 0.5d0*pp_trip_Phi(q,j,p,b)) * X & + - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) + 0d0*0.5d0*eh_trip_Phi(q,j,b,p) & + - 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*0.5d0*pp_trip_Phi(q,j,p,b)) * X & + (- ERI(q,b,j,p) & - - 0.5d0*eh_sing_Phi(q,b,j,p) + 0.5d0*eh_trip_Phi(q,b,j,p) & - - 0.5d0*pp_sing_Phi(q,b,p,j) + 0.5d0*pp_trip_Phi(q,b,p,j)) * Y + - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) + 0d0*0.5d0*eh_trip_Phi(q,b,j,p) & + - 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*0.5d0*pp_trip_Phi(q,b,p,j)) * Y end do end do @@ -174,8 +174,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & - + 0.5d0*eh_sing_Phi(p,q,d,c) - 1.5d0*eh_trip_Phi(p,q,d,c))& + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & + + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& *X1(cd,ab)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d @@ -188,8 +188,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & - + 0.5d0*eh_sing_Phi(p,q,l,k) - 1.5d0*eh_trip_Phi(p,q,l,k))& + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & + + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& *Y1(kl,ab)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -207,8 +207,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) - 1.5d0*eh_trip_Phi(p,q,c,d) & - + 0.5d0*eh_sing_Phi(p,q,d,c) - 1.5d0*eh_trip_Phi(p,q,d,c))& + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & + + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& *X2(cd,ij)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d end do ! c @@ -219,8 +219,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) - 1.5d0*eh_trip_Phi(p,q,k,l) & - + 0.5d0*eh_sing_Phi(p,q,l,k) - 1.5d0*eh_trip_Phi(p,q,l,k))& + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & + + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& *Y2(kl,ij)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -291,8 +291,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & - - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & + - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) end do ! d end do ! c @@ -304,8 +304,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & - - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & + - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) end do ! l end do ! k end do ! b @@ -322,8 +322,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, cd = cd + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0.5d0*eh_sing_Phi(p,q,c,d) + 0.5d0*eh_trip_Phi(p,q,c,d) & - - 0.5d0*eh_sing_Phi(p,q,d,c) - 0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) + + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & + - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) end do ! d end do ! c @@ -333,8 +333,8 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, kl = kl + 1 rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0.5d0*eh_sing_Phi(p,q,k,l) + 0.5d0*eh_trip_Phi(p,q,k,l) & - - 0.5d0*eh_sing_Phi(p,q,l,k) - 0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) + + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & + - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) end do ! l end do ! k diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 4275944..cb50cde 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -379,7 +379,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, call wall_time(start_Parquet) call RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & nOrb,nC,nO,nV,nR,nS, & - eHF,ERI_MO) + eGW,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet From 014a6adcfe1b5f71667072a7de7c68d0bdd16ad1 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 31 Mar 2025 16:18:56 +0200 Subject: [PATCH 33/71] add renormalization factor --- src/Parquet/GParquet.f90 | 2 +- src/Parquet/G_irred_Parquet_self_energy.f90 | 20 ++++++++++++++++++-- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index a53244c..08eba12 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -497,7 +497,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, err_1b = maxval(abs(eOld - eQP)) eOld(:) = eQP(:) - + write(*,'(A50,1X,F9.5,A8)') 'Error for one-body iteration =', err_1b call wall_time(end_1b) t_1b = end_1b - start_1b write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' diff --git a/src/Parquet/G_irred_Parquet_self_energy.f90 b/src/Parquet/G_irred_Parquet_self_energy.f90 index e75de75..ebb88a5 100644 --- a/src/Parquet/G_irred_Parquet_self_energy.f90 +++ b/src/Parquet/G_irred_Parquet_self_energy.f90 @@ -47,7 +47,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& eps = eQP(p) + eQP(a) - eQP(i) - eQP(j) reg = (1d0 - exp(- 2d0 * eta * eps * eps)) - num = 0.5d0*(ERI(p,a,i,j) - ERI(p,a,j,i))**2 + num = 0.5d0*(ERI(p,a,j,i) - ERI(p,a,i,j))**2 SigC(p) = SigC(p) + num*reg/eps Z(p) = Z(p) - num*reg/eps**2 @@ -62,7 +62,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& eps = eQP(p) + eQP(i) - eQP(a) - eQP(b) reg = (1d0 - exp(- 2d0 * eta * eps * eps)) - num = 0.5d0*(ERI(p,i,a,b) - ERI(p,i,b,a))**2 + num = 0.5d0*(ERI(p,i,b,a) - ERI(p,i,a,b))**2 SigC(p) = SigC(p) + num*reg/eps Z(p) = Z(p) - num*reg/eps**2 @@ -93,6 +93,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,a,j,i) * & (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) @@ -103,6 +104,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,i,j,a) * & (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) @@ -113,6 +115,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,a,j,i) * & (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) @@ -123,6 +126,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! j !3p2h @@ -136,6 +140,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,i,b,a) * & (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) @@ -145,6 +150,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,i,b,a) * & (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) @@ -155,6 +161,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,i,b,a) * & (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) @@ -165,6 +172,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! b @@ -193,6 +201,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k ! 3h2p @@ -205,6 +214,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! a end do ! n @@ -219,6 +229,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) dem1 = hh_Om(n) - eQP(i) - eQP(j) @@ -227,6 +238,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -246,6 +258,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c ! 3p2h @@ -258,6 +271,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k end do ! n @@ -272,6 +286,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) dem1 = ee_Om(n) - eQP(a) - eQP(b) @@ -280,6 +295,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n From cd54aab559a4ac5d7f1df542668ad54a2ca8e137 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 31 Mar 2025 16:21:52 +0200 Subject: [PATCH 34/71] =?UTF-8?q?correct=20unwanted=20change=C3=A9?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/GT/RGTeh_SigC.f90 | 4 ++-- src/GT/RGTeh_dSigC.f90 | 4 ++-- src/GT/RGTeh_self_energy_diag.f90 | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/GT/RGTeh_SigC.f90 b/src/GT/RGTeh_SigC.f90 index 85f61d5..2f59db3 100644 --- a/src/GT/RGTeh_SigC.f90 +++ b/src/GT/RGTeh_SigC.f90 @@ -35,7 +35,7 @@ double precision function RGTeh_SigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR) do i=nC+1,nO do m=1,nS eps = w - e(i) + Om(m) - num = rhoL(i,p,m)*rhoL(i,p,m) + num = rhoL(i,p,m)*rhoR(i,p,m) RGTeh_SigC = RGTeh_SigC + num*eps/(eps**2 + eta**2) end do end do @@ -45,7 +45,7 @@ double precision function RGTeh_SigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR) do a=nO+1,nBas-nR do m=1,nS eps = w - e(a) - Om(m) - num = rhoL(p,a,m)*rhoL(p,a,m) + num = rhoL(p,a,m)*rhoR(p,a,m) RGTeh_SigC = RGTeh_SigC + num*eps/(eps**2 + eta**2) end do end do diff --git a/src/GT/RGTeh_dSigC.f90 b/src/GT/RGTeh_dSigC.f90 index fbb2215..850ab38 100644 --- a/src/GT/RGTeh_dSigC.f90 +++ b/src/GT/RGTeh_dSigC.f90 @@ -35,7 +35,7 @@ double precision function RGTeh_dSigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR do i=nC+1,nO do m=1,nS eps = w - e(i) + Om(m) - num = rhoL(i,p,m)*rhoL(i,p,m) + num = rhoL(i,p,m)*rhoR(i,p,m) RGTeh_dSigC = RGTeh_dSigC - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 end do end do @@ -45,7 +45,7 @@ double precision function RGTeh_dSigC(p,w,eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR do a=nO+1,nBas-nR do m=1,nS eps = w - e(a) - Om(m) - num = rhoL(p,a,m)*rhoL(p,a,m) + num = rhoL(p,a,m)*rhoR(p,a,m) RGTeh_dSigC = RGTeh_dSigC - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 end do end do diff --git a/src/GT/RGTeh_self_energy_diag.f90 b/src/GT/RGTeh_self_energy_diag.f90 index 039e17e..14e0055 100644 --- a/src/GT/RGTeh_self_energy_diag.f90 +++ b/src/GT/RGTeh_self_energy_diag.f90 @@ -46,7 +46,7 @@ subroutine RGTeh_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR,EcGM,Si do m=1,nS eps = e(p) - e(i) + Om(m) - num = rhoL(i,p,m)*rhoL(i,p,m) + num = rhoL(i,p,m)*rhoR(i,p,m) Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 @@ -61,7 +61,7 @@ subroutine RGTeh_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rhoL,rhoR,EcGM,Si do m=1,nS eps = e(p) - e(a) - Om(m) - num = rhoL(p,a,m)*rhoL(p,a,m) + num = rhoL(p,a,m)*rhoR(p,a,m) Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 From 337a672461a2a9a6dbce6b1130a9d1e7a03d7de3 Mon Sep 17 00:00:00 2001 From: pfloos Date: Mon, 31 Mar 2025 21:31:59 +0200 Subject: [PATCH 35/71] proper printing routine for 1b parquet --- src/GW/print_qsRGW.f90 | 7 ++-- src/Parquet/GParquet.f90 | 27 ++++++++------- src/Parquet/print_parquet_1b.f90 | 58 ++++++++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 18 deletions(-) create mode 100644 src/Parquet/print_parquet_1b.f90 diff --git a/src/GW/print_qsRGW.f90 b/src/GW/print_qsRGW.f90 index 9fd695c..e093975 100644 --- a/src/GW/print_qsRGW.f90 +++ b/src/GW/print_qsRGW.f90 @@ -1,8 +1,5 @@ - -! --- - -subroutine print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, & - Z, ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole) +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 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 08eba12..ed0481e 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -411,12 +411,12 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, deallocate(eh_Phi,pp_Phi) - write(*,*) '----------------------------------------------' - write(*,*) ' Two-body (frequency/kernel) convergence ' - write(*,*) '----------------------------------------------' - write(*,'(1X,A24,F10.6,1X,F10.6)')'Error for eh channel = ',err_eig_eh,err_eh - write(*,'(1X,A24,F10.6,1X,F10.6)')'Error for pp channel = ',err_eig_pp,err_pp - write(*,*) '----------------------------------------------' + write(*,*) '------------------------------------------------' + write(*,*) ' Two-body (frequency/kernel) convergence ' + write(*,*) '------------------------------------------------' + write(*,'(1X,A24,F10.6,1X,A1,1X,F10.6)')'Error for eh channel = ',err_eig_eh,'/',err_eh + write(*,'(1X,A24,F10.6,1X,A1,1X,F10.6)')'Error for pp channel = ',err_eig_pp,'/',err_pp + write(*,*) '------------------------------------------------' write(*,*) ! Convergence criteria @@ -459,8 +459,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) - write(*,*) 'Building self-energy' - + write(*,*) 'Building self-energy...' call wall_time(start_t) call G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eOld,ERI, & @@ -471,8 +470,6 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, write(*,*) eQPlin(:) = eHF(:) + Z(:)*SigC(:) - - call print_RG0F2(nOrb,nO,eHF,SigC,eQPlin,Z,0d0,0d0,0d0) ! Solve the quasi-particle equation @@ -491,13 +488,17 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, end if - deallocate(eQPlin,Z,SigC) - ! Check one-body converge err_1b = maxval(abs(eOld - eQP)) eOld(:) = eQP(:) - write(*,'(A50,1X,F9.5,A8)') 'Error for one-body iteration =', err_1b + + ! Print for one-body part + + call print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,0d0,0d0,0d0) + + deallocate(eQPlin,Z,SigC) + call wall_time(end_1b) t_1b = end_1b - start_1b write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' diff --git a/src/Parquet/print_parquet_1b.f90 b/src/Parquet/print_parquet_1b.f90 new file mode 100644 index 0000000..4b6ab38 --- /dev/null +++ b/src/Parquet/print_parquet_1b.f90 @@ -0,0 +1,58 @@ +subroutine print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,ERHF,Ec) + +! Print one-electron energies and other stuff for G0F2 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nOrb + integer,intent(in) :: nO + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: SigC(nOrb) + double precision,intent(in) :: eQP(nOrb) + double precision,intent(in) :: Z(nOrb) + integer,intent(in) :: n_it_1b + double precision,intent(in) :: err_1b + double precision,intent(in) :: ENuc + double precision,intent(in) :: ERHF + double precision,intent(in) :: Ec + + integer :: p + integer :: HOMO + integer :: LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eQP(LUMO) - eQP(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + write(*,*)' Parquet self-energy ' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + 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)*HaToeV,'|',Z(p),'|',eQP(p)*HaToeV,'|' + end do + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,I15)') 'One-body iteration # ',n_it_1b + write(*,'(2X,A60,F15.6)') 'One-body convergence ',err_1b + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO energy = ',eQP(HOMO)*HaToeV,' eV' + write(*,'(2X,A60,F15.6,A3)') 'Parquet LUMO energy = ',eQP(LUMO)*HaToeV,' eV' + write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO-LUMO gap = ',Gap*HaToeV,' eV' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') 'Parquet total energy = ',ENuc + ERHF + Ec,' au' + write(*,'(2X,A60,F15.6,A3)') 'Parquet correlation energy = ',Ec,' au' + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine From a96e46bbc5a3f23c4a9709ddc3409461affdc3f1 Mon Sep 17 00:00:00 2001 From: pfloos Date: Mon, 31 Mar 2025 22:03:00 +0200 Subject: [PATCH 36/71] more changes in print --- src/Parquet/GParquet.f90 | 13 ++++++++----- src/Parquet/print_parquet_1b.f90 | 16 +++++++++++----- src/QuAcK/GQuAcK.f90 | 11 +++++------ 3 files changed, 24 insertions(+), 16 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index ed0481e..b1ca02c 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -1,4 +1,4 @@ -subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF,ERI) +subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eGHF,eHF,ERI) ! Parquet approximation based on restricted orbitals @@ -15,6 +15,8 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Input variables + double precision,intent(in) :: ENuc + double precision,intent(in) :: EGHF integer,intent(in) :: max_it_1b,max_it_2b double precision,intent(in) :: conv_1b,conv_2b integer,intent(in) :: nOrb,nC,nO,nV,nR,nS @@ -34,12 +36,13 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: nOO,nVV ! eh BSE - double precision :: EcRPA + double precision :: Ec_eh double precision,allocatable :: Aph(:,:), Bph(:,:) double precision,allocatable :: XpY(:,:), XmY(:,:) double precision,allocatable :: eh_Om(:), old_eh_Om(:) double precision,allocatable :: eh_Gam_A(:,:),eh_Gam_B(:,:) ! pp BSE + double precision :: Ec_pp double precision,allocatable :: Bpp(:,:), Cpp(:,:), Dpp(:,:) double precision,allocatable :: X1(:,:),Y1(:,:) double precision,allocatable :: ee_Om(:), old_ee_Om(:) @@ -207,7 +210,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) - call phGLR(TDA,nS,Aph,Bph,EcRPA,eh_Om,XpY,XmY) + call phGLR(TDA,nS,Aph,Bph,Ec_eh,eh_Om,XpY,XmY) call wall_time(end_t) @@ -260,7 +263,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) - call ppGLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,EcRPA) + call ppGLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,Ec_pp) call wall_time(end_t) t = end_t - start_t @@ -495,7 +498,7 @@ subroutine GParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Print for one-body part - call print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,0d0,0d0,0d0) + call print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) deallocate(eQPlin,Z,SigC) diff --git a/src/Parquet/print_parquet_1b.f90 b/src/Parquet/print_parquet_1b.f90 index 4b6ab38..a2324d9 100644 --- a/src/Parquet/print_parquet_1b.f90 +++ b/src/Parquet/print_parquet_1b.f90 @@ -1,4 +1,4 @@ -subroutine print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,ERHF,Ec) +subroutine print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) ! Print one-electron energies and other stuff for G0F2 @@ -14,8 +14,10 @@ subroutine print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,ERHF,Ec) integer,intent(in) :: n_it_1b double precision,intent(in) :: err_1b double precision,intent(in) :: ENuc - double precision,intent(in) :: ERHF - double precision,intent(in) :: Ec + double precision,intent(in) :: EGHF + double precision,intent(in) :: EcGM + double precision,intent(in) :: Ec_eh + double precision,intent(in) :: Ec_pp integer :: p integer :: HOMO @@ -50,8 +52,12 @@ subroutine print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,ERHF,Ec) write(*,'(2X,A60,F15.6,A3)') 'Parquet LUMO energy = ',eQP(LUMO)*HaToeV,' eV' write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO-LUMO gap = ',Gap*HaToeV,' eV' write(*,*)'-------------------------------------------------------------------------------' - write(*,'(2X,A60,F15.6,A3)') 'Parquet total energy = ',ENuc + ERHF + Ec,' au' - write(*,'(2X,A60,F15.6,A3)') 'Parquet correlation energy = ',Ec,' au' + write(*,'(2X,A60,F15.6,A3)') ' Parquet total energy = ',ENuc + EGHF + EcGM,' au' + write(*,'(2X,A60,F15.6,A3)') ' Parquet correlation energy = ',EcGM,' au' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') ' eh-RPA correlation energy = ',Ec_eh,' au' + write(*,'(2X,A60,F15.6,A3)') ' pp-RPA correlation energy = ',Ec_pp,' au' + write(*,'(2X,A60,F15.6,A3)') '(eh+pp)-RPA correlation energy = ',Ec_pp,' au' write(*,*)'-------------------------------------------------------------------------------' write(*,*) diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index b6d7534..3ffa793 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -8,7 +8,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_macro,conv_one_body,max_it_micro,conv_two_body) + max_it_1b,conv_1b,max_it_2b,conv_2b) implicit none include 'parameters.h' @@ -75,8 +75,8 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop logical,intent(in) :: dophBSE,dophBSE2,doppBSE,dBSE,dTDA logical,intent(in) :: doACFDT,exchange_kernel,doXBS - integer,intent(in) :: max_it_macro,max_it_micro - double precision,intent(in) :: conv_one_body,conv_two_body + integer,intent(in) :: max_it_1b,max_it_2b + double precision,intent(in) :: conv_1b,conv_2b ! Local variables @@ -349,9 +349,8 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) - call GParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & - nBas2,nC,nO,nV,nR,nS, & - eHF,ERI_MO) + call GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b, & + nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet From d1dd544b3ed103bc62c50934bc4ae958c7335f56 Mon Sep 17 00:00:00 2001 From: pfloos Date: Mon, 31 Mar 2025 22:19:07 +0200 Subject: [PATCH 37/71] adding more variables (Ec,TDA) --- src/Parquet/GParquet.f90 | 27 ++++++++-------- src/Parquet/RParquet.f90 | 67 +++++++++++++++++++++------------------- src/QuAcK/GQuAcK.f90 | 3 +- src/QuAcK/RQuAcK.f90 | 10 +++--- 4 files changed, 54 insertions(+), 53 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index b1ca02c..68cc8fa 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -7,7 +7,8 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS ! Hard-coded parameters - logical :: TDA = .true. + logical :: TDAeh = .true. + logical :: TDApp = .true. logical :: linearize = .true. logical :: print_phLR = .false. logical :: print_ppLR = .false. @@ -192,8 +193,8 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS call wall_time(start_t) - call phGLR_A(.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) - if(.not.TDA) call phGLR_B(.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phGLR_A(.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) + if(.not.TDAeh) call phGLR_B(.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) if(n_it_2b == 1) then @@ -202,15 +203,15 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS else - call G_eh_Gamma_A(nOrb,nC,nO,nR,nS,old_eh_Phi,old_pp_Phi,eh_Gam_A) - if(.not.TDA) call G_eh_Gamma_B(nOrb,nC,nO,nR,nS,old_eh_Phi,old_pp_Phi,eh_Gam_B) + call G_eh_Gamma_A(nOrb,nC,nO,nR,nS,old_eh_Phi,old_pp_Phi,eh_Gam_A) + if(.not.TDAeh) call G_eh_Gamma_B(nOrb,nC,nO,nR,nS,old_eh_Phi,old_pp_Phi,eh_Gam_B) end if Aph(:,:) = Aph(:,:) + eh_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_Gam_B(:,:) - call phGLR(TDA,nS,Aph,Bph,Ec_eh,eh_Om,XpY,XmY) + call phGLR(TDAeh,nS,Aph,Bph,Ec_eh,eh_Om,XpY,XmY) call wall_time(end_t) @@ -241,9 +242,9 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS Dpp(:,:) = 0d0 call wall_time(start_t) - if(.not.TDA) call ppGLR_B(nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) - call ppGLR_C(nOrb,nC,nO,nV,nR,nVV,1d0,eOld,ERI,Cpp) - call ppGLR_D(nOrb,nC,nO,nV,nR,nOO,1d0,eOld,ERI,Dpp) + if(.not.TDApp) call ppGLR_B(nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp) + call ppGLR_C(nOrb,nC,nO,nV,nR,nVV,1d0,eOld,ERI,Cpp) + call ppGLR_D(nOrb,nC,nO,nV,nR,nOO,1d0,eOld,ERI,Dpp) if(n_it_2b == 1) then @@ -253,9 +254,9 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS else - if(.not.TDA) call G_pp_Gamma_B(nOrb,nC,nO,nR,nOO,nVV,old_eh_Phi,pp_Gam_B) - call G_pp_Gamma_C(nOrb,nO,nR,nVV,old_eh_Phi,pp_Gam_C) - call G_pp_Gamma_D(nOrb,nC,nO,nOO,old_eh_Phi,pp_Gam_D) + if(.not.TDApp) call G_pp_Gamma_B(nOrb,nC,nO,nR,nOO,nVV,old_eh_Phi,pp_Gam_B) + call G_pp_Gamma_C(nOrb,nO,nR,nVV,old_eh_Phi,pp_Gam_C) + call G_pp_Gamma_D(nOrb,nC,nO,nOO,old_eh_Phi,pp_Gam_D) end if @@ -263,7 +264,7 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS Cpp(:,:) = Cpp(:,:) + pp_Gam_C(:,:) Dpp(:,:) = Dpp(:,:) + pp_Gam_D(:,:) - call ppGLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,Ec_pp) + call ppGLR(TDApp,nOO,nVV,Bpp,Cpp,Dpp,ee_Om,X1,Y1,hh_Om,X2,Y2,Ec_pp) call wall_time(end_t) t = end_t - start_t diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index cb0e02f..336c991 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -1,4 +1,4 @@ -subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF,ERI) +subroutine RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI) ! Parquet approximation based on restricted orbitals @@ -7,13 +7,16 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, ! Hard-coded parameters - logical :: linearize = .true. - logical :: TDA = .true. + logical :: TDAeh = .true. + logical :: TDApp = .true. + logical :: linearize = .true. logical :: print_phLR = .true. logical :: print_ppLR = .true. ! Input variables + double precision,intent(in) :: ENuc + double precision,intent(in) :: ERHF integer,intent(in) :: max_it_1b,max_it_2b double precision,intent(in) :: conv_1b,conv_2b integer,intent(in) :: nOrb,nC,nO,nV,nR,nS @@ -39,7 +42,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, integer :: nVVs,nVVt ! eh BSE - double precision :: EcRPA + double precision :: Ec_eh(nspin) double precision,allocatable :: Aph(:,:), Bph(:,:) double precision,allocatable :: sing_XpY(:,:),trip_XpY(:,:) double precision,allocatable :: sing_XmY(:,:),trip_XmY(:,:) @@ -47,7 +50,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, double precision,allocatable :: eh_trip_Om(:), old_eh_trip_Om(:) double precision,allocatable :: eh_sing_Gam_A(:,:),eh_sing_Gam_B(:,:) double precision,allocatable :: eh_trip_Gam_A(:,:),eh_trip_Gam_B(:,:) + ! pp BSE + double precision :: Ec_pp(nspin) double precision,allocatable :: Bpp(:,:), Cpp(:,:), Dpp(:,:) double precision,allocatable :: X1s(:,:),X1t(:,:) double precision,allocatable :: Y1s(:,:),Y1t(:,:) @@ -199,8 +204,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(start_t) - call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) - if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDAeh) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) if(n_it_2b == 1) then @@ -213,9 +218,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & eh_sing_Gam_A) - if(.not.TDA) call R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS, & - old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & - eh_sing_Gam_B) + if(.not.TDAeh) call R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS, & + old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + eh_sing_Gam_B) end if @@ -223,7 +228,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Bph(:,:) = Bph(:,:) + eh_sing_Gam_B(:,:) - call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_sing_Om,sing_XpY,sing_XmY) + call phRLR(TDAeh,nS,Aph,Bph,Ec_eh(ispin),eh_sing_Om,sing_XpY,sing_XmY) call wall_time(end_t) @@ -254,8 +259,8 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, call wall_time(start_t) - call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) - if(.not.TDA) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + if(.not.TDAeh) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) if(n_it_2b == 1) then @@ -268,16 +273,16 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & eh_trip_Gam_A) - if(.not.TDA) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS, & - old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & - eh_trip_Gam_B) + if(.not.TDAeh) call R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS, & + old_eh_sing_Phi,old_eh_trip_Phi,old_pp_sing_Phi,old_pp_trip_Phi, & + eh_trip_Gam_B) end if Aph(:,:) = Aph(:,:) + eh_trip_Gam_A(:,:) Bph(:,:) = Bph(:,:) + eh_trip_Gam_B(:,:) - call phRLR(TDA,nS,Aph,Bph,EcRPA,eh_trip_Om,trip_XpY,trip_XmY) + call phRLR(TDAeh,nS,Aph,Bph,Ec_eh(ispin),eh_trip_Om,trip_XpY,trip_XmY) call wall_time(end_t) t = end_t - start_t @@ -311,9 +316,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Dpp(:,:) = 0d0 call wall_time(start_t) - if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + if(.not.TDApp) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) if(n_it_2b == 1) then @@ -323,10 +328,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - if(.not.TDA) call R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nOOs,nVVs,& - old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_B) - call R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_C) - call R_pp_singlet_Gamma_D(nOrb,nC,nO,nOOs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_D) + if(.not.TDApp) call R_pp_singlet_Gamma_B(nOrb,nC,nO,nR,nOOs,nVVs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_B) + call R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_C) + call R_pp_singlet_Gamma_D(nOrb,nC,nO,nOOs,old_eh_sing_Phi,old_eh_trip_Phi,pp_sing_Gam_D) end if @@ -334,7 +338,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) - call ppRLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,EcRPA) + call ppRLR(TDApp,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,Ec_pp(ispin)) call wall_time(end_t) t = end_t - start_t @@ -369,9 +373,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Dpp(:,:) = 0d0 call wall_time(start_t) - if(.not.TDA) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + if(.not.TDApp) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) if(n_it_2b == 1) then @@ -381,10 +385,9 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, else - if(.not.TDA) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nOOt,nVVt,& - old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_B) - call R_pp_triplet_Gamma_C(nOrb,nO,nR,nVVt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_C) - call R_pp_triplet_Gamma_D(nOrb,nC,nO,nOOt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_D) + if(.not.TDApp) call R_pp_triplet_Gamma_B(nOrb,nC,nO,nR,nOOt,nVVt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_B) + call R_pp_triplet_Gamma_C(nOrb,nO,nR,nVVt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_C) + call R_pp_triplet_Gamma_D(nOrb,nC,nO,nOOt,old_eh_sing_Phi,old_eh_trip_Phi,pp_trip_Gam_D) end if @@ -392,7 +395,7 @@ subroutine RParquet(max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eHF, Cpp(:,:) = Cpp(:,:) + pp_trip_Gam_C(:,:) Dpp(:,:) = Dpp(:,:) + pp_trip_Gam_D(:,:) - call ppRLR(TDA,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,EcRPA) + call ppRLR(TDApp,nOOt,nVVt,Bpp,Cpp,Dpp,ee_trip_Om,X1t,Y1t,hh_trip_Om,X2t,Y2t,Ec_pp(ispin)) call wall_time(end_t) t = end_t - start_t diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index 3ffa793..dd1b3a8 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -349,8 +349,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) - call GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b, & - nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) + call GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index cb50cde..72cf799 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -8,7 +8,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_macro,conv_one_body,max_it_micro,conv_two_body) + max_it_1b,conv_1b,max_it_2b,conv_2b) ! Restricted branch of QuAcK @@ -82,8 +82,8 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, logical,intent(in) :: dophBSE,dophBSE2,doppBSE,dBSE,dTDA logical,intent(in) :: doACFDT,exchange_kernel,doXBS - integer,intent(in) :: max_it_macro,max_it_micro - double precision,intent(in) :: conv_one_body,conv_two_body + integer,intent(in) :: max_it_1b,max_it_2b + double precision,intent(in) :: conv_1b,conv_2b ! Local variables @@ -377,9 +377,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, if(doParquet) then call wall_time(start_Parquet) - call RParquet(max_it_macro,conv_one_body,max_it_micro,conv_two_body, & - nOrb,nC,nO,nV,nR,nS, & - eGW,ERI_MO) + call RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eGW,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet From 2a0172e703dbf60cd411ba4412a6ac2102fd917d Mon Sep 17 00:00:00 2001 From: pfloos Date: Mon, 31 Mar 2025 22:34:59 +0200 Subject: [PATCH 38/71] modify script to create new routines --- src/Parquet/GParquet.f90 | 2 +- src/Parquet/G_eh_Gam.f90 | 4 ++-- src/Parquet/G_eh_Phi.f90 | 2 +- src/Parquet/G_irred_Parquet_self_energy.f90 | 2 +- src/Parquet/G_pp_Phi.f90 | 2 +- src/Parquet/G_screened_integrals.f90 | 4 ++-- src/Parquet/RParquet.f90 | 2 +- src/Parquet/R_eh_singlet_Gam.f90 | 4 ++-- src/Parquet/R_eh_singlet_Phi.f90 | 2 +- src/Parquet/R_eh_triplet_Gam.f90 | 4 ++-- src/Parquet/R_eh_triplet_Phi.f90 | 2 +- src/Parquet/R_irred_Parquet_self_energy.f90 | 2 +- src/Parquet/R_pp_singlet_Phi.f90 | 2 +- src/Parquet/R_pp_triplet_Phi.f90 | 2 +- src/Parquet/R_screened_integrals.f90 | 8 ++++---- utils/create_function.sh | 2 +- utils/create_subroutine.sh | 2 +- 17 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 68cc8fa..6aa7453 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -532,4 +532,4 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS end if -end subroutine GParquet +end subroutine diff --git a/src/Parquet/G_eh_Gam.f90 b/src/Parquet/G_eh_Gam.f90 index af8d235..7fe751f 100644 --- a/src/Parquet/G_eh_Gam.f90 +++ b/src/Parquet/G_eh_Gam.f90 @@ -35,7 +35,7 @@ subroutine G_eh_Gamma_A(nOrb,nC,nO,nR,nS,eh_Phi,pp_Phi,eh_Gam_A) enddo enddo -end subroutine G_eh_Gamma_A +end subroutine subroutine G_eh_Gamma_B(nOrb,nC,nO,nR,nS,eh_Phi,pp_Phi,eh_Gam_B) @@ -74,4 +74,4 @@ subroutine G_eh_Gamma_B(nOrb,nC,nO,nR,nS,eh_Phi,pp_Phi,eh_Gam_B) enddo enddo -end subroutine G_eh_Gamma_B +end subroutine diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 index 99f76f8..d110c64 100644 --- a/src/Parquet/G_eh_Phi.f90 +++ b/src/Parquet/G_eh_Phi.f90 @@ -34,4 +34,4 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) enddo enddo -end subroutine G_eh_Phi +end subroutine diff --git a/src/Parquet/G_irred_Parquet_self_energy.f90 b/src/Parquet/G_irred_Parquet_self_energy.f90 index ebb88a5..ad78e8c 100644 --- a/src/Parquet/G_irred_Parquet_self_energy.f90 +++ b/src/Parquet/G_irred_Parquet_self_energy.f90 @@ -310,4 +310,4 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(:) = 1d0/(1d0 - Z(:)) -end subroutine G_Parquet_self_energy +end subroutine diff --git a/src/Parquet/G_pp_Phi.f90 b/src/Parquet/G_pp_Phi.f90 index b4c9853..65a5b4d 100644 --- a/src/Parquet/G_pp_Phi.f90 +++ b/src/Parquet/G_pp_Phi.f90 @@ -40,4 +40,4 @@ subroutine G_pp_Phi(nOrb,nC,nR,nOO,nVV,ee_Om,ee_rho,hh_Om,hh_rho,pp_Phi) enddo enddo -end subroutine G_pp_Phi +end subroutine diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 5f55898..aa66cb2 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -54,7 +54,7 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho ! !$OMP END DO ! !$OMP END PARALLEL -end subroutine G_eh_screened_integral +end subroutine subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2,Y2,rho2) @@ -163,4 +163,4 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 ! !$OMP END DO ! !$OMP END PARALLEL -end subroutine G_pp_screened_integral +end subroutine diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 336c991..15d3cdd 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -685,4 +685,4 @@ subroutine RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS end if -end subroutine RParquet +end subroutine diff --git a/src/Parquet/R_eh_singlet_Gam.f90 b/src/Parquet/R_eh_singlet_Gam.f90 index 6a82d1d..02dcc02 100644 --- a/src/Parquet/R_eh_singlet_Gam.f90 +++ b/src/Parquet/R_eh_singlet_Gam.f90 @@ -39,7 +39,7 @@ subroutine R_eh_singlet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo -end subroutine R_eh_singlet_Gamma_A +end subroutine subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_sing_Gam_B) @@ -83,4 +83,4 @@ subroutine R_eh_singlet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo -end subroutine R_eh_singlet_Gamma_B +end subroutine diff --git a/src/Parquet/R_eh_singlet_Phi.f90 b/src/Parquet/R_eh_singlet_Phi.f90 index 91bb865..d7f8783 100644 --- a/src/Parquet/R_eh_singlet_Phi.f90 +++ b/src/Parquet/R_eh_singlet_Phi.f90 @@ -35,4 +35,4 @@ subroutine R_eh_singlet_Phi(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_sing_Phi) enddo enddo -end subroutine R_eh_singlet_Phi +end subroutine diff --git a/src/Parquet/R_eh_triplet_Gam.f90 b/src/Parquet/R_eh_triplet_Gam.f90 index acf03bc..d8fc0a5 100644 --- a/src/Parquet/R_eh_triplet_Gam.f90 +++ b/src/Parquet/R_eh_triplet_Gam.f90 @@ -40,7 +40,7 @@ subroutine R_eh_triplet_Gamma_A(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo -end subroutine R_eh_triplet_Gamma_A +end subroutine subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,eh_trip_Gam_B) @@ -83,4 +83,4 @@ subroutine R_eh_triplet_Gamma_B(nOrb,nC,nO,nR,nS,eh_sing_Phi,eh_trip_Phi,pp_sing enddo enddo -end subroutine R_eh_triplet_Gamma_B +end subroutine diff --git a/src/Parquet/R_eh_triplet_Phi.f90 b/src/Parquet/R_eh_triplet_Phi.f90 index e6d8587..38fd216 100644 --- a/src/Parquet/R_eh_triplet_Phi.f90 +++ b/src/Parquet/R_eh_triplet_Phi.f90 @@ -35,4 +35,4 @@ subroutine R_eh_triplet_Phi(nOrb,nC,nR,nS,eh_trip_Om,eh_trip_rho,eh_trip_Phi) enddo enddo -end subroutine R_eh_triplet_Phi +end subroutine diff --git a/src/Parquet/R_irred_Parquet_self_energy.f90 b/src/Parquet/R_irred_Parquet_self_energy.f90 index e385ff2..d0a0bbd 100644 --- a/src/Parquet/R_irred_Parquet_self_energy.f90 +++ b/src/Parquet/R_irred_Parquet_self_energy.f90 @@ -91,4 +91,4 @@ subroutine R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,e,EcGM,SigC,Z) ! end do ! end do -end subroutine R_irred_Parquet_self_energy +end subroutine diff --git a/src/Parquet/R_pp_singlet_Phi.f90 b/src/Parquet/R_pp_singlet_Phi.f90 index 740bb5a..e1ae594 100644 --- a/src/Parquet/R_pp_singlet_Phi.f90 +++ b/src/Parquet/R_pp_singlet_Phi.f90 @@ -41,4 +41,4 @@ subroutine R_pp_singlet_Phi(nOrb,nC,nR,nOO,nVV,ee_sing_Om,ee_sing_rho,hh_sing_Om enddo enddo -end subroutine R_pp_singlet_Phi +end subroutine diff --git a/src/Parquet/R_pp_triplet_Phi.f90 b/src/Parquet/R_pp_triplet_Phi.f90 index 6dd7b1e..eaea4e2 100644 --- a/src/Parquet/R_pp_triplet_Phi.f90 +++ b/src/Parquet/R_pp_triplet_Phi.f90 @@ -41,4 +41,4 @@ subroutine R_pp_triplet_Phi(nOrb,nC,nR,nOO,nVV,ee_trip_Om,ee_trip_rho,hh_trip_Om enddo enddo -end subroutine R_pp_triplet_Phi +end subroutine diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 0b619d3..fca69ea 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -55,7 +55,7 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr ! !$OMP END DO ! !$OMP END PARALLEL -end subroutine R_eh_singlet_screened_integral +end subroutine subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi,XpY,XmY,rho) @@ -114,7 +114,7 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr ! !$OMP END DO ! !$OMP END PARALLEL -end subroutine R_eh_triplet_screened_integral +end subroutine subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi,eh_trip_Phi,X1,Y1,rho1,X2,Y2,rho2) @@ -233,7 +233,7 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, ! !$OMP END DO ! !$OMP END PARALLEL -end subroutine R_pp_singlet_screened_integral +end subroutine @@ -346,4 +346,4 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, ! !$OMP END DO ! !$OMP END PARALLEL -end subroutine R_pp_triplet_screened_integral +end subroutine diff --git a/utils/create_function.sh b/utils/create_function.sh index 1c124ff..387809e 100755 --- a/utils/create_function.sh +++ b/utils/create_function.sh @@ -34,7 +34,7 @@ echo "function ${NAME}() result(${RES}) ! Initalization -end function ${NAME}" > ${NAME}.f90 +end function " > ${NAME}.f90 fi diff --git a/utils/create_subroutine.sh b/utils/create_subroutine.sh index e2f2a49..ca4ef81 100755 --- a/utils/create_subroutine.sh +++ b/utils/create_subroutine.sh @@ -34,7 +34,7 @@ echo "subroutine ${NAME}() ! Initalization -end subroutine ${NAME}" > ${NAME}.f90 +end subroutine" > ${NAME}.f90 fi From abf82a345305b1eba350e13ba7bb866d8c0c206a Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Tue, 1 Apr 2025 13:51:37 +0200 Subject: [PATCH 39/71] working on parquet --- input/options.default | 4 ++-- src/Parquet/GParquet.f90 | 10 +++++----- src/QuAcK/GQuAcK.f90 | 8 +++++--- src/QuAcK/QuAcK.f90 | 17 ++++++++++------- src/QuAcK/read_options.f90 | 32 ++++++++++++++++++++++---------- 5 files changed, 44 insertions(+), 27 deletions(-) diff --git a/input/options.default b/input/options.default index 2e47df4..73355b6 100644 --- a/input/options.default +++ b/input/options.default @@ -18,5 +18,5 @@ F F F F T # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F -# Parquet: max_it_macro conv_one_body max_it_micro conv_two_body - 1 0.00001 1 0.00001 +# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b lin reg + T T 1 0.00001 1 0.00001 F 0.0 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 6aa7453..87da119 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -1,4 +1,4 @@ -subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eGHF,eHF,ERI) +subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eGHF,eHF,ERI) ! Parquet approximation based on restricted orbitals @@ -7,15 +7,15 @@ subroutine GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS ! Hard-coded parameters - logical :: TDAeh = .true. - logical :: TDApp = .true. - logical :: linearize = .true. logical :: print_phLR = .false. logical :: print_ppLR = .false. - double precision :: eta = 100d0 ! Input variables + logical,intent(in) :: TDAeh + logical,intent(in) :: TDApp + logical,intent(in) :: linearize + double precision,intent(in) :: eta double precision,intent(in) :: ENuc double precision,intent(in) :: EGHF integer,intent(in) :: max_it_1b,max_it_2b diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index dd1b3a8..d858ac7 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -8,7 +8,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_1b,conv_1b,max_it_2b,conv_2b) + TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) implicit none include 'parameters.h' @@ -77,6 +77,9 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop integer,intent(in) :: max_it_1b,max_it_2b double precision,intent(in) :: conv_1b,conv_2b + logical,intent(in) :: TDAeh,TDApp + double precision,intent(in) :: reg_parquet + logical,intent(in) :: lin_parquet ! Local variables @@ -349,7 +352,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) - call GParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) + call GParquet(TDAeh,TDApp,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet @@ -357,6 +360,5 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop write(*,*) end if - end subroutine diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index fe78983..f7ba0f4 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -78,18 +78,21 @@ program QuAcK logical :: restart_hfb double precision :: temperature,sigma - - integer :: max_it_macro,max_it_micro - double precision :: conv_one_body,conv_two_body + integer :: max_it_1b,max_it_2b + double precision :: conv_1b,conv_2b + logical :: TDAeh,TDApp + double precision :: reg_parquet + logical :: lin_parquet character(len=256) :: working_dir ! Check if the right number of arguments is provided + if(command_argument_count() < 1) then print *, "No working directory provided." stop else - call get_command_argument(1, working_dir) + call get_command_argument(1,working_dir) endif !-------------! @@ -146,7 +149,7 @@ program QuAcK doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA, & temperature,sigma,chem_pot_hf,restart_hfb, & - max_it_macro,conv_one_body,max_it_micro,conv_two_body) + TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) !------------------! ! Hardware ! @@ -263,7 +266,7 @@ program QuAcK maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_macro,conv_one_body,max_it_micro,conv_two_body) + max_it_1b,conv_1b,max_it_2b,conv_2b) endif endif @@ -296,7 +299,7 @@ program QuAcK maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_macro,conv_one_body,max_it_micro,conv_two_body) + TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) !--------------------------! ! Bogoliubov QuAcK branch ! diff --git a/src/QuAcK/read_options.f90 b/src/QuAcK/read_options.f90 index 27ca5ee..8fe56f6 100644 --- a/src/QuAcK/read_options.f90 +++ b/src/QuAcK/read_options.f90 @@ -9,7 +9,7 @@ subroutine read_options(working_dir, doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA, & temperature,sigma,chem_pot_hf,restart_hfb, & - max_it_macro,conv_one_body,max_it_micro,conv_two_body) + TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) ! Read desired methods @@ -79,8 +79,11 @@ subroutine read_options(working_dir, double precision,intent(out) :: temperature double precision,intent(out) :: sigma - integer,intent(out) :: max_it_macro,max_it_micro - double precision,intent(out) :: conv_one_body,conv_two_body + integer :: max_it_1b,max_it_2b + double precision :: conv_1b,conv_2b + logical :: TDAeh,TDApp + double precision :: reg_parquet + logical :: lin_parquet ! Local variables @@ -241,18 +244,27 @@ subroutine read_options(working_dir, if(ans2 == 'T') restart_hfb = .true. ! Options for Parquet module - - max_it_macro = 1 - conv_one_body = 0.01 - max_it_micro = 1 - conv_two_body = 0.01 + + TDAeh = .false. + TDApp = .false. + max_it_1b = 1 + conv_1b = 1d-2 + max_it_2b = 1 + conv_2b = 1d-2 + lin_parquet = .false. + reg_parquet = 0d0 read(1,*) - read(1,*) max_it_macro,conv_one_body,max_it_micro,conv_two_body - + read(1,*) ans1,ans2,max_it_1b,conv_1b,max_it_2b,conv_2b,ans3,reg_parquet + + if(ans1 == 'T') TDAeh = .true. + if(ans2 == 'T') TDApp = .true. + if(ans3 == 'T') lin_parquet = .true. + endif ! Close file with options + close(unit=1) end subroutine From 2b99b154c5969f85496f716fb45490dc1a6a88fd Mon Sep 17 00:00:00 2001 From: pfloos Date: Tue, 1 Apr 2025 18:18:35 +0200 Subject: [PATCH 40/71] more options in parquet --- input/options.default | 2 +- src/Parquet/GParquet.f90 | 18 +++++++----------- src/Parquet/RParquet.f90 | 33 +++++++++++++++------------------ src/QuAcK/QuAcK.f90 | 2 +- src/QuAcK/RQuAcK.f90 | 7 +++++-- 5 files changed, 29 insertions(+), 33 deletions(-) diff --git a/input/options.default b/input/options.default index 73355b6..93be274 100644 --- a/input/options.default +++ b/input/options.default @@ -19,4 +19,4 @@ # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F # Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b lin reg - T T 1 0.00001 1 0.00001 F 0.0 + F F 1 0.00001 1 0.00001 F 0.0 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 87da119..b47a38a 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -1,4 +1,4 @@ -subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,eGHF,eHF,ERI) +subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,EGHF,eHF,ERI) ! Parquet approximation based on restricted orbitals @@ -107,21 +107,17 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c write(*,*)'---------------------------------------------------------------' write(*,'(1X,A50,1X,I5)') 'Maximum number of one-body iteration:',max_it_1b write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:',conv_1b + write(*,'(1X,A50,1X,L5)') 'Linearization of quasiparticle equation?',conv_1b + write(*,'(1X,A50,1X,E10.5)') 'Strenght of SRG regularization:',eta write(*,*)'---------------------------------------------------------------' write(*,'(1X,A50,1X,I5)') 'Maximum number of two-body iteration:',max_it_2b write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:',conv_2b + write(*,'(1X,A50,1X,L5)') 'TDA for eh excitation energies?',TDAeh + write(*,'(1X,A50,1X,L5)') 'TDA for pp excitation energies?',TDApp write(*,*)'---------------------------------------------------------------' write(*,*) - if(linearize) then - write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' - write(*,*) - else - write(*,*) ' *** Quasiparticle energies obtained by root search *** ' - write(*,*) - endif - - ! Memory allocation + ! Memory allocation allocate(old_eh_Om(nS),old_ee_Om(nVV),old_hh_Om(nOO)) allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) @@ -494,7 +490,7 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c ! Check one-body converge - err_1b = maxval(abs(eOld - eQP)) + err_1b = maxval(abs(eOld - eQP)) eOld(:) = eQP(:) ! Print for one-body part diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 15d3cdd..a8634b6 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -1,4 +1,4 @@ -subroutine RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI) +subroutine RParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI) ! Parquet approximation based on restricted orbitals @@ -7,14 +7,15 @@ subroutine RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS ! Hard-coded parameters - logical :: TDAeh = .true. - logical :: TDApp = .true. - logical :: linearize = .true. - logical :: print_phLR = .true. - logical :: print_ppLR = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. ! Input variables + logical,intent(in) :: TDAeh + logical,intent(in) :: TDApp + logical,intent(in) :: linearize + double precision,intent(in) :: eta double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF integer,intent(in) :: max_it_1b,max_it_2b @@ -101,22 +102,18 @@ subroutine RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS write(*,*)'---------------------------------------------------------------' write(*,*)' Parquet parameters for one-body and two-body self-consistency ' write(*,*)'---------------------------------------------------------------' - write(*,'(1X,A50,1X,I5)') 'Maximum number for one-body self-consistency:', max_it_1b - write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:', conv_1b + write(*,'(1X,A50,1X,I5)') 'Maximum number of one-body iteration:',max_it_1b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:',conv_1b + write(*,'(1X,A50,1X,L5)') 'Linearization of quasiparticle equation?',conv_1b + write(*,'(1X,A50,1X,E10.5)') 'Strenght of SRG regularization:',eta write(*,*)'---------------------------------------------------------------' - write(*,'(1X,A50,1X,I5)') 'Maximum number for two-body self-consistency:', max_it_2b - write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:', conv_2b + write(*,'(1X,A50,1X,I5)') 'Maximum number of two-body iteration:',max_it_2b + write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:',conv_2b + write(*,'(1X,A50,1X,L5)') 'TDA for eh excitation energies?',TDAeh + write(*,'(1X,A50,1X,L5)') 'TDA for pp excitation energies?',TDApp write(*,*)'---------------------------------------------------------------' write(*,*) - if(linearize) then - write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' - write(*,*) - else - write(*,*) ' *** Quasiparticle energies obtained by root search *** ' - write(*,*) - endif - ! Memory allocation allocate(old_eh_sing_Om(nS),old_eh_trip_Om(nS)) diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index f7ba0f4..63b507e 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -266,7 +266,7 @@ program QuAcK maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_1b,conv_1b,max_it_2b,conv_2b) + TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) endif endif diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 72cf799..ff64438 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -8,7 +8,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - max_it_1b,conv_1b,max_it_2b,conv_2b) + TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) ! Restricted branch of QuAcK @@ -84,6 +84,9 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, integer,intent(in) :: max_it_1b,max_it_2b double precision,intent(in) :: conv_1b,conv_2b + logical,intent(in) :: TDAeh,TDApp + double precision,intent(in) :: reg_parquet + logical,intent(in) :: lin_parquet ! Local variables @@ -377,7 +380,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, if(doParquet) then call wall_time(start_Parquet) - call RParquet(ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eGW,ERI_MO) + call RParquet(TDAeh,TDApp,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eGW,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet From ecf657810bc6a591d484cef1f78676adabf470dd Mon Sep 17 00:00:00 2001 From: pfloos Date: Tue, 1 Apr 2025 18:21:35 +0200 Subject: [PATCH 41/71] fix test --- tests/inp/options.RHF | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/inp/options.RHF b/tests/inp/options.RHF index 85ba948..daea672 100644 --- a/tests/inp/options.RHF +++ b/tests/inp/options.RHF @@ -18,5 +18,5 @@ F F F F T # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F -# Parquet: max_it_macro conv_one_body max_it_micro conv_two_body - 1 0.00001 1 0 0.00001 +# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b lin reg + F F 1 0.00001 1 0.00001 F 0.0 From d6b6e7ce63d9bb47f87842aba086037028d874cb Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 2 Apr 2025 10:52:04 +0200 Subject: [PATCH 42/71] saving work --- src/LR/phGLR_A.f90 | 34 ++++++++++++++++++++- src/LR/phGLR_B.f90 | 29 +++++++++++++++++- src/Parquet/GParquet.f90 | 4 +-- src/Parquet/G_irred_Parquet_self_energy.f90 | 22 ++++++++++--- src/Parquet/G_screened_integrals.f90 | 13 ++++---- src/Parquet/RParquet.f90 | 4 +-- src/QuAcK/RQuAcK.f90 | 2 +- 7 files changed, 91 insertions(+), 17 deletions(-) diff --git a/src/LR/phGLR_A.f90 b/src/LR/phGLR_A.f90 index 12d33d5..3b6f6c4 100644 --- a/src/LR/phGLR_A.f90 +++ b/src/LR/phGLR_A.f90 @@ -24,6 +24,9 @@ subroutine phGLR_A(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,e,ERI,Aph) double precision,external :: Kronecker_delta integer :: i,j,a,b,ia,jb + integer :: nn,jb0 + logical :: i_eq_j + double precision :: ct1,ct2 ! Output variables @@ -35,7 +38,36 @@ subroutine phGLR_A(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,e,ERI,Aph) if(dRPA) delta_dRPA = 1d0 ! Build A matrix for spin orbitals + ! nn = nOrb - nR - nO + ! ct1 = lambda + ! ct2 = - (1d0 - delta_dRPA) * lambda + + ! !$OMP PARALLEL DEFAULT(NONE) & + ! !$OMP PRIVATE (i, a, j, b, i_eq_j, ia, jb0, jb) & + ! !$OMP SHARED (nC, nO, nR, nOrb, nn, ct1, ct2, e, ERI, Aph) + ! !$OMP DO COLLAPSE(2) + ! do i = nC+1, nO + ! do a = nO+1, nOrb-nR + ! ia = a - nO + (i - nC - 1) * nn + ! do j = nC+1, nO + ! i_eq_j = i == j + ! jb0 = (j - nC - 1) * nn - nO + ! do b = nO+1, nOrb-nR + ! jb = b + jb0 + + ! Aph(ia,jb) = ct1 * ERI(b,i,j,a) + ct2 * ERI(b,j,a,i) + ! if(i_eq_j) then + ! if(a == b) Aph(ia,jb) = Aph(ia,jb) + e(a) - e(i) + ! endif + + ! enddo + ! enddo + + ! enddo + ! enddo + ! !$OMP END DO + ! !$OMP END PARALLEL ia = 0 do i=nC+1,nO do a=nO+1,nOrb-nR @@ -53,4 +85,4 @@ subroutine phGLR_A(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,e,ERI,Aph) end do end do -end subroutine +end subroutine diff --git a/src/LR/phGLR_B.f90 b/src/LR/phGLR_B.f90 index acf94ec..bfc1ce5 100644 --- a/src/LR/phGLR_B.f90 +++ b/src/LR/phGLR_B.f90 @@ -22,7 +22,9 @@ subroutine phGLR_B(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,ERI,Bph) double precision :: delta_dRPA integer :: i,j,a,b,ia,jb - + integer :: nn,jb0 + double precision :: ct1,ct2 + ! Output variables double precision,intent(out) :: Bph(nS,nS) @@ -33,7 +35,32 @@ subroutine phGLR_B(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,ERI,Bph) if(dRPA) delta_dRPA = 1d0 ! Build B matrix for spin orbitals + ! nn = nOrb - nR - nO + ! ct1 = lambda + ! ct2 = - (1d0 - delta_dRPA) * lambda + + ! !$OMP PARALLEL DEFAULT(NONE) & + ! !$OMP PRIVATE (i, a, j, b, ia, jb0, jb) & + ! !$OMP SHARED (nC, nO, nR, nOrb, nn, ct1, ct2, ERI, Bph) + ! !$OMP DO COLLAPSE(2) + ! do i = nC+1, nO + ! do a = nO+1, nOrb-nR + ! ia = a - nO + (i - nC - 1) * nn + ! do j = nC+1, nO + ! jb0 = (j - nC - 1) * nn - nO + ! do b = nO+1, nOrb-nR + ! jb = b + jb0 + + ! Bph(ia,jb) = ct1 * ERI(i,j,a,b) + ct2 * ERI(i,j,b,a) + + ! enddo + ! enddo + + ! enddo + ! enddo + ! !$OMP END DO + ! !$OMP END PARALLEL ia = 0 do i=nC+1,nO do a=nO+1,nOrb-nR diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index b47a38a..3dc247a 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -7,8 +7,8 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c ! Hard-coded parameters - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables diff --git a/src/Parquet/G_irred_Parquet_self_energy.f90 b/src/Parquet/G_irred_Parquet_self_energy.f90 index ad78e8c..e091560 100644 --- a/src/Parquet/G_irred_Parquet_self_energy.f90 +++ b/src/Parquet/G_irred_Parquet_self_energy.f90 @@ -24,6 +24,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& integer :: p,n double precision :: eps,dem1,dem2,reg,reg1,reg2 double precision :: num + double precision :: start_t,end_t,t ! Output variables double precision,intent(out) :: SigC(nOrb) @@ -39,6 +40,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& !-----------------------------! ! GF2 part of the self-energy ! !-----------------------------! + call wall_time(start_t) do p=nC+1,nOrb-nR ! 2h1p sum do i=nC+1,nO @@ -71,11 +73,15 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do end do end do + call wall_time(end_t) + t = end_t - start_t + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! eh part of the self-energy ! !-----------------------------! - + call wall_time(start_t) do p=nC+1,nOrb-nR do i=nC+1,nO @@ -182,11 +188,15 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! i end do ! p - + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! pp part of the self-energy ! !-----------------------------! - + call wall_time(start_t) do p=nC+1,nOrb-nR do i=nC+1,nO @@ -303,7 +313,11 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! a end do ! p - + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building pp self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! Renormalization factor ! !-----------------------------! diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index aa66cb2..31cca2c 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -38,9 +38,9 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho rho(p,q,ia) = rho(p,q,ia) & - + (1d0*ERI(q,j,p,b) - 1d0*ERI(q,j,b,p) & + + (ERI(q,j,p,b) - ERI(q,j,b,p) & - 0d0*eh_Phi(q,j,b,p) + 0d0*pp_Phi(q,j,p,b)) * X & - + (1d0*ERI(q,b,p,j) - 1d0*ERI(q,b,j,p) & + + (ERI(q,b,p,j) - ERI(q,b,j,p) & - 0d0*eh_Phi(q,b,j,p) + 0d0*pp_Phi(q,b,p,j)) * Y @@ -110,7 +110,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) + ( 1d0*ERI(p,q,c,d) - 1d0*ERI(p,q,d,c) & + rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) end do @@ -121,7 +121,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do l=k+1,nO kl = kl + 1 - rho1(p,q,ab) = rho1(p,q,ab) + ( 1d0*ERI(p,q,k,l) - 1d0*ERI(p,q,l,k) & + rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,k,l) - ERI(p,q,l,k) & + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do @@ -134,12 +134,13 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do i=nC+1,nO do j=i+1,nO ij = ij + 1 + cd = 0 do c=nO+1,nOrb-nR do d=c+1,nOrb-nR cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) + ( 1d0*ERI(p,q,c,d) - 1d0*ERI(p,q,d,c) & + rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) end do @@ -150,7 +151,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do l=k+1,nO kl = kl + 1 - rho2(p,q,ij) = rho2(p,q,ij) + ( 1d0*ERI(p,q,k,l) - 1d0*ERI(p,q,l,k) & + rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,k,l) - ERI(p,q,l,k) & + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index a8634b6..f519c43 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -7,8 +7,8 @@ subroutine RParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c ! Hard-coded parameters - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index ff64438..20c5642 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -380,7 +380,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, if(doParquet) then call wall_time(start_Parquet) - call RParquet(TDAeh,TDApp,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eGW,ERI_MO) + call RParquet(TDAeh,TDApp,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet From 99f26d72bf8ba6048abff0ee9802c626a49cce9d Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 2 Apr 2025 11:35:33 +0200 Subject: [PATCH 43/71] speedup phGLR and G_screened_int --- src/LR/phGLR_A.f90 | 78 ++++++++++++++-------------- src/LR/phGLR_B.f90 | 68 ++++++++++++------------ src/Parquet/GParquet.f90 | 2 +- src/Parquet/G_screened_integrals.f90 | 50 +++++++++--------- 4 files changed, 98 insertions(+), 100 deletions(-) diff --git a/src/LR/phGLR_A.f90 b/src/LR/phGLR_A.f90 index 3b6f6c4..a7ba367 100644 --- a/src/LR/phGLR_A.f90 +++ b/src/LR/phGLR_A.f90 @@ -38,51 +38,51 @@ subroutine phGLR_A(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,e,ERI,Aph) if(dRPA) delta_dRPA = 1d0 ! Build A matrix for spin orbitals - ! nn = nOrb - nR - nO - ! ct1 = lambda - ! ct2 = - (1d0 - delta_dRPA) * lambda + nn = nOrb - nR - nO + ct1 = lambda + ct2 = - (1d0 - delta_dRPA) * lambda - ! !$OMP PARALLEL DEFAULT(NONE) & - ! !$OMP PRIVATE (i, a, j, b, i_eq_j, ia, jb0, jb) & - ! !$OMP SHARED (nC, nO, nR, nOrb, nn, ct1, ct2, e, ERI, Aph) - ! !$OMP DO COLLAPSE(2) - ! do i = nC+1, nO - ! do a = nO+1, nOrb-nR - ! ia = a - nO + (i - nC - 1) * nn + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE (i, a, j, b, i_eq_j, ia, jb0, jb) & + !$OMP SHARED (nC, nO, nR, nOrb, nn, ct1, ct2, e, ERI, Aph) + !$OMP DO COLLAPSE(2) + do i = nC+1, nO + do a = nO+1, nOrb-nR + ia = a - nO + (i - nC - 1) * nn - ! do j = nC+1, nO - ! i_eq_j = i == j - ! jb0 = (j - nC - 1) * nn - nO - ! do b = nO+1, nOrb-nR - ! jb = b + jb0 + do j = nC+1, nO + i_eq_j = i == j + jb0 = (j - nC - 1) * nn - nO + do b = nO+1, nOrb-nR + jb = b + jb0 - ! Aph(ia,jb) = ct1 * ERI(b,i,j,a) + ct2 * ERI(b,j,a,i) - ! if(i_eq_j) then - ! if(a == b) Aph(ia,jb) = Aph(ia,jb) + e(a) - e(i) - ! endif + Aph(ia,jb) = ct1 * ERI(b,i,j,a) + ct2 * ERI(b,j,a,i) + if(i_eq_j) then + if(a == b) Aph(ia,jb) = Aph(ia,jb) + e(a) - e(i) + endif - ! enddo - ! enddo + enddo + enddo - ! enddo - ! enddo - ! !$OMP END DO - ! !$OMP END PARALLEL - ia = 0 - do i=nC+1,nO - do a=nO+1,nOrb-nR - ia = ia + 1 - jb = 0 - do j=nC+1,nO - do b=nO+1,nOrb-nR - jb = jb + 1 + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + ! ia = 0 + ! do i=nC+1,nO + ! do a=nO+1,nOrb-nR + ! ia = ia + 1 + ! jb = 0 + ! do j=nC+1,nO + ! do b=nO+1,nOrb-nR + ! jb = jb + 1 - Aph(ia,jb) = (e(a) - e(i))*Kronecker_delta(i,j)*Kronecker_delta(a,b) & - + lambda*ERI(i,b,a,j) - (1d0 - delta_dRPA)*lambda*ERI(i,b,j,a) + ! Aph(ia,jb) = (e(a) - e(i))*Kronecker_delta(i,j)*Kronecker_delta(a,b) & + ! + lambda*ERI(i,b,a,j) - (1d0 - delta_dRPA)*lambda*ERI(i,b,j,a) - end do - end do - end do - end do + ! end do + ! end do + ! end do + ! end do end subroutine diff --git a/src/LR/phGLR_B.f90 b/src/LR/phGLR_B.f90 index bfc1ce5..0eebf64 100644 --- a/src/LR/phGLR_B.f90 +++ b/src/LR/phGLR_B.f90 @@ -35,46 +35,46 @@ subroutine phGLR_B(dRPA,nOrb,nC,nO,nV,nR,nS,lambda,ERI,Bph) if(dRPA) delta_dRPA = 1d0 ! Build B matrix for spin orbitals - ! nn = nOrb - nR - nO - ! ct1 = lambda - ! ct2 = - (1d0 - delta_dRPA) * lambda + nn = nOrb - nR - nO + ct1 = lambda + ct2 = - (1d0 - delta_dRPA) * lambda - ! !$OMP PARALLEL DEFAULT(NONE) & - ! !$OMP PRIVATE (i, a, j, b, ia, jb0, jb) & - ! !$OMP SHARED (nC, nO, nR, nOrb, nn, ct1, ct2, ERI, Bph) - ! !$OMP DO COLLAPSE(2) - ! do i = nC+1, nO - ! do a = nO+1, nOrb-nR - ! ia = a - nO + (i - nC - 1) * nn + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE (i, a, j, b, ia, jb0, jb) & + !$OMP SHARED (nC, nO, nR, nOrb, nn, ct1, ct2, ERI, Bph) + !$OMP DO COLLAPSE(2) + do i = nC+1, nO + do a = nO+1, nOrb-nR + ia = a - nO + (i - nC - 1) * nn - ! do j = nC+1, nO - ! jb0 = (j - nC - 1) * nn - nO - ! do b = nO+1, nOrb-nR - ! jb = b + jb0 + do j = nC+1, nO + jb0 = (j - nC - 1) * nn - nO + do b = nO+1, nOrb-nR + jb = b + jb0 - ! Bph(ia,jb) = ct1 * ERI(i,j,a,b) + ct2 * ERI(i,j,b,a) + Bph(ia,jb) = ct1 * ERI(i,j,a,b) + ct2 * ERI(i,j,b,a) - ! enddo - ! enddo + enddo + enddo - ! enddo - ! enddo - ! !$OMP END DO - ! !$OMP END PARALLEL - ia = 0 - do i=nC+1,nO - do a=nO+1,nOrb-nR - ia = ia + 1 - jb = 0 - do j=nC+1,nO - do b=nO+1,nOrb-nR - jb = jb + 1 + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + ! ia = 0 + ! do i=nC+1,nO + ! do a=nO+1,nOrb-nR + ! ia = ia + 1 + ! jb = 0 + ! do j=nC+1,nO + ! do b=nO+1,nOrb-nR + ! jb = jb + 1 - Bph(ia,jb) = lambda*ERI(i,j,a,b) - (1d0 - delta_dRPA)*lambda*ERI(i,j,b,a) + ! Bph(ia,jb) = lambda*ERI(i,j,a,b) - (1d0 - delta_dRPA)*lambda*ERI(i,j,b,a) - end do - end do - end do - end do + ! end do + ! end do + ! end do + ! end do end subroutine diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 3dc247a..266c671 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -82,7 +82,7 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c ! DIIS parameters - max_diis = 2 + max_diis = 1 n_diis = 0 rcond = 1d0 diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 31cca2c..77fafc3 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -18,11 +18,10 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho double precision,intent(out) :: rho(nOrb,nOrb,nS) rho(:,:,:) = 0d0 -! !$OMP PARALLEL & -! !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY,eh_sing_Gam) & -! !$OMP PRIVATE(q,p,jb,ia) & -! !$OMP DEFAULT(NONE) -! !$OMP DO + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(q,p,j,b,jb,ia,X,Y) & + !$OMP SHARED(nC,nOrb,nR,nO,nS,rho,ERI,XpY,XmY,eh_Phi,pp_Phi) + !$OMP DO do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR @@ -37,11 +36,10 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) & - - + (ERI(q,j,p,b) - ERI(q,j,b,p) & - - 0d0*eh_Phi(q,j,b,p) + 0d0*pp_Phi(q,j,p,b)) * X & - + (ERI(q,b,p,j) - ERI(q,b,j,p) & - - 0d0*eh_Phi(q,b,j,p) + 0d0*pp_Phi(q,b,p,j)) * Y + + (ERI(q,j,p,b) - ERI(q,j,b,p)) * X !& + !- (eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & + !+ (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + !- (eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y end do @@ -51,8 +49,8 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho end do end do -! !$OMP END DO -! !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL end subroutine @@ -93,10 +91,10 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 rho1(:,:,:) = 0d0 rho2(:,:,:) = 0d0 -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & -! !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_sing_Gam, X1, Y1, X2, Y2) -! !$OMP DO COLLAPSE(2) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, eh_Phi, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR @@ -110,8 +108,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X1(cd,ab) + rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,c,d) - ERI(p,q,d,c)) * X1(cd,ab)! & + !+ (eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X1(cd,ab) end do end do @@ -121,8 +119,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & - + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y1(kl,ab) + rho1(p,q,ab) = rho1(p,q,ab) + ( ERI(p,q,k,l) - ERI(p,q,l,k))* Y1(kl,ab) !& + !+ (eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y1(kl,ab) end do end do @@ -140,8 +138,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 do d=c+1,nOrb-nR cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*eh_Phi(p,q,c,d) - 0d0*eh_Phi(p,q,d,c) ) * X2(cd,ij) + rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,c,d) - ERI(p,q,d,c)) * X2(cd,ij) !& + !+ ( eh_Phi(p,q,c,d) - eh_Phi(p,q,d,c) ) * X2(cd,ij) end do end do @@ -151,8 +149,8 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 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) & - + 0d0*eh_Phi(p,q,k,l) - 0d0*eh_Phi(p,q,l,k) ) * Y2(kl,ij) + rho2(p,q,ij) = rho2(p,q,ij) + ( ERI(p,q,k,l) - ERI(p,q,l,k)) * Y2(kl,ij) !& + !+ ( eh_Phi(p,q,k,l) - eh_Phi(p,q,l,k) ) * Y2(kl,ij) end do end do @@ -161,7 +159,7 @@ subroutine G_pp_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_Phi,X1,Y1,rho1,X2 end do end do -! !$OMP END DO -! !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL end subroutine From 2d651dd1ccf7a9bf177349839fc0038f115f59f6 Mon Sep 17 00:00:00 2001 From: pfloos Date: Wed, 2 Apr 2025 14:40:00 +0200 Subject: [PATCH 44/71] diis options in parquet --- input/options.default | 4 ++-- src/Parquet/GParquet.f90 | 25 ++++++++++++++----------- src/Parquet/RParquet.f90 | 5 ++++- src/QuAcK/GQuAcK.f90 | 6 ++++-- src/QuAcK/QuAcK.f90 | 7 ++++--- src/QuAcK/RQuAcK.f90 | 6 ++++-- src/QuAcK/read_options.f90 | 17 ++++++++++------- tests/inp/options.RHF | 4 ++-- 8 files changed, 44 insertions(+), 30 deletions(-) diff --git a/input/options.default b/input/options.default index 93be274..1dcd72d 100644 --- a/input/options.default +++ b/input/options.default @@ -18,5 +18,5 @@ F F F F T # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F -# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b lin reg - F F 1 0.00001 1 0.00001 F 0.0 +# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b DIIS_1b DIIS_2b lin reg + T T 10 0.00001 10 0.00001 2 2 T 100.0 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 266c671..d8d26b9 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -1,6 +1,7 @@ -subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,EGHF,eHF,ERI) +subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b, & + nOrb,nC,nO,nV,nR,nS,EGHF,eHF,ERI) -! Parquet approximation based on restricted orbitals +! Parquet approximation based on spin orbitals implicit none include 'parameters.h' @@ -14,6 +15,8 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c logical,intent(in) :: TDAeh logical,intent(in) :: TDApp + integer,intent(in) :: max_diis_1b + integer,intent(in) :: max_diis_2b logical,intent(in) :: linearize double precision,intent(in) :: eta double precision,intent(in) :: ENuc @@ -61,9 +64,9 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c double precision,allocatable :: Z(:) double precision :: EcGM ! DIIS - integer :: max_diis,n_diis + integer :: n_diis_2b double precision :: rcond - double precision,allocatable :: err_diis(:,:) + double precision,allocatable :: err_diis_2b(:,:) double precision,allocatable :: Phi_diis(:,:) double precision,allocatable :: err(:) double precision,allocatable :: Phi(:) @@ -82,14 +85,12 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c ! DIIS parameters - max_diis = 1 - n_diis = 0 rcond = 1d0 - allocate(err_diis(2*nOrb**4,max_diis),Phi_diis(2*nOrb**4,max_diis)) + allocate(err_diis_2b(2*nOrb**4,max_diis_2b),Phi_diis(2*nOrb**4,max_diis_2b)) allocate(err(2*nOrb**4),Phi(2*nOrb**4)) - err_diis(:,:) = 0d0 + err_diis_2b(:,:) = 0d0 Phi_diis(:,:) = 0d0 ! Start @@ -109,11 +110,13 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:',conv_1b write(*,'(1X,A50,1X,L5)') 'Linearization of quasiparticle equation?',conv_1b write(*,'(1X,A50,1X,E10.5)') 'Strenght of SRG regularization:',eta + write(*,'(1X,A50,1X,I5)') 'Maximum length of DIIS expansion:',max_diis_1b write(*,*)'---------------------------------------------------------------' write(*,'(1X,A50,1X,I5)') 'Maximum number of two-body iteration:',max_it_2b write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:',conv_2b write(*,'(1X,A50,1X,L5)') 'TDA for eh excitation energies?',TDAeh write(*,'(1X,A50,1X,L5)') 'TDA for pp excitation energies?',TDApp + write(*,'(1X,A50,1X,I5)') 'Maximum length of DIIS expansion:',max_diis_2b write(*,*)'---------------------------------------------------------------' write(*,*) @@ -382,10 +385,10 @@ subroutine GParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c end do end do - if(max_diis > 1) then + if(max_diis_2b > 1) then - n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,2*nOrb**4,2*nOrb**4,n_diis,err_diis,Phi_diis,err,Phi) + n_diis_2b = min(n_diis_2b+1,max_diis_2b) + call DIIS_extrapolation(rcond,2*nOrb**4,2*nOrb**4,n_diis_2b,err_diis_2b,Phi_diis,err,Phi) end if diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index f519c43..310e4cc 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -1,4 +1,5 @@ -subroutine RParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI) +subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b, & + nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI) ! Parquet approximation based on restricted orbitals @@ -14,6 +15,8 @@ subroutine RParquet(TDAeh,TDApp,linearize,eta,ENuc,max_it_1b,conv_1b,max_it_2b,c logical,intent(in) :: TDAeh logical,intent(in) :: TDApp + integer,intent(in) :: max_diis_1b + integer,intent(in) :: max_diis_2b logical,intent(in) :: linearize double precision,intent(in) :: eta double precision,intent(in) :: ENuc diff --git a/src/QuAcK/GQuAcK.f90 b/src/QuAcK/GQuAcK.f90 index d858ac7..9555608 100644 --- a/src/QuAcK/GQuAcK.f90 +++ b/src/QuAcK/GQuAcK.f90 @@ -8,7 +8,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) + TDAeh,TDApp,max_diis_1b,max_diis_2b,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) implicit none include 'parameters.h' @@ -77,6 +77,7 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop integer,intent(in) :: max_it_1b,max_it_2b double precision,intent(in) :: conv_1b,conv_2b + integer,intent(in) :: max_diis_1b,max_diis_2b logical,intent(in) :: TDAeh,TDApp double precision,intent(in) :: reg_parquet logical,intent(in) :: lin_parquet @@ -352,7 +353,8 @@ subroutine GQuAcK(working_dir,dotest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dop if(doParquet) then call wall_time(start_Parquet) - call GParquet(TDAeh,TDApp,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) + call GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b, & + nBas2,nC,nO,nV,nR,nS,EGHF,eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index 63b507e..a41675a 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -80,6 +80,7 @@ program QuAcK integer :: max_it_1b,max_it_2b double precision :: conv_1b,conv_2b + integer :: max_diis_1b,max_diis_2b logical :: TDAeh,TDApp double precision :: reg_parquet logical :: lin_parquet @@ -149,7 +150,7 @@ program QuAcK doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA, & temperature,sigma,chem_pot_hf,restart_hfb, & - TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) + TDAeh,TDApp,max_diis_1b,max_diis_2b,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) !------------------! ! Hardware ! @@ -266,7 +267,7 @@ program QuAcK maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) + TDAeh,TDApp,max_diis_1b,max_diis_2b,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) endif endif @@ -299,7 +300,7 @@ program QuAcK maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW, & maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) + TDAeh,TDApp,max_diis_1b,max_diis_2b,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) !--------------------------! ! Bogoliubov QuAcK branch ! diff --git a/src/QuAcK/RQuAcK.f90 b/src/QuAcK/RQuAcK.f90 index 20c5642..a47ee60 100644 --- a/src/QuAcK/RQuAcK.f90 +++ b/src/QuAcK/RQuAcK.f90 @@ -8,7 +8,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW, & TDA_W,lin_GW,reg_GW,eta_GW,maxSCF_GT,max_diis_GT,thresh_GT,TDA_T,lin_GT,reg_GT,eta_GT, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS, & - TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) + TDAeh,TDApp,max_diis_1b,max_diis_2b,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) ! Restricted branch of QuAcK @@ -84,6 +84,7 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, integer,intent(in) :: max_it_1b,max_it_2b double precision,intent(in) :: conv_1b,conv_2b + integer,intent(in) :: max_diis_1b,max_diis_2b logical,intent(in) :: TDAeh,TDApp double precision,intent(in) :: reg_parquet logical,intent(in) :: lin_parquet @@ -380,7 +381,8 @@ subroutine RQuAcK(working_dir,use_gpu,dotest,doRHF,doROHF,dostab,dosearch,doMP2, if(doParquet) then call wall_time(start_Parquet) - call RParquet(TDAeh,TDApp,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b,nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI_MO) + call RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,lin_parquet,reg_parquet,ENuc,max_it_1b,conv_1b,max_it_2b,conv_2b, & + nOrb,nC,nO,nV,nR,nS,ERHF,eHF,ERI_MO) call wall_time(end_Parquet) t_Parquet = end_Parquet - start_Parquet diff --git a/src/QuAcK/read_options.f90 b/src/QuAcK/read_options.f90 index 8fe56f6..028fa64 100644 --- a/src/QuAcK/read_options.f90 +++ b/src/QuAcK/read_options.f90 @@ -9,7 +9,7 @@ subroutine read_options(working_dir, doACFDT,exchange_kernel,doXBS, & dophBSE,dophBSE2,doppBSE,dBSE,dTDA, & temperature,sigma,chem_pot_hf,restart_hfb, & - TDAeh,TDApp,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) + TDAeh,TDApp,max_diis_1b,max_diis_2b,max_it_1b,conv_1b,max_it_2b,conv_2b,lin_parquet,reg_parquet) ! Read desired methods @@ -79,11 +79,12 @@ subroutine read_options(working_dir, double precision,intent(out) :: temperature double precision,intent(out) :: sigma - integer :: max_it_1b,max_it_2b - double precision :: conv_1b,conv_2b - logical :: TDAeh,TDApp - double precision :: reg_parquet - logical :: lin_parquet + integer,intent(out) :: max_it_1b,max_it_2b + double precision,intent(out) :: conv_1b,conv_2b + integer,intent(out) :: max_diis_1b,max_diis_2b + logical,intent(out) :: TDAeh,TDApp + double precision,intent(out) :: reg_parquet + logical,intent(out) :: lin_parquet ! Local variables @@ -247,6 +248,8 @@ subroutine read_options(working_dir, TDAeh = .false. TDApp = .false. + max_diis_1b = 1 + max_diis_2b = 1 max_it_1b = 1 conv_1b = 1d-2 max_it_2b = 1 @@ -255,7 +258,7 @@ subroutine read_options(working_dir, reg_parquet = 0d0 read(1,*) - read(1,*) ans1,ans2,max_it_1b,conv_1b,max_it_2b,conv_2b,ans3,reg_parquet + read(1,*) ans1,ans2,max_it_1b,conv_1b,max_it_2b,conv_2b,max_diis_1b,max_diis_2b,ans3,reg_parquet if(ans1 == 'T') TDAeh = .true. if(ans2 == 'T') TDApp = .true. diff --git a/tests/inp/options.RHF b/tests/inp/options.RHF index daea672..07c570a 100644 --- a/tests/inp/options.RHF +++ b/tests/inp/options.RHF @@ -18,5 +18,5 @@ F F F F T # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F -# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b lin reg - F F 1 0.00001 1 0.00001 F 0.0 +# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b DIIS_1b DIIS_2b lin reg + T T 10 0.00001 10 0.00001 2 2 T 100.0 From d024fb5db4f585b9f544e75d9f27c71426b81f87 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 2 Apr 2025 15:13:47 +0200 Subject: [PATCH 45/71] open mp in ghf --- src/Parquet/G_eh_Phi.f90 | 6 ++ src/Parquet/G_irred_Parquet_self_energy.f90 | 106 ++++++++++++-------- src/Parquet/G_pp_Phi.f90 | 6 ++ 3 files changed, 76 insertions(+), 42 deletions(-) diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 index d110c64..bfa6cbe 100644 --- a/src/Parquet/G_eh_Phi.f90 +++ b/src/Parquet/G_eh_Phi.f90 @@ -18,6 +18,10 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) ! Initialization eh_Phi(:,:,:,:) = 0d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r, s, n) & + !$OMP SHARED(nC, nOrb, nR, nS, eh_Phi, eh_rho, eh_Om) + !$OMP DO COLLAPSE(2) do s = nC+1, nOrb-nR do r = nC+1, nOrb-nR do q = nC+1, nOrb-nR @@ -33,5 +37,7 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL end subroutine diff --git a/src/Parquet/G_irred_Parquet_self_energy.f90 b/src/Parquet/G_irred_Parquet_self_energy.f90 index e091560..2a3b143 100644 --- a/src/Parquet/G_irred_Parquet_self_energy.f90 +++ b/src/Parquet/G_irred_Parquet_self_energy.f90 @@ -82,6 +82,10 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! eh part of the self-energy ! !-----------------------------! call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) do p=nC+1,nOrb-nR do i=nC+1,nO @@ -101,38 +105,39 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,a,j,i) * & - (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + !num = ERI(p,a,j,i) * & + !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - dem1 = eQP(a) - eQP(i) - eh_Om(n) + !dem1 = eQP(a) - eQP(i) - eh_Om(n) dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,a,j,i) * & + !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,i,j,a) * & (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) - dem1 = eQP(a) - eQP(i) + eh_Om(n) + !dem1 = eQP(a) - eQP(i) + eh_Om(n) dem2 = eQP(p) - eQP(j) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,a,j,i) * & - (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! j !3p2h @@ -151,35 +156,36 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& num = ERI(p,i,b,a) * & (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,i,b,a) * & - (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,i,b,a) * & - (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + end do ! b end do ! n @@ -188,6 +194,8 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! i end do ! p + !$OMP END DO + !$OMP END PARALLEL call wall_time(end_t) t = end_t - start_t @@ -197,6 +205,10 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! pp part of the self-energy ! !-----------------------------! call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) do p=nC+1,nOrb-nR do i=nC+1,nO @@ -218,9 +230,9 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do c=nO+1,nOrb-nR num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) - dem1 = ee_Om(n) - eQP(i) - eQP(j) + !dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) @@ -242,9 +254,9 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - dem1 = hh_Om(n) - eQP(i) - eQP(j) + !dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -254,7 +266,15 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! n end do ! j end do ! i - + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR do a=nO+1,nOrb-nR do b=nO+1,nOrb-nR do n=1,nOO @@ -275,9 +295,9 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do k=nC+1,nO num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) - dem1 = hh_Om(n) - eQP(a) - eQP(b) + !dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) @@ -299,9 +319,9 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - dem1 = ee_Om(n) - eQP(a) - eQP(b) + !dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -313,6 +333,8 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! a end do ! p + !$OMP END DO + !$OMP END PARALLEL call wall_time(end_t) t = end_t - start_t diff --git a/src/Parquet/G_pp_Phi.f90 b/src/Parquet/G_pp_Phi.f90 index 65a5b4d..0818b8f 100644 --- a/src/Parquet/G_pp_Phi.f90 +++ b/src/Parquet/G_pp_Phi.f90 @@ -20,6 +20,10 @@ subroutine G_pp_Phi(nOrb,nC,nR,nOO,nVV,ee_Om,ee_rho,hh_Om,hh_rho,pp_Phi) ! Initialization pp_Phi(:,:,:,:) = 0d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r, s, n) & + !$OMP SHARED(nC, nOrb, nR, nVV, nOO, pp_Phi, ee_rho, ee_Om, hh_rho, hh_Om) + !$OMP DO COLLAPSE(2) do s = nC+1, nOrb-nR do r = nC+1, nOrb-nR do q = nC+1, nOrb-nR @@ -39,5 +43,7 @@ subroutine G_pp_Phi(nOrb,nC,nR,nOO,nVV,ee_Om,ee_rho,hh_Om,hh_rho,pp_Phi) enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL end subroutine From 54d88733df2bb3b0794f5d475e87184b567a32d6 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 2 Apr 2025 16:16:34 +0200 Subject: [PATCH 46/71] RHF GF2 self-energy --- src/Parquet/GParquet.f90 | 4 +- src/Parquet/G_Parquet_self_energy.f90 | 357 ++++++++++++++++++++ src/Parquet/G_irred_Parquet_self_energy.f90 | 349 ------------------- src/Parquet/RParquet.f90 | 24 +- src/Parquet/R_Parquet_self_energy.f90 | 102 ++++++ src/Parquet/R_irred_Parquet_self_energy.f90 | 94 ------ src/Parquet/print_parquet_1b.f90 | 64 ---- 7 files changed, 477 insertions(+), 517 deletions(-) create mode 100644 src/Parquet/G_Parquet_self_energy.f90 delete mode 100644 src/Parquet/G_irred_Parquet_self_energy.f90 create mode 100644 src/Parquet/R_Parquet_self_energy.f90 delete mode 100644 src/Parquet/R_irred_Parquet_self_energy.f90 delete mode 100644 src/Parquet/print_parquet_1b.f90 diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index d8d26b9..c4e534c 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -497,8 +497,8 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i eOld(:) = eQP(:) ! Print for one-body part - - call print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) + + call G_print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) deallocate(eQPlin,Z,SigC) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 new file mode 100644 index 0000000..783e5cf --- /dev/null +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -0,0 +1,357 @@ +subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& + eh_rho,eh_Om,ee_rho,ee_Om,hh_rho,hh_Om,EcGM,SigC,Z) + +! Compute correlation part of the self-energy coming from irreducible vertices contribution + implicit none + include 'parameters.h' + +! Input variables + double precision,intent(in) :: eta + integer,intent(in) :: nOrb + integer,intent(in) :: nC, nO, nV, nR + integer,intent(in) :: nS, nOO, nVV + double precision,intent(in) :: eQP(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_Om(nS) + double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) + double precision,intent(in) :: ee_Om(nVV) + double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) + double precision,intent(in) :: hh_Om(nOO) + +! Local variables + integer :: i,j,k,a,b,c + integer :: p,n + double precision :: eps,dem1,dem2,reg,reg1,reg2 + double precision :: num + double precision :: start_t,end_t,t + +! Output variables + double precision,intent(out) :: SigC(nOrb) + double precision,intent(out) :: Z(nOrb) + double precision,intent(out) :: EcGM + + ! Initialize + + SigC(:) = 0d0 + Z(:) = 0d0 + EcGM = 0d0 + +!-----------------------------! +! GF2 part of the self-energy ! +!-----------------------------! + call wall_time(start_t) + do p=nC+1,nOrb-nR + ! 2h1p sum + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nOrb-nR + + eps = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg = (1d0 - exp(- 2d0 * eta * eps * eps)) + num = 0.5d0*(ERI(p,a,j,i) - ERI(p,a,i,j))**2 + + SigC(p) = SigC(p) + num*reg/eps + Z(p) = Z(p) - num*reg/eps**2 + + end do + end do + end do + ! 2p1h sum + do i=nC+1,nO + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + + eps = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg = (1d0 - exp(- 2d0 * eta * eps * eps)) + num = 0.5d0*(ERI(p,i,b,a) - ERI(p,i,a,b))**2 + + SigC(p) = SigC(p) + num*reg/eps + Z(p) = Z(p) - num*reg/eps**2 + + end do + end do + end do + end do + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' + write(*,*) +! !-----------------------------! +! ! eh part of the self-energy ! +! !-----------------------------! +! call wall_time(start_t) +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & +! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) +! !$OMP DO COLLAPSE(2) +! do p=nC+1,nOrb-nR + +! do i=nC+1,nO +! do a=nO+1,nOrb-nR + +! do n=1,nS +! !3h2p +! do j=nC+1,nO +! num = ERI(p,a,j,i) * & +! (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + +! dem1 = eQP(a) - eQP(i) - eh_Om(n) +! dem2 = eQP(p) - eQP(j) + eh_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! !num = ERI(p,a,j,i) * & +! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + +! !dem1 = eQP(a) - eQP(i) - eh_Om(n) +! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + +! !num = ERI(p,a,j,i) * & +! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + +! dem1 = eQP(a) - eQP(i) + eh_Om(n) +! !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! num = ERI(p,i,j,a) * & +! (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) + +! !dem1 = eQP(a) - eQP(i) + eh_Om(n) +! dem2 = eQP(p) - eQP(j) + eh_Om(n) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + +! end do ! j +! !3p2h +! do b=nO+1,nOrb-nR +! num = ERI(p,a,b,i) * & +! (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(b,a,n) * eh_rho(i,p,n)) + +! dem1 = eQP(a) - eQP(i) + eh_Om(n) +! dem2 = eQP(p) - eQP(b) - eh_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! num = ERI(p,i,b,a) * & +! (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + +! !dem1 = eQP(a) - eQP(i) + eh_Om(n) +! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! !num = ERI(p,i,b,a) * & +! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + +! dem1 = eQP(a) - eQP(i) - eh_Om(n) +! !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + +! !num = ERI(p,i,b,a) * & +! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + +! !dem1 = eQP(a) - eQP(i) - eh_Om(n) +! dem2 = eQP(p) - eQP(b) - eh_Om(n) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! b + +! end do ! n + +! end do ! a +! end do ! i + +! end do ! p +! !$OMP END DO +! !$OMP END PARALLEL +! call wall_time(end_t) +! t = end_t - start_t + +! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' +! write(*,*) +! !-----------------------------! +! ! pp part of the self-energy ! +! !-----------------------------! +! call wall_time(start_t) +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & +! !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) +! !$OMP DO COLLAPSE(2) +! do p=nC+1,nOrb-nR + +! do i=nC+1,nO +! do j=nC+1,nO +! do n=1,nVV +! ! 4h1p +! do k=nC+1,nO +! num = ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) +! dem1 = ee_Om(n) - eQP(i) - eQP(j) +! dem2 = eQP(p) + eQP(k) - ee_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! k +! ! 3h2p +! do c=nO+1,nOrb-nR + +! num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) +! !dem1 = ee_Om(n) - eQP(i) - eQP(j) +! dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! a +! end do ! n +! do n=1,nOO +! ! 3h2p +! do c=nO+1,nOrb-nR + +! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) +! dem1 = hh_Om(n) - eQP(i) - eQP(j) +! dem2 = eQP(p) + eQP(c) - hh_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) +! !dem1 = hh_Om(n) - eQP(i) - eQP(j) +! dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! c +! end do ! n +! end do ! j +! end do ! i + +! end do ! p +! !$OMP END DO +! !$OMP END PARALLEL +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & +! !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) +! !$OMP DO COLLAPSE(2) +! do p=nC+1,nOrb-nR +! do a=nO+1,nOrb-nR +! do b=nO+1,nOrb-nR +! do n=1,nOO +! ! 4p1h +! do c=nO+1,nOrb-nR + +! num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) +! dem1 = hh_Om(n) - eQP(a) - eQP(b) +! dem2 = eQP(p) + eQP(c) - hh_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! c +! ! 3p2h +! do k=nC+1,nO + +! num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) +! !dem1 = hh_Om(n) - eQP(a) - eQP(b) +! dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! k +! end do ! n +! do n=1,nVV +! ! 3p2h +! do k=nC+1,nO + +! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) +! dem1 = ee_Om(n) - eQP(a) - eQP(b) +! dem2 = eQP(p) + eQP(k) - ee_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + +! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) +! !dem1 = ee_Om(n) - eQP(a) - eQP(b) +! dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) +! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + +! end do ! c +! end do ! n +! end do ! b +! end do ! a + +! end do ! p +! !$OMP END DO +! !$OMP END PARALLEL +! call wall_time(end_t) +! t = end_t - start_t + +! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building pp self-energy =',t,' seconds' +! write(*,*) + +!-----------------------------! +! Renormalization factor ! +!-----------------------------! + + call vecout(nOrb,Z) + Z(:) = 1d0/(1d0 - Z(:)) + +!-------------------------------------! +! Galitskii-Migdal correlation energy ! +!-------------------------------------! + + EcGM = 0d0 + +end subroutine diff --git a/src/Parquet/G_irred_Parquet_self_energy.f90 b/src/Parquet/G_irred_Parquet_self_energy.f90 deleted file mode 100644 index 2a3b143..0000000 --- a/src/Parquet/G_irred_Parquet_self_energy.f90 +++ /dev/null @@ -1,349 +0,0 @@ -subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& - eh_rho,eh_Om,ee_rho,ee_Om,hh_rho,hh_Om,EcGM,SigC,Z) - -! Compute correlation part of the self-energy coming from irreducible vertices contribution - implicit none - include 'parameters.h' - -! Input variables - double precision,intent(in) :: eta - integer,intent(in) :: nOrb - integer,intent(in) :: nC, nO, nV, nR - integer,intent(in) :: nS, nOO, nVV - double precision,intent(in) :: eQP(nOrb) - double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) - double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) - double precision,intent(in) :: ee_Om(nVV) - double precision,intent(in) :: hh_rho(nOrb,nOrb,nOO) - double precision,intent(in) :: hh_Om(nOO) - -! Local variables - integer :: i,j,k,a,b,c - integer :: p,n - double precision :: eps,dem1,dem2,reg,reg1,reg2 - double precision :: num - double precision :: start_t,end_t,t - -! Output variables - double precision,intent(out) :: SigC(nOrb) - double precision,intent(out) :: Z(nOrb) - double precision,intent(out) :: EcGM - - ! Initialize - - SigC(:) = 0d0 - Z(:) = 0d0 - EcGM = 0d0 - -!-----------------------------! -! GF2 part of the self-energy ! -!-----------------------------! - call wall_time(start_t) - do p=nC+1,nOrb-nR - ! 2h1p sum - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nOrb-nR - - eps = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg = (1d0 - exp(- 2d0 * eta * eps * eps)) - num = 0.5d0*(ERI(p,a,j,i) - ERI(p,a,i,j))**2 - - SigC(p) = SigC(p) + num*reg/eps - Z(p) = Z(p) - num*reg/eps**2 - - end do - end do - end do - ! 2p1h sum - do i=nC+1,nO - do a=nO+1,nOrb-nR - do b=nO+1,nOrb-nR - - eps = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg = (1d0 - exp(- 2d0 * eta * eps * eps)) - num = 0.5d0*(ERI(p,i,b,a) - ERI(p,i,a,b))**2 - - SigC(p) = SigC(p) + num*reg/eps - Z(p) = Z(p) - num*reg/eps**2 - - end do - end do - end do - end do - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' - write(*,*) -!-----------------------------! -! eh part of the self-energy ! -!-----------------------------! - call wall_time(start_t) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR - - do i=nC+1,nO - do a=nO+1,nOrb-nR - - do n=1,nS - !3h2p - do j=nC+1,nO - num = ERI(p,a,j,i) * & - (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - - !dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - - dem1 = eQP(a) - eQP(i) + eh_Om(n) - !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,i,j,a) * & - (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) - - !dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - - end do ! j - !3p2h - do b=nO+1,nOrb-nR - num = ERI(p,a,b,i) * & - (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(b,a,n) * eh_rho(i,p,n)) - - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,i,b,a) * & - (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - - !dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - - dem1 = eQP(a) - eQP(i) - eh_Om(n) - !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - - !dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! b - - end do ! n - - end do ! a - end do ! i - - end do ! p - !$OMP END DO - !$OMP END PARALLEL - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' - write(*,*) -!-----------------------------! -! pp part of the self-energy ! -!-----------------------------! - call wall_time(start_t) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR - - do i=nC+1,nO - do j=nC+1,nO - do n=1,nVV - ! 4h1p - do k=nC+1,nO - num = ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) - dem1 = ee_Om(n) - eQP(i) - eQP(j) - dem2 = eQP(p) + eQP(k) - ee_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! k - ! 3h2p - do c=nO+1,nOrb-nR - - num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) - !dem1 = ee_Om(n) - eQP(i) - eQP(j) - dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! a - end do ! n - do n=1,nOO - ! 3h2p - do c=nO+1,nOrb-nR - - num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - dem1 = hh_Om(n) - eQP(i) - eQP(j) - dem2 = eQP(p) + eQP(c) - hh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - !dem1 = hh_Om(n) - eQP(i) - eQP(j) - dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! c - end do ! n - end do ! j - end do ! i - - end do ! p - !$OMP END DO - !$OMP END PARALLEL - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR - do a=nO+1,nOrb-nR - do b=nO+1,nOrb-nR - do n=1,nOO - ! 4p1h - do c=nO+1,nOrb-nR - - num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) - dem1 = hh_Om(n) - eQP(a) - eQP(b) - dem2 = eQP(p) + eQP(c) - hh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! c - ! 3p2h - do k=nC+1,nO - - num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) - !dem1 = hh_Om(n) - eQP(a) - eQP(b) - dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! k - end do ! n - do n=1,nVV - ! 3p2h - do k=nC+1,nO - - num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - dem1 = ee_Om(n) - eQP(a) - eQP(b) - dem2 = eQP(p) + eQP(k) - ee_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - !dem1 = ee_Om(n) - eQP(a) - eQP(b) - dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - end do ! c - end do ! n - end do ! b - end do ! a - - end do ! p - !$OMP END DO - !$OMP END PARALLEL - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building pp self-energy =',t,' seconds' - write(*,*) -!-----------------------------! -! Renormalization factor ! -!-----------------------------! - - Z(:) = 1d0/(1d0 - Z(:)) - -end subroutine diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 310e4cc..a228c7c 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -600,7 +600,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*)' Two-body convergence failed ' write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write(*,*) - stop + !stop else @@ -624,13 +624,17 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) 'Building self-energy' call wall_time(start_t) - call R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,eOld,EcGM,SigC,Z) + call R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eOld,ERI, & + eh_sing_rho,old_eh_sing_Om,eh_trip_rho,old_eh_trip_Om, & + ee_sing_rho,old_ee_sing_Om,ee_trip_rho,old_ee_trip_Om, & + hh_sing_rho,old_hh_sing_Om,hh_trip_rho,old_hh_trip_Om, & + EcGM,SigC,Z) call wall_time(end_t) t = end_t - start_t write(*,'(A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' write(*,*) - eQPlin(:) = eHF(:) !+ Z(:)*SigC(:) + eQPlin(:) = eHF(:) + Z(:)*SigC(:) ! Solve the quasi-particle equation @@ -647,15 +651,19 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) stop - end if - - deallocate(eQPlin,Z,SigC) - + end if + ! Check one-body converge err_1b = maxval(abs(eOld - eQP)) eOld(:) = eQP(:) - + + ! Print for one-body part + + call R_print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,ERHF,EcGM,Ec_eh,Ec_pp) + + deallocate(eQPlin,Z,SigC) + call wall_time(end_1b) t_1b = end_1b - start_1b write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 new file mode 100644 index 0000000..1e85c31 --- /dev/null +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -0,0 +1,102 @@ +subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP,ERI, & + eh_sing_rho,eh_sing_Om,eh_trip_rho,eh_trip_Om, & + ee_sing_rho,ee_sing_Om,ee_trip_rho,ee_trip_Om, & + hh_sing_rho,hh_sing_Om,hh_trip_rho,hh_trip_Om, & + EcGM,SigC,Z) + +! Compute correlation part of the self-energy with only irreducible vertices contribution + implicit none + include 'parameters.h' + +! Input variables + double precision,intent(in) :: eta + integer,intent(in) :: nOrb,nC,nO,nV,nR + integer,intent(in) :: nS,nOOs,nVVs,nOOt,nVVt + double precision,intent(in) :: eQP(nOrb) + double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) + double precision,intent(in) :: eh_sing_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_sing_Om(nS) + double precision,intent(in) :: eh_trip_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_trip_Om(nS) + double precision,intent(in) :: ee_sing_rho(nOrb,nOrb,nVVs) + double precision,intent(in) :: ee_sing_Om(nVVs) + double precision,intent(in) :: ee_trip_rho(nOrb,nOrb,nVVt) + double precision,intent(in) :: ee_trip_Om(nVVt) + double precision,intent(in) :: hh_sing_rho(nOrb,nOrb,nOOs) + double precision,intent(in) :: hh_sing_Om(nOOs) + double precision,intent(in) :: hh_trip_rho(nOrb,nOrb,nOOt) + double precision,intent(in) :: hh_trip_Om(nOOt) + +! Local variables + integer :: i,j,k,a,b,c + integer :: p,n + double precision :: eps,dem1,dem2,reg,reg1,reg2 + double precision :: num + double precision :: start_t,end_t,t + +! Output variables + double precision,intent(out) :: EcGM + double precision,intent(out) :: SigC(nOrb) + double precision,intent(out) :: Z(nOrb) + +! Initialize + + SigC(:) = 0d0 + Z(:) = 0d0 + EcGM = 0d0 + +!-----------------------------! +! GF2 part of the self-energy ! +!-----------------------------! + call wall_time(start_t) + do p=nC+1,nOrb-nR + ! 2h1p sum + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nOrb-nR + + eps = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg = (1d0 - exp(- 2d0 * eta * eps * eps)) + num = ERI(p,a,j,i)*(2d0*ERI(j,i,p,a) - ERI(j,i,a,p)) + + SigC(p) = SigC(p) + num*reg/eps + Z(p) = Z(p) - num*reg/eps**2 + + end do + end do + end do + ! 2p1h sum + do i=nC+1,nO + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + + eps = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg = (1d0 - exp(- 2d0 * eta * eps * eps)) + num = ERI(p,i,b,a)*(2d0*ERI(b,a,p,i) - ERI(b,a,i,p)) + + SigC(p) = SigC(p) + num*reg/eps + Z(p) = Z(p) - num*reg/eps**2 + + end do + end do + end do + end do + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' + write(*,*) + +!-----------------------------! +! Renormalization factor ! +!-----------------------------! + call vecout(nOrb,Z) + Z(:) = 1d0/(1d0 - Z(:)) + +!-------------------------------------! +! Galitskii-Migdal correlation energy ! +!-------------------------------------! + + EcGM = 0d0 + +end subroutine diff --git a/src/Parquet/R_irred_Parquet_self_energy.f90 b/src/Parquet/R_irred_Parquet_self_energy.f90 deleted file mode 100644 index d0a0bbd..0000000 --- a/src/Parquet/R_irred_Parquet_self_energy.f90 +++ /dev/null @@ -1,94 +0,0 @@ -subroutine R_irred_Parquet_self_energy(nOrb,nC,nO,nV,nR,e,EcGM,SigC,Z) - -! Compute correlation part of the self-energy with only irreducible vertices contribution - implicit none - include 'parameters.h' - -! Input variables - integer,intent(in) :: nOrb,nC,nO,nV,nR - double precision,intent(in) :: e(nOrb) -! Local variables - integer :: p,i,j,a,b - double precision :: D2p1h,D2h1p -! Output variables - double precision,intent(out) :: EcGM - double precision,intent(out) :: SigC(nOrb) - double precision,intent(out) :: Z(nOrb) - -!----------------------------! -! Static Parquet self-energy ! -!----------------------------! - SigC(:) = 0d0 - ! 2h1p part of the correlation self-energy - do p=nC+1,nOrb-nR - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nOrb-nR - - D2h1p = e(p) + e(a) - e(i) - e(j) - SigC(p) = SigC(p) !+ 2d0*rho(p,i,m)**2*(1d0-exp(-2d0*s*Dpim*Dpim))/Dpim - - end do - end do - end do - end do - ! 2p1h part of the correlation self-energy - do p=nC+1,nOrb-nR - do i=nC+1,nO - do a=nO+1,nOrb-nR - do b=nO+1,nOrb-nR - - D2p1h = e(p) + e(i) - e(a) - e(b) - SigC(p) = SigC(p) !+ 2d0*rho(p,a,m)**2*(1d0-exp(-2d0*s*Dpam*Dpam))/Dpam - - end do - end do - end do - end do -!------------------------! -! Renormalization factor ! -!------------------------! - Z(:) = 0d0 - ! 2h1p part of the renormlization factor - do p=nC+1,nOrb-nR - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nOrb-nR - - D2h1p = e(p) + e(a) - e(i) - e(j) - Z(p) = Z(p) - - end do - end do - end do - end do - ! 2p1h part of the renormlization factor - do p=nC+1,nOrb-nR - do i=nC+1,nO - do a=nO+1,nOrb-nR - do b=nO+1,nOrb-nR - - D2p1h = e(p) + e(i) - e(a) - e(b) - Z(p) = Z(p) - - end do - end do - end do - end do - - Z(:) = 1d0/(1d0 - Z(:)) - -!-------------------------------------! -! Galitskii-Migdal correlation energy ! -!-------------------------------------! - - EcGM = 0d0 - ! do i=nC+1,nO - ! do a=nO+1,nOrb-nR - ! do m=1,nS - - ! end do - ! end do - ! end do - -end subroutine diff --git a/src/Parquet/print_parquet_1b.f90 b/src/Parquet/print_parquet_1b.f90 deleted file mode 100644 index a2324d9..0000000 --- a/src/Parquet/print_parquet_1b.f90 +++ /dev/null @@ -1,64 +0,0 @@ -subroutine print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) - -! Print one-electron energies and other stuff for G0F2 - - implicit none - include 'parameters.h' - - integer,intent(in) :: nOrb - integer,intent(in) :: nO - double precision,intent(in) :: eHF(nOrb) - double precision,intent(in) :: SigC(nOrb) - double precision,intent(in) :: eQP(nOrb) - double precision,intent(in) :: Z(nOrb) - integer,intent(in) :: n_it_1b - double precision,intent(in) :: err_1b - double precision,intent(in) :: ENuc - double precision,intent(in) :: EGHF - double precision,intent(in) :: EcGM - double precision,intent(in) :: Ec_eh - double precision,intent(in) :: Ec_pp - - integer :: p - integer :: HOMO - integer :: LUMO - double precision :: Gap - -! HOMO and LUMO - - HOMO = nO - LUMO = HOMO + 1 - Gap = eQP(LUMO) - eQP(HOMO) - -! Dump results - - write(*,*)'-------------------------------------------------------------------------------' - write(*,*)' Parquet self-energy ' - write(*,*)'-------------------------------------------------------------------------------' - write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & - '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' - write(*,*)'-------------------------------------------------------------------------------' - - 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)*HaToeV,'|',Z(p),'|',eQP(p)*HaToeV,'|' - end do - - write(*,*)'-------------------------------------------------------------------------------' - write(*,'(2X,A60,I15)') 'One-body iteration # ',n_it_1b - write(*,'(2X,A60,F15.6)') 'One-body convergence ',err_1b - write(*,*)'-------------------------------------------------------------------------------' - write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO energy = ',eQP(HOMO)*HaToeV,' eV' - write(*,'(2X,A60,F15.6,A3)') 'Parquet LUMO energy = ',eQP(LUMO)*HaToeV,' eV' - write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO-LUMO gap = ',Gap*HaToeV,' eV' - write(*,*)'-------------------------------------------------------------------------------' - write(*,'(2X,A60,F15.6,A3)') ' Parquet total energy = ',ENuc + EGHF + EcGM,' au' - write(*,'(2X,A60,F15.6,A3)') ' Parquet correlation energy = ',EcGM,' au' - write(*,*)'-------------------------------------------------------------------------------' - write(*,'(2X,A60,F15.6,A3)') ' eh-RPA correlation energy = ',Ec_eh,' au' - write(*,'(2X,A60,F15.6,A3)') ' pp-RPA correlation energy = ',Ec_pp,' au' - write(*,'(2X,A60,F15.6,A3)') '(eh+pp)-RPA correlation energy = ',Ec_pp,' au' - write(*,*)'-------------------------------------------------------------------------------' - write(*,*) - -end subroutine From 56224b3600feb92cd25f046cbf541136ec565a51 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 2 Apr 2025 16:17:00 +0200 Subject: [PATCH 47/71] change print --- src/Parquet/G_print_parquet_1b.f90 | 64 ++++++++++++++++++++++++++++++ src/Parquet/R_print_parquet_1b.f90 | 64 ++++++++++++++++++++++++++++++ 2 files changed, 128 insertions(+) create mode 100644 src/Parquet/G_print_parquet_1b.f90 create mode 100644 src/Parquet/R_print_parquet_1b.f90 diff --git a/src/Parquet/G_print_parquet_1b.f90 b/src/Parquet/G_print_parquet_1b.f90 new file mode 100644 index 0000000..ef71712 --- /dev/null +++ b/src/Parquet/G_print_parquet_1b.f90 @@ -0,0 +1,64 @@ +subroutine G_print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) + +! Print one-electron energies and other stuff for G0F2 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nOrb + integer,intent(in) :: nO + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: SigC(nOrb) + double precision,intent(in) :: eQP(nOrb) + double precision,intent(in) :: Z(nOrb) + integer,intent(in) :: n_it_1b + double precision,intent(in) :: err_1b + double precision,intent(in) :: ENuc + double precision,intent(in) :: EGHF + double precision,intent(in) :: EcGM + double precision,intent(in) :: Ec_eh + double precision,intent(in) :: Ec_pp + + integer :: p + integer :: HOMO + integer :: LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eQP(LUMO) - eQP(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + write(*,*)' Parquet self-energy ' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + 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)*HaToeV,'|',Z(p),'|',eQP(p)*HaToeV,'|' + end do + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,I15)') 'One-body iteration # ',n_it_1b + write(*,'(2X,A60,F15.6)') 'One-body convergence ',err_1b + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO energy = ',eQP(HOMO)*HaToeV,' eV' + write(*,'(2X,A60,F15.6,A3)') 'Parquet LUMO energy = ',eQP(LUMO)*HaToeV,' eV' + write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO-LUMO gap = ',Gap*HaToeV,' eV' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') ' Parquet total energy = ',ENuc + EGHF + EcGM,' au' + write(*,'(2X,A60,F15.6,A3)') ' Parquet correlation energy = ',EcGM,' au' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') ' eh-RPA correlation energy = ',Ec_eh,' au' + write(*,'(2X,A60,F15.6,A3)') ' pp-RPA correlation energy = ',Ec_pp,' au' + !write(*,'(2X,A60,F15.6,A3)') '(eh+pp)-RPA correlation energy = ',Ec_pp,' au' + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine diff --git a/src/Parquet/R_print_parquet_1b.f90 b/src/Parquet/R_print_parquet_1b.f90 new file mode 100644 index 0000000..76a6e3d --- /dev/null +++ b/src/Parquet/R_print_parquet_1b.f90 @@ -0,0 +1,64 @@ +subroutine R_print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,EGHF,EcGM,Ec_eh,Ec_pp) + +! Print one-electron energies and other stuff for G0F2 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nOrb + integer,intent(in) :: nO + double precision,intent(in) :: eHF(nOrb) + double precision,intent(in) :: SigC(nOrb) + double precision,intent(in) :: eQP(nOrb) + double precision,intent(in) :: Z(nOrb) + integer,intent(in) :: n_it_1b + double precision,intent(in) :: err_1b + double precision,intent(in) :: ENuc + double precision,intent(in) :: EGHF + double precision,intent(in) :: EcGM + double precision,intent(in) :: Ec_eh(nspin) + double precision,intent(in) :: Ec_pp(nspin) + + integer :: p + integer :: HOMO + integer :: LUMO + double precision :: Gap + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eQP(LUMO) - eQP(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + write(*,*)' Parquet self-energy ' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + 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)*HaToeV,'|',Z(p),'|',eQP(p)*HaToeV,'|' + end do + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,I15)') 'One-body iteration # ',n_it_1b + write(*,'(2X,A60,F15.6)') 'One-body convergence ',err_1b + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO energy = ',eQP(HOMO)*HaToeV,' eV' + write(*,'(2X,A60,F15.6,A3)') 'Parquet LUMO energy = ',eQP(LUMO)*HaToeV,' eV' + write(*,'(2X,A60,F15.6,A3)') 'Parquet HOMO-LUMO gap = ',Gap*HaToeV,' eV' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') ' Parquet total energy = ',ENuc + EGHF + EcGM,' au' + write(*,'(2X,A60,F15.6,A3)') ' Parquet correlation energy = ',EcGM,' au' + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A60,F15.6,A3)') ' eh-RPA correlation energy = ',Ec_eh(1)+3d0*Ec_eh(2),' au' + write(*,'(2X,A60,F15.6,A3)') ' pp-RPA correlation energy = ',Ec_pp(1)+3d0*Ec_pp(2),' au' + !write(*,'(2X,A60,F15.6,A3)') '(eh+pp)-RPA correlation energy = ',Ec_pp,' au' + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + +end subroutine From d2cf0cc7b0958df735509ed7447396acb272272b Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 2 Apr 2025 16:19:32 +0200 Subject: [PATCH 48/71] remove prints --- src/Parquet/G_Parquet_self_energy.f90 | 1 - src/Parquet/R_Parquet_self_energy.f90 | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 783e5cf..45d7e22 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -345,7 +345,6 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! Renormalization factor ! !-----------------------------! - call vecout(nOrb,Z) Z(:) = 1d0/(1d0 - Z(:)) !-------------------------------------! diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index 1e85c31..5d57747 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -90,7 +90,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP !-----------------------------! ! Renormalization factor ! !-----------------------------! - call vecout(nOrb,Z) + Z(:) = 1d0/(1d0 - Z(:)) !-------------------------------------! From 0881c8f24cfefb2f1988ed86e455d98d3b79fba9 Mon Sep 17 00:00:00 2001 From: pfloos Date: Wed, 2 Apr 2025 16:27:59 +0200 Subject: [PATCH 49/71] memory usage in GParquet --- src/Parquet/GParquet.f90 | 72 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 66 insertions(+), 6 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index d8d26b9..2ba854e 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -8,8 +8,8 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Hard-coded parameters - logical :: print_phLR = .true. - logical :: print_ppLR = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. ! Input variables @@ -72,7 +72,10 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i double precision,allocatable :: Phi(:) double precision :: alpha - integer ::p,q,r,s,pqrs + integer :: p,q,r,s,pqrs + + double precision :: mem = 0d0 + double precision :: dp_in_GB = 8d0/(1024d0**3) ! Output variables ! None @@ -82,6 +85,8 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i nVV = nV*(nV - 1)/2 allocate(eQP(nOrb),eOld(nOrb)) + + mem = mem + size(eQP) + size(eOld) ! DIIS parameters @@ -90,6 +95,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(err_diis_2b(2*nOrb**4,max_diis_2b),Phi_diis(2*nOrb**4,max_diis_2b)) allocate(err(2*nOrb**4),Phi(2*nOrb**4)) + mem = mem + size(err_diis_2b) + size(Phi_diis) + size(err) + size(Phi) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + err_diis_2b(:,:) = 0d0 Phi_diis(:,:) = 0d0 @@ -126,6 +134,11 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) allocate(old_eh_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_Phi(nOrb,nOrb,nOrb,nOrb)) + mem = mem + size(old_eh_Om) + size(old_ee_Om) + size(old_hh_Om) + mem = mem + size(eh_rho) + size(ee_rho) + size(hh_rho) + mem = mem + size(old_eh_Phi) + size(old_pp_Phi) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + ! Initialization n_it_1b = 0 @@ -187,6 +200,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(Aph(nS,nS),Bph(nS,nS),eh_Om(nS),XpY(nS,nS),XmY(nS,nS),eh_Gam_A(nS,nS),eh_Gam_B(nS,nS)) + mem = mem + size(Aph) + size(Bph) + size(eh_Om) + size(XpY) + size(XmY) + size(eh_Gam_A) + size(eh_Gam_B) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + Aph(:,:) = 0d0 Bph(:,:) = 0d0 @@ -224,18 +240,27 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(Aph,Bph,eh_Gam_A,eh_Gam_B) + mem = mem - size(Aph) - size(Bph) - size(eh_Gam_A) - size(eh_Gam_B) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + !-----------------! ! pp channel ! !-----------------! write(*,*) 'Diagonalizing pp BSE problem...' - allocate(Bpp(nVV,nOO),Cpp(nVV,nVV),Dpp(nOO,nOO), & ee_Om(nVV),X1(nVV,nVV),Y1(nOO,nVV), & hh_Om(nOO),X2(nVV,nOO),Y2(nOO,nOO), & pp_Gam_B(nVV,nOO),pp_Gam_C(nVV,nVV),pp_Gam_D(nOO,nOO)) + mem = mem + size(Bpp) + size(Cpp) + size(Dpp) & + + size(ee_Om) + size(X1) + size(Y1) & + + size(hh_Om) + size(X2) + size(Y2) & + + size(pp_Gam_B) + size(pp_Gam_C) + size(pp_Gam_D) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + + Bpp(:,:) = 0d0 Cpp(:,:) = 0d0 Dpp(:,:) = 0d0 @@ -278,6 +303,10 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i err_eig_pp = max(err_eig_ee,err_eig_hh) deallocate(Bpp,Cpp,Dpp,pp_Gam_B,pp_Gam_C,pp_Gam_D) + + mem = mem - size(Bpp) - size(Cpp) - size(Dpp) & + - size(pp_Gam_B) - size(pp_Gam_C) - size(pp_Gam_D) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' !----------! ! Updating ! @@ -288,6 +317,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i old_hh_Om(:) = hh_Om(:) deallocate(eh_Om,ee_Om,hh_Om) + + mem = mem - size(eh_Om) - size(ee_Om) - size(hh_Om) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' !----------------------------! ! Compute screened integrals ! @@ -295,11 +327,18 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Free memory deallocate(eh_rho,ee_rho,hh_rho) + + mem = mem - size(eh_rho) - size(ee_rho) - size(hh_rho) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation allocate(eh_rho(nOrb,nOrb,nS)) allocate(ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + mem = mem + size(eh_rho) + size(ee_rho) + size(hh_rho) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + ! Build singlet eh integrals write(*,*) 'Computing eh screened integrals...' @@ -309,9 +348,14 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for eh integrals =',t,' seconds' write(*,*) + ! Done with eigenvectors and kernel + deallocate(XpY,XmY) + mem = mem - size(XpY) - size(XmY) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + ! Build singlet pp integrals write(*,*) 'Computing pp screened integrals...' @@ -320,11 +364,15 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_t) t = end_t - start_t ! Done with eigenvectors and kernel - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp integrals =',t,' seconds' - write(*,*) deallocate(X1,Y1,X2,Y2) + mem = mem - size(X1) - size(Y1) - size(X2) - size(Y2) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp integrals =',t,' seconds' + write(*,*) + !----------------------------! ! Compute reducible kernels ! !----------------------------! @@ -333,6 +381,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(eh_Phi(nOrb,nOrb,nOrb,nOrb)) allocate(pp_Phi(nOrb,nOrb,nOrb,nOrb)) + mem = mem + size(eh_Phi) + size(pp_Phi) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + ! Build eh reducible kernels write(*,*) 'Computing eh reducible kernel...' @@ -413,6 +464,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Free memory deallocate(eh_Phi,pp_Phi) + + mem = mem - size(eh_Phi) - size(pp_Phi) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' write(*,*) '------------------------------------------------' write(*,*) ' Two-body (frequency/kernel) convergence ' @@ -462,6 +516,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) + mem = mem + size(eQPlin) + size(Z) + size(SigC) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,*) 'Building self-energy...' call wall_time(start_t) @@ -502,6 +559,9 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(eQPlin,Z,SigC) + mem = mem - size(eQPlin) - size(Z) - size(SigC) + write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + call wall_time(end_1b) t_1b = end_1b - start_1b write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' From bf35de22d7377cadc5c58fa6b7377f9fc5bf41ba Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 3 Apr 2025 13:51:28 +0200 Subject: [PATCH 50/71] ok with pp self-energy --- src/Parquet/G_Parquet_self_energy.f90 | 412 +++++++++++++------------- src/Parquet/R_Parquet_self_energy.f90 | 279 ++++++++++++++++- 2 files changed, 484 insertions(+), 207 deletions(-) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 45d7e22..2ad126e 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -78,268 +78,268 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' write(*,*) -! !-----------------------------! -! ! eh part of the self-energy ! -! !-----------------------------! -! call wall_time(start_t) -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & -! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) -! !$OMP DO COLLAPSE(2) -! do p=nC+1,nOrb-nR +!-----------------------------! +! eh part of the self-energy ! +!-----------------------------! + ! call wall_time(start_t) + ! !$OMP PARALLEL DEFAULT(NONE) & + ! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + ! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + ! !$OMP DO COLLAPSE(2) + ! do p=nC+1,nOrb-nR -! do i=nC+1,nO -! do a=nO+1,nOrb-nR + ! do i=nC+1,nO + ! do a=nO+1,nOrb-nR -! do n=1,nS -! !3h2p -! do j=nC+1,nO -! num = ERI(p,a,j,i) * & -! (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + ! do n=1,nS + ! !3h2p + ! do j=nC+1,nO + ! num = ERI(p,a,j,i) * & + ! (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) -! dem1 = eQP(a) - eQP(i) - eh_Om(n) -! dem2 = eQP(p) - eQP(j) + eh_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) - eQP(j) + eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! !num = ERI(p,a,j,i) * & -! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + ! !num = ERI(p,a,j,i) * & + ! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) -! !dem1 = eQP(a) - eQP(i) - eh_Om(n) -! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! !dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! !num = ERI(p,a,j,i) * & -! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + ! !num = ERI(p,a,j,i) * & + ! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) -! dem1 = eQP(a) - eQP(i) + eh_Om(n) -! !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ERI(p,i,j,a) * & -! (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) + ! num = ERI(p,i,j,a) * & + ! (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) -! !dem1 = eQP(a) - eQP(i) + eh_Om(n) -! dem2 = eQP(p) - eQP(j) + eh_Om(n) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! !dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) - eQP(j) + eh_Om(n) + ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! j -! !3p2h -! do b=nO+1,nOrb-nR -! num = ERI(p,a,b,i) * & -! (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(b,a,n) * eh_rho(i,p,n)) + ! end do ! j + ! !3p2h + ! do b=nO+1,nOrb-nR + ! num = ERI(p,a,b,i) * & + ! (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(b,a,n) * eh_rho(i,p,n)) -! dem1 = eQP(a) - eQP(i) + eh_Om(n) -! dem2 = eQP(p) - eQP(b) - eh_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) - eQP(b) - eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ERI(p,i,b,a) * & -! (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + ! num = ERI(p,i,b,a) * & + ! (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) -! !dem1 = eQP(a) - eQP(i) + eh_Om(n) -! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! !dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! !num = ERI(p,i,b,a) * & -! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + ! !num = ERI(p,i,b,a) * & + ! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) -! dem1 = eQP(a) - eQP(i) - eh_Om(n) -! !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! !num = ERI(p,i,b,a) * & -! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + ! !num = ERI(p,i,b,a) * & + ! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) -! !dem1 = eQP(a) - eQP(i) - eh_Om(n) -! dem2 = eQP(p) - eQP(b) - eh_Om(n) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! !dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) - eQP(b) - eh_Om(n) + ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! b + ! end do ! b -! end do ! n + ! end do ! n -! end do ! a -! end do ! i + ! end do ! a + ! end do ! i -! end do ! p -! !$OMP END DO -! !$OMP END PARALLEL -! call wall_time(end_t) -! t = end_t - start_t + ! end do ! p + ! !$OMP END DO + ! !$OMP END PARALLEL + ! call wall_time(end_t) + ! t = end_t - start_t -! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' -! write(*,*) -! !-----------------------------! -! ! pp part of the self-energy ! -! !-----------------------------! -! call wall_time(start_t) -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & -! !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) -! !$OMP DO COLLAPSE(2) -! do p=nC+1,nOrb-nR + ! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + ! write(*,*) +!-----------------------------! +! pp part of the self-energy ! +!-----------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR -! do i=nC+1,nO -! do j=nC+1,nO -! do n=1,nVV -! ! 4h1p -! do k=nC+1,nO -! num = ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) -! dem1 = ee_Om(n) - eQP(i) - eQP(j) -! dem2 = eQP(p) + eQP(k) - ee_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + do i=nC+1,nO + do j=nC+1,nO + do n=1,nVV + ! 4h1p + do k=nC+1,nO + num = ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) + dem1 = ee_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(k) - ee_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! k -! ! 3h2p -! do c=nO+1,nOrb-nR + end do ! k + ! 3h2p + do c=nO+1,nOrb-nR -! num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) -! !dem1 = ee_Om(n) - eQP(i) - eQP(j) -! dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) + !dem1 = ee_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! a -! end do ! n -! do n=1,nOO -! ! 3h2p -! do c=nO+1,nOrb-nR + end do ! a + end do ! n + do n=1,nOO + ! 3h2p + do c=nO+1,nOrb-nR -! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) -! dem1 = hh_Om(n) - eQP(i) - eQP(j) -! dem2 = eQP(p) + eQP(c) - hh_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - hh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) -! !dem1 = hh_Om(n) - eQP(i) - eQP(j) -! dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + !dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! c -! end do ! n -! end do ! j -! end do ! i + end do ! c + end do ! n + end do ! j + end do ! i -! end do ! p -! !$OMP END DO -! !$OMP END PARALLEL -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & -! !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) -! !$OMP DO COLLAPSE(2) -! do p=nC+1,nOrb-nR -! do a=nO+1,nOrb-nR -! do b=nO+1,nOrb-nR -! do n=1,nOO -! ! 4p1h -! do c=nO+1,nOrb-nR + end do ! p + !$OMP END DO + !$OMP END PARALLEL + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + do n=1,nOO + ! 4p1h + do c=nO+1,nOrb-nR -! num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) -! dem1 = hh_Om(n) - eQP(a) - eQP(b) -! dem2 = eQP(p) + eQP(c) - hh_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) + dem1 = hh_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(c) - hh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! c -! ! 3p2h -! do k=nC+1,nO + end do ! c + ! 3p2h + do k=nC+1,nO -! num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) -! !dem1 = hh_Om(n) - eQP(a) - eQP(b) -! dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) + !dem1 = hh_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! k -! end do ! n -! do n=1,nVV -! ! 3p2h -! do k=nC+1,nO + end do ! k + end do ! n + do n=1,nVV + ! 3p2h + do k=nC+1,nO -! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) -! dem1 = ee_Om(n) - eQP(a) - eQP(b) -! dem2 = eQP(p) + eQP(k) - ee_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - ee_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) -! !dem1 = ee_Om(n) - eQP(a) - eQP(b) -! dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) -! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + !dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! c -! end do ! n -! end do ! b -! end do ! a + end do ! c + end do ! n + end do ! b + end do ! a -! end do ! p -! !$OMP END DO -! !$OMP END PARALLEL -! call wall_time(end_t) -! t = end_t - start_t + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t -! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building pp self-energy =',t,' seconds' -! write(*,*) + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building pp self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! Renormalization factor ! diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index 5d57747..5a69db4 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -86,7 +86,284 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' write(*,*) - +!-------------------------------------! +! singlet pp part of the self-energy ! +!-------------------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOOs,nVVs,eta,ERI,eQP,ee_sing_rho,ee_sing_Om,hh_sing_rho,hh_sing_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + + do i=nC+1,nO + do j=nC+1,nO + do n=1,nVVs + ! 4h1p + do k=nC+1,nO + num = 0.5d0*ERI(p,k,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,k,n) + dem1 = ee_sing_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(k) - ee_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! k + ! 3h2p + do c=nO+1,nOrb-nR + + num = 0.5d0*ERI(p,c,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,c,n) + !dem1 = ee_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! a + end do ! n + do n=1,nOOs + ! 3h2p + do c=nO+1,nOrb-nR + + num = 0.5d0*ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) + dem1 = hh_sing_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - hh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = 0.5d0*ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) + !dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! c + end do ! n + end do ! j + end do ! i + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOOs,nVVs,eta,ERI,eQP,ee_sing_rho,ee_sing_Om,hh_sing_rho,hh_sing_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + do n=1,nOOs + ! 4p1h + do c=nO+1,nOrb-nR + + num = 0.5d0*ERI(p,c,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,c,n) + dem1 = hh_sing_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(c) - hh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! c + ! 3p2h + do k=nC+1,nO + + num = 0.5d0*ERI(p,k,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,k,n) + !dem1 = hh_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! k + end do ! n + do n=1,nVVs + ! 3p2h + do k=nC+1,nO + + num = 0.5d0*ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) + dem1 = ee_sing_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - ee_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = 0.5d0*ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) + !dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! c + end do ! n + end do ! b + end do ! a + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building singlet pp self-energy =',t,' seconds' + write(*,*) +!-------------------------------------! +! triplet pp part of the self-energy ! +!-------------------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOOt,nVVt,eta,ERI,eQP,ee_trip_rho,ee_trip_Om,hh_trip_rho,hh_trip_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + + do i=nC+1,nO + do j=nC+1,nO + do n=1,nVVt + ! 4h1p + do k=nC+1,nO + num = 1.5d0*ERI(p,k,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,k,n) + dem1 = ee_trip_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(k) - ee_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! k + ! 3h2p + do c=nO+1,nOrb-nR + + num = 1.5d0*ERI(p,c,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,c,n) + !dem1 = ee_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! a + end do ! n + do n=1,nOOt + ! 3h2p + do c=nO+1,nOrb-nR + + num = 1.5d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) + dem1 = hh_trip_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - hh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = 1.5d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) + !dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! c + end do ! n + end do ! j + end do ! i + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,k,a,b,c,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nOOt,nVVt,eta,ERI,eQP,ee_trip_rho,ee_trip_Om,hh_trip_rho,hh_trip_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + do a=nO+1,nOrb-nR + do b=nO+1,nOrb-nR + do n=1,nOOt + ! 4p1h + do c=nO+1,nOrb-nR + + num = 1.5d0*ERI(p,c,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,c,n) + dem1 = hh_trip_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(c) - hh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! c + ! 3p2h + do k=nC+1,nO + + num = 1.5d0*ERI(p,k,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,k,n) + !dem1 = hh_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! k + end do ! n + do n=1,nVVt + ! 3p2h + do k=nC+1,nO + + num = 1.5d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) + dem1 = ee_trip_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - ee_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = 1.5d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) + !dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! c + end do ! n + end do ! b + end do ! a + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building triplet pp self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! Renormalization factor ! !-----------------------------! From 992c65b497f72c4abe4ffa64720cd0f634f188a9 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 3 Apr 2025 15:50:31 +0200 Subject: [PATCH 51/71] restricted self energy done --- src/Parquet/G_Parquet_self_energy.f90 | 178 +++++++++---------- src/Parquet/R_Parquet_self_energy.f90 | 246 ++++++++++++++++++++++++++ src/Parquet/R_screened_integrals.f90 | 125 ++++++------- 3 files changed, 398 insertions(+), 151 deletions(-) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 2ad126e..28133ab 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -81,126 +81,126 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& !-----------------------------! ! eh part of the self-energy ! !-----------------------------! - ! call wall_time(start_t) - ! !$OMP PARALLEL DEFAULT(NONE) & - ! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - ! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) - ! !$OMP DO COLLAPSE(2) - ! do p=nC+1,nOrb-nR + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR - ! do i=nC+1,nO - ! do a=nO+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR - ! do n=1,nS - ! !3h2p - ! do j=nC+1,nO - ! num = ERI(p,a,j,i) * & - ! (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + do n=1,nS + !3h2p + do j=nC+1,nO + num = ERI(p,a,j,i) * & + (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,j,n)) - ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) - eQP(j) + eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - ! !num = ERI(p,a,j,i) * & - ! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + !num = ERI(p,a,j,i) * & + !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - ! !dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! !num = ERI(p,a,j,i) * & - ! !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + !num = ERI(p,a,j,i) * & + !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = ERI(p,i,j,a) * & - ! (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(j,i,n) * eh_rho(a,p,n)) + num = ERI(p,i,j,a) * & + (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(i,p,n) * eh_rho(a,j,n)) - ! !dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) - eQP(j) + eh_Om(n) - ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - ! end do ! j - ! !3p2h - ! do b=nO+1,nOrb-nR - ! num = ERI(p,a,b,i) * & - ! (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(b,a,n) * eh_rho(i,p,n)) + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = ERI(p,a,b,i) * & + (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,b,n)) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) - eQP(b) - eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = ERI(p,i,b,a) * & - ! (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + num = ERI(p,i,b,a) * & + (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(i,p,n) * eh_rho(a,b,n)) - ! !dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - ! !num = ERI(p,i,b,a) * & - ! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_Om(n) + !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! !num = ERI(p,i,b,a) * & - ! !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - ! !dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) - eQP(b) - eh_Om(n) - ! !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - ! end do ! b + end do ! b - ! end do ! n + end do ! n - ! end do ! a - ! end do ! i + end do ! a + end do ! i - ! end do ! p - ! !$OMP END DO - ! !$OMP END PARALLEL - ! call wall_time(end_t) - ! t = end_t - start_t + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t - ! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' - ! write(*,*) + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! pp part of the self-energy ! !-----------------------------! diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index 5a69db4..a51a81c 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -87,6 +87,252 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' write(*,*) !-------------------------------------! +! singlet eh part of the self-energy ! +!-------------------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_sing_rho,eh_sing_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + + do i=nC+1,nO + do a=nO+1,nOrb-nR + + do n=1,nS + !3h2p + do j=nC+1,nO + num = ERI(p,a,j,i) * & + (eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) - 0.5d0*eh_sing_rho(a,p,n) * eh_sing_rho(i,j,n)) + + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,a,j,i) * & + !(eh_rho(j,p,n) * eh_rho(i,a,n) - 0.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) + + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,a,j,i) * & + !(eh_rho(j,p,n) * eh_rho(i,a,n) - 0.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = ERI(p,i,j,a) * & + (eh_sing_rho(j,p,n) * eh_sing_rho(a,i,n) - 0.5d0*eh_sing_rho(i,p,n) * eh_sing_rho(a,j,n)) + + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = ERI(p,a,b,i) * & + (eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) - 0.5d0*eh_sing_rho(a,p,n) * eh_sing_rho(i,b,n)) + + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = ERI(p,i,b,a) * & + (eh_sing_rho(b,p,n) * eh_sing_rho(a,i,n) - 0.5d0*eh_sing_rho(i,p,n) * eh_sing_rho(a,b,n)) + + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) + + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) + + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! b + + end do ! n + + end do ! a + end do ! i + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,*) +!-------------------------------------! +! triplet eh part of the self-energy ! +!-------------------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_trip_rho,eh_trip_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR + + do i=nC+1,nO + do a=nO+1,nOrb-nR + + do n=1,nS + !3h2p + do j=nC+1,nO + num = ERI(p,a,j,i) * & + (- 1.5d0*eh_trip_rho(a,p,n) * eh_trip_rho(i,j,n)) + + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,a,j,i) * & + !(- 1.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) + + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,a,j,i) * & + !(- 1.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) + + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = ERI(p,i,j,a) * & + (- 1.5d0*eh_trip_rho(i,p,n) * eh_trip_rho(a,j,n)) + + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = ERI(p,a,b,i) * & + (- 1.5d0*eh_trip_rho(a,p,n) * eh_trip_rho(i,b,n)) + + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + num = ERI(p,i,b,a) * & + (- 1.5d0*eh_trip_rho(i,p,n) * eh_trip_rho(a,b,n)) + + !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) + + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + !num = ERI(p,i,b,a) * & + !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) + + !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) + !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + + end do ! b + + end do ! n + + end do ! a + end do ! i + + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t + + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,*) +!-------------------------------------! ! singlet pp part of the self-energy ! !-------------------------------------! call wall_time(start_t) diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index fca69ea..032e37d 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -38,12 +38,12 @@ subroutine R_eh_singlet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(q,j,p,b) - ERI(q,j,b,p) & - - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) - 0d0*1.5d0*eh_trip_Phi(q,j,b,p) & - + 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*1.5d0*pp_trip_Phi(q,j,p,b)) * X & - + (2d0*ERI(q,b,p,j) - ERI(q,b,j,p) & - - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) - 0d0*1.5d0*eh_trip_Phi(q,b,j,p) & - + 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*1.5d0*pp_trip_Phi(q,b,p,j)) * Y + rho(p,q,ia) = rho(p,q,ia) + (2d0*ERI(q,j,p,b) - ERI(q,j,b,p))*X ! & + !(- 0d0*0.5d0*eh_sing_Phi(q,j,b,p) - 0d0*1.5d0*eh_trip_Phi(q,j,b,p) & + !+ 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*1.5d0*pp_trip_Phi(q,j,p,b)) * X & + !+ (2d0*ERI(q,b,p,j) - ERI(q,b,j,p))*Y & + !(- 0d0*0.5d0*eh_sing_Phi(q,b,j,p) - 0d0*1.5d0*eh_trip_Phi(q,b,j,p) & + !+ 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*1.5d0*pp_trip_Phi(q,b,p,j)) * Y end do @@ -97,12 +97,13 @@ subroutine R_eh_triplet_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_sing_Phi,eh_tr X = 0.5d0*(XpY(ia,jb) + XmY(ia,jb)) Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) - rho(p,q,ia) = rho(p,q,ia) + (- ERI(q,j,b,p) & - - 0d0*0.5d0*eh_sing_Phi(q,j,b,p) + 0d0*0.5d0*eh_trip_Phi(q,j,b,p) & - - 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*0.5d0*pp_trip_Phi(q,j,p,b)) * X & - + (- ERI(q,b,j,p) & - - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) + 0d0*0.5d0*eh_trip_Phi(q,b,j,p) & - - 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*0.5d0*pp_trip_Phi(q,b,p,j)) * Y + rho(p,q,ia) = rho(p,q,ia) - ERI(q,j,b,p) * X ! & + ! (- 0d0*0.5d0*eh_sing_Phi(q,j,b,p) + 0d0*0.5d0*eh_trip_Phi(q,j,b,p) & + ! - 0d0*0.5d0*pp_sing_Phi(q,j,p,b) + 0d0*0.5d0*pp_trip_Phi(q,j,p,b)) * X & + ! + (- ERI(q,b,j,p) & + ! - 0d0*0.5d0*eh_sing_Phi(q,b,j,p) + 0d0*0.5d0*eh_trip_Phi(q,b,j,p) & + ! - 0d0*0.5d0*pp_sing_Phi(q,b,p,j) + 0d0*0.5d0*pp_trip_Phi(q,b,p,j)) * Y + end do end do @@ -173,26 +174,26 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do d = c, nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & - + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& + rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) + ERI(p,q,d,c)) & + !+ 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & + !+ 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& *X1(cd,ab)/sqrt(1d0 + Kronecker_delta(c,d)) end do ! d end do ! c - kl = 0 - do k = nC+1, nO - do l = k, nO + ! kl = 0 + ! do k = nC+1, nO + ! do l = k, nO - kl = kl + 1 + ! kl = kl + 1 - rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & - + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& - *Y1(kl,ab)/sqrt(1d0 + Kronecker_delta(k,l)) - end do ! l - end do ! k + ! rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) + ERI(p,q,l,k) & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& + ! *Y1(kl,ab)/sqrt(1d0 + Kronecker_delta(k,l)) + ! end do ! l + ! end do ! k end do ! b end do ! a @@ -201,26 +202,26 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do j = i, nO ij = ij + 1 - cd = 0 - do c = nO+1, nOrb-nR - do d = c, nOrb-nR - cd = cd + 1 + ! cd = 0 + ! do c = nO+1, nOrb-nR + ! do d = c, nOrb-nR + ! cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) + ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & - + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& - *X2(cd,ij)/sqrt(1d0 + Kronecker_delta(c,d)) - end do ! d - end do ! c + ! rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) + ERI(p,q,d,c) & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) - 0d0*1.5d0*eh_trip_Phi(p,q,c,d) & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*1.5d0*eh_trip_Phi(p,q,d,c))& + ! *X2(cd,ij)/sqrt(1d0 + Kronecker_delta(c,d)) + ! end do ! d + ! end do ! c kl = 0 do k = nC+1, nO do l = k, nO kl = kl + 1 - rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) + ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & - + 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& + rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) + ERI(p,q,l,k)) & + !+ 0d0*0.5d0*eh_sing_Phi(p,q,k,l) - 0d0*1.5d0*eh_trip_Phi(p,q,k,l) & + !+ 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*1.5d0*eh_trip_Phi(p,q,l,k))& *Y2(kl,ij)/sqrt(1d0 + Kronecker_delta(k,l)) end do ! l end do ! k @@ -290,24 +291,24 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do d = c+1, nOrb-nR cd = cd + 1 - rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & - - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X1(cd,ab) + rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab)! & + !+ 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & + !- 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(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 = 0 + ! do k = nC+1, nO + ! do l = k+1, nO - kl = kl + 1 + ! kl = kl + 1 - rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) - ERI(p,q,l,k) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & - - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) - end do ! l - end do ! k + ! rho1(p,q,ab) = rho1(p,q,ab) + (ERI(p,q,k,l) - ERI(p,q,l,k) & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & + ! - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y1(kl,ab) + ! end do ! l + ! end do ! k end do ! b end do ! a @@ -316,25 +317,25 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, do j = i+1, nO ij = ij + 1 - cd = 0 - do c = nO+1, nOrb-nR - do d = c+1, nOrb-nR - cd = cd + 1 + ! cd = 0 + ! do c = nO+1, nOrb-nR + ! do d = c+1, nOrb-nR + ! cd = cd + 1 - rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) - ERI(p,q,d,c) & - + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & - - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(p,q,d,c) )*X2(cd,ij) - end do ! d - end do ! c + ! rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,c,d) - ERI(p,q,d,c) & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,c,d) + 0d0*0.5d0*eh_trip_Phi(p,q,c,d) & + ! - 0d0*0.5d0*eh_sing_Phi(p,q,d,c) - 0d0*0.5d0*eh_trip_Phi(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) & - + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & - - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) + rho2(p,q,ij) = rho2(p,q,ij) + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij)! & + ! + 0d0*0.5d0*eh_sing_Phi(p,q,k,l) + 0d0*0.5d0*eh_trip_Phi(p,q,k,l) & + ! - 0d0*0.5d0*eh_sing_Phi(p,q,l,k) - 0d0*0.5d0*eh_trip_Phi(p,q,l,k) )*Y2(kl,ij) end do ! l end do ! k From e39c90723ac89b04ee2628064c0f9402a6911911 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 3 Apr 2025 15:53:19 +0200 Subject: [PATCH 52/71] correct SCF loop in RHF --- src/Parquet/RParquet.f90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index a228c7c..8738db9 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -133,9 +133,6 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i n_it_1b = 0 err_1b = 1d0 - n_it_2b = 0 - err_2b = 1d0 - eQP(:) = eHF(:) eOld(:) = eHF(:) @@ -173,6 +170,11 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*)'=====================================' write(*,*) +! Initialization + + n_it_2b = 0 + err_2b = 1d0 + !-----------------------------------------! ! Main loop for two-body self-consistency ! !-----------------------------------------! From 8002e021fdc031db248712cc4c3306ff7cbb2bd7 Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 3 Apr 2025 17:23:28 +0200 Subject: [PATCH 53/71] modify print in parquet --- src/Parquet/GParquet.f90 | 9 +-- src/Parquet/RParquet.f90 | 97 ++++++++++++++------------- src/Parquet/R_Parquet_self_energy.f90 | 17 +++-- 3 files changed, 62 insertions(+), 61 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index e8153e8..b4cc1e6 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -481,7 +481,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_2b) t_2b = end_2b - start_2b - write(*,'(A50,1X,I4,A2,F9.3,A8)') 'Wall time for two-body iteration #',n_it_2b,' =',t_2b,' seconds' + write(*,'(1X,A44,1X,I4,A2,F9.3,A8)') 'Wall time for two-body iteration #',n_it_2b,' =',t_2b,' seconds' write(*,*) end do @@ -519,14 +519,15 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i mem = mem + size(eQPlin) + size(Z) + size(SigC) write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' - write(*,*) 'Building self-energy...' + write(*,*) 'Computing self-energy...' + write(*,*) call wall_time(start_t) call G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eOld,ERI, & eh_rho,old_eh_Om,ee_rho,old_ee_Om,hh_rho,old_hh_Om,EcGM,SigC,Z) call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' write(*,*) eQPlin(:) = eHF(:) + Z(:)*SigC(:) @@ -564,7 +565,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_1b) t_1b = end_1b - start_1b - write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' + write(*,'(1X,A44,1X,I4,A2,F9.3,A8)') 'Wall time for one-body iteration #',n_it_1b,' =',t_1b,' seconds' end do !---------------------------------------------! diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 8738db9..5afd801 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -8,8 +8,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Hard-coded parameters - logical :: print_phLR = .true. - logical :: print_ppLR = .true. + logical :: print_phLR = .false. + logical :: print_ppLR = .false. ! Input variables @@ -109,11 +109,13 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for one-body energies:',conv_1b write(*,'(1X,A50,1X,L5)') 'Linearization of quasiparticle equation?',conv_1b write(*,'(1X,A50,1X,E10.5)') 'Strenght of SRG regularization:',eta + write(*,'(1X,A50,1X,I5)') 'Maximum length of DIIS expansion:',max_diis_1b write(*,*)'---------------------------------------------------------------' write(*,'(1X,A50,1X,I5)') 'Maximum number of two-body iteration:',max_it_2b write(*,'(1X,A50,1X,E10.5)') 'Convergence threshold for two-body energies:',conv_2b write(*,'(1X,A50,1X,L5)') 'TDA for eh excitation energies?',TDAeh write(*,'(1X,A50,1X,L5)') 'TDA for pp excitation energies?',TDApp + write(*,'(1X,A50,1X,I5)') 'Maximum length of DIIS expansion:',max_diis_2b write(*,*)'---------------------------------------------------------------' write(*,*) @@ -193,10 +195,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Density channel ! !-----------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing singlet ehBSE |' - write(*,*)' -------------------------------' - write(*,*) + write(*,*) 'Diagonalizing singlet ehBSE problem (density channel)...' allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) @@ -235,7 +234,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet phBSE =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet phBSE problem =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','singlet',nS,eh_sing_Om) @@ -248,10 +247,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Magnetic channel ! !------------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing triplet ehBSE |' - write(*,*)' -------------------------------' - write(*,*) + write(*,*) 'Diagonalizing triplet ehBSE problem (magnetic channel)...' allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) @@ -289,7 +285,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet phBSE =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet phBSE problem =',t,' seconds' write(*,*) if(print_phLR) call print_excitation_energies('phBSE@Parquet','triplet',nS,eh_trip_Om) @@ -302,10 +298,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Singlet channel ! !-----------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing singlet ppBSE |' - write(*,*)' -------------------------------' - write(*,*) + write(*,*) 'Diagonalizing singlet ppBSE problem (singlet channel)...' allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs), & ee_sing_Om(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & @@ -344,7 +337,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE problem =',t,' seconds' write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) @@ -359,10 +352,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Triplet channel ! !-----------------! - write(*,*)' -------------------------------' - write(*,*)' | Diagonalizing triplet ppBSE |' - write(*,*)' -------------------------------' - write(*,*) + write(*,*) 'Diagonalizing triplet ppBSE problem (triplet channel)...' allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt), & ee_trip_Om(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & @@ -402,7 +392,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for triplet ppBSE =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet ppBSE problem =',t,' seconds' write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (triplets)',nVVt,ee_trip_Om) @@ -413,15 +403,15 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) - write(*,*) '----------------------------------------' - write(*,*) ' Two-body (eigenvalue) convergence ' - write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eig_eh_sing - write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eig_eh_trip - write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_eig_ee_sing,err_eig_hh_sing) - write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_eig_ee_trip,err_eig_hh_trip) - write(*,*) '----------------------------------------' - write(*,*) +! write(*,*) '----------------------------------------' +! write(*,*) ' Two-body (eigenvalue) convergence ' +! write(*,*) '----------------------------------------' +! write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eig_eh_sing +! write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eig_eh_trip +! write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_eig_ee_sing,err_eig_hh_sing) +! write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_eig_ee_trip,err_eig_hh_trip) +! write(*,*) '----------------------------------------' +! write(*,*) !----------! ! Updating ! @@ -513,7 +503,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(pp_trip_Phi(nOrb,nOrb,nOrb,nOrb)) ! Build singlet eh reducible kernels - write(*,*) 'Computing singlet eh reducible kernel ...' + write(*,*) 'Computing singlet eh reducible kernel...' call wall_time(start_t) call R_eh_singlet_Phi(nOrb,nC,nR,nS,old_eh_sing_Om,eh_sing_rho,eh_sing_Phi) @@ -523,7 +513,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) ! Build triplet eh reducible kernels - write(*,*) 'Computing triplet eh reducible kernel ...' + write(*,*) 'Computing triplet eh reducible kernel...' call wall_time(start_t) call R_eh_triplet_Phi(nOrb,nC,nR,nS,old_eh_trip_Om,eh_trip_rho,eh_trip_Phi) @@ -533,7 +523,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) ! Build singlet pp reducible kernels - write(*,*) 'Computing singlet pp reducible kernel ...' + write(*,*) 'Computing singlet pp reducible kernel...' call wall_time(start_t) call R_pp_singlet_Phi(nOrb,nC,nR,nOOs,nVVs,old_ee_sing_Om,ee_sing_rho,old_hh_sing_Om,hh_sing_rho,pp_sing_Phi) @@ -543,7 +533,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) ! Build triplet pp reducible kernels - write(*,*) 'Computing triplet pp reducible kernel ...' + write(*,*) 'Computing triplet pp reducible kernel...' call wall_time(start_t) call R_pp_triplet_Phi(nOrb,nC,nR,nOOt,nVVt,old_ee_trip_Om,ee_trip_rho,old_hh_trip_Om,hh_trip_rho,pp_trip_Phi) @@ -570,22 +560,32 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i !--------------------! - write(*,*) '----------------------------------------' - write(*,*) ' Two-body (kernel) convergence ' - write(*,*) '----------------------------------------' - write(*,'(1X,A30,F10.6)')'Error for singlet eh channel = ',err_eh_sing - write(*,'(1X,A30,F10.6)')'Error for triplet eh channel = ',err_eh_trip - write(*,'(1X,A30,F10.6)')'Error for singlet pp channel = ',err_pp_sing - write(*,'(1X,A30,F10.6)')'Error for triplet pp channel = ',err_pp_trip - write(*,*) '----------------------------------------' +! write(*,*) '----------------------------------------' +! write(*,*) ' Two-body (kernel) convergence ' +! write(*,*) '----------------------------------------' +! write(*,'(1X,A30,F10.6)')'Error for singlet eh channel = ',err_eh_sing +! write(*,'(1X,A30,F10.6)')'Error for triplet eh channel = ',err_eh_trip +! write(*,'(1X,A30,F10.6)')'Error for singlet pp channel = ',err_pp_sing +! write(*,'(1X,A30,F10.6)')'Error for triplet pp channel = ',err_pp_trip +! write(*,*) '----------------------------------------' +! write(*,*) + + write(*,*) '------------------------------------------------------' + write(*,*) ' Two-body (frequency/kernel) convergence ' + write(*,*) '------------------------------------------------------' + write(*,'(1X,A30,F10.6,1X,A1,1X,F10.6)')'Error for density channel = ',err_eig_eh_sing,'/',err_eh_sing + write(*,'(1X,A30,F10.6,1X,A1,1X,F10.6)')'Error for magnetic channel = ',err_eig_eh_trip,'/',err_eh_trip + write(*,'(1X,A30,F10.6,1X,A1,1X,F10.6)')'Error for singlet channel = ',max(err_eig_ee_sing,err_eig_hh_sing),'/',err_pp_sing + write(*,'(1X,A30,F10.6,1X,A1,1X,F10.6)')'Error for triplet channel = ',max(err_eig_ee_trip,err_eig_hh_trip),'/',err_pp_sing + write(*,*) '------------------------------------------------------' write(*,*) - + ! Convergence criteria err_2b = max(err_eh_sing,err_eh_trip,err_pp_sing,err_pp_trip) call wall_time(end_2b) t_2b = end_2b - start_2b - write(*,'(A50,1X,F9.3,A8)') 'Wall time for two-body iteration =',t_2b,' seconds' + write(*,'(1X,A44,1X,I4,A2,F9.3,A8)') 'Wall time for two-body iteration #',n_it_2b,' =',t_2b,' seconds' write(*,*) end do @@ -623,7 +623,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) - write(*,*) 'Building self-energy' + write(*,*) 'Computing self-energy...' + write(*,*) call wall_time(start_t) call R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eOld,ERI, & @@ -633,7 +634,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i EcGM,SigC,Z) call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for self energy =',t,' seconds' write(*,*) eQPlin(:) = eHF(:) + Z(:)*SigC(:) @@ -668,7 +669,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(end_1b) t_1b = end_1b - start_1b - write(*,'(A50,1X,F9.3,A8)') 'Wall time for one-body iteration =',t_1b,' seconds' + write(*,'(1X,A44,1X,I4,A2,F9.3,A8)') 'Wall time for one-body iteration #',n_it_1b,' =',t_1b,' seconds' end do !---------------------------------------------! diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index a51a81c..c323150 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -45,9 +45,9 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP Z(:) = 0d0 EcGM = 0d0 -!-----------------------------! -! GF2 part of the self-energy ! -!-----------------------------! +!-----------------------------------! +! 2nd-order part of the self-energy ! +!-----------------------------------! call wall_time(start_t) do p=nC+1,nOrb-nR ! 2h1p sum @@ -84,7 +84,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for 2nd-order self-energy =',t,' seconds' write(*,*) !-------------------------------------! ! singlet eh part of the self-energy ! @@ -207,7 +207,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh self-energy =',t,' seconds' write(*,*) !-------------------------------------! ! triplet eh part of the self-energy ! @@ -330,7 +330,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh self-energy =',t,' seconds' write(*,*) !-------------------------------------! ! singlet pp part of the self-energy ! @@ -469,7 +469,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building singlet pp self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet pp self-energy =',t,' seconds' write(*,*) !-------------------------------------! ! triplet pp part of the self-energy ! @@ -607,8 +607,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP !$OMP END PARALLEL call wall_time(end_t) t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building triplet pp self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp self-energy =',t,' seconds' write(*,*) !-----------------------------! ! Renormalization factor ! From 100357747b51be36f7e787100a4f3c0ee81c1dc9 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 3 Apr 2025 17:26:35 +0200 Subject: [PATCH 54/71] more openMP --- src/Parquet/RParquet.f90 | 20 +++++++++++++------- src/Parquet/R_Parquet_self_energy.f90 | 4 ++-- src/Parquet/R_eh_singlet_Phi.f90 | 6 ++++++ src/Parquet/R_eh_triplet_Phi.f90 | 6 ++++++ src/Parquet/R_pp_singlet_Gam.f90 | 27 +++++++++++++-------------- src/Parquet/R_pp_singlet_Phi.f90 | 6 ++++++ src/Parquet/R_pp_triplet_Phi.f90 | 6 ++++++ src/Parquet/R_screened_integrals.f90 | 24 ++++++++++++------------ 8 files changed, 64 insertions(+), 35 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 8738db9..f644ce3 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -206,7 +206,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(start_t) - call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) if(.not.TDAeh) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) if(n_it_2b == 1) then @@ -261,7 +261,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(start_t) - call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph) + call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) if(.not.TDAeh) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) if(n_it_2b == 1) then @@ -319,8 +319,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(start_t) if(.not.TDApp) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp) - call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp) - call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eOld,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eOld,ERI,Dpp) if(n_it_2b == 1) then @@ -340,11 +340,17 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) + call wall_time(end_t) + t = end_t - start_t + + write(*,'(A50,1X,F9.3,A8)') 'Wall time for building singlet ppBSE =',t,' seconds' + call wall_time(start_t) + call ppRLR(TDApp,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,Ec_pp(ispin)) call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE =',t,' seconds' + write(*,'(A50,1X,F9.3,A8)') 'Wall time for diagonalizing singlet ppBSE =',t,' seconds' write(*,*) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) @@ -376,8 +382,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call wall_time(start_t) if(.not.TDApp) call ppRLR_B(ispin,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp) - call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp) - call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp) + call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eOld,ERI,Cpp) + call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eOld,ERI,Dpp) if(n_it_2b == 1) then diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index a51a81c..efcdb73 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -207,7 +207,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building singlet eh self-energy =',t,' seconds' write(*,*) !-------------------------------------! ! triplet eh part of the self-energy ! @@ -330,7 +330,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building triplet eh self-energy =',t,' seconds' write(*,*) !-------------------------------------! ! singlet pp part of the self-energy ! diff --git a/src/Parquet/R_eh_singlet_Phi.f90 b/src/Parquet/R_eh_singlet_Phi.f90 index d7f8783..f02d518 100644 --- a/src/Parquet/R_eh_singlet_Phi.f90 +++ b/src/Parquet/R_eh_singlet_Phi.f90 @@ -19,6 +19,10 @@ subroutine R_eh_singlet_Phi(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_sing_Phi) ! Initialization eh_sing_Phi(:,:,:,:) = 0d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r, s, n) & + !$OMP SHARED(nC, nOrb, nR, nS, eh_sing_Phi, eh_sing_rho, eh_sing_Om) + !$OMP DO COLLAPSE(2) do s = nC+1, nOrb-nR do r = nC+1, nOrb-nR do q = nC+1, nOrb-nR @@ -34,5 +38,7 @@ subroutine R_eh_singlet_Phi(nOrb,nC,nR,nS,eh_sing_Om,eh_sing_rho,eh_sing_Phi) enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL end subroutine diff --git a/src/Parquet/R_eh_triplet_Phi.f90 b/src/Parquet/R_eh_triplet_Phi.f90 index 38fd216..9e7b2e9 100644 --- a/src/Parquet/R_eh_triplet_Phi.f90 +++ b/src/Parquet/R_eh_triplet_Phi.f90 @@ -19,6 +19,10 @@ subroutine R_eh_triplet_Phi(nOrb,nC,nR,nS,eh_trip_Om,eh_trip_rho,eh_trip_Phi) ! Initialization eh_trip_Phi(:,:,:,:) = 0d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r, s, n) & + !$OMP SHARED(nC, nOrb, nR, nS, eh_trip_Phi, eh_trip_rho, eh_trip_Om) + !$OMP DO COLLAPSE(2) do s = nC+1, nOrb-nR do r = nC+1, nOrb-nR do q = nC+1, nOrb-nR @@ -34,5 +38,7 @@ subroutine R_eh_triplet_Phi(nOrb,nC,nR,nS,eh_trip_Om,eh_trip_rho,eh_trip_Phi) enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL end subroutine diff --git a/src/Parquet/R_pp_singlet_Gam.f90 b/src/Parquet/R_pp_singlet_Gam.f90 index 4bf6f88..206a577 100644 --- a/src/Parquet/R_pp_singlet_Gam.f90 +++ b/src/Parquet/R_pp_singlet_Gam.f90 @@ -60,7 +60,7 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_ ! Local variables integer :: a,b,c,d - integer :: ab,cd + integer :: ab,cd,aa,a0 double precision,external :: Kronecker_delta ! Output variables @@ -69,21 +69,20 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_ ! Initialization pp_sing_Gam_C(:,:) = 0d0 -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(a, b, ab, c, d, cd, n) & -! !$OMP SHARED(nC, nOrb, nO, nS, pp_sing_Gam_C, eh_sing_rho, eh_sing_Om, eh_trip_rho, eh_trip_Om) -! !$OMP DO COLLAPSE(2) - - ab = 0 - do a=nO+1,nOrb - nR - do b=a,nOrb - nR - ab = ab + 1 - + a0 = nOrb - nR - nO + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(a, b, aa, ab, c, d, cd) & + !$OMP SHARED(nO, nOrb, nR, a0, pp_sing_Gam_C, eh_sing_Phi, eh_trip_Phi) + !$OMP DO + do a = nO+1, nOrb-nR + aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO + do b = a, nOrb-nR + ab = aa + b + cd = 0 do c=nO+1,nOrb - nR do d=c,nOrb - nR cd = cd +1 - pp_sing_Gam_C(ab,cd) = 0.5d0*eh_sing_Phi(a,b,c,d) - 1.5d0*eh_trip_Phi(a,b,c,d) & + 0.5d0*eh_sing_Phi(a,b,d,c) - 1.5d0*eh_trip_Phi(a,b,d,c) @@ -94,8 +93,8 @@ subroutine R_pp_singlet_Gamma_C(nOrb,nO,nR,nVVs,eh_sing_Phi,eh_trip_Phi,pp_sing_ end do end do end do -! !$OMP END DO -! !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL end subroutine diff --git a/src/Parquet/R_pp_singlet_Phi.f90 b/src/Parquet/R_pp_singlet_Phi.f90 index e1ae594..73552a7 100644 --- a/src/Parquet/R_pp_singlet_Phi.f90 +++ b/src/Parquet/R_pp_singlet_Phi.f90 @@ -21,6 +21,10 @@ subroutine R_pp_singlet_Phi(nOrb,nC,nR,nOO,nVV,ee_sing_Om,ee_sing_rho,hh_sing_Om ! Initialization pp_sing_Phi(:,:,:,:) = 0d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r, s, n) & + !$OMP SHARED(nC, nOrb, nR, nVV, nOO, pp_sing_Phi, ee_sing_rho, ee_sing_Om, hh_sing_rho, hh_sing_Om) + !$OMP DO COLLAPSE(2) do s = nC+1, nOrb-nR do r = nC+1, nOrb-nR do q = nC+1, nOrb-nR @@ -40,5 +44,7 @@ subroutine R_pp_singlet_Phi(nOrb,nC,nR,nOO,nVV,ee_sing_Om,ee_sing_rho,hh_sing_Om enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL end subroutine diff --git a/src/Parquet/R_pp_triplet_Phi.f90 b/src/Parquet/R_pp_triplet_Phi.f90 index eaea4e2..b7c204b 100644 --- a/src/Parquet/R_pp_triplet_Phi.f90 +++ b/src/Parquet/R_pp_triplet_Phi.f90 @@ -21,6 +21,10 @@ subroutine R_pp_triplet_Phi(nOrb,nC,nR,nOO,nVV,ee_trip_Om,ee_trip_rho,hh_trip_Om ! Initialization pp_trip_Phi(:,:,:,:) = 0d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r, s, n) & + !$OMP SHARED(nC, nOrb, nR, nVV, nOO, pp_trip_Phi, ee_trip_rho, ee_trip_Om, hh_trip_rho, hh_trip_Om) + !$OMP DO COLLAPSE(2) do s = nC+1, nOrb-nR do r = nC+1, nOrb-nR do q = nC+1, nOrb-nR @@ -40,5 +44,7 @@ subroutine R_pp_triplet_Phi(nOrb,nC,nR,nOO,nVV,ee_trip_Om,ee_trip_rho,hh_trip_Om enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL end subroutine diff --git a/src/Parquet/R_screened_integrals.f90 b/src/Parquet/R_screened_integrals.f90 index 032e37d..9999e75 100644 --- a/src/Parquet/R_screened_integrals.f90 +++ b/src/Parquet/R_screened_integrals.f90 @@ -157,10 +157,10 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, rho1(:,:,:) = 0d0 rho2(:,:,:) = 0d0 -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & -! !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_sing_Gam, X1, Y1, X2, Y2) -! !$OMP DO COLLAPSE(2) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, eh_sing_Phi, eh_trip_Phi, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) do q=nC+1,nOrb-nR do p=nC+1,nOrb-nR @@ -231,8 +231,8 @@ subroutine R_pp_singlet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, end do end do -! !$OMP END DO -! !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL end subroutine @@ -274,10 +274,10 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, dim_1 = (nOrb - nO) * (nOrb - nO - 1) / 2 dim_2 = nO * (nO - 1) / 2 -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & -! !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, pp_trip_Gam, X1, Y1, X2, Y2) -! !$OMP DO COLLAPSE(2) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) & + !$OMP SHARED(nC, nOrb, nR, nO, rho1, rho2, ERI, eh_sing_Phi, eh_trip_Phi, X1, Y1, X2, Y2) + !$OMP DO COLLAPSE(2) do q = nC+1, nOrb-nR do p = nC+1, nOrb-nR @@ -344,7 +344,7 @@ subroutine R_pp_triplet_screened_integral(nOrb,nC,nO,nR,nOO,nVV,ERI,eh_sing_Phi, end do ! p end do ! q -! !$OMP END DO -! !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL end subroutine From e967e12bfb35a67e8ef26ed3e8950d9b954f8398 Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 3 Apr 2025 18:11:24 +0200 Subject: [PATCH 55/71] improve convergence by removing silly reset to zero --- src/Parquet/GParquet.f90 | 4 ++-- src/Parquet/RParquet.f90 | 29 ++++------------------------- 2 files changed, 6 insertions(+), 27 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index b4cc1e6..597ef24 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -211,7 +211,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call phGLR_A(.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) if(.not.TDAeh) call phGLR_B(.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - if(n_it_2b == 1) then + if(n_it_1b == 1 .and. n_it_2b == 1) then eh_Gam_A(:,:) = 0d0 eh_Gam_B(:,:) = 0d0 @@ -270,7 +270,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call ppGLR_C(nOrb,nC,nO,nV,nR,nVV,1d0,eOld,ERI,Cpp) call ppGLR_D(nOrb,nC,nO,nV,nR,nOO,1d0,eOld,ERI,Dpp) - if(n_it_2b == 1) then + if(n_it_1b == 1 .and. n_it_2b == 1) then pp_Gam_B(:,:) = 0d0 pp_Gam_C(:,:) = 0d0 diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 212e0b3..1b51201 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -208,7 +208,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) if(.not.TDAeh) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - if(n_it_2b == 1) then + if(n_it_1b == 1 .and. n_it_2b == 1) then eh_sing_Gam_A(:,:) = 0d0 eh_sing_Gam_B(:,:) = 0d0 @@ -260,7 +260,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call phRLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,eOld,ERI,Aph) if(.not.TDAeh) call phRLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI,Bph) - if(n_it_2b == 1) then + if(n_it_1b == 1 .and. n_it_2b == 1) then eh_trip_Gam_A(:,:) = 0d0 eh_trip_Gam_B(:,:) = 0d0 @@ -315,7 +315,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVs,1d0,eOld,ERI,Cpp) call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOs,1d0,eOld,ERI,Dpp) - if(n_it_2b == 1) then + if(n_it_1b == 1 .and. n_it_2b == 1) then pp_sing_Gam_B(:,:) = 0d0 pp_sing_Gam_C(:,:) = 0d0 @@ -375,7 +375,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call ppRLR_C(ispin,nOrb,nC,nO,nV,nR,nVVt,1d0,eOld,ERI,Cpp) call ppRLR_D(ispin,nOrb,nC,nO,nV,nR,nOOt,1d0,eOld,ERI,Dpp) - if(n_it_2b == 1) then + if(n_it_1b == 1 .and. n_it_2b == 1) then pp_trip_Gam_B(:,:) = 0d0 pp_trip_Gam_C(:,:) = 0d0 @@ -409,16 +409,6 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) -! write(*,*) '----------------------------------------' -! write(*,*) ' Two-body (eigenvalue) convergence ' -! write(*,*) '----------------------------------------' -! write(*,'(1X,A30,F10.6)')'Error for density channel = ',err_eig_eh_sing -! write(*,'(1X,A30,F10.6)')'Error for magnetic channel = ',err_eig_eh_trip -! write(*,'(1X,A30,F10.6)')'Error for singlet channel = ',max(err_eig_ee_sing,err_eig_hh_sing) -! write(*,'(1X,A30,F10.6)')'Error for triplet channel = ',max(err_eig_ee_trip,err_eig_hh_trip) -! write(*,*) '----------------------------------------' -! write(*,*) - !----------! ! Updating ! !----------! @@ -565,17 +555,6 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! DIIS extrapolation ! !--------------------! - -! write(*,*) '----------------------------------------' -! write(*,*) ' Two-body (kernel) convergence ' -! write(*,*) '----------------------------------------' -! write(*,'(1X,A30,F10.6)')'Error for singlet eh channel = ',err_eh_sing -! write(*,'(1X,A30,F10.6)')'Error for triplet eh channel = ',err_eh_trip -! write(*,'(1X,A30,F10.6)')'Error for singlet pp channel = ',err_pp_sing -! write(*,'(1X,A30,F10.6)')'Error for triplet pp channel = ',err_pp_trip -! write(*,*) '----------------------------------------' -! write(*,*) - write(*,*) '------------------------------------------------------' write(*,*) ' Two-body (frequency/kernel) convergence ' write(*,*) '------------------------------------------------------' From fff8fd71ecd2f60b34f6431c27da646bf06f58fe Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 3 Apr 2025 21:47:28 +0200 Subject: [PATCH 56/71] tracking memory usage in RParquet --- src/Parquet/GParquet.f90 | 32 ++++++++-------- src/Parquet/RParquet.f90 | 80 ++++++++++++++++++++++++++++++++++++---- 2 files changed, 88 insertions(+), 24 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 597ef24..2f5e11b 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -96,7 +96,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(err(2*nOrb**4),Phi(2*nOrb**4)) mem = mem + size(err_diis_2b) + size(Phi_diis) + size(err) + size(Phi) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' err_diis_2b(:,:) = 0d0 Phi_diis(:,:) = 0d0 @@ -137,7 +137,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i mem = mem + size(old_eh_Om) + size(old_ee_Om) + size(old_hh_Om) mem = mem + size(eh_rho) + size(ee_rho) + size(hh_rho) mem = mem + size(old_eh_Phi) + size(old_pp_Phi) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' ! Initialization @@ -201,7 +201,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(Aph(nS,nS),Bph(nS,nS),eh_Om(nS),XpY(nS,nS),XmY(nS,nS),eh_Gam_A(nS,nS),eh_Gam_B(nS,nS)) mem = mem + size(Aph) + size(Bph) + size(eh_Om) + size(XpY) + size(XmY) + size(eh_Gam_A) + size(eh_Gam_B) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' Aph(:,:) = 0d0 Bph(:,:) = 0d0 @@ -241,7 +241,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(Aph,Bph,eh_Gam_A,eh_Gam_B) mem = mem - size(Aph) - size(Bph) - size(eh_Gam_A) - size(eh_Gam_B) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' !-----------------! ! pp channel ! @@ -258,7 +258,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i + size(ee_Om) + size(X1) + size(Y1) & + size(hh_Om) + size(X2) + size(Y2) & + size(pp_Gam_B) + size(pp_Gam_C) + size(pp_Gam_D) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' Bpp(:,:) = 0d0 @@ -306,8 +306,8 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i mem = mem - size(Bpp) - size(Cpp) - size(Dpp) & - size(pp_Gam_B) - size(pp_Gam_C) - size(pp_Gam_D) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' - + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' + !----------! ! Updating ! !----------! @@ -319,7 +319,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(eh_Om,ee_Om,hh_Om) mem = mem - size(eh_Om) - size(ee_Om) - size(hh_Om) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' !----------------------------! ! Compute screened integrals ! @@ -329,7 +329,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(eh_rho,ee_rho,hh_rho) mem = mem - size(eh_rho) - size(ee_rho) - size(hh_rho) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation @@ -337,7 +337,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) mem = mem + size(eh_rho) + size(ee_rho) + size(hh_rho) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' ! Build singlet eh integrals write(*,*) 'Computing eh screened integrals...' @@ -354,7 +354,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(XpY,XmY) mem = mem - size(XpY) - size(XmY) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' ! Build singlet pp integrals write(*,*) 'Computing pp screened integrals...' @@ -368,7 +368,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(X1,Y1,X2,Y2) mem = mem - size(X1) - size(Y1) - size(X2) - size(Y2) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for pp integrals =',t,' seconds' write(*,*) @@ -382,7 +382,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(pp_Phi(nOrb,nOrb,nOrb,nOrb)) mem = mem + size(eh_Phi) + size(pp_Phi) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' ! Build eh reducible kernels write(*,*) 'Computing eh reducible kernel...' @@ -466,7 +466,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(eh_Phi,pp_Phi) mem = mem - size(eh_Phi) - size(pp_Phi) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' write(*,*) '------------------------------------------------' write(*,*) ' Two-body (frequency/kernel) convergence ' @@ -517,7 +517,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) mem = mem + size(eQPlin) + size(Z) + size(SigC) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' write(*,*) 'Computing self-energy...' write(*,*) @@ -561,7 +561,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(eQPlin,Z,SigC) mem = mem - size(eQPlin) - size(Z) - size(SigC) - write(*,'(1X,A50,1X,F6.3,A3)') 'Memory usage in GParquet:',mem*dp_in_GB,' GB' + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in GParquet =',mem*dp_in_GB,' GB' call wall_time(end_1b) t_1b = end_1b - start_1b diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 1b51201..f881d15 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -82,17 +82,24 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) double precision :: EcGM + + double precision :: mem = 0d0 + double precision :: dp_in_GB = 8d0/(1024d0**3) ! Output variables ! None ! Useful parameters + nOOs = nO*(nO + 1)/2 nVVs = nV*(nV + 1)/2 nOOt = nO*(nO - 1)/2 nVVt = nV*(nV - 1)/2 allocate(eQP(nOrb),eOld(nOrb)) + + mem = mem + size(eQP) + size(eOld) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet = ',mem*dp_in_GB,' GB' write(*,*) write(*,*)'**********************************' @@ -130,6 +137,19 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(old_eh_sing_Phi(nOrb,nOrb,nOrb,nOrb),old_eh_trip_Phi(nOrb,nOrb,nOrb,nOrb)) allocate(old_pp_sing_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_trip_Phi(nOrb,nOrb,nOrb,nOrb)) +! Memory usage + + mem = mem + size(old_eh_sing_Om) + size(old_eh_trip_Om) & + + size(old_ee_sing_Om) + size(old_hh_sing_Om) & + + size(old_ee_trip_Om) + size(old_hh_trip_Om) & + + size(eh_sing_rho) + size(eh_trip_rho) & + + size(ee_sing_rho) + size(hh_sing_rho) & + + size(ee_trip_rho) + size(hh_trip_rho) & + + size(old_eh_sing_Phi) + size(old_eh_trip_Phi) & + + size(old_pp_sing_Phi) + size(old_pp_trip_Phi) + + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet = ',mem*dp_in_GB,' GB' + ! Initialization n_it_1b = 0 @@ -199,6 +219,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) + mem = mem + size(Aph) + size(Bph) + size(eh_sing_Om) + size(sing_XpY) + size(sing_XmY) + size(eh_sing_Gam_A) + size(eh_sing_Gam_B) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' + ispin = 1 Aph(:,:) = 0d0 Bph(:,:) = 0d0 @@ -243,6 +266,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(Aph,Bph,eh_sing_Gam_A,eh_sing_Gam_B) + mem = mem - size(Aph) - size(Bph) - size(eh_sing_Gam_A) - size(eh_sing_Gam_B) + !------------------! ! Magnetic channel ! !------------------! @@ -251,6 +276,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) + mem = mem + size(Aph) + size(Bph) + size(eh_trip_Om) + size(trip_XpY) + size(trip_XmY) + size(eh_trip_Gam_A) + size(eh_trip_Gam_B) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' + ispin = 2 Aph(:,:) = 0d0 Bph(:,:) = 0d0 @@ -293,7 +321,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i err_eig_eh_trip = maxval(abs(old_eh_trip_Om - eh_trip_Om)) deallocate(Aph,Bph,eh_trip_Gam_A,eh_trip_Gam_B) - + + mem = mem - size(Aph) - size(Bph) - size(eh_trip_Gam_A) - size(eh_trip_Gam_B) + !-----------------! ! Singlet channel ! !-----------------! @@ -305,6 +335,13 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i hh_sing_Om(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & pp_sing_Gam_B(nVVs,nOOs),pp_sing_Gam_C(nVVs,nVVs),pp_sing_Gam_D(nOOs,nOOs)) + mem = mem + size(Bpp) + size(Cpp) + size(Dpp) & + + size(ee_sing_Om) + size(X1s) + size(Y1s) & + + size(hh_sing_Om) + size(X2s) + size(Y2s) & + + size(pp_sing_Gam_B) + size(pp_sing_Gam_C) + size(pp_sing_Gam_D) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' + + ispin = 1 Bpp(:,:) = 0d0 Cpp(:,:) = 0d0 @@ -333,18 +370,13 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i Cpp(:,:) = Cpp(:,:) + pp_sing_Gam_C(:,:) Dpp(:,:) = Dpp(:,:) + pp_sing_Gam_D(:,:) - call wall_time(end_t) - t = end_t - start_t - - write(*,'(A50,1X,F9.3,A8)') 'Wall time for building singlet ppBSE =',t,' seconds' - call wall_time(start_t) call ppRLR(TDApp,nOOs,nVVs,Bpp,Cpp,Dpp,ee_sing_Om,X1s,Y1s,hh_sing_Om,X2s,Y2s,Ec_pp(ispin)) call wall_time(end_t) t = end_t - start_t - write(*,'(A50,1X,F9.3,A8)') 'Wall time for diagonalizing singlet ppBSE =',t,' seconds' - write(*,*) + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet ppBSE =',t,' seconds' + call wall_time(start_t) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2p (singlets)',nVVs,ee_sing_Om) if(print_ppLR) call print_excitation_energies('ppBSE@Parquet','2h (singlets)',nOOs,hh_sing_Om) @@ -353,6 +385,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i err_eig_hh_sing = maxval(abs(old_hh_sing_Om - hh_sing_Om)) deallocate(Bpp,Cpp,Dpp,pp_sing_Gam_B,pp_sing_Gam_C,pp_sing_Gam_D) + + mem = mem - size(Bpp) - size(Cpp) - size(Dpp) & + - size(pp_sing_Gam_B) - size(pp_sing_Gam_C) - size(pp_sing_Gam_D) !-----------------! ! Triplet channel ! @@ -365,6 +400,12 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i hh_trip_Om(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & pp_trip_Gam_B(nVVt,nOOt),pp_trip_Gam_C(nVVt,nVVt),pp_trip_Gam_D(nOOt,nOOt)) + mem = mem + size(Bpp) + size(Cpp) + size(Dpp) & + + size(ee_trip_Om) + size(X1t) + size(Y1t) & + + size(hh_trip_Om) + size(X2t) + size(Y2t) & + + size(pp_trip_Gam_B) + size(pp_trip_Gam_C) + size(pp_trip_Gam_D) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' + ispin = 2 Bpp(:,:) = 0d0 Cpp(:,:) = 0d0 @@ -408,6 +449,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i err_eig_hh_trip = maxval(abs(old_hh_trip_Om - hh_trip_Om)) deallocate(Bpp,Cpp,Dpp,pp_trip_Gam_B,pp_trip_Gam_C,pp_trip_Gam_D) + + mem = mem - size(Bpp) - size(Cpp) - size(Dpp) & + - size(pp_trip_Gam_B) - size(pp_trip_Gam_C) - size(pp_trip_Gam_D) !----------! ! Updating ! @@ -421,6 +465,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i old_hh_trip_Om(:) = hh_trip_Om(:) deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) + + mem = mem - size(eh_sing_Om) - size(eh_trip_Om) - size(ee_sing_Om) - size(hh_sing_Om) - size(ee_trip_Om) - size(hh_trip_Om) !----------------------------! ! Compute screened integrals ! @@ -447,6 +493,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) ! Done with eigenvectors and kernel deallocate(sing_XpY,sing_XmY) + + mem = mem - size(sing_XpY) - size(sing_XmY) ! Build triplet eh screened integrals write(*,*) 'Computing triplet eh screened integrals...' @@ -460,6 +508,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) ! Done with eigenvectors and kernel deallocate(trip_XpY,trip_XmY) + + mem = mem - size(trip_XpY) - size(trip_XmY) ! Build singlet pp screened integrals write(*,*) 'Computing singlet pp screened integrals...' @@ -475,6 +525,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(X1s,Y1s,X2s,Y2s) + mem = mem - size(X1s) - size(Y1s) - size(X2s) - size(Y2s) + ! Build triplet pp screened integrals write(*,*) 'Computing triplet pp screened integrals...' @@ -488,6 +540,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Done with eigenvectors and kernel deallocate(X1t,Y1t,X2t,Y2t) + mem = mem - size(X1t) - size(Y1t) - size(X2t) - size(Y2t) + !----------------------------! ! Compute reducible kernels ! !----------------------------! @@ -498,6 +552,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(pp_sing_Phi(nOrb,nOrb,nOrb,nOrb)) allocate(pp_trip_Phi(nOrb,nOrb,nOrb,nOrb)) + mem = mem + size(eh_sing_Phi) + size(eh_trip_Phi) + size(pp_sing_Phi) + size(pp_trip_Phi) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' + ! Build singlet eh reducible kernels write(*,*) 'Computing singlet eh reducible kernel...' @@ -551,6 +608,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Free memory deallocate(eh_sing_Phi,eh_trip_Phi,pp_sing_Phi,pp_trip_Phi) + mem = mem - size(eh_sing_Phi) - size(eh_trip_Phi) - size(pp_sing_Phi) - size(pp_trip_Phi) + !--------------------! ! DIIS extrapolation ! !--------------------! @@ -608,6 +667,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(eQPlin(nOrb),Z(nOrb),SigC(nOrb)) + mem = mem + size(eQPlin) + size(Z) + size(SigC) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' + write(*,*) 'Computing self-energy...' write(*,*) @@ -651,6 +713,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i call R_print_parquet_1b(nOrb,nO,eHF,SigC,eQP,Z,n_it_1b,err_1b,ENuc,ERHF,EcGM,Ec_eh,Ec_pp) deallocate(eQPlin,Z,SigC) + + mem = mem - size(eQPlin) - size(Z) - size(SigC) call wall_time(end_1b) t_1b = end_1b - start_1b From a168d1be341d4c974e6ba0540fcddcffd1a7667a Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 3 Apr 2025 22:06:07 +0200 Subject: [PATCH 57/71] diis for one-body part in RParquet --- src/Parquet/RParquet.f90 | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index f881d15..6860ee3 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -85,6 +85,12 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i double precision :: mem = 0d0 double precision :: dp_in_GB = 8d0/(1024d0**3) + +! DIIS + integer :: n_diis_1b,n_diis_2b + double precision :: rcond_1b + double precision,allocatable :: err_diis_1b(:,:) + double precision,allocatable :: eQP_diis(:,:) ! Output variables ! None @@ -150,6 +156,15 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet = ',mem*dp_in_GB,' GB' +! DIIS for one-body part + + allocate(err_diis_1b(nOrb,max_diis_1b),eQP_diis(nOrb,max_diis_1b)) + + rcond_1b = 1d0 + n_diis_1b = 0 + err_diis_1b(:,:) = 0d0 + eQP_diis(:,:) = 0d0 + ! Initialization n_it_1b = 0 @@ -701,8 +716,17 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*) stop - end if + end if + ! DIIS for one-body part + + if(max_diis_1b > 1) then + + n_diis_1b = min(n_diis_1b+1,max_diis_1b) + call DIIS_extrapolation(rcond_1b,nOrb,nOrb,n_diis_1b,err_diis_1b,eQP_diis,eQP-eOld,eQP) + + end if + ! Check one-body converge err_1b = maxval(abs(eOld - eQP)) From 8213c476156942db2b8a2f0c39da7fba091bde02 Mon Sep 17 00:00:00 2001 From: pfloos Date: Thu, 3 Apr 2025 22:19:01 +0200 Subject: [PATCH 58/71] DIIS in parquet 1b with more printing --- src/Parquet/RParquet.f90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 6860ee3..312f1a1 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -88,7 +88,7 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! DIIS integer :: n_diis_1b,n_diis_2b - double precision :: rcond_1b + double precision :: rcond_1b,rcond_2b double precision,allocatable :: err_diis_1b(:,:) double precision,allocatable :: eQP_diis(:,:) @@ -160,6 +160,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(err_diis_1b(nOrb,max_diis_1b),eQP_diis(nOrb,max_diis_1b)) + mem = mem + size(err_diis_1b) + size(eQP_diis) + write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet = ',mem*dp_in_GB,' GB' + rcond_1b = 1d0 n_diis_1b = 0 err_diis_1b(:,:) = 0d0 @@ -207,7 +210,12 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i write(*,*)'=====================================' write(*,*) -! Initialization + ! DIIS for two-body part + + rcond_2b = 0d0 + n_diis_2b = 0 + + ! Initialization n_it_2b = 0 err_2b = 1d0 From deee1061c99b287a78aaefe2ff45e6366859710c Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 4 Apr 2025 09:23:05 +0200 Subject: [PATCH 59/71] remove long lines --- src/Parquet/G_Parquet_self_energy.f90 | 22 ++++++++++++++++++---- src/Parquet/RParquet.f90 | 12 +++++++++--- 2 files changed, 27 insertions(+), 7 deletions(-) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 28133ab..5a44a60 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -2,10 +2,12 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& eh_rho,eh_Om,ee_rho,ee_Om,hh_rho,hh_Om,EcGM,SigC,Z) ! Compute correlation part of the self-energy coming from irreducible vertices contribution + implicit none include 'parameters.h' ! Input variables + double precision,intent(in) :: eta integer,intent(in) :: nOrb integer,intent(in) :: nC, nO, nV, nR @@ -27,20 +29,23 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& double precision :: start_t,end_t,t ! Output variables + double precision,intent(out) :: SigC(nOrb) double precision,intent(out) :: Z(nOrb) double precision,intent(out) :: EcGM - ! Initialize +! Initialize SigC(:) = 0d0 Z(:) = 0d0 EcGM = 0d0 -!-----------------------------! -! GF2 part of the self-energy ! -!-----------------------------! +!-----------------------! +! 2nd-order self-energy ! +!-----------------------! + call wall_time(start_t) + do p=nC+1,nOrb-nR ! 2h1p sum do i=nC+1,nO @@ -73,15 +78,19 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do end do end do + call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building GF(2) self-energy =',t,' seconds' write(*,*) + !-----------------------------! ! eh part of the self-energy ! !-----------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) @@ -196,15 +205,19 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! p !$OMP END DO !$OMP END PARALLEL + call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' write(*,*) + !-----------------------------! ! pp part of the self-energy ! !-----------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(p,i,j,k,c,n,num,dem1,dem2,reg1,reg2) & !$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,eta,ERI,eQP,ee_rho,ee_Om,hh_rho,hh_Om,SigC,Z) @@ -335,6 +348,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& end do ! p !$OMP END DO !$OMP END PARALLEL + call wall_time(end_t) t = end_t - start_t diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 312f1a1..289a89e 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -242,7 +242,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(Aph(nS,nS),Bph(nS,nS),eh_sing_Om(nS),sing_XpY(nS,nS),sing_XmY(nS,nS),eh_sing_Gam_A(nS,nS),eh_sing_Gam_B(nS,nS)) - mem = mem + size(Aph) + size(Bph) + size(eh_sing_Om) + size(sing_XpY) + size(sing_XmY) + size(eh_sing_Gam_A) + size(eh_sing_Gam_B) + mem = mem + size(Aph) + size(Bph) & + + size(eh_sing_Om) + size(sing_XpY) & + + size(sing_XmY) + size(eh_sing_Gam_A) + size(eh_sing_Gam_B) write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' ispin = 1 @@ -299,7 +301,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i allocate(Aph(nS,nS),Bph(nS,nS),eh_trip_Om(nS),trip_XpY(nS,nS),trip_XmY(nS,nS),eh_trip_Gam_A(nS,nS),eh_trip_Gam_B(nS,nS)) - mem = mem + size(Aph) + size(Bph) + size(eh_trip_Om) + size(trip_XpY) + size(trip_XmY) + size(eh_trip_Gam_A) + size(eh_trip_Gam_B) + mem = mem + size(Aph) + size(Bph) & + + size(eh_trip_Om) + size(trip_XpY) + size(trip_XmY) & + + size(eh_trip_Gam_A) + size(eh_trip_Gam_B) write(*,'(1X,A50,4X,F6.3,A3)') 'Memory usage in RParquet =',mem*dp_in_GB,' GB' ispin = 2 @@ -489,7 +493,9 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i deallocate(eh_sing_Om,eh_trip_Om,ee_sing_Om,hh_sing_Om,ee_trip_Om,hh_trip_Om) - mem = mem - size(eh_sing_Om) - size(eh_trip_Om) - size(ee_sing_Om) - size(hh_sing_Om) - size(ee_trip_Om) - size(hh_trip_Om) + mem = mem - size(eh_sing_Om) - size(eh_trip_Om) & + - size(ee_sing_Om) - size(hh_sing_Om) & + - size(ee_trip_Om) - size(hh_trip_Om) !----------------------------! ! Compute screened integrals ! From e1cddba6c34f07fb26499c558357673c82e09dcd Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 4 Apr 2025 09:54:02 +0200 Subject: [PATCH 60/71] corrections in GParquet self-energy --- src/Parquet/G_Parquet_self_energy.f90 | 30 +++++++++++++-------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 5a44a60..9fa7beb 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -40,9 +40,9 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(:) = 0d0 EcGM = 0d0 -!-----------------------! -! 2nd-order self-energy ! -!-----------------------! +!-----------------------------------! +! 2nd-order part of the self-energy ! +!-----------------------------------! call wall_time(start_t) @@ -115,7 +115,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,j,n)) !dem1 = eQP(a) - eQP(i) - eh_Om(n) dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) @@ -126,7 +126,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(j,a,n) * eh_rho(i,p,n)) + !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,j,n)) dem1 = eQP(a) - eQP(i) + eh_Om(n) !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) @@ -235,8 +235,8 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k ! 3h2p @@ -248,8 +248,8 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! a end do ! n @@ -263,17 +263,17 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) +! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) !dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -331,7 +331,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) +! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) !dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) From 095695ab6b6aadd12dc5bfcc2708ddf8247b58a8 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Sat, 5 Apr 2025 17:29:13 +0200 Subject: [PATCH 61/71] trying to solve problem --- src/Parquet/G_Parquet_self_energy.f90 | 130 ++++++------- src/Parquet/R_Parquet_self_energy.f90 | 264 +++++++++++++------------- 2 files changed, 197 insertions(+), 197 deletions(-) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 9fa7beb..6e3f80c 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -103,97 +103,97 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do n=1,nS !3h2p do j=nC+1,nO - num = ERI(p,a,j,i) * & - (eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,j,n)) + num = ( - ERI(p,a,j,i) + ERI(p,a,i,j))* & + eh_rho(a,i,n) * eh_rho(j,p,n) dem1 = eQP(a) - eQP(i) - eh_Om(n) dem2 = eQP(p) - eQP(j) + eh_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,j,n)) + num = (ERI(p,a,j,i) - ERI(p,a,i,j))* & + eh_rho(a,i,n) * eh_rho(j,p,n) - !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem1 = eQP(a) - eQP(i) - eh_Om(n) dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + num = (- ERI(p,i,j,a) + ERI(p,i,a,j)) * & + eh_rho(j,p,n) * eh_rho(i,a,n) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,j,n)) + num = (- ERI(p,a,j,i) + ERI(p,a,i,j))* & + eh_rho(p,j,n) * eh_rho(i,a,n) dem1 = eQP(a) - eQP(i) + eh_Om(n) - !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,i,j,a) * & - (eh_rho(j,p,n) * eh_rho(a,i,n) - eh_rho(i,p,n) * eh_rho(a,j,n)) - - !dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! j !3p2h do b=nO+1,nOrb-nR - num = ERI(p,a,b,i) * & - (eh_rho(b,p,n) * eh_rho(i,a,n) - eh_rho(a,p,n) * eh_rho(i,b,n)) + num = (- ERI(p,a,b,i) + ERI(p,a,i,b)) * & + eh_rho(p,b,n) * eh_rho(i,a,n) dem1 = eQP(a) - eQP(i) + eh_Om(n) dem2 = eQP(p) - eQP(b) - eh_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,i,b,a) * & - (eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(i,p,n) * eh_rho(a,b,n)) + num = (- ERI(p,i,b,a) + ERI(p,i,a,b)) * & + eh_rho(b,p,n) * eh_rho(i,a,n) - !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem1 = eQP(a) - eQP(i) + eh_Om(n) dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) - - dem1 = eQP(a) - eQP(i) - eh_Om(n) - !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - eh_rho(b,i,n) * eh_rho(a,p,n)) + num = (- ERI(p,i,b,a) + ERI(p,i,a,b)) * & + eh_rho(p,b,n) * eh_rho(a,i,n) - !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem1 = eQP(a) - eQP(i) - eh_Om(n) dem2 = eQP(p) - eQP(b) - eh_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + num = (ERI(p,i,b,a) - ERI(p,i,a,b)) * & + eh_rho(p,b,n) * eh_rho(a,i,n) + + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! b @@ -229,7 +229,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do n=1,nVV ! 4h1p do k=nC+1,nO - num = ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) + num = 2d0 * ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(k) - ee_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -242,10 +242,10 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3h2p do c=nO+1,nOrb-nR - num = ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) - !dem1 = ee_Om(n) - eQP(i) - eQP(j) + num = 2d0 * ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) + dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -257,7 +257,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3h2p do c=nO+1,nOrb-nR - num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + num = 2d0 * ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - hh_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -266,10 +266,10 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - !dem1 = hh_Om(n) - eQP(i) - eQP(j) + num = 2d0 * ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) @@ -294,7 +294,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 4p1h do c=nO+1,nOrb-nR - num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) + num = 2d0 * ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(c) - hh_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -307,10 +307,10 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3p2h do k=nC+1,nO - num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) - !dem1 = hh_Om(n) - eQP(a) - eQP(b) + num = 2d0 * ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) + dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) @@ -322,7 +322,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3p2h do k=nC+1,nO - num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + num = 2d0 * ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -331,10 +331,10 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - !dem1 = ee_Om(n) - eQP(a) - eQP(b) + num = 2d0 * ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index c323150..45c35db 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -102,97 +102,97 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP do n=1,nS !3h2p do j=nC+1,nO - num = ERI(p,a,j,i) * & - (eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) - 0.5d0*eh_sing_rho(a,p,n) * eh_sing_rho(i,j,n)) + num = ( - ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & + eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - 0.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) + num = (ERI(p,a,j,i) - 0.5d0*ERI(p,a,i,j))* & + eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) - !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,a,j,i) * & - !(eh_rho(j,p,n) * eh_rho(i,a,n) - 0.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) - - dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) - !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + num = (- ERI(p,i,j,a) + 0.5d0*ERI(p,i,a,j)) * & + eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) - num = ERI(p,i,j,a) * & - (eh_sing_rho(j,p,n) * eh_sing_rho(a,i,n) - 0.5d0*eh_sing_rho(i,p,n) * eh_sing_rho(a,j,n)) - - !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + num = (- ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & + eh_sing_rho(p,j,n) * eh_sing_rho(i,a,n) + + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! j !3p2h do b=nO+1,nOrb-nR - num = ERI(p,a,b,i) * & - (eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) - 0.5d0*eh_sing_rho(a,p,n) * eh_sing_rho(i,b,n)) + num = (- ERI(p,a,b,i) + 0.5d0*ERI(p,a,i,b)) * & + eh_sing_rho(p,b,n) * eh_sing_rho(i,a,n) dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,i,b,a) * & - (eh_sing_rho(b,p,n) * eh_sing_rho(a,i,n) - 0.5d0*eh_sing_rho(i,p,n) * eh_sing_rho(a,b,n)) + num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & + eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) - !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) - - dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) - !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) + num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & + eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) - !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + num = (ERI(p,i,b,a) - 0.5d0*ERI(p,i,a,b)) * & + eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) + + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! b @@ -225,97 +225,97 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP do n=1,nS !3h2p do j=nC+1,nO - num = ERI(p,a,j,i) * & - (- 1.5d0*eh_trip_rho(a,p,n) * eh_trip_rho(i,j,n)) + num = ( + 1.5d0*ERI(p,a,i,j))* & + eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,a,j,i) * & - !(- 1.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) + num = ( - 1.5d0*ERI(p,a,i,j))* & + eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) - !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,a,j,i) * & - !(- 1.5d0*eh_rho(j,a,n) * eh_rho(i,p,n)) - - dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) - !dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + num = ( + 1.5d0*ERI(p,i,a,j)) * & + eh_trip_rho(j,p,n) * eh_trip_rho(i,a,n) - num = ERI(p,i,j,a) * & - (- 1.5d0*eh_trip_rho(i,p,n) * eh_trip_rho(a,j,n)) - - !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + num = ( + 1.5d0*ERI(p,a,i,j))* & + eh_trip_rho(p,j,n) * eh_trip_rho(i,a,n) + + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! j !3p2h do b=nO+1,nOrb-nR - num = ERI(p,a,b,i) * & - (- 1.5d0*eh_trip_rho(a,p,n) * eh_trip_rho(i,b,n)) + num = ( + 1.5d0*ERI(p,a,i,b)) * & + eh_trip_rho(p,b,n) * eh_trip_rho(i,a,n) dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,i,b,a) * & - (- 1.5d0*eh_trip_rho(i,p,n) * eh_trip_rho(a,b,n)) + num = ( + 1.5d0*ERI(p,i,a,b)) * & + eh_trip_rho(b,p,n) * eh_trip_rho(i,a,n) - !dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) - - dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) - !dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - !reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - !num = ERI(p,i,b,a) * & - !(eh_rho(b,p,n) * eh_rho(a,i,n) - 0.5d0*eh_rho(b,i,n) * eh_rho(a,p,n)) + num = ( + 1.5d0*ERI(p,i,a,b)) * & + eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) - !dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + num = ( - 1.5d0*ERI(p,i,a,b)) * & + eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) + + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! b @@ -347,27 +347,27 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP do n=1,nVVs ! 4h1p do k=nC+1,nO - num = 0.5d0*ERI(p,k,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,k,n) + num = ERI(p,k,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,k,n) dem1 = ee_sing_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(k) - ee_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k ! 3h2p do c=nO+1,nOrb-nR - num = 0.5d0*ERI(p,c,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,c,n) + num = ERI(p,c,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,c,n) !dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! a end do ! n @@ -375,23 +375,23 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3h2p do c=nO+1,nOrb-nR - num = 0.5d0*ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) + num = ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) dem1 = hh_sing_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - hh_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = 0.5d0*ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) + num = ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) !dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -412,7 +412,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 4p1h do c=nO+1,nOrb-nR - num = 0.5d0*ERI(p,c,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,c,n) + num = ERI(p,c,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,c,n) dem1 = hh_sing_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(c) - hh_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -425,7 +425,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3p2h do k=nC+1,nO - num = 0.5d0*ERI(p,k,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,k,n) + num = ERI(p,k,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,k,n) !dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -440,7 +440,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3p2h do k=nC+1,nO - num = 0.5d0*ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) + num = ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) dem1 = ee_sing_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -449,7 +449,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - num = 0.5d0*ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) + num = ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) !dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -486,27 +486,27 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP do n=1,nVVt ! 4h1p do k=nC+1,nO - num = 1.5d0*ERI(p,k,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,k,n) + num = 3d0*ERI(p,k,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,k,n) dem1 = ee_trip_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(k) - ee_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k ! 3h2p do c=nO+1,nOrb-nR - num = 1.5d0*ERI(p,c,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,c,n) + num = 3d0*ERI(p,c,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,c,n) !dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! a end do ! n @@ -514,23 +514,23 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3h2p do c=nO+1,nOrb-nR - num = 1.5d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) + num = 3d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) dem1 = hh_trip_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - hh_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = 1.5d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) + num = 3d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) !dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -551,7 +551,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 4p1h do c=nO+1,nOrb-nR - num = 1.5d0*ERI(p,c,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,c,n) + num = 3d0*ERI(p,c,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,c,n) dem1 = hh_trip_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(c) - hh_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -564,7 +564,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3p2h do k=nC+1,nO - num = 1.5d0*ERI(p,k,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,k,n) + num = 3d0*ERI(p,k,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,k,n) !dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -579,7 +579,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3p2h do k=nC+1,nO - num = 1.5d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) + num = 3d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) dem1 = ee_trip_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -588,7 +588,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) - num = 1.5d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) + num = 3d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) !dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) From ee8299a5f68b6a8008220f4c071a0bae371e6400 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Mon, 14 Apr 2025 15:27:47 +0200 Subject: [PATCH 62/71] clean up in AOtoMO --- src/AOtoMO/AOtoMO.f90 | 12 ++++++------ src/AOtoMO/AOtoMO_GHF.f90 | 32 ++++++++++++++++++++++++++------ 2 files changed, 32 insertions(+), 12 deletions(-) diff --git a/src/AOtoMO/AOtoMO.f90 b/src/AOtoMO/AOtoMO.f90 index 8383273..6481ee2 100644 --- a/src/AOtoMO/AOtoMO.f90 +++ b/src/AOtoMO/AOtoMO.f90 @@ -1,17 +1,17 @@ -subroutine AOtoMO(nBas, nOrb, 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 implicit none - integer, intent(in) :: nBas, nOrb - double precision, intent(in) :: C(nBas,nOrb) - double precision, intent(in) :: M_AOs(nBas,nBas) + integer,intent(in) :: nBas, nOrb + double precision,intent(in) :: C(nBas,nOrb) + double precision,intent(in) :: M_AOs(nBas,nBas) - double precision, intent(out) :: M_MOs(nOrb,nOrb) + double precision,intent(out) :: M_MOs(nOrb,nOrb) - double precision, allocatable :: AC(:,:) + double precision,allocatable :: AC(:,:) allocate(AC(nBas,nOrb)) diff --git a/src/AOtoMO/AOtoMO_GHF.f90 b/src/AOtoMO/AOtoMO_GHF.f90 index 0338a42..bb086c2 100644 --- a/src/AOtoMO/AOtoMO_GHF.f90 +++ b/src/AOtoMO/AOtoMO_GHF.f90 @@ -1,4 +1,4 @@ -subroutine AOtoMO_GHF(nBas,nBas2,Ca,Cb,A,B) +subroutine AOtoMO_GHF(nBas,nOrb,Ca,Cb,A,B) ! Perform AO to MO transformation of a matrix A for given coefficients c @@ -7,25 +7,45 @@ subroutine AOtoMO_GHF(nBas,nBas2,Ca,Cb,A,B) ! Input variables integer,intent(in) :: nBas - integer,intent(in) :: nBas2 - double precision,intent(in) :: Ca(nBas,nBas2) - double precision,intent(in) :: Cb(nBas,nBas2) + integer,intent(in) :: nOrb + double precision,intent(in) :: Ca(nBas,nOrb) + double precision,intent(in) :: Cb(nBas,nOrb) double precision,intent(in) :: A(nBas,nBas) ! Local variables double precision,allocatable :: AC(:,:) +! double precision,allocatable :: Ba(:,:) ! Output variables - double precision,intent(out) :: B(nBas2,nBas2) + double precision,intent(out) :: B(nOrb,nOrb) - allocate(AC(nBas,nBas2)) + allocate(AC(nBas,nOrb)) +! allocate(Ba(nOrb,nOrb)) AC = matmul(A,Ca) B = matmul(transpose(Ca),AC) +! call dgemm("N", "N", nBas, nOrb, nBas, 1.d0, & +! A(1,1), nBas, Ca(1,1), nBas, & +! 0.d0, AC(1,1), nBas) + +! call dgemm("T", "N", nOrb, nOrb, nBas, 1.d0, & +! Ca(1,1), nBas, AC(1,1), nBas, & +! 0.d0, Ba(1,1), nOrb) + AC = matmul(A,Cb) B = B + matmul(transpose(Cb),AC) +! call dgemm("N", "N", nBas, nOrb, nBas, 1.d0, & +! A(1,1), nBas, Cb(1,1), nBas, & +! 0.d0, AC(1,1), nBas) + +! call dgemm("T", "N", nOrb, nOrb, nBas, 1.d0, & +! Cb(1,1), nBas, AC(1,1), nBas, & +! 0.d0, B(1,1), nOrb) + +! B(:,:) = Ba(:,:) + B(:,:) + end subroutine From 9234df0e107d814418b588e371a3a924f066371a Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Mon, 14 Apr 2025 21:42:49 +0200 Subject: [PATCH 63/71] Update README.md --- README.md | 104 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 60 insertions(+), 44 deletions(-) diff --git a/README.md b/README.md index f0be62c..3384b55 100644 --- a/README.md +++ b/README.md @@ -12,10 +12,15 @@ # What is it? -QuAcK is a small electronic structure program written in `Fortran 90` and developed at the Laboratoire de Chimie et Physique Quantiques [LCPQ](https://www.lcpq.ups-tlse.fr) (Toulouse, France). -QuAcK is usually used for prototyping purposes and the successful ideas are usually implemented more efficiently in [Quantum Package](https://quantumpackage.github.io/qp2/). QuAcK is an excellent place to start for experienced PhD students or postdocs as the code is simple and written with a fairly well-known and straightforward language. For beginners, we suggest having a look at [qcmath](https://github.com/LCPQ/qcmath/), a [Mathematica](https://www.wolfram.com/mathematica/)-based program to help newcomers in quantum chemistry easily develop their ideas. +**QuAcK** is a lightweight electronic structure program written in `Fortran 90`, developed at the [Laboratoire de Chimie et Physique Quantiques (LCPQ)](https://www.lcpq.ups-tlse.fr) in Toulouse, France. Originally designed as a platform for rapid prototyping of new ideas in quantum chemistry, QuAcK serves as a flexible and accessible environment for testing novel methods before integrating them more efficiently into larger-scale projects such as the [Quantum Package](https://quantumpackage.github.io/qp2/). -QuAcK is under continuous and active development, so it is very (very) likely to contain many bugs and errors. QuAcK is a code for experts, which means that you must know what you're doing and you have to make sure you're not doing anything silly (QuAcK may allow silly things to happen on purpose!). You have been warned. +Thanks to its compact and transparent codebase, QuAcK is particularly well-suited for experienced PhD students and postdoctoral researchers who are already familiar with electronic structure theory and want to quickly implement or explore new concepts. Written in a clean and relatively straightforward programming language, it provides an excellent entry point for those looking to dive into method development. + +For beginners in the field or those with less programming experience, we recommend starting with [qcmath](https://github.com/LCPQ/qcmath/), a symbolic and numerical quantum chemistry toolkit built in [Mathematica](https://www.wolfram.com/mathematica/). qcmath is specifically designed to help newcomers explore and develop ideas without the complexity of full-fledged numerical implementations. + +QuAcK is under active and ongoing development, which means that bugs, inconsistencies, and incomplete features are to be expected. It is a tool made *by* experts *for* experts—users are expected to understand what they’re doing and to remain cautious when interpreting results. The code may allow questionable inputs or behavior *on purpose*, to encourage flexibility during prototyping—so always double-check your results and assumptions. + +In short: use QuAcK at your own risk—but also to your advantage, if you're ready to experiment and explore. # Installation guide The QuAcK software can be downloaded on GitHub as a Git repository @@ -40,27 +45,30 @@ Therefore, it is very easy to use other software to compute the integrals or to ``` ~ 💩 % cd $QUACK_ROOT QuAcK 💩 % python PyDuck.py -h -usage: PyDuck.py [-h] -b BASIS [--bohr] [-c CHARGE] [--cartesian] [-fc FROZEN_CORE] [-m MULTIPLICITY] [--working_dir WORKING_DIR] -x XYZ +usage: PyDuck.py [-h] -b BASIS [--bohr] [-c CHARGE] [--cartesian] [--print_2e] [--formatted_2e] [--mmap_2e] [--aosym_2e] [-fc FROZEN_CORE] + [-m MULTIPLICITY] [--working_dir WORKING_DIR] -x XYZ This script is the main script of QuAcK, it is used to run the calculation. If $QUACK_ROOT is not set, $QUACK_ROOT is replaces by the current directory. options: -h, --help show this help message and exit - -b BASIS, --basis BASIS - Name of the file containing the basis set in the $QUACK_ROOT/basis/ directory + -b, --basis BASIS Name of the file containing the basis set information in the $QUACK_ROOT/basis/ directory --bohr By default QuAcK assumes that the xyz files are in Angstrom. Add this argument if your xyz file is in Bohr. - -c CHARGE, --charge CHARGE - Total charge of the molecule. Specify negative charges with "m" instead of the minus sign, for example m1 instead of -1. + -c, --charge CHARGE Total charge of the molecule. Specify negative charges with "m" instead of the minus sign, for example m1 instead of -1. Default is 0 --cartesian Add this option if you want to use cartesian basis functions. - -fc FROZEN_CORE, --frozen_core FROZEN_CORE - Freeze core MOs. Default is false - -m MULTIPLICITY, --multiplicity MULTIPLICITY - Number of unpaired electrons 2S. Default is 0 therefore singlet + --print_2e If True, print ERIs to disk. + --formatted_2e Add this option if you want to print formatted ERIs. + --mmap_2e If True, avoid using DRAM when generating ERIs. + --aosym_2e If True, use 8-fold symmetry in ERIs. + -fc, --frozen_core FROZEN_CORE + Freeze core orbitals. Default is false + -m, --multiplicity MULTIPLICITY + Spin multiplicity. Default is 1 (singlet) --working_dir WORKING_DIR Set a working directory to run the calculation. - -x XYZ, --xyz XYZ Name of the file containing the nuclear coordinates in xyz format in the $QUACK_ROOT/mol/ directory without the .xyz + -x, --xyz XYZ Name of the file containing the nuclear coordinates in xyz format in the $QUACK_ROOT/mol/ directory without the .xyz extension ``` @@ -77,47 +85,56 @@ You can then edit these files to run the methods you'd like with specific option These files look like this ``` QuAcK 💩 % cat input/methods -# RHF UHF RMOM UMOM KS - T F F F F -# MP2* MP3 +# RHF UHF GHF ROHF HFB + T F F F F +# MP2 MP3 F F # CCD pCCD DCD CCSD CCSD(T) F F F F F # drCCD rCCD crCCD lCCD F F F F -# CIS* CIS(D) CID CISD FCI - F F F F F -# phRPA* phRPAx* crRPA ppRPA - F F F F -# G0F2* evGF2* qsGF2* G0F3 evGF3 - F F F F F -# G0W0* evGW* qsGW* SRG-qsGW ufG0W0 ufGW - T F F F F F -# G0T0pp* evGTpp* qsGTpp* G0T0eh evGTeh qsGTeh - F F F F F F -# * unrestricted version available +# CIS CIS(D) CID CISD FCI + F F F F F +# phRPA phRPAx crRPA ppRPA + F F F F +# G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3 + F F F F F F +# G0W0 evGW qsGW ufG0W0 ufGW + F F F F F +# G0T0pp evGTpp qsGTpp ufG0T0pp + F F F F +# G0T0eh evGTeh qsGTeh + F F F +# Parquet + T +# Rtest Utest Gtest + F F F ``` and ``` QuAcK 💩 % cat input/options -# HF: maxSCF thresh DIIS n_diis guess_type ortho_type mix_guess level_shift stability - 512 0.0000001 T 5 1 1 F 0.0 F +# HF: maxSCF thresh DIIS guess mix shift stab search + 256 0.0000001 5 1 0.0 0.0 F F # MP: reg F -# CC: maxSCF thresh DIIS n_diis - 64 0.0000001 T 5 -# spin: TDA singlet triplet spin_conserved spin_flip - F T F T T -# GF: maxSCF thresh DIIS n_diis lin eta renorm reg - 256 0.00001 T 5 T 0.0 0 F -# GW: maxSCF thresh DIIS n_diis lin eta COHSEX TDA_W reg - 256 0.00001 T 5 T 0.0 F F F -# GT: maxSCF thresh DIIS n_diis lin eta TDA_T reg - 256 0.00001 T 5 T 0.1 F F +# CC: maxSCF thresh DIIS + 64 0.00001 5 +# LR: 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 T T -# BSE: BSE dBSE dTDA evDyn ppBSE BSE2 - T T T F F F + F F T +# BSE: phBSE phBSE2 ppBSE dBSE dTDA + F F F F T +# HFB: temperature sigma chem_pot_HF restart_HFB + 0.05 1.00 T F +# Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b DIIS_1b DIIS_2b lin reg + T T 20 0.0001 3 0.0001 10 1 T 500.0 ``` For example, if you want to run a calculation on water using the cc-pvdz basis set: @@ -125,8 +142,7 @@ For example, if you want to run a calculation on water using the cc-pvdz basis s QuAcK 💩 % python PyDuck.py -x water -b cc-pvdz ``` -QuAcK runs calculations in the `QUACK_ROOT` directory which is quite unusual but it can be easily modified to run calculations elsewhere. -You just have to make sure that QuAcK reads/writes the integrals and molecular information at the right spot. +QuAcK runs calculations in the `QUACK_ROOT` directory which is quite unusual but it also use the `--working_dir` option to run calculations elsewhere. From acf65597ecc1e998be2a09e50cc5c2dfa1d0aff3 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Mon, 14 Apr 2025 21:45:08 +0200 Subject: [PATCH 64/71] Update README.md --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 3384b55..e7d57d3 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,7 @@ - [Antoine Marie](https://antoine-marie.github.io) - [Abdallah Ammar](https://scholar.google.com/citations?user=y437T5sAAAAJ&hl=en) - [Mauricio Rodriguez-Mayorga](https://scholar.google.com/citations?user=OLGOgQgAAAAJ&hl=es) +- [Loris Burth](https://github.com/lburth) # What is it? @@ -76,7 +77,7 @@ The two most important files are: - `$QUACK_ROOT/input/methods` that gathers the methods you want to use. - `$QUACK_ROOT/input/options` that gathers the different options associated these methods. -Copy the files `methods.default` and `options.default` to `methods.default` `options.default` +Copy the files `methods.default` and `options.default` to `methods.default` and `options.default`, respectively. ``` cp $QUACK_ROOT/input/methods.default $QUACK_ROOT/input/methods cp $QUACK_ROOT/input/options.default $QUACK_ROOT/input/options From 500ad141f65e6a942908a8a5b1737e03d3fc2f20 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Mon, 14 Apr 2025 21:46:28 +0200 Subject: [PATCH 65/71] Update README.md --- README.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index e7d57d3..d1ee136 100644 --- a/README.md +++ b/README.md @@ -87,7 +87,7 @@ These files look like this ``` QuAcK 💩 % cat input/methods # RHF UHF GHF ROHF HFB - T F F F F + F F F F F # MP2 MP3 F F # CCD pCCD DCD CCSD CCSD(T) @@ -107,7 +107,7 @@ QuAcK 💩 % cat input/methods # G0T0eh evGTeh qsGTeh F F F # Parquet - T + F # Rtest Utest Gtest F F F ``` @@ -115,7 +115,7 @@ and ``` QuAcK 💩 % cat input/options # HF: maxSCF thresh DIIS guess mix shift stab search - 256 0.0000001 5 1 0.0 0.0 F F + 256 0.00001 5 1 0.0 0.0 F F # MP: reg F # CC: maxSCF thresh DIIS @@ -135,7 +135,7 @@ QuAcK 💩 % cat input/options # HFB: temperature sigma chem_pot_HF restart_HFB 0.05 1.00 T F # Parquet: TDAeh TDApp max_it_1b conv_1b max_it_2b conv_2b DIIS_1b DIIS_2b lin reg - T T 20 0.0001 3 0.0001 10 1 T 500.0 + T T 10 0.00001 10 0.00001 2 2 T 100.0 ``` For example, if you want to run a calculation on water using the cc-pvdz basis set: From a4c422fe39f66c52b8164b319a04289ee121a729 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Mon, 14 Apr 2025 21:48:20 +0200 Subject: [PATCH 66/71] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index d1ee136..16ffcdc 100644 --- a/README.md +++ b/README.md @@ -82,7 +82,7 @@ Copy the files `methods.default` and `options.default` to `methods.default` and cp $QUACK_ROOT/input/methods.default $QUACK_ROOT/input/methods cp $QUACK_ROOT/input/options.default $QUACK_ROOT/input/options ``` -You can then edit these files to run the methods you'd like with specific options. +You can then edit these files to run the methods you'd like (by replacing `F` with `T`) with specific options. These files look like this ``` QuAcK 💩 % cat input/methods From ccc32dace078280fb2ac3ac60b568120cca0eab0 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Mon, 14 Apr 2025 21:49:01 +0200 Subject: [PATCH 67/71] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 16ffcdc..5ed8fa7 100644 --- a/README.md +++ b/README.md @@ -77,7 +77,7 @@ The two most important files are: - `$QUACK_ROOT/input/methods` that gathers the methods you want to use. - `$QUACK_ROOT/input/options` that gathers the different options associated these methods. -Copy the files `methods.default` and `options.default` to `methods.default` and `options.default`, respectively. +Copy the files `methods.default` and `options.default` to `methods` and `options`, respectively. ``` cp $QUACK_ROOT/input/methods.default $QUACK_ROOT/input/methods cp $QUACK_ROOT/input/options.default $QUACK_ROOT/input/options From 1d316f0fd2c4c7c93b3c4afa16e416a4a65411bd Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Tue, 15 Apr 2025 15:55:24 +0200 Subject: [PATCH 68/71] ok with pp self-energy, eh self-energy still giving crazy results --- src/Parquet/GParquet.f90 | 4 +- src/Parquet/G_Parquet_self_energy.f90 | 212 ++++++------ src/Parquet/G_pp_Phi.f90 | 4 +- src/Parquet/RParquet.f90 | 4 +- src/Parquet/R_Parquet_self_energy.f90 | 462 +++++++++++++------------- src/Parquet/R_pp_singlet_Phi.f90 | 4 +- src/Parquet/R_pp_triplet_Phi.f90 | 4 +- 7 files changed, 348 insertions(+), 346 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 2f5e11b..5b551c0 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -8,8 +8,8 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Hard-coded parameters - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 6e3f80c..e795c46 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -89,129 +89,129 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! eh part of the self-energy ! !-----------------------------! - call wall_time(start_t) + ! call wall_time(start_t) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR + ! !$OMP PARALLEL DEFAULT(NONE) & + ! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + ! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + ! !$OMP DO COLLAPSE(2) + ! do p=nC+1,nOrb-nR - do i=nC+1,nO - do a=nO+1,nOrb-nR + ! do i=nC+1,nO + ! do a=nO+1,nOrb-nR - do n=1,nS - !3h2p - do j=nC+1,nO - num = ( - ERI(p,a,j,i) + ERI(p,a,i,j))* & - eh_rho(a,i,n) * eh_rho(j,p,n) + ! do n=1,nS + ! !3h2p + ! do j=nC+1,nO + ! num = ( - ERI(p,a,j,i) + 0d0*ERI(p,a,i,j) ) * & + ! eh_rho(a,i,n) * eh_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) - eQP(j) + eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (ERI(p,a,j,i) - ERI(p,a,i,j))* & - eh_rho(a,i,n) * eh_rho(j,p,n) + ! num = (ERI(p,a,j,i) - 0d0*ERI(p,a,i,j))* & + ! eh_rho(a,i,n) * eh_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,i,j,a) + ERI(p,i,a,j)) * & - eh_rho(j,p,n) * eh_rho(i,a,n) + ! num = (- ERI(p,i,j,a) + 0d0*ERI(p,i,a,j)) * & + ! eh_rho(j,p,n) * eh_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) - eQP(j) + eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,a,j,i) + ERI(p,a,i,j))* & - eh_rho(p,j,n) * eh_rho(i,a,n) + ! num = (- ERI(p,a,j,i) + 0d0*ERI(p,a,i,j))* & + ! eh_rho(p,j,n) * eh_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! j - !3p2h - do b=nO+1,nOrb-nR - num = (- ERI(p,a,b,i) + ERI(p,a,i,b)) * & - eh_rho(p,b,n) * eh_rho(i,a,n) + ! end do ! j + ! !3p2h + ! do b=nO+1,nOrb-nR + ! num = (- ERI(p,a,b,i) + 0d0*ERI(p,a,i,b)) * & + ! eh_rho(p,b,n) * eh_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) - eQP(b) - eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,i,b,a) + ERI(p,i,a,b)) * & - eh_rho(b,p,n) * eh_rho(i,a,n) + ! num = (- ERI(p,i,b,a) + 0d0*ERI(p,i,a,b)) * & + ! eh_rho(b,p,n) * eh_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,i,b,a) + ERI(p,i,a,b)) * & - eh_rho(p,b,n) * eh_rho(a,i,n) + ! num = (- ERI(p,i,b,a) + 0d0*ERI(p,i,a,b)) * & + ! eh_rho(p,b,n) * eh_rho(a,i,n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) - eQP(b) - eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (ERI(p,i,b,a) - ERI(p,i,a,b)) * & - eh_rho(p,b,n) * eh_rho(a,i,n) + ! num = (ERI(p,i,b,a) - 0d0*ERI(p,i,a,b)) * & + ! eh_rho(p,b,n) * eh_rho(a,i,n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! b + ! end do ! b - end do ! n + ! end do ! n - end do ! a - end do ! i + ! end do ! a + ! end do ! i - end do ! p - !$OMP END DO - !$OMP END PARALLEL + ! end do ! p + ! !$OMP END DO + ! !$OMP END PARALLEL - call wall_time(end_t) - t = end_t - start_t - - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' - write(*,*) + ! call wall_time(end_t) + ! t = end_t - start_t + ! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + ! write(*,*) + !-----------------------------! ! pp part of the self-energy ! !-----------------------------! @@ -229,7 +229,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do n=1,nVV ! 4h1p do k=nC+1,nO - num = 2d0 * ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) + num = - ERI(p,k,i,j) * ee_rho(i,j,n) * ee_rho(p,k,n) dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(k) - ee_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -242,7 +242,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3h2p do c=nO+1,nOrb-nR - num = 2d0 * ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) + num = - ERI(p,c,i,j) * ee_rho(i,j,n) * ee_rho(p,c,n) dem1 = ee_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -257,7 +257,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3h2p do c=nO+1,nOrb-nR - num = 2d0 * ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + num = - ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - hh_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -266,14 +266,14 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = 2d0 * ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) dem1 = hh_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -294,27 +294,27 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 4p1h do c=nO+1,nOrb-nR - num = 2d0 * ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) + num = ERI(p,c,a,b) * hh_rho(a,b,n) * hh_rho(p,c,n) dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(c) - hh_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c ! 3p2h do k=nC+1,nO - num = 2d0 * ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) + num = ERI(p,k,a,b) * hh_rho(a,b,n) * hh_rho(p,k,n) dem1 = hh_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k end do ! n @@ -322,16 +322,16 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! 3p2h do k=nC+1,nO - num = 2d0 * ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = 2d0 * ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + num = - ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) dem1 = ee_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) diff --git a/src/Parquet/G_pp_Phi.f90 b/src/Parquet/G_pp_Phi.f90 index 0818b8f..1fcb813 100644 --- a/src/Parquet/G_pp_Phi.f90 +++ b/src/Parquet/G_pp_Phi.f90 @@ -31,12 +31,12 @@ subroutine G_pp_Phi(nOrb,nC,nR,nOO,nVV,ee_Om,ee_rho,hh_Om,hh_rho,pp_Phi) do n=1,nVV pp_Phi(p,q,r,s) = pp_Phi(p,q,r,s) & - + 2d0 * ee_rho(p,q,n)*ee_rho(r,s,n)/ee_Om(n) + - ee_rho(p,q,n)*ee_rho(r,s,n)/ee_Om(n) end do do n=1,nOO pp_Phi(p,q,r,s) = pp_Phi(p,q,r,s) & - - 2d0 * hh_rho(p,q,n)*hh_rho(r,s,n)/hh_Om(n) + + hh_rho(p,q,n)*hh_rho(r,s,n)/hh_Om(n) end do enddo diff --git a/src/Parquet/RParquet.f90 b/src/Parquet/RParquet.f90 index 289a89e..d7742cb 100644 --- a/src/Parquet/RParquet.f90 +++ b/src/Parquet/RParquet.f90 @@ -8,8 +8,8 @@ subroutine RParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Hard-coded parameters - logical :: print_phLR = .false. - logical :: print_ppLR = .false. + logical :: print_phLR = .true. + logical :: print_ppLR = .true. ! Input variables diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index 45c35db..f68a033 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -89,249 +89,250 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP !-------------------------------------! ! singlet eh part of the self-energy ! !-------------------------------------! - call wall_time(start_t) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_sing_rho,eh_sing_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR + ! call wall_time(start_t) +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & +! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_sing_rho,eh_sing_Om,SigC,Z) +! !$OMP DO COLLAPSE(2) +! do p=nC+1,nOrb-nR - do i=nC+1,nO - do a=nO+1,nOrb-nR +! do i=nC+1,nO +! do a=nO+1,nOrb-nR - do n=1,nS - !3h2p - do j=nC+1,nO - num = ( - ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & - eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) +! do n=1,nS +! !3h2p +! do j=nC+1,nO +! num = ( - ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & +! eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) - dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) +! dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (ERI(p,a,j,i) - 0.5d0*ERI(p,a,i,j))* & - eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) +! num = (ERI(p,a,j,i) - 0.5d0*ERI(p,a,i,j))* & +! eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) +! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,i,j,a) + 0.5d0*ERI(p,i,a,j)) * & - eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) +! num = (- ERI(p,i,j,a) + 0.5d0*ERI(p,i,a,j)) * & +! eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) - dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) +! dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & - eh_sing_rho(p,j,n) * eh_sing_rho(i,a,n) +! num = (- ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & +! eh_sing_rho(p,j,n) * eh_sing_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) +! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! j - !3p2h - do b=nO+1,nOrb-nR - num = (- ERI(p,a,b,i) + 0.5d0*ERI(p,a,i,b)) * & - eh_sing_rho(p,b,n) * eh_sing_rho(i,a,n) +! end do ! j +! !3p2h +! do b=nO+1,nOrb-nR +! num = (- ERI(p,a,b,i) + 0.5d0*ERI(p,a,i,b)) * & +! eh_sing_rho(p,b,n) * eh_sing_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) - dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) +! dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & - eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) +! num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & +! eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) +! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & - eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) +! num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & +! eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) - dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) - dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) +! dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = (ERI(p,i,b,a) - 0.5d0*ERI(p,i,a,b)) * & - eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) +! num = (ERI(p,i,b,a) - 0.5d0*ERI(p,i,a,b)) * & +! eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) - dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) +! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! b +! end do ! b - end do ! n +! end do ! n - end do ! a - end do ! i +! end do ! a +! end do ! i - end do ! p - !$OMP END DO - !$OMP END PARALLEL - call wall_time(end_t) - t = end_t - start_t +! end do ! p +! !$OMP END DO +! !$OMP END PARALLEL +! call wall_time(end_t) +! t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh self-energy =',t,' seconds' - write(*,*) -!-------------------------------------! -! triplet eh part of the self-energy ! -!-------------------------------------! - call wall_time(start_t) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_trip_rho,eh_trip_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR +! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh self-energy =',t,' seconds' +! write(*,*) +! !-------------------------------------! +! ! triplet eh part of the self-energy ! +! !-------------------------------------! +! call wall_time(start_t) +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & +! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_trip_rho,eh_trip_Om,SigC,Z) +! !$OMP DO COLLAPSE(2) +! do p=nC+1,nOrb-nR - do i=nC+1,nO - do a=nO+1,nOrb-nR +! do i=nC+1,nO +! do a=nO+1,nOrb-nR - do n=1,nS - !3h2p - do j=nC+1,nO - num = ( + 1.5d0*ERI(p,a,i,j))* & - eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) +! do n=1,nS +! !3h2p +! do j=nC+1,nO +! num = ( + 1.5d0*ERI(p,a,i,j))* & +! eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) - dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) +! dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ( - 1.5d0*ERI(p,a,i,j))* & - eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) +! num = ( - 1.5d0*ERI(p,a,i,j))* & +! eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) +! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ( + 1.5d0*ERI(p,i,a,j)) * & - eh_trip_rho(j,p,n) * eh_trip_rho(i,a,n) +! num = ( + 1.5d0*ERI(p,i,a,j)) * & +! eh_trip_rho(j,p,n) * eh_trip_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) - dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) +! dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ( + 1.5d0*ERI(p,a,i,j))* & - eh_trip_rho(p,j,n) * eh_trip_rho(i,a,n) +! num = ( + 1.5d0*ERI(p,a,i,j))* & +! eh_trip_rho(p,j,n) * eh_trip_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) +! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! j - !3p2h - do b=nO+1,nOrb-nR - num = ( + 1.5d0*ERI(p,a,i,b)) * & - eh_trip_rho(p,b,n) * eh_trip_rho(i,a,n) +! end do ! j +! !3p2h +! do b=nO+1,nOrb-nR +! num = ( + 1.5d0*ERI(p,a,i,b)) * & +! eh_trip_rho(p,b,n) * eh_trip_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) - dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) +! dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ( + 1.5d0*ERI(p,i,a,b)) * & - eh_trip_rho(b,p,n) * eh_trip_rho(i,a,n) +! num = ( + 1.5d0*ERI(p,i,a,b)) * & +! eh_trip_rho(b,p,n) * eh_trip_rho(i,a,n) - dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) +! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ( + 1.5d0*ERI(p,i,a,b)) * & - eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) +! num = ( + 1.5d0*ERI(p,i,a,b)) * & +! eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) - dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) - dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) +! dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ( - 1.5d0*ERI(p,i,a,b)) * & - eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) +! num = ( - 1.5d0*ERI(p,i,a,b)) * & +! eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) - dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) +! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) +! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) +! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) +! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) +! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) +! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! b +! end do ! b - end do ! n +! end do ! n - end do ! a - end do ! i +! end do ! a +! end do ! i - end do ! p - !$OMP END DO - !$OMP END PARALLEL - call wall_time(end_t) - t = end_t - start_t +! end do ! p +! !$OMP END DO +! !$OMP END PARALLEL +! call wall_time(end_t) +! t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh self-energy =',t,' seconds' - write(*,*) +! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh self-energy =',t,' seconds' +! write(*,*) + !-------------------------------------! ! singlet pp part of the self-energy ! !-------------------------------------! @@ -347,7 +348,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP do n=1,nVVs ! 4h1p do k=nC+1,nO - num = ERI(p,k,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,k,n) + num = - 0.5d0 * ERI(p,k,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,k,n) dem1 = ee_sing_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(k) - ee_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -360,10 +361,10 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3h2p do c=nO+1,nOrb-nR - num = ERI(p,c,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,c,n) - !dem1 = ee_Om(n) - eQP(i) - eQP(j) + num = - 0.5d0*ERI(p,c,i,j) * ee_sing_rho(i,j,n) * ee_sing_rho(p,c,n) + dem1 = ee_sing_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -375,7 +376,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3h2p do c=nO+1,nOrb-nR - num = ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) + num = - 0.5d0*ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) dem1 = hh_sing_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - hh_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -384,14 +385,14 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) - !dem1 = hh_Om(n) - eQP(i) - eQP(j) + num = 0.5d0*ERI(p,c,i,j) * hh_sing_rho(i,j,n) * hh_sing_rho(p,c,n) + dem1 = hh_sing_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -412,27 +413,27 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 4p1h do c=nO+1,nOrb-nR - num = ERI(p,c,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,c,n) + num = 0.5d0*ERI(p,c,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,c,n) dem1 = hh_sing_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(c) - hh_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c ! 3p2h do k=nC+1,nO - num = ERI(p,k,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,k,n) - !dem1 = hh_Om(n) - eQP(a) - eQP(b) + num = 0.5d0*ERI(p,k,a,b) * hh_sing_rho(a,b,n) * hh_sing_rho(p,k,n) + dem1 = hh_sing_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k end do ! n @@ -440,19 +441,19 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3p2h do k=nC+1,nO - num = ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) + num = 0.5d0*ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) dem1 = ee_sing_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_sing_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) - !dem1 = ee_Om(n) - eQP(a) - eQP(b) + num = - 0.5d0*ERI(p,k,a,b) * ee_sing_rho(a,b,n) * ee_sing_rho(p,k,n) + dem1 = ee_sing_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -486,7 +487,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP do n=1,nVVt ! 4h1p do k=nC+1,nO - num = 3d0*ERI(p,k,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,k,n) + num = - 1.5d0 * ERI(p,k,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,k,n) dem1 = ee_trip_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(k) - ee_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -499,10 +500,10 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3h2p do c=nO+1,nOrb-nR - num = 3d0*ERI(p,c,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,c,n) - !dem1 = ee_Om(n) - eQP(i) - eQP(j) + num = - 1.5d0 * ERI(p,c,i,j) * ee_trip_rho(i,j,n) * ee_trip_rho(p,c,n) + dem1 = ee_trip_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -514,7 +515,7 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3h2p do c=nO+1,nOrb-nR - num = 3d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) + num = - 1.5d0 * ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) dem1 = hh_trip_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - hh_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) @@ -523,14 +524,14 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = 3d0*ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) - !dem1 = hh_Om(n) - eQP(i) - eQP(j) + num = 1.5d0 * ERI(p,c,i,j) * hh_trip_rho(i,j,n) * hh_trip_rho(p,c,n) + dem1 = hh_trip_Om(n) - eQP(i) - eQP(j) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -551,27 +552,27 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 4p1h do c=nO+1,nOrb-nR - num = 3d0*ERI(p,c,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,c,n) + num = 1.5d0 * ERI(p,c,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,c,n) dem1 = hh_trip_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(c) - hh_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c ! 3p2h do k=nC+1,nO - num = 3d0*ERI(p,k,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,k,n) - !dem1 = hh_Om(n) - eQP(a) - eQP(b) + num = 1.5d0 * ERI(p,k,a,b) * hh_trip_rho(a,b,n) * hh_trip_rho(p,k,n) + dem1 = hh_trip_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! k end do ! n @@ -579,19 +580,19 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP ! 3p2h do k=nC+1,nO - num = 3d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) + num = 1.5d0 * ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) dem1 = ee_trip_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_trip_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) - num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) + num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = 3d0*ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) - !dem1 = ee_Om(n) - eQP(a) - eQP(b) + num = - 1.5d0 * ERI(p,k,a,b) * ee_trip_rho(a,b,n) * ee_trip_rho(p,k,n) + dem1 = ee_trip_Om(n) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - !reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) @@ -608,7 +609,8 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP call wall_time(end_t) t = end_t - start_t write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet pp self-energy =',t,' seconds' - write(*,*) + write(*,*) + !-----------------------------! ! Renormalization factor ! !-----------------------------! diff --git a/src/Parquet/R_pp_singlet_Phi.f90 b/src/Parquet/R_pp_singlet_Phi.f90 index 73552a7..eaa275f 100644 --- a/src/Parquet/R_pp_singlet_Phi.f90 +++ b/src/Parquet/R_pp_singlet_Phi.f90 @@ -32,12 +32,12 @@ subroutine R_pp_singlet_Phi(nOrb,nC,nR,nOO,nVV,ee_sing_Om,ee_sing_rho,hh_sing_Om do n=1,nVV pp_sing_Phi(p,q,r,s) = pp_sing_Phi(p,q,r,s) & - + 2d0 * ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) + - ee_sing_rho(p,q,n)*ee_sing_rho(r,s,n)/ee_sing_Om(n) end do do n=1,nOO pp_sing_Phi(p,q,r,s) = pp_sing_Phi(p,q,r,s) & - - 2d0 * hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) + + hh_sing_rho(p,q,n)*hh_sing_rho(r,s,n)/hh_sing_Om(n) end do enddo diff --git a/src/Parquet/R_pp_triplet_Phi.f90 b/src/Parquet/R_pp_triplet_Phi.f90 index b7c204b..8d4990d 100644 --- a/src/Parquet/R_pp_triplet_Phi.f90 +++ b/src/Parquet/R_pp_triplet_Phi.f90 @@ -32,12 +32,12 @@ subroutine R_pp_triplet_Phi(nOrb,nC,nR,nOO,nVV,ee_trip_Om,ee_trip_rho,hh_trip_Om do n=1,nVV pp_trip_Phi(p,q,r,s) = pp_trip_Phi(p,q,r,s) & - + 2d0 * ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) + - ee_trip_rho(p,q,n)*ee_trip_rho(r,s,n)/ee_trip_Om(n) end do do n=1,nOO pp_trip_Phi(p,q,r,s) = pp_trip_Phi(p,q,r,s) & - - 2d0 * hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) + + hh_trip_rho(p,q,n)*hh_trip_rho(r,s,n)/hh_trip_Om(n) end do enddo From c3d222ee26cdc039f59bb21c93f7e03cd9fce372 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Thu, 17 Apr 2025 15:03:45 +0200 Subject: [PATCH 69/71] saving work in ghf --- src/Parquet/GParquet.f90 | 4 +- src/Parquet/G_Parquet_self_energy.f90 | 181 +++++++++++++------------- src/Parquet/G_eh_Phi.f90 | 4 +- src/Parquet/G_screened_integrals.f90 | 7 +- 4 files changed, 100 insertions(+), 96 deletions(-) diff --git a/src/Parquet/GParquet.f90 b/src/Parquet/GParquet.f90 index 5b551c0..c027119 100644 --- a/src/Parquet/GParquet.f90 +++ b/src/Parquet/GParquet.f90 @@ -131,7 +131,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! Memory allocation allocate(old_eh_Om(nS),old_ee_Om(nVV),old_hh_Om(nOO)) - allocate(eh_rho(nOrb,nOrb,nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) + allocate(eh_rho(nOrb,nOrb,nS+nS),ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) allocate(old_eh_Phi(nOrb,nOrb,nOrb,nOrb),old_pp_Phi(nOrb,nOrb,nOrb,nOrb)) mem = mem + size(old_eh_Om) + size(old_ee_Om) + size(old_hh_Om) @@ -333,7 +333,7 @@ subroutine GParquet(TDAeh,TDApp,max_diis_1b,max_diis_2b,linearize,eta,ENuc,max_i ! TODO Once we will compute the blocks of kernel starting from the 4-tensors we can move the freeing up ! Memory allocation - allocate(eh_rho(nOrb,nOrb,nS)) + allocate(eh_rho(nOrb,nOrb,nS+nS)) allocate(ee_rho(nOrb,nOrb,nVV),hh_rho(nOrb,nOrb,nOO)) mem = mem + size(eh_rho) + size(ee_rho) + size(hh_rho) diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index e795c46..d47e3ff 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -14,7 +14,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& integer,intent(in) :: nS, nOO, nVV double precision,intent(in) :: eQP(nOrb) double precision,intent(in) :: ERI(nOrb,nOrb,nOrb,nOrb) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS+nS) double precision,intent(in) :: eh_Om(nS) double precision,intent(in) :: ee_rho(nOrb,nOrb,nVV) double precision,intent(in) :: ee_Om(nVV) @@ -89,128 +89,127 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! eh part of the self-energy ! !-----------------------------! - ! call wall_time(start_t) + call wall_time(start_t) - ! !$OMP PARALLEL DEFAULT(NONE) & - ! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - ! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) - ! !$OMP DO COLLAPSE(2) - ! do p=nC+1,nOrb-nR + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR - ! do i=nC+1,nO - ! do a=nO+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR - ! do n=1,nS - ! !3h2p - ! do j=nC+1,nO - ! num = ( - ERI(p,a,j,i) + 0d0*ERI(p,a,i,j) ) * & - ! eh_rho(a,i,n) * eh_rho(j,p,n) + do n=1,nS + !3h2p + do j=nC+1,nO + num = - ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & + + ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) - eQP(j) + eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = (ERI(p,a,j,i) - 0d0*ERI(p,a,i,j))* & - ! eh_rho(a,i,n) * eh_rho(j,p,n) + num = + ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & + - ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) - ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = (- ERI(p,i,j,a) + 0d0*ERI(p,i,a,j)) * & - ! eh_rho(j,p,n) * eh_rho(i,a,n) + num = - ERI(p,i,j,a) * eh_rho(p,j,nS+n) * eh_rho(a,i,nS+n) & + + ERI(p,i,a,j) * eh_rho(i,a,n) * eh_rho(j,p,n) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) - eQP(j) + eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = (- ERI(p,a,j,i) + 0d0*ERI(p,a,i,j))* & - ! eh_rho(p,j,n) * eh_rho(i,a,n) + num = - ERI(p,a,j,i) * eh_rho(p,j,n) * eh_rho(i,a,n) & + + ERI(p,a,i,j) * eh_rho(a,i,nS+n) * eh_rho(j,p,nS+n) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! end do ! j - ! !3p2h - ! do b=nO+1,nOrb-nR - ! num = (- ERI(p,a,b,i) + 0d0*ERI(p,a,i,b)) * & - ! eh_rho(p,b,n) * eh_rho(i,a,n) + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = - ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & + + ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) - eQP(b) - eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = (- ERI(p,i,b,a) + 0d0*ERI(p,i,a,b)) * & - ! eh_rho(b,p,n) * eh_rho(i,a,n) + num = + ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & + - ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = (- ERI(p,i,b,a) + 0d0*ERI(p,i,a,b)) * & - ! eh_rho(p,b,n) * eh_rho(a,i,n) + num = - ERI(p,a,b,i) * eh_rho(p,b,n) * eh_rho(i,a,n) & + + ERI(p,a,i,b) * eh_rho(a,i,nS+n) * eh_rho(b,p,nS+n) - ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) - eQP(b) - eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = (ERI(p,i,b,a) - 0d0*ERI(p,i,a,b)) * & - ! eh_rho(p,b,n) * eh_rho(a,i,n) + num = - ERI(p,i,b,a) * eh_rho(p,b,nS+n) * eh_rho(a,i,nS+n) & + + ERI(p,i,a,b) * eh_rho(i,a,n) * eh_rho(b,p,n) - ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! end do ! b + end do ! b - ! end do ! n + end do ! n - ! end do ! a - ! end do ! i + end do ! a + end do ! i - ! end do ! p - ! !$OMP END DO - ! !$OMP END PARALLEL + end do ! p + !$OMP END DO + !$OMP END PARALLEL - ! call wall_time(end_t) - ! t = end_t - start_t + call wall_time(end_t) + t = end_t - start_t - ! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' - ! write(*,*) + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! pp part of the self-energy ! diff --git a/src/Parquet/G_eh_Phi.f90 b/src/Parquet/G_eh_Phi.f90 index bfa6cbe..d4b2709 100644 --- a/src/Parquet/G_eh_Phi.f90 +++ b/src/Parquet/G_eh_Phi.f90 @@ -6,7 +6,7 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) ! Input variables integer,intent(in) :: nOrb,nC,nR,nS double precision,intent(in) :: eh_Om(nS) - double precision,intent(in) :: eh_rho(nOrb,nOrb,nS) + double precision,intent(in) :: eh_rho(nOrb,nOrb,nS+nS) ! Local variables integer :: p,q,r,s @@ -30,7 +30,7 @@ subroutine G_eh_Phi(nOrb,nC,nR,nS,eh_Om,eh_rho,eh_Phi) do n=1,nS eh_Phi(p,q,r,s) = eh_Phi(p,q,r,s) & - eh_rho(r,p,n)*eh_rho(q,s,n)/eh_Om(n) & - - eh_rho(p,r,n)*eh_rho(s,q,n)/eh_Om(n) + - eh_rho(r,p,nS+n)*eh_rho(q,s,nS+n)/eh_Om(n) end do enddo diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 77fafc3..2e3d270 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -15,7 +15,7 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho double precision :: X,Y ! Output variables - double precision,intent(out) :: rho(nOrb,nOrb,nS) + double precision,intent(out) :: rho(nOrb,nOrb,nS+nS) rho(:,:,:) = 0d0 !$OMP PARALLEL DEFAULT(NONE) & @@ -41,6 +41,11 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho !+ (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & !- (eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y + rho(p,q,nS+ia) = rho(p,q,nS+ia) & + + (ERI(q,b,p,j) - ERI(q,b,j,p)) * X !& + !- (eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & + !+ (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + !- (eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y end do end do From 921902962b5f482e987dd8eadb217e2e66f87359 Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Mon, 21 Apr 2025 14:56:27 +0200 Subject: [PATCH 70/71] trying a sanity check --- src/GT/GG0T0pp.f90 | 2 +- src/GT/GGTpp_self_energy_diag.f90 | 101 ++++++- src/Parquet/G_Parquet_self_energy.f90 | 264 +++++++++++-------- src/Parquet/R_Parquet_self_energy.f90 | 362 +++++++++++++------------- 4 files changed, 434 insertions(+), 295 deletions(-) diff --git a/src/GT/GG0T0pp.f90 b/src/GT/GG0T0pp.f90 index 7be6092..2af71ca 100644 --- a/src/GT/GG0T0pp.f90 +++ b/src/GT/GG0T0pp.f90 @@ -128,7 +128,7 @@ subroutine GG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,T if(regularize) call GTpp_regularization(nOrb,nC,nO,nV,nR,nOO,nVV,eHF,Om1,rho1,Om2,rho2) - call GGTpp_self_energy_diag(eta,nOrb,nC,nO,nV,nR,nOO,nVV,eHF,Om1,rho1,Om2,rho2,EcGM,Sig,Z) + call GGTpp_self_energy_diag(eta,nOrb,nC,nO,nV,nR,nOO,nVV,eHF,Om1,rho1,Om2,rho2,EcGM,Sig,Z,ERI) !---------------------------------------------- ! Solve the quasi-particle equation diff --git a/src/GT/GGTpp_self_energy_diag.f90 b/src/GT/GGTpp_self_energy_diag.f90 index 1f34638..f319548 100644 --- a/src/GT/GGTpp_self_energy_diag.f90 +++ b/src/GT/GGTpp_self_energy_diag.f90 @@ -1,4 +1,4 @@ -subroutine GGTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOO,nVV,e,Om1,rho1,Om2,rho2,EcGM,Sig,Z) +subroutine GGTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOO,nVV,e,Om1,rho1,Om2,rho2,EcGM,Sig,Z,ERI) ! Compute diagonal of the correlation part of the T-matrix self-energy @@ -20,11 +20,12 @@ subroutine GGTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOO,nVV,e,Om1,rho1,Om2,rh double precision,intent(in) :: rho1(nBas,nBas,nVV) double precision,intent(in) :: Om2(nOO) double precision,intent(in) :: rho2(nBas,nBas,nOO) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables - integer :: i,j,a,b,p,cd,kl - double precision :: num,eps + integer :: i,j,k,a,b,c,p,m,cd,kl + double precision :: num,eps,dem1,dem2 ! Output variables @@ -72,6 +73,100 @@ subroutine GGTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOO,nVV,e,Om1,rho1,Om2,rh end do end do +!-----------------------------------------------! +! Testing another way to compute GT self-energy ! +!-----------------------------------------------! + + ! do p=nC+1,nBas-nR + ! do i=nC+1,nO + ! do j=nC+1,nO + ! do a=nO+1,nBas-nR + + ! eps = e(p) + e(a) - e(i) - e(j) + ! num = 0.5d0*(ERI(p,a,i,j) - ERI(p,a,j,i))**2 + + ! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) + ! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + ! end do + ! do a=nO+1,nBas-nR + + ! do m=1,nVV + ! num = - ERI(p,a,i,j) * rho1(p,a,m) * rho1(i,j,m) + ! dem1 = e(p) + e(a) - e(i) - e(j) + ! dem2 = Om1(m) - e(i) - e(j) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 + ! end do + + ! do m=1,nOO + ! num = - ERI(p,a,i,j) * rho2(p,a,m) * rho2(i,j,m) + ! dem1 = e(p) + e(a) - e(i) - e(j) + ! dem2 = e(p) + e(a) - Om2(m) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 + ! end do + + ! end do + ! do k=nC+1,nO + + ! do m=1,nVV + ! num = - ERI(p,i,j,k) * rho1(p,i,m) * rho1(j,k,m) + ! dem1 = e(p) + e(i) - Om1(m) + ! dem2 = Om1(m) - e(j) - e(k) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 + ! end do + + ! end do + ! end do + ! end do + ! end do + ! do p=nC+1,nBas-nR + ! do a=nO+1,nBas-nR + ! do b=nO+1,nBas-nR + ! do i=nC+1,nO + + ! eps = e(p) + e(i) - e(a) - e(b) + ! num = 0.5d0*(ERI(p,i,a,b) - ERI(p,i,b,a))**2 + + ! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) + ! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + ! end do + ! do i=nC+1,nO + + ! do m=1,nVV + ! num = ERI(p,i,a,b) * rho1(p,i,m) * rho1(a,b,m) + ! dem1 = e(p) + e(i) - e(a) - e(b) + ! dem2 = e(p) + e(i) - Om1(m) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 + ! end do + + ! do m=1,nOO + ! num = ERI(p,i,a,b) * rho2(p,i,m) * rho2(a,b,m) + ! dem1 = e(p) + e(i) - e(a) - e(b) + ! dem2 = Om2(m) - e(a) - e(b) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 + ! end do + + ! end do + ! do c=nO+1,nBas-nR + ! do m=1,nOO + ! num = ERI(p,a,b,c) * rho2(p,a,m) * rho2(b,c,m) + ! dem1 = e(p) + e(a) - Om2(m) + ! dem2 = Om2(m) - e(b) - e(c) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 + ! end do + + ! end do + ! end do + ! end do + ! end do + !-------------------------------------! ! Galitskii-Migdal correlation energy ! !-------------------------------------! diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index d47e3ff..7ab19b5 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -89,127 +89,151 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! eh part of the self-energy ! !-----------------------------! - call wall_time(start_t) + ! call wall_time(start_t) - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) - !$OMP DO COLLAPSE(2) - do p=nC+1,nOrb-nR + ! !$OMP PARALLEL DEFAULT(NONE) & + ! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + ! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + ! !$OMP DO COLLAPSE(2) + ! do p=nC+1,nOrb-nR - do i=nC+1,nO - do a=nO+1,nOrb-nR + ! do i=nC+1,nO + ! do a=nO+1,nOrb-nR - do n=1,nS - !3h2p - do j=nC+1,nO - num = - ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & - + ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! do n=1,nS + ! !3h2p + ! do j=nC+1,nO - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! num = - ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & + ! + ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) + ! dem1 = eQP(p) - eQP(j) + eh_Om(n) + ! dem2 = eQP(p) - eQP(j) + eQP(a) - eQP(i) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & + ! - num * (reg1/dem1/dem1) * (reg2/dem2) - num = + ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & - - ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) + ! ! num = - 0d0*ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & + ! ! + ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) + ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! ! dem2 = eQP(p) - eQP(j) + eh_Om(n) + ! ! reg1 = (1d0 - 0d0*exp(- 2d0 * eta * dem1 * dem1)) + ! ! reg2 = (1d0 - 0d0*exp(- 2d0 * eta * dem2 * dem2)) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = - ERI(p,i,j,a) * eh_rho(p,j,nS+n) * eh_rho(a,i,nS+n) & - + ERI(p,i,a,j) * eh_rho(i,a,n) * eh_rho(j,p,n) + ! ! num = + ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & + ! ! - ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(j) + eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + ! ! reg1 = (1d0 - 0d0*exp(- 2d0 * eta * dem1 * dem1)) + ! ! reg2 = (1d0 - 0d0*exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + ! num = - ERI(p,i,j,a) * eh_rho(p,j,nS+n) * eh_rho(a,i,nS+n) & + ! + ERI(p,i,a,j) * eh_rho(i,a,n) * eh_rho(j,p,n) + + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) - eQP(j) + eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = - ERI(p,a,j,i) * eh_rho(p,j,n) * eh_rho(i,a,n) & - + ERI(p,a,i,j) * eh_rho(a,i,nS+n) * eh_rho(j,p,nS+n) + ! num = - ERI(p,a,j,i) * eh_rho(p,j,n) * eh_rho(i,a,n) & + ! + ERI(p,a,i,j) * eh_rho(a,i,nS+n) * eh_rho(j,p,nS+n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! j - !3p2h - do b=nO+1,nOrb-nR - num = - ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & - + ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) + ! end do ! j + ! !3p2h + ! do b=nO+1,nOrb-nR + ! num = - ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & + ! + ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(p) - eQP(b) - eh_Om(n) + ! dem2 = eQP(p) - eQP(b) - eQP(a) + eQP(i) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & + ! - num * (reg1/dem1/dem1) * (reg2/dem2) - num = + ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & - - ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) + ! ! num = - ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & + ! ! + ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - dem1 = eQP(a) - eQP(i) - eh_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! ! dem2 = eQP(p) - eQP(b) - eh_Om(n) + ! ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = - ERI(p,a,b,i) * eh_rho(p,b,n) * eh_rho(i,a,n) & - + ERI(p,a,i,b) * eh_rho(a,i,nS+n) * eh_rho(b,p,nS+n) + ! ! num = + ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & + ! ! - ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) - eQP(b) - eh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) + ! ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + ! ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - num = - ERI(p,i,b,a) * eh_rho(p,b,nS+n) * eh_rho(a,i,nS+n) & - + ERI(p,i,a,b) * eh_rho(i,a,n) * eh_rho(b,p,n) + ! num = - ERI(p,a,b,i) * eh_rho(p,b,n) * eh_rho(i,a,n) & + ! + ERI(p,a,i,b) * eh_rho(a,i,nS+n) * eh_rho(b,p,nS+n) - dem1 = eQP(a) - eQP(i) + eh_Om(n) - dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) - eQP(b) - eh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! b + ! num = - ERI(p,i,b,a) * eh_rho(p,b,nS+n) * eh_rho(a,i,nS+n) & + ! + ERI(p,i,a,b) * eh_rho(i,a,n) * eh_rho(b,p,n) + + ! dem1 = eQP(a) - eQP(i) + eh_Om(n) + ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + ! end do ! b - end do ! n + ! end do ! n - end do ! a - end do ! i + ! end do ! a + ! end do ! i - end do ! p - !$OMP END DO - !$OMP END PARALLEL + ! end do ! p + ! !$OMP END DO + ! !$OMP END PARALLEL - call wall_time(end_t) - t = end_t - start_t + ! call wall_time(end_t) + ! t = end_t - start_t - write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' - write(*,*) + ! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + ! write(*,*) !-----------------------------! ! pp part of the self-energy ! @@ -257,22 +281,32 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do c=nO+1,nOrb-nR num = - ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - dem1 = hh_Om(n) - eQP(i) - eQP(j) - dem2 = eQP(p) + eQP(c) - hh_Om(n) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - dem1 = hh_Om(n) - eQP(i) - eQP(j) + dem1 = eQP(p) + eQP(c) - hh_Om(n) dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & + - num * (reg1/dem1/dem1) * (reg2/dem2) + + ! num = - ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + ! dem1 = hh_Om(n) - eQP(i) - eQP(j) + ! dem2 = eQP(p) + eQP(c) - hh_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + + ! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) + ! dem1 = hh_Om(n) - eQP(i) - eQP(j) + ! dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n @@ -322,22 +356,32 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& do k=nC+1,nO num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - dem1 = ee_Om(n) - eQP(a) - eQP(b) + dem1 = eQP(p) + eQP(k) - eQP(a) - eQP(b) dem2 = eQP(p) + eQP(k) - ee_Om(n) reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & + - num * (reg1/dem1/dem1) * (reg2/dem2) + + ! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + ! dem1 = ee_Om(n) - eQP(a) - eQP(b) + ! dem2 = eQP(p) + eQP(k) - ee_Om(n) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - num = - ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - dem1 = ee_Om(n) - eQP(a) - eQP(b) - dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + ! num = - ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) + ! dem1 = ee_Om(n) - eQP(a) - eQP(b) + ! dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) + ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) end do ! c end do ! n diff --git a/src/Parquet/R_Parquet_self_energy.f90 b/src/Parquet/R_Parquet_self_energy.f90 index f68a033..948771c 100644 --- a/src/Parquet/R_Parquet_self_energy.f90 +++ b/src/Parquet/R_Parquet_self_energy.f90 @@ -89,249 +89,249 @@ subroutine R_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,eQP !-------------------------------------! ! singlet eh part of the self-energy ! !-------------------------------------! - ! call wall_time(start_t) -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & -! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_sing_rho,eh_sing_Om,SigC,Z) -! !$OMP DO COLLAPSE(2) -! do p=nC+1,nOrb-nR + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_sing_rho,eh_sing_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR -! do i=nC+1,nO -! do a=nO+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR -! do n=1,nS -! !3h2p -! do j=nC+1,nO -! num = ( - ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & -! eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) + do n=1,nS + !3h2p + do j=nC+1,nO + num = ( - ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & + eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) -! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) -! dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = (ERI(p,a,j,i) - 0.5d0*ERI(p,a,i,j))* & -! eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) + num = (ERI(p,a,j,i) - 0.5d0*ERI(p,a,i,j))* & + eh_sing_rho(a,i,n) * eh_sing_rho(j,p,n) -! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) -! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = (- ERI(p,i,j,a) + 0.5d0*ERI(p,i,a,j)) * & -! eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) + num = (- ERI(p,i,j,a) + 0.5d0*ERI(p,i,a,j)) * & + eh_sing_rho(j,p,n) * eh_sing_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) -! dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + dem2 = eQP(p) - eQP(j) + eh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = (- ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & -! eh_sing_rho(p,j,n) * eh_sing_rho(i,a,n) + num = (- ERI(p,a,j,i) + 0.5d0*ERI(p,a,i,j))* & + eh_sing_rho(p,j,n) * eh_sing_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) -! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! j -! !3p2h -! do b=nO+1,nOrb-nR -! num = (- ERI(p,a,b,i) + 0.5d0*ERI(p,a,i,b)) * & -! eh_sing_rho(p,b,n) * eh_sing_rho(i,a,n) + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = (- ERI(p,a,b,i) + 0.5d0*ERI(p,a,i,b)) * & + eh_sing_rho(p,b,n) * eh_sing_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) -! dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & -! eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) + num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & + eh_sing_rho(b,p,n) * eh_sing_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) -! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_sing_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & -! eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) + num = (- ERI(p,i,b,a) + 0.5d0*ERI(p,i,a,b)) * & + eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) -! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) -! dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + dem2 = eQP(p) - eQP(b) - eh_sing_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = (ERI(p,i,b,a) - 0.5d0*ERI(p,i,a,b)) * & -! eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) + num = (ERI(p,i,b,a) - 0.5d0*ERI(p,i,a,b)) * & + eh_sing_rho(p,b,n) * eh_sing_rho(a,i,n) -! dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) -! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_sing_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! b + end do ! b -! end do ! n + end do ! n -! end do ! a -! end do ! i + end do ! a + end do ! i -! end do ! p -! !$OMP END DO -! !$OMP END PARALLEL -! call wall_time(end_t) -! t = end_t - start_t + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t -! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh self-energy =',t,' seconds' -! write(*,*) -! !-------------------------------------! -! ! triplet eh part of the self-energy ! -! !-------------------------------------! -! call wall_time(start_t) -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & -! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_trip_rho,eh_trip_Om,SigC,Z) -! !$OMP DO COLLAPSE(2) -! do p=nC+1,nOrb-nR + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for singlet eh self-energy =',t,' seconds' + write(*,*) +!-------------------------------------! +! triplet eh part of the self-energy ! +!-------------------------------------! + call wall_time(start_t) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_trip_rho,eh_trip_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR -! do i=nC+1,nO -! do a=nO+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR -! do n=1,nS -! !3h2p -! do j=nC+1,nO -! num = ( + 1.5d0*ERI(p,a,i,j))* & -! eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) + do n=1,nS + !3h2p + do j=nC+1,nO + num = ( + 1.5d0*ERI(p,a,i,j))* & + eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) -! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) -! dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ( - 1.5d0*ERI(p,a,i,j))* & -! eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) + num = ( - 1.5d0*ERI(p,a,i,j))* & + eh_trip_rho(a,i,n) * eh_trip_rho(j,p,n) -! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) -! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ( + 1.5d0*ERI(p,i,a,j)) * & -! eh_trip_rho(j,p,n) * eh_trip_rho(i,a,n) + num = ( + 1.5d0*ERI(p,i,a,j)) * & + eh_trip_rho(j,p,n) * eh_trip_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) -! dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + dem2 = eQP(p) - eQP(j) + eh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ( + 1.5d0*ERI(p,a,i,j))* & -! eh_trip_rho(p,j,n) * eh_trip_rho(i,a,n) + num = ( + 1.5d0*ERI(p,a,i,j))* & + eh_trip_rho(p,j,n) * eh_trip_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) -! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! j -! !3p2h -! do b=nO+1,nOrb-nR -! num = ( + 1.5d0*ERI(p,a,i,b)) * & -! eh_trip_rho(p,b,n) * eh_trip_rho(i,a,n) + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = ( + 1.5d0*ERI(p,a,i,b)) * & + eh_trip_rho(p,b,n) * eh_trip_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) -! dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ( + 1.5d0*ERI(p,i,a,b)) * & -! eh_trip_rho(b,p,n) * eh_trip_rho(i,a,n) + num = ( + 1.5d0*ERI(p,i,a,b)) * & + eh_trip_rho(b,p,n) * eh_trip_rho(i,a,n) -! dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) -! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_trip_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ( + 1.5d0*ERI(p,i,a,b)) * & -! eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) + num = ( + 1.5d0*ERI(p,i,a,b)) * & + eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) -! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) -! dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + dem2 = eQP(p) - eQP(b) - eh_trip_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! num = ( - 1.5d0*ERI(p,i,a,b)) * & -! eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) + num = ( - 1.5d0*ERI(p,i,a,b)) * & + eh_trip_rho(p,b,n) * eh_trip_rho(a,i,n) -! dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) -! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) -! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) -! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) - eh_trip_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) -! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) -! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) -! end do ! b + end do ! b -! end do ! n + end do ! n -! end do ! a -! end do ! i + end do ! a + end do ! i -! end do ! p -! !$OMP END DO -! !$OMP END PARALLEL -! call wall_time(end_t) -! t = end_t - start_t + end do ! p + !$OMP END DO + !$OMP END PARALLEL + call wall_time(end_t) + t = end_t - start_t -! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh self-energy =',t,' seconds' -! write(*,*) + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for triplet eh self-energy =',t,' seconds' + write(*,*) !-------------------------------------! ! singlet pp part of the self-energy ! From 09051226deba9789b12dfef62a4a769442742efa Mon Sep 17 00:00:00 2001 From: Antoine MARIE Date: Wed, 23 Apr 2025 14:19:29 +0200 Subject: [PATCH 71/71] GW alternatif --- src/GT/GGTpp_self_energy_diag.f90 | 194 ++++++++++----------- src/GW/GG0W0.f90 | 2 +- src/GW/GGW_self_energy_diag.f90 | 129 +++++++++++--- src/Parquet/G_Parquet_self_energy.f90 | 239 +++++++++----------------- src/Parquet/G_screened_integrals.f90 | 8 +- 5 files changed, 289 insertions(+), 283 deletions(-) diff --git a/src/GT/GGTpp_self_energy_diag.f90 b/src/GT/GGTpp_self_energy_diag.f90 index f319548..961c915 100644 --- a/src/GT/GGTpp_self_energy_diag.f90 +++ b/src/GT/GGTpp_self_energy_diag.f90 @@ -43,129 +43,129 @@ subroutine GGTpp_self_energy_diag(eta,nBas,nC,nO,nV,nR,nOO,nVV,e,Om1,rho1,Om2,rh ! Occupied part of the Tpp self-energy ! !--------------------------------------! - do p=nC+1,nBas-nR - do i=nC+1,nO +! do p=nC+1,nBas-nR +! do i=nC+1,nO - do cd=1,nVV - eps = e(p) + e(i) - Om1(cd) - num = rho1(p,i,cd)**2 - Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - end do +! do cd=1,nVV +! eps = e(p) + e(i) - Om1(cd) +! num = rho1(p,i,cd)**2 +! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) +! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 +! end do - end do - end do +! end do +! end do -!------------------------------------------! -! Virtual part of the T-matrix self-energy ! -!------------------------------------------! +! !------------------------------------------! +! ! Virtual part of the T-matrix self-energy ! +! !------------------------------------------! - do p=nC+1,nBas-nR - do a=nO+1,nBas-nR +! do p=nC+1,nBas-nR +! do a=nO+1,nBas-nR - do kl=1,nOO - eps = e(p) + e(a) - Om2(kl) - num = rho2(p,a,kl)**2 - Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - end do +! do kl=1,nOO +! eps = e(p) + e(a) - Om2(kl) +! num = rho2(p,a,kl)**2 +! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) +! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 +! end do - end do - end do +! end do +! end do !-----------------------------------------------! ! Testing another way to compute GT self-energy ! !-----------------------------------------------! - ! do p=nC+1,nBas-nR - ! do i=nC+1,nO - ! do j=nC+1,nO - ! do a=nO+1,nBas-nR + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR - ! eps = e(p) + e(a) - e(i) - e(j) - ! num = 0.5d0*(ERI(p,a,i,j) - ERI(p,a,j,i))**2 + eps = e(p) + e(a) - e(i) - e(j) + num = 0.5d0*(ERI(p,a,i,j) - ERI(p,a,j,i))**2 - ! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - ! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) + Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - ! end do - ! do a=nO+1,nBas-nR + end do + do a=nO+1,nBas-nR - ! do m=1,nVV - ! num = - ERI(p,a,i,j) * rho1(p,a,m) * rho1(i,j,m) - ! dem1 = e(p) + e(a) - e(i) - e(j) - ! dem2 = Om1(m) - e(i) - e(j) - ! Sig(p) = Sig(p) + num/dem1/dem2 - ! Z(p) = Z(p) - num/dem1/dem1/dem2 - ! end do + do m=1,nVV + num = - ERI(p,a,i,j) * rho1(p,a,m) * rho1(i,j,m) + dem1 = e(p) + e(a) - e(i) - e(j) + dem2 = Om1(m) - e(i) - e(j) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 + end do - ! do m=1,nOO - ! num = - ERI(p,a,i,j) * rho2(p,a,m) * rho2(i,j,m) - ! dem1 = e(p) + e(a) - e(i) - e(j) - ! dem2 = e(p) + e(a) - Om2(m) - ! Sig(p) = Sig(p) + num/dem1/dem2 - ! Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 - ! end do + do m=1,nOO + num = - ERI(p,a,i,j) * rho2(p,a,m) * rho2(i,j,m) + dem1 = e(p) + e(a) - e(i) - e(j) + dem2 = e(p) + e(a) - Om2(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 + end do - ! end do - ! do k=nC+1,nO + end do + ! do k=nC+1,nO - ! do m=1,nVV - ! num = - ERI(p,i,j,k) * rho1(p,i,m) * rho1(j,k,m) - ! dem1 = e(p) + e(i) - Om1(m) - ! dem2 = Om1(m) - e(j) - e(k) - ! Sig(p) = Sig(p) + num/dem1/dem2 - ! Z(p) = Z(p) - num/dem1/dem1/dem2 - ! end do + ! do m=1,nVV + ! num = - ERI(p,i,j,k) * rho1(p,i,m) * rho1(j,k,m) + ! dem1 = e(p) + e(i) - Om1(m) + ! dem2 = Om1(m) - e(j) - e(k) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 + ! end do - ! end do - ! end do - ! end do - ! end do - ! do p=nC+1,nBas-nR - ! do a=nO+1,nBas-nR - ! do b=nO+1,nBas-nR - ! do i=nC+1,nO + ! end do + end do + end do + end do + do p=nC+1,nBas-nR + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do i=nC+1,nO - ! eps = e(p) + e(i) - e(a) - e(b) - ! num = 0.5d0*(ERI(p,i,a,b) - ERI(p,i,b,a))**2 + eps = e(p) + e(i) - e(a) - e(b) + num = 0.5d0*(ERI(p,i,a,b) - ERI(p,i,b,a))**2 - ! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - ! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) + Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - ! end do - ! do i=nC+1,nO + end do + do i=nC+1,nO - ! do m=1,nVV - ! num = ERI(p,i,a,b) * rho1(p,i,m) * rho1(a,b,m) - ! dem1 = e(p) + e(i) - e(a) - e(b) - ! dem2 = e(p) + e(i) - Om1(m) - ! Sig(p) = Sig(p) + num/dem1/dem2 - ! Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 - ! end do + do m=1,nVV + num = ERI(p,i,a,b) * rho1(p,i,m) * rho1(a,b,m) + dem1 = e(p) + e(i) - e(a) - e(b) + dem2 = e(p) + e(i) - Om1(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 + end do - ! do m=1,nOO - ! num = ERI(p,i,a,b) * rho2(p,i,m) * rho2(a,b,m) - ! dem1 = e(p) + e(i) - e(a) - e(b) - ! dem2 = Om2(m) - e(a) - e(b) - ! Sig(p) = Sig(p) + num/dem1/dem2 - ! Z(p) = Z(p) - num/dem1/dem1/dem2 - ! end do + do m=1,nOO + num = ERI(p,i,a,b) * rho2(p,i,m) * rho2(a,b,m) + dem1 = e(p) + e(i) - e(a) - e(b) + dem2 = Om2(m) - e(a) - e(b) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 + end do - ! end do - ! do c=nO+1,nBas-nR - ! do m=1,nOO - ! num = ERI(p,a,b,c) * rho2(p,a,m) * rho2(b,c,m) - ! dem1 = e(p) + e(a) - Om2(m) - ! dem2 = Om2(m) - e(b) - e(c) - ! Sig(p) = Sig(p) + num/dem1/dem2 - ! Z(p) = Z(p) - num/dem1/dem1/dem2 - ! end do + end do + ! do c=nO+1,nBas-nR + ! do m=1,nOO + ! num = ERI(p,a,b,c) * rho2(p,a,m) * rho2(b,c,m) + ! dem1 = e(p) + e(a) - Om2(m) + ! dem2 = Om2(m) - e(b) - e(c) + ! Sig(p) = Sig(p) + num/dem1/dem2 + ! Z(p) = Z(p) - num/dem1/dem1/dem2 + ! end do - ! end do - ! end do - ! end do - ! end do + ! end do + end do + end do + end do !-------------------------------------! ! Galitskii-Migdal correlation energy ! diff --git a/src/GW/GG0W0.f90 b/src/GW/GG0W0.f90 index a58989c..72163d6 100644 --- a/src/GW/GG0W0.f90 +++ b/src/GW/GG0W0.f90 @@ -119,7 +119,7 @@ subroutine GG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA if(doSRG) then call GGW_SRG_self_energy_diag(flow,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,EcGM,SigC,Z) else - call GGW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,EcGM,SigC,Z) + call GGW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,Om,rho,EcGM,SigC,Z,ERI) end if !-----------------------------------! diff --git a/src/GW/GGW_self_energy_diag.f90 b/src/GW/GGW_self_energy_diag.f90 index 2a02837..0f1bd30 100644 --- a/src/GW/GGW_self_energy_diag.f90 +++ b/src/GW/GGW_self_energy_diag.f90 @@ -1,4 +1,4 @@ -subroutine GGW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rho,EcGM,Sig,Z) +subroutine GGW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rho,EcGM,Sig,Z,ERI) ! Compute diagonal of the correlation part of the self-energy and the renormalization factor @@ -17,11 +17,12 @@ subroutine GGW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rho,EcGM,Sig,Z) double precision,intent(in) :: e(nBas) double precision,intent(in) :: Om(nS) double precision,intent(in) :: rho(nBas,nBas,nS) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables - integer :: i,a,p,m - double precision :: num,eps + integer :: i,j,a,b,p,m + double precision :: num,eps,dem1,dem2 ! Output variables @@ -38,36 +39,118 @@ subroutine GGW_self_energy_diag(eta,nBas,nC,nO,nV,nR,nS,e,Om,rho,EcGM,Sig,Z) ! GW self-energy ! !----------------! -! Occupied part of the correlation self-energy +! ! Occupied part of the correlation self-energy + +! do p=nC+1,nBas-nR +! do i=nC+1,nO +! do m=1,nS + +! eps = e(p) - e(i) + Om(m) +! num = rho(p,i,m)**2 +! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) +! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + +! end do +! end do +! end do + +! ! Virtual part of the correlation self-energy + +! do p=nC+1,nBas-nR +! do a=nO+1,nBas-nR +! do m=1,nS + +! eps = e(p) - e(a) - Om(m) +! num = rho(p,a,m)**2 +! Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) +! Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + +! end do +! end do +! end do + +!-----------------------------------------------! +! Testing another way to compute GT self-energy ! +!-----------------------------------------------! do p=nC+1,nBas-nR - do i=nC+1,nO - do m=1,nS + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR - eps = e(p) - e(i) + Om(m) - num = rho(p,i,m)**2 - Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + eps = e(p) + e(a) - e(i) - e(j) + num = ERI(p,a,i,j)**2 - end do - end do + Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) + Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + end do + do a=nO+1,nBas-nR + + do m=1,nS + num = - ERI(p,i,j,a) * rho(i,a,m) * rho(j,p,m) + dem1 = e(p) + e(a) - e(i) - e(j) + dem2 = e(p) - e(j) + Om(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 + + num = - ERI(p,i,j,a) * rho(i,a,m) * rho(j,p,m) + dem1 = e(p) + e(a) - e(i) - e(j) + dem2 = e(a) - e(i) + Om(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 + + num = - ERI(p,a,j,i) * rho(a,i,m) * rho(j,p,m) + dem1 = e(p) - e(j) + Om(m) + dem2 = e(a) - e(i) + Om(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 + end do + + end do + end do + end do end do - -! Virtual part of the correlation self-energy - do p=nC+1,nBas-nR - do a=nO+1,nBas-nR - do m=1,nS + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + do i=nC+1,nO + + eps = e(p) + e(i) - e(a) - e(b) + num = ERI(p,i,a,b)**2 + + Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) + Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + end do + do i=nC+1,nO + + do m=1,nS + num = ERI(p,a,b,i) * rho(a,i,m) * rho(b,p,m) + dem1 = e(p) + e(i) - e(a) - e(b) + dem2 = e(p) - e(b) - Om(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 - num/dem1/dem2/dem2 - eps = e(p) - e(a) - Om(m) - num = rho(p,a,m)**2 - Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + num = - ERI(p,a,b,i) * rho(a,i,m) * rho(b,p,m) + dem1 = e(p) + e(i) - e(a) - e(b) + dem2 = e(a) - e(i) + Om(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 + + num = - ERI(p,i,b,a) * rho(i,a,m) * rho(b,p,m) + dem1 = e(p) - e(b) - Om(m) + dem2 = e(a) - e(i) + Om(m) + Sig(p) = Sig(p) + num/dem1/dem2 + Z(p) = Z(p) - num/dem1/dem1/dem2 + end do - end do - end do + end do + end do + end do end do + ! Galitskii-Migdal correlation energy EcGM = 0d0 diff --git a/src/Parquet/G_Parquet_self_energy.f90 b/src/Parquet/G_Parquet_self_energy.f90 index 7ab19b5..d163a42 100644 --- a/src/Parquet/G_Parquet_self_energy.f90 +++ b/src/Parquet/G_Parquet_self_energy.f90 @@ -55,6 +55,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& eps = eQP(p) + eQP(a) - eQP(i) - eQP(j) reg = (1d0 - exp(- 2d0 * eta * eps * eps)) num = 0.5d0*(ERI(p,a,j,i) - ERI(p,a,i,j))**2 + ! num = ERI(p,a,j,i)**2 SigC(p) = SigC(p) + num*reg/eps Z(p) = Z(p) - num*reg/eps**2 @@ -70,6 +71,7 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& eps = eQP(p) + eQP(i) - eQP(a) - eQP(b) reg = (1d0 - exp(- 2d0 * eta * eps * eps)) num = 0.5d0*(ERI(p,i,b,a) - ERI(p,i,a,b))**2 + ! num = ERI(p,i,b,a)**2 SigC(p) = SigC(p) + num*reg/eps Z(p) = Z(p) - num*reg/eps**2 @@ -89,151 +91,108 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& ! eh part of the self-energy ! !-----------------------------! - ! call wall_time(start_t) + call wall_time(start_t) - ! !$OMP PARALLEL DEFAULT(NONE) & - ! !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & - ! !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) - ! !$OMP DO COLLAPSE(2) - ! do p=nC+1,nOrb-nR + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(p,i,a,j,b,n,num,dem1,dem2,reg1,reg2) & + !$OMP SHARED(nC,nO,nOrb,nR,nS,eta,ERI,eQP,eh_rho,eh_Om,SigC,Z) + !$OMP DO COLLAPSE(2) + do p=nC+1,nOrb-nR - ! do i=nC+1,nO - ! do a=nO+1,nOrb-nR + do i=nC+1,nO + do a=nO+1,nOrb-nR - ! do n=1,nS - ! !3h2p - ! do j=nC+1,nO + do n=1,nS + !3h2p + do j=nC+1,nO - ! num = - ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & - ! + ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) - ! dem1 = eQP(p) - eQP(j) + eh_Om(n) - ! dem2 = eQP(p) - eQP(j) + eQP(a) - eQP(i) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + num = - (ERI(p,a,j,i) - ERI(p,a,i,j)) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) !& + !+ ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) + dem1 = eQP(p) - eQP(j) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eQP(a) - eQP(i) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & - ! - num * (reg1/dem1/dem1) * (reg2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & + - num * (reg1/dem1/dem1) * (reg2/dem2) - ! ! num = - 0d0*ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & - ! ! + ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) - ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! ! dem2 = eQP(p) - eQP(j) + eh_Om(n) - ! ! reg1 = (1d0 - 0d0*exp(- 2d0 * eta * dem1 * dem1)) - ! ! reg2 = (1d0 - 0d0*exp(- 2d0 * eta * dem2 * dem2)) + num = - (ERI(p,i,j,a) - ERI(p,i,a,j)) * eh_rho(p,j,nS+n) * eh_rho(a,i,nS+n) !& + !+ ERI(p,i,a,j) * eh_rho(i,a,n) * eh_rho(j,p,n) - ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! ! num = + ERI(p,a,j,i) * eh_rho(p,j,nS+n) * eh_rho(i,a,nS+n) & - ! ! - ERI(p,a,i,j) * eh_rho(a,i,n) * eh_rho(j,p,n) - - ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - ! ! reg1 = (1d0 - 0d0*exp(- 2d0 * eta * dem1 * dem1)) - ! ! reg2 = (1d0 - 0d0*exp(- 2d0 * eta * dem2 * dem2)) - - ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! num = - ERI(p,i,j,a) * eh_rho(p,j,nS+n) * eh_rho(a,i,nS+n) & - ! + ERI(p,i,a,j) * eh_rho(i,a,n) * eh_rho(j,p,n) - - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) - eQP(j) + eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(j) + eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! num = - ERI(p,a,j,i) * eh_rho(p,j,n) * eh_rho(i,a,n) & - ! + ERI(p,a,i,j) * eh_rho(a,i,nS+n) * eh_rho(j,p,nS+n) + num = - (ERI(p,a,j,i) - ERI(p,a,i,j)) * eh_rho(p,j,n) * eh_rho(i,a,n) !& + !+ ERI(p,a,i,j) * eh_rho(a,i,nS+n) * eh_rho(j,p,nS+n) - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(a) - eQP(i) - eQP(j) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! end do ! j - ! !3p2h - ! do b=nO+1,nOrb-nR - ! num = - ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & - ! + ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) + end do ! j + !3p2h + do b=nO+1,nOrb-nR + num = (ERI(p,i,b,a) - ERI(p,i,a,b)) * eh_rho(p,b,n) * eh_rho(a,i,n) !& + !- ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - ! dem1 = eQP(p) - eQP(b) - eh_Om(n) - ! dem2 = eQP(p) - eQP(b) - eQP(a) + eQP(i) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(p) - eQP(b) - eh_Om(n) + dem2 = eQP(p) - eQP(b) - eQP(a) + eQP(i) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & - ! - num * (reg1/dem1/dem1) * (reg2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & + - num * (reg1/dem1/dem1) * (reg2/dem2) + + num = - (ERI(p,a,b,i) - ERI(p,a,i,b)) * eh_rho(p,b,n) * eh_rho(i,a,n) !& + !+ ERI(p,a,i,b) * eh_rho(a,i,nS+n) * eh_rho(b,p,nS+n) + + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) - eQP(b) - eh_Om(n) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! ! num = - ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & - ! ! + ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) + num = - (ERI(p,i,b,a) - ERI(p,i,a,b)) * eh_rho(p,b,nS+n) * eh_rho(a,i,nS+n) !& + !+ ERI(p,i,a,b) * eh_rho(i,a,n) * eh_rho(b,p,n) - ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! ! dem2 = eQP(p) - eQP(b) - eh_Om(n) - ! ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) + dem1 = eQP(a) - eQP(i) + eh_Om(n) + dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) + reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) + reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) + SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) + Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - ! ! num = + ERI(p,i,b,a) * eh_rho(p,b,n) * eh_rho(a,i,n) & - ! ! - ERI(p,i,a,b) * eh_rho(i,a,nS+n) * eh_rho(b,p,nS+n) - - ! ! dem1 = eQP(a) - eQP(i) - eh_Om(n) - ! ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - ! ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! num = - ERI(p,a,b,i) * eh_rho(p,b,n) * eh_rho(i,a,n) & - ! + ERI(p,a,i,b) * eh_rho(a,i,nS+n) * eh_rho(b,p,nS+n) - - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) - eQP(b) - eh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! num = - ERI(p,i,b,a) * eh_rho(p,b,nS+n) * eh_rho(a,i,nS+n) & - ! + ERI(p,i,a,b) * eh_rho(i,a,n) * eh_rho(b,p,n) - - ! dem1 = eQP(a) - eQP(i) + eh_Om(n) - ! dem2 = eQP(p) + eQP(i) - eQP(a) - eQP(b) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! end do ! b + end do ! b - ! end do ! n + end do ! n - ! end do ! a - ! end do ! i + end do ! a + end do ! i - ! end do ! p - ! !$OMP END DO - ! !$OMP END PARALLEL + end do ! p + !$OMP END DO + !$OMP END PARALLEL - ! call wall_time(end_t) - ! t = end_t - start_t + call wall_time(end_t) + t = end_t - start_t - ! write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' - ! write(*,*) + write(*,'(1X,A50,1X,F9.3,A8)') 'Wall time for building eh self-energy =',t,' seconds' + write(*,*) !-----------------------------! ! pp part of the self-energy ! @@ -290,24 +249,6 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & - num * (reg1/dem1/dem1) * (reg2/dem2) - ! num = - ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - ! dem1 = hh_Om(n) - eQP(i) - eQP(j) - ! dem2 = eQP(p) + eQP(c) - hh_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! num = ERI(p,c,i,j) * hh_rho(i,j,n) * hh_rho(p,c,n) - ! dem1 = hh_Om(n) - eQP(i) - eQP(j) - ! dem2 = eQP(p) + eQP(c) - eQP(i) - eQP(j) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! c end do ! n end do ! j @@ -365,24 +306,6 @@ subroutine G_Parquet_self_energy(eta,nOrb,nC,nO,nV,nR,nS,nOO,nVV,eQP,ERI,& Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) & - num * (reg1/dem1/dem1) * (reg2/dem2) - ! num = ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - ! dem1 = ee_Om(n) - eQP(a) - eQP(b) - ! dem2 = eQP(p) + eQP(k) - ee_Om(n) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - - ! num = - ERI(p,k,a,b) * ee_rho(a,b,n) * ee_rho(p,k,n) - ! dem1 = ee_Om(n) - eQP(a) - eQP(b) - ! dem2 = eQP(p) + eQP(k) - eQP(a) - eQP(b) - ! reg1 = (1d0 - exp(- 2d0 * eta * dem1 * dem1)) - ! reg2 = (1d0 - exp(- 2d0 * eta * dem2 * dem2)) - - ! SigC(p) = SigC(p) + num * (reg1/dem1) * (reg2/dem2) - ! Z(p) = Z(p) - num * (reg1/dem1) * (reg2/dem2/dem2) - end do ! c end do ! n end do ! b diff --git a/src/Parquet/G_screened_integrals.f90 b/src/Parquet/G_screened_integrals.f90 index 2e3d270..efeb6e8 100644 --- a/src/Parquet/G_screened_integrals.f90 +++ b/src/Parquet/G_screened_integrals.f90 @@ -36,15 +36,15 @@ subroutine G_eh_screened_integral(nOrb,nC,nO,nR,nS,ERI,eh_Phi,pp_Phi,XpY,XmY,rho Y = 0.5d0*(XpY(ia,jb) - XmY(ia,jb)) rho(p,q,ia) = rho(p,q,ia) & - + (ERI(q,j,p,b) - ERI(q,j,b,p)) * X !& + + (ERI(q,j,p,b) - ERI(q,j,b,p)) * X & !- (eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & - !+ (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + + (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y !& !- (eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y rho(p,q,nS+ia) = rho(p,q,nS+ia) & - + (ERI(q,b,p,j) - ERI(q,b,j,p)) * X !& + + (ERI(q,j,p,b) - ERI(q,b,j,p)) * X & !- (eh_Phi(q,j,b,p) + pp_Phi(q,j,p,b)) * X & - !+ (ERI(q,b,p,j) - ERI(q,b,j,p)) * Y & + + (ERI(q,b,p,j) - ERI(q,j,b,p)) * Y !& !- (eh_Phi(q,b,j,p) + pp_Phi(q,b,p,j)) * Y end do