From e5c2d5ee65bb6d716caf744402b5a1bce6ef1974 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 3 Apr 2015 13:34:27 +0200 Subject: [PATCH 01/70] add michel routine --- ocaml/Input.ml | 2 +- .../{convert_ezfio.sh => upgrade_1.0_2.0.sh} | 0 src/NEEDED_MODULES | 2 +- src/Pseudo/ASSUMPTIONS.rst | 0 src/Pseudo/Makefile | 6 + src/Pseudo/NEEDED_MODULES | 0 src/Pseudo/README.rst | 4 + src/Pseudo/int.f90 | 2022 +++++++++++++++++ 8 files changed, 2034 insertions(+), 2 deletions(-) rename scripts/ezfio_interface/{convert_ezfio.sh => upgrade_1.0_2.0.sh} (100%) create mode 100644 src/Pseudo/ASSUMPTIONS.rst create mode 100644 src/Pseudo/Makefile create mode 100644 src/Pseudo/NEEDED_MODULES create mode 100644 src/Pseudo/README.rst create mode 100644 src/Pseudo/int.f90 diff --git a/ocaml/Input.ml b/ocaml/Input.ml index 01bb54a0..fe155f80 100644 --- a/ocaml/Input.ml +++ b/ocaml/Input.ml @@ -8,4 +8,4 @@ include Input_determinants;; include Input_electrons;; include Input_mo_basis;; include Input_nuclei;; -include Input_auto_generated;; \ No newline at end of file +include Input_auto_generated;; diff --git a/scripts/ezfio_interface/convert_ezfio.sh b/scripts/ezfio_interface/upgrade_1.0_2.0.sh similarity index 100% rename from scripts/ezfio_interface/convert_ezfio.sh rename to scripts/ezfio_interface/upgrade_1.0_2.0.sh diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index a144c42c..35aa5ec3 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Dets Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD_selected DDCI_selected MRCC +AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Dets Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD_selected DDCI_selected MRCC Pseudo diff --git a/src/Pseudo/ASSUMPTIONS.rst b/src/Pseudo/ASSUMPTIONS.rst new file mode 100644 index 00000000..e69de29b diff --git a/src/Pseudo/Makefile b/src/Pseudo/Makefile new file mode 100644 index 00000000..5cf11b78 --- /dev/null +++ b/src/Pseudo/Makefile @@ -0,0 +1,6 @@ +# Define here all new external source files and objects.Don't forget to prefix the +# object files with IRPF90_temp/ +SRC=int.f90 +OBJ=IRPF90_temp/int.o + +include $(QPACKAGE_ROOT)/src/Makefile.common diff --git a/src/Pseudo/NEEDED_MODULES b/src/Pseudo/NEEDED_MODULES new file mode 100644 index 00000000..e69de29b diff --git a/src/Pseudo/README.rst b/src/Pseudo/README.rst new file mode 100644 index 00000000..ebb762c1 --- /dev/null +++ b/src/Pseudo/README.rst @@ -0,0 +1,4 @@ +======= + Module +======= + diff --git a/src/Pseudo/int.f90 b/src/Pseudo/int.f90 new file mode 100644 index 00000000..16aca8e0 --- /dev/null +++ b/src/Pseudo/int.f90 @@ -0,0 +1,2022 @@ +!! +!! Computation of Vps, matrix element of the +!! pseudo-potential centered at point C +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Vps= < Phi_A | Vloc(C) + Vpp(C) | Phi_B> +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Phi_M (M=A,B) Cartesian gaussian orbital centered at point M : +!! Phi_M = (x-M_x)**n^M_x *(y-M_y)**n^M_y *(z-M_z)**n^M_z exp(-g_M rM**2) +!! with rM**2=(x-M_x)**2 + (y-M_y)**2 + (z-M_z)**2 +!! +!!** Vloc(C)= \sum_{k=1}^klocmax v_k rC**n_k exp(-dz_k rC**2) +!! +!!** Vpp(C)= \sum_{l=0}^lmax v_l(rC) \sum_{m=-l}^{m=l} |Y_lm> : +!! function Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) +!! lmax of formula above +!! kmax of formula above +!! v_kl = array v_kl(kmax_max,0:lmax_max) +!! n_kl = array n_kl(kmax_max,0:lmax_max) +!! dz_kl = array dz_kl(kmax_max,0:lmax_max) +!! n_a(1),n_a(2),n_a(3) +!! a(1),a(2),a(3) +!! g_a +!! n_b(1),n_b(2),n_b(3) +!! b(1),b(2),b(3) +!! g_b +!! c(1),c(2),c(3) +!! +!! Routine computing : +!! function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) +!! klocmax of formula above +!! v_k = array v_k(klocmax_max) +!! n_k = array n_k(klocmax_max) +!! dz_k= array dz_k(klocmax_max) +!! Routine total matrix element : +!! function Vps(a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) +!! +!! Routines Vps_num, Vpseudo_num, and Vloc_num = brute force numerical +!! estimations of the same integrals + + +!! Vps= +!! +!! with: Vloc(C)=\sum_{k=1}^klocmax v_k rC**n_k exp(-dz_k rC**2) +!! Vpp(C)=\sum_{l=0}^lmax\sum_{k=1}^kmax v_kl rC**n_kl exp(-dz_kl rC**2)*|l> 0 factor* P_l^|m|(cos(theta)) cos (|m| phi) +! m = 0 1/sqrt(2) *factor* P_l^0(cos(theta)) +! m < 0 factor* P_l^|m|(cos(theta)) sin (|m| phi) +! +! x=cos(theta) + + double precision function ylm_real(l,m,x,phi) + implicit double precision (a-h,o-z) + DIMENSION PM(0:100,0:100) + MM=100 + pi=dacos(-1.d0) + iabs_m=iabs(m) + if(iabs_m.gt.l)stop 'm must be between -l and l' + factor= dsqrt( ((2*l+1)*fact(l-iabs_m))/(4.d0*pi*fact(l+iabs_m)) ) + if(dabs(x).gt.1.d0)then + print*,'pb. in ylm_no' + print*,'x=',x + stop + endif + call LPMN(MM,l,l,X,PM) + plm=PM(iabs_m,l) + coef=factor*plm + if(m.gt.0)ylm_real=dsqrt(2.d0)*coef*dcos(iabs_m*phi) + if(m.eq.0)ylm_real=coef + if(m.lt.0)ylm_real=dsqrt(2.d0)*coef*dsin(iabs_m*phi) + + fourpi=4.d0*dacos(-1.d0) + if(l.eq.0)ylm_real=dsqrt(1.d0/fourpi) + + xchap=dsqrt(1.d0-x**2)*dcos(phi) + ychap=dsqrt(1.d0-x**2)*dsin(phi) + zchap=x + if(l.eq.1.and.m.eq.1)ylm_real=dsqrt(3.d0/fourpi)*xchap + if(l.eq.1.and.m.eq.0)ylm_real=dsqrt(3.d0/fourpi)*zchap + if(l.eq.1.and.m.eq.-1)ylm_real=dsqrt(3.d0/fourpi)*ychap + + if(l.eq.2.and.m.eq.2)ylm_real=dsqrt(15.d0/16.d0/pi)*(xchap**2-ychap**2) + if(l.eq.2.and.m.eq.1)ylm_real=dsqrt(15.d0/fourpi)*xchap*zchap + if(l.eq.2.and.m.eq.0)ylm_real=dsqrt(5.d0/16.d0/pi)*(-xchap**2-ychap**2+2.d0*zchap**2) + if(l.eq.2.and.m.eq.-1)ylm_real=dsqrt(15.d0/fourpi)*ychap*zchap + if(l.eq.2.and.m.eq.-2)ylm_real=dsqrt(15.d0/fourpi)*xchap*ychap + + if(l.gt.2)stop 'l > 2 not coded!' + + end + +!! Routine Vpseudo is based on formumla (66) +!! of Kahn Baybutt TRuhlar J.Chem.Phys. vol.65 3826 (1976): +!! +!! Vpseudo= (4pi)**2* \sum_{l=0}^lmax \sum_{m=-l}^{l} +!! \sum{lambda=0}^{l+nA} \sum_{mu=-lambda}^{lambda} +!! \sum{k1=0}^{nAx} \sum{k2=0}^{nAy} \sum{k3=0}^{nAz} +!! binom(nAx,k1)*binom(nAy,k2)*binom(nAz,k3)* Y_{lambda mu}(AC_unit) +!! *CAx**(nAx-k1)*CAy**(nAy-k2)*CAz**(nAz-k3)* +!! bigI(lambda,mu,l,m,k1,k2,k3) +!! \sum{lambdap=0}^{l+nB} \sum_{mup=-lambdap}^{lambdap} +!! \sum{k1p=0}^{nBx} \sum{k2p=0}^{nBy} \sum{k3p=0}^{nBz} +!! binom(nBx,k1p)*binom(nBy,k2p)*binom(nBz,k3p)* Y_{lambdap mup}(BC_unit) +!! *CBx**(nBx-k1p)*CBy**(nBy-k2p)*CBz**(nBz-k3p)* +!! bigI(lambdap,mup,l,m,k1p,k2p,k3p)* +!! \sum_{k=1}^{kmax} v_kl(k,l)* +!! bigR(lambda,lambdap,k1+k2+k3+k1p+k2p+k3p+n_kl(k,l),g_a,g_b,AC,BC,dz_kl(k,l)) +!! +!! nA=nAx+nAy+nAz +!! nB=nBx+nBy+nBz +!! AC=|A-C| +!! AC_x= A_x-C_x, etc. +!! BC=|B-C| +!! AC_unit= vect(AC)/AC +!! BC_unit= vect(BC)/BC +!! bigI(lambda,mu,l,m,k1,k2,k3)= +!! \int dOmega Y_{lambda mu}(Omega) xchap^k1 ychap^k2 zchap^k3 Y_{l m}(Omega) +!! +!! bigR(lambda,lambdap,N,g_a,g_b,gamm_k,AC,BC) +!! = exp(-g_a* AC**2 -g_b* BC**2) * int_prod_bessel_loc(ktot+2,g_a+g_b+dz_k(k),l,dreal) +!! /int dx x^{ktot} exp(-g_k)*x**2) M_lambda(2 g_k D x) + +double precision function Vpseudo & +(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) +implicit none +integer kmax_max,lmax_max,ntot_max,nkl_max +parameter (kmax_max=2,lmax_max=2,nkl_max=4) +parameter (ntot_max=10) +integer lmax,kmax,n_kl(kmax_max,0:lmax_max),l,k +double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) +double precision a(3),g_a,b(3),g_b,c(3) +double precision fourpi,f,prod,prodp,binom,accu,bigR,bigI,ylm +double precision theta_AC0,phi_AC0,theta_BC0,phi_BC0,ac,bc,big +double precision areal,freal,breal,t1,t2,int_prod_bessel +integer ntot,ntotA,m,mu,mup,k1,k2,k3,ntotB,k1p,k2p,k3p,lambda,lambdap,ktot +integer n_a(3),n_b(3) +double precision array_R(0:ntot_max+nkl_max,kmax_max,0:lmax_max,0:lmax_max+ntot_max,0:lmax_max+ntot_max) +double precision & +array_I_A(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max) +double precision & +array_I_B(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max) + +double precision array_coefs_A(0:ntot_max,0:ntot_max,0:ntot_max) +double precision array_coefs_B(0:ntot_max,0:ntot_max,0:ntot_max) +double precision arg + +fourpi=4.d0*dacos(-1.d0) +ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) +bc=dsqrt((b(1)-c(1))**2+(b(2)-c(2))**2+(b(3)-c(3))**2) +arg=g_a*ac**2+g_b*bc**2 +if(arg.gt.-dlog(10.d-20))then +Vpseudo=0.d0 +return +endif +freal=dexp(-arg) + +areal=2.d0*g_a*ac +breal=2.d0*g_b*bc +ntotA=n_a(1)+n_a(2)+n_a(3) +ntotB=n_b(1)+n_b(2)+n_b(3) +ntot=ntotA+ntotB + +if(ntot.gt.ntot_max)stop 'increase ntot_max' + +if(ac.eq.0.d0.and.bc.eq.0.d0)then + + accu=0.d0 + do k=1,kmax + do l=0,lmax + ktot=ntot+n_kl(k,l) + do m=-l,l + prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) + prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) + accu=accu+prod*prodp*v_kl(k,l)*freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal) + enddo + enddo + enddo + Vpseudo=accu*fourpi + return +endif + +if(ac.ne.0.d0.and.bc.ne.0.d0)then + + f=fourpi**2 + + theta_AC0=dacos( (a(3)-c(3))/ac ) + phi_AC0=datan2((a(2)-c(2))/ac,(a(1)-c(1))/ac) + theta_BC0=dacos( (b(3)-c(3))/bc ) + phi_BC0=datan2((b(2)-c(2))/bc,(b(1)-c(1))/bc) + + do ktot=0,ntotA+ntotB+nkl_max + do lambda=0,lmax+ntotA + do lambdap=0,lmax+ntotB + do k=1,kmax + do l=0,lmax + array_R(ktot,k,l,lambda,lambdap)= & + freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal) + enddo + enddo + enddo + enddo + enddo + + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + array_coefs_A(k1,k2,k3)=binom(n_a(1),k1)*binom(n_a(2),k2)*binom(n_a(3),k3) & + *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) + enddo + enddo + enddo + + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_coefs_B(k1p,k2p,k3p)=binom(n_b(1),k1p)*binom(n_b(2),k2p)*binom(n_b(3),k3p) & + *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) + enddo + enddo + enddo + + accu=0.d0 + do l=0,lmax + do m=-l,l + + do lambda=0,l+ntotA + do mu=-lambda,lambda + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + enddo + enddo + enddo + enddo + enddo + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) + enddo + enddo + enddo + enddo + enddo + + do lambda=0,l+ntotA + do mu=-lambda,lambda + + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + + prod=ylm(lambda,mu,theta_AC0,phi_AC0)*array_coefs_A(k1,k2,k3)*array_I_A(lambda,mu,k1,k2,k3) + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + + prodp=ylm(lambdap,mup,theta_BC0,phi_BC0)*array_coefs_B(k1p,k2p,k3p)*array_I_B(lambdap,mup,k1p,k2p,k3p) + + do k=1,kmax + ktot=k1+k2+k3+k1p+k2p+k3p+n_kl(k,l) + accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,lambdap) + enddo + + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + Vpseudo=f*accu + return +endif + +if(ac.eq.0.d0.and.bc.ne.0.d0)then + + f=fourpi**1.5d0 + theta_BC0=dacos( (b(3)-c(3))/bc ) + phi_BC0=datan2((b(2)-c(2))/bc,(b(1)-c(1))/bc) + + areal=2.d0*g_a*ac + breal=2.d0*g_b*bc + freal=dexp(-g_a*ac**2-g_b*bc**2) + do ktot=0,ntotA+ntotB+nkl_max + do lambdap=0,lmax+ntotB + do k=1,kmax + do l=0,lmax + array_R(ktot,k,l,0,lambdap)= & + freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal) + enddo + enddo + enddo + enddo + + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_coefs_B(k1p,k2p,k3p)=binom(n_b(1),k1p)*binom(n_b(2),k2p)*binom(n_b(3),k3p) & + *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) + enddo + enddo + enddo + + accu=0.d0 + do l=0,lmax + do m=-l,l + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) + enddo + enddo + enddo + enddo + enddo + + prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + + prodp=array_coefs_B(k1p,k2p,k3p)*ylm(lambdap,mup,theta_BC0,phi_BC0)*array_I_B(lambdap,mup,k1p,k2p,k3p) + + do k=1,kmax + ktot=ntotA+k1p+k2p+k3p+n_kl(k,l) + accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,0,lambdap) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + Vpseudo=f*accu + return +endif + +if(ac.ne.0.d0.and.bc.eq.0.d0)then + + f=fourpi**1.5d0 + theta_AC0=dacos( (a(3)-c(3))/ac ) + phi_AC0=datan2((a(2)-c(2))/ac,(a(1)-c(1))/ac) + + areal=2.d0*g_a*ac + breal=2.d0*g_b*bc + freal=dexp(-g_a*ac**2-g_b*bc**2) + do ktot=0,ntotA+ntotB+nkl_max + do lambda=0,lmax+ntotA + do k=1,kmax + do l=0,lmax + array_R(ktot,k,l,lambda,0)= & + freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal) + enddo + enddo + enddo + enddo + + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + array_coefs_A(k1,k2,k3)=binom(n_a(1),k1)*binom(n_a(2),k2)*binom(n_a(3),k3) & + *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) + enddo + enddo + enddo + + accu=0.d0 + do l=0,lmax + do m=-l,l + + do lambda=0,l+ntotA + do mu=-lambda,lambda + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + enddo + enddo + enddo + enddo + enddo + + do lambda=0,l+ntotA + do mu=-lambda,lambda + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + prod=array_coefs_A(k1,k2,k3)*ylm(lambda,mu,theta_AC0,phi_AC0)*array_I_A(lambda,mu,k1,k2,k3) + prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) + do k=1,kmax + ktot=k1+k2+k3+ntotB+n_kl(k,l) + accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,0) + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + Vpseudo=f*accu + return +endif +end + +double precision function Vpseudo_num(npts,rmax,lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) +implicit none +integer kmax_max,lmax_max +parameter (kmax_max=2,lmax_max=2) +integer lmax,kmax, n_kl(kmax_max,0:lmax_max),l,m,k,kk +double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) +double precision a(3),g_a,b(3),g_b,c(3),ac(3),bc(3) +integer n_a(3),n_b(3),npts +double precision rmax,dr,sum,rC +double precision overlap_orb_ylm_brute + +do l=1,3 + ac(l)=a(l)-c(l) + bc(l)=b(l)-c(l) +enddo +dr=rmax/npts +sum=0.d0 +do l=0,lmax + do m=-l,l + do k=1,npts + rC=(k-1)*dr+dr/2.d0 + do kk=1,kmax + sum=sum+dr*v_kl(kk,l)*rC**(n_kl(kk,l)+2)*dexp(-dz_kl(kk,l)*rC**2) & + *overlap_orb_ylm_brute(npts,rC,n_a,ac,g_a,l,m) & + *overlap_orb_ylm_brute(npts,rC,n_b,bc,g_b,l,m) + enddo + enddo + enddo +enddo +Vpseudo_num=sum +return +end +!! Routine Vloc is a variation of formumla (66) +!! of Kahn Baybutt TRuhlar J.Chem.Phys. vol.65 3826 (1976) +!! without the projection operator +!! +!! Vloc= (4pi)**3/2* \sum_{k=1}^{klocmax} \sum_{l=0}^lmax \sum_{m=-l}^{l} +!!\sum{k1=0}^{nAx} \sum{k2=0}^{nAy} \sum{k3=0}^{nAz} +!! binom(nAx,k1)*binom(nAy,k2)*binom(nAz,k3) +!! *CAx**(nAx-k1)*CAy**(nAy-k2)*CAz**(nAz-k3)* +!! \sum{k1p=0}^{nBx} \sum{k2p=0}^{nBy} \sum{k3p=0}^{nBz} +!! binom(nBx,k1p)*binom(nBy,k2p)*binom(nBz,k3p) +!! *CBx**(nBx-k1p)*CBy**(nBy-k2p)*CBz**(nBz-k3p)* +!!\sum_{l=0}^lmax \sum_{m=-l}^{l} + +!! bigI(0,0,l,m,k1+k1p,k2+k2p,k3+k3p)*Y_{l m}(D_unit) +!! *v_k(k)* bigR(lambda,k1+k2+k3+k1p+k2p+k3p+n_k(k),g_a,g_b,AC,BC,dz_k(k)) +!! +!! nA=nAx+nAy+nAz +!! nB=nBx+nBy+nBz +!! D=(g_a AC+g_b BC) +!! D_unit= vect(D)/D +!! AC_x= A_x-C_x, etc. +!! BC=|B-C| +!! AC_unit= vect(AC)/AC +!! BC_unit= vect(BC)/BCA +!! +!! bigR(lambda,g_a,g_b,g_k,AC,BC) +!! = exp(-g_a* AC**2 -g_b* BC**2)* +!! I_loc= \int dx x**l *exp(-gam*x**2) M_n(ax) l=ktot+2 gam=g_a+g_b+dz_k(k) a=dreal n=l +!! M_n(x) modified spherical bessel function + + +double precision function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) +implicit none +integer klocmax_max,lmax_max,ntot_max +parameter (klocmax_max=10,lmax_max=2) +parameter (ntot_max=10) +integer klocmax +double precision v_k(klocmax_max),dz_k(klocmax_max),crochet,bigA +integer n_k(klocmax_max) +double precision a(3),g_a,b(3),g_b,c(3),d(3) +integer n_a(3),n_b(3),ntotA,ntotB,ntot,m +integer i,l,k,ktot,k1,k2,k3,k1p,k2p,k3p +double precision f,fourpi,ac,bc,freal,d2,dreal,theta_DC0,phi_DC0 +double precision,allocatable :: array_R_loc(:,:,:) +double precision,allocatable :: array_coefs(:,:,:,:,:,:) +double precision int_prod_bessel_loc,binom,accu,prod,ylm,bigI,arg + + + fourpi=4.d0*dacos(-1.d0) + f=fourpi**1.5d0 + ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) + bc=dsqrt((b(1)-c(1))**2+(b(2)-c(2))**2+(b(3)-c(3))**2) + arg=g_a*ac**2+g_b*bc**2 + if(arg.gt.-dlog(10.d-20))then + Vloc=0.d0 + return + endif + freal=dexp(-g_a*ac**2-g_b*bc**2) + + ntotA=n_a(1)+n_a(2)+n_a(3) + ntotB=n_b(1)+n_b(2)+n_b(3) + ntot=ntotA+ntotB + + d2=0.d0 + do i=1,3 + d(i)=g_a*(a(i)-c(i))+g_b*(b(i)-c(i)) + d2=d2+d(i)**2 + enddo + d2=dsqrt(d2) + dreal=2.d0*d2 + + theta_DC0=dacos(d(3)/d2) + phi_DC0=datan2(d(2)/d2,d(1)/d2) + +allocate (array_R_loc(-2:ntot_max+klocmax_max,klocmax_max,0:ntot_max)) +allocate (array_coefs(0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) + + do ktot=-2,ntotA+ntotB+klocmax + do l=0,ntot + do k=1,klocmax + array_R_loc(ktot,k,l)=freal*int_prod_bessel_loc(ktot+2,g_a+g_b+dz_k(k),l,dreal) + enddo + enddo + enddo + + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_coefs(k1,k2,k3,k1p,k2p,k3p)=binom(n_a(1),k1)*binom(n_a(2),k2)*binom(n_a(3),k3) & + *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) & + *binom(n_b(1),k1p)*binom(n_b(2),k2p)*binom(n_b(3),k3p) & + *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) + enddo + enddo + enddo + enddo + enddo + enddo + + accu=0.d0 + do k=1,klocmax + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + + do l=0,ntot + do m=-l,l + prod=ylm(l,m,theta_DC0,phi_DC0)*array_coefs(k1,k2,k3,k1p,k2p,k3p) & + *bigI(l,m,0,0,k1+k1p,k2+k2p,k3+k3p) + ktot=k1+k2+k3+k1p+k2p+k3p+n_k(k) + accu=accu+prod*v_k(k)*array_R_loc(ktot,k,l) + enddo + enddo + + enddo + enddo + enddo + enddo + enddo + enddo + enddo + Vloc=f*accu + + deallocate (array_R_loc) + deallocate (array_coefs) +end + +double precision function bigA(i,j,k) +implicit none +integer i,j,k +double precision fourpi,dblefact +fourpi=4.d0*dacos(-1.d0) +bigA=0.d0 +if(mod(i,2).eq.1)return +if(mod(j,2).eq.1)return +if(mod(k,2).eq.1)return +bigA=fourpi*dblefact(i-1)*dblefact(j-1)*dblefact(k-1)/dblefact(i+j+k+1) +end +!! +!! I_{lambda,mu,l,m}^{k1,k2,k3} = /int dOmega Y_{lambda mu} xchap^k1 ychap^k2 zchap^k3 Y_{lm} +!! + +double precision function bigI(lambda,mu,l,m,k1,k2,k3) +implicit none +integer lambda,mu,l,m,k1,k2,k3 +integer k,i,kp,ip +double precision pi,sum,factor1,factor2,cylm,cylmp,bigA,binom,fact,coef_pm +pi=dacos(-1.d0) + +if(mu.gt.0.and.m.gt.0)then +sum=0.d0 +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +do k=0,mu/2 + do i=0,lambda-mu + do kp=0,m/2 + do ip=0,l-m + cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + sum=sum+cylm*cylmp*bigA(mu-2*k+m-2*kp+k1,2*k+2*kp+k2,i+ip+k3) + enddo + enddo + enddo +enddo +bigI=sum +return +endif + +if(mu.eq.0.and.m.eq.0)then +factor1=dsqrt((2*lambda+1)/(4.d0*pi)) +factor2=dsqrt((2*l+1)/(4.d0*pi)) +sum=0.d0 +do i=0,lambda + do ip=0,l + cylm=factor1*coef_pm(lambda,i) + cylmp=factor2*coef_pm(l,ip) + sum=sum+cylm*cylmp*bigA(k1,k2,i+ip+k3) + enddo +enddo +bigI=sum +return +endif + +if(mu.eq.0.and.m.gt.0)then +factor1=dsqrt((2*lambda+1)/(4.d0*pi)) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +sum=0.d0 +do i=0,lambda + do kp=0,m/2 + do ip=0,l-m + cylm=factor1*coef_pm(lambda,i) + cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + sum=sum+cylm*cylmp*bigA(m-2*kp+k1,2*kp+k2,i+ip+k3) + enddo + enddo +enddo +bigI=sum +return +endif + +if(mu.gt.0.and.m.eq.0)then +sum=0.d0 +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)/(4.d0*pi)) +do k=0,mu/2 + do i=0,lambda-mu + do ip=0,l + cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=factor2*coef_pm(l,ip) + sum=sum+cylm*cylmp*bigA(mu-2*k +k1,2*k +k2,i+ip +k3) + enddo + enddo +enddo +bigI=sum +return +endif + +if(mu.lt.0.and.m.lt.0)then +mu=-mu +m=-m +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +sum=0.d0 +do k=0,(mu-1)/2 + do i=0,lambda-mu + do kp=0,(m-1)/2 + do ip=0,l-m + cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+m-(2*kp+1)+k1,(2*k+1)+(2*kp+1)+k2,i+ip+k3) + enddo + enddo + enddo +enddo +mu=-mu +m=-m +bigI=sum +return +endif + +if(mu.eq.0.and.m.lt.0)then +m=-m +factor1=dsqrt((2*lambda+1)/(4.d0*pi)) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +sum=0.d0 +do i=0,lambda + do kp=0,(m-1)/2 + do ip=0,l-m + cylm=factor1*coef_pm(lambda,i) + cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + sum=sum+cylm*cylmp*bigA(m-(2*kp+1)+k1,2*kp+1+k2,i+ip+k3) + enddo + enddo +enddo +m=-m +bigI=sum +return +endif + +if(mu.lt.0.and.m.eq.0)then +sum=0.d0 +mu=-mu +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)/(4.d0*pi)) +do k=0,(mu-1)/2 + do i=0,lambda-mu + do ip=0,l + cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=factor2*coef_pm(l,ip) + sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+k1,2*k+1+k2,i+ip+k3) + enddo + enddo +enddo +mu=-mu +bigI=sum +return +endif + +if(mu.gt.0.and.m.lt.0)then +sum=0.d0 +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +m=-m +do k=0,mu/2 + do i=0,lambda-mu + do kp=0,(m-1)/2 + do ip=0,l-m + cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + sum=sum+cylm*cylmp*bigA(mu-2*k+m-(2*kp+1)+k1,2*k+2*kp+1+k2,i+ip+k3) + enddo + enddo + enddo +enddo +m=-m +bigI=sum +return +endif + +if(mu.lt.0.and.m.gt.0)then +mu=-mu +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +sum=0.d0 +do k=0,(mu-1)/2 + do i=0,lambda-mu + do kp=0,m/2 + do ip=0,l-m + cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+m-2*kp+k1,2*k+1+2*kp+k2,i+ip+k3) + enddo + enddo + enddo +enddo +bigI=sum +mu=-mu +return +endif + +stop 'pb in bigI!' +end + +double precision function crochet(n,g) +implicit none +integer n +double precision g,pi,dblefact,expo +pi=dacos(-1.d0) +expo=0.5d0*dfloat(n+1) +crochet=dblefact(n-1)/(2.d0*g)**expo +if(mod(n,2).eq.0)crochet=crochet*dsqrt(pi/2.d0) +end + +!! +!! overlap= = /int dOmega Ylm (x-center_x)**nx*(y-center_y)**nx*(z-center)**nx +!! *exp(-g*(r-center)**2) +!! +double precision function overlap_orb_ylm_brute(npts,r,npower_orb,center_orb,g_orb,l,m) +implicit none +integer npower_orb(3),l,m,i,j,npts +double precision u,g_orb,du,dphi,term,orb_phi,ylm_real,sintheta,r_orb,phi,center_orb(3) +double precision x_orb,y_orb,z_orb,twopi,r +twopi=2.d0*dacos(-1.d0) +du=2.d0/npts +dphi=twopi/npts +overlap_orb_ylm_brute=0.d0 +do i=1,npts + u=-1.d0+du*(i-1)+du/2.d0 + sintheta=dsqrt(1.d0-u**2) + do j=1,npts + phi=dphi*(j-1)+dphi/2.d0 + x_orb=r*dcos(phi)*sintheta + y_orb=r*dsin(phi)*sintheta + z_orb=r*u + term=orb_phi(x_orb,y_orb,z_orb,npower_orb,center_orb,g_orb)*ylm_real(l,m,u,phi) + overlap_orb_ylm_brute= overlap_orb_ylm_brute+term*du*dphi + enddo +enddo +end + +double precision function overlap_orb_ylm_grid(nptsgrid,r_orb,npower_orb,center_orb,g_orb,l,m) +implicit none +!! PSEUDOS +integer nptsgridmax,nptsgrid +double precision coefs_pseudo,ptsgrid +parameter(nptsgridmax=50) +common/pseudos/coefs_pseudo(nptsgridmax),ptsgrid(nptsgridmax,3) +!!!!! +integer npower_orb(3),l,m,i +double precision x,g_orb,two_pi,dx,dphi,term,orb_phi,ylm_real,sintheta,r_orb,phi,center_orb(3) +double precision x_orb,y_orb,z_orb,twopi,pi,cosphi,sinphi,xbid +pi=dacos(-1.d0) +twopi=2.d0*pi +overlap_orb_ylm_grid=0.d0 +do i=1,nptsgrid + x_orb=r_orb*ptsgrid(i,1) + y_orb=r_orb*ptsgrid(i,2) + z_orb=r_orb*ptsgrid(i,3) + x=ptsgrid(i,3) + phi=datan2(ptsgrid(i,2),ptsgrid(i,1)) + term=orb_phi(x_orb,y_orb,z_orb,npower_orb,center_orb,g_orb)*ylm_real(l,m,x,phi) + overlap_orb_ylm_grid= overlap_orb_ylm_grid+coefs_pseudo(i)*term +enddo +overlap_orb_ylm_grid=2.d0*twopi*overlap_orb_ylm_grid +end + +! Y_l^m(theta,phi) = i^(m+|m|) ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 P_l^|m|(cos(theta)) exp(i m phi) +! l=0,1,2,.... +! m=0,1,...,l +! Here: +! n=l (n=0,1,...) +! m=0,1,...,n +! x=cos(theta) 0 < x < 1 +! +! +! This routine computes: PM(m,n) for n=0,...,N (number N in input) and m=0,..,n + +! Exemples (see 'Associated Legendre Polynomilas wikipedia') +! P_{0}^{0}(x)=1 +! P_{1}^{-1}(x)=-1/2 P_{1}^{1}(x) +! P_{1}^{0}(x)=x +! P_{1}^{1}(x)=-(1-x^2)^{1/2} +! P_{2}^{-2}(x)=1/24 P_{2}^{2}(x) +! P_{2}^{-1}(x)=-1/6 P_{2}^{1}(x) +! P_{2}^{0}(x)=1/2 (3x^{2}-1) +! P_{2}^{1}(x)=-3x(1-x^2)^{1/2} +! P_{2}^{2}(x)=3(1-x^2) + + + SUBROUTINE LPMN(MM,M,N,X,PM) +! +! Here N = LMAX +! Here M= MMAX (we take M=LMAX in input) +! +! ===================================================== +! Purpose: Compute the associated Legendre functions Pmn(x) +! Input : x --- Argument of Pmn(x) +! m --- Order of Pmn(x), m = 0,1,2,...,n +! n --- Degree of Pmn(x), n = 0,1,2,...,N +! mm --- Physical dimension of PM +! Output: PM(m,n) --- Pmn(x) +! ===================================================== +! + IMPLICIT DOUBLE PRECISION (P,X) + DIMENSION PM(0:MM,0:(N+1)) + DO 10 I=0,N + DO 10 J=0,M +10 PM(J,I)=0.0D0 + PM(0,0)=1.0D0 + IF (DABS(X).EQ.1.0D0) THEN + DO 15 I=1,N +15 PM(0,I)=X**I + RETURN + ENDIF + LS=1 + IF (DABS(X).GT.1.0D0) LS=-1 + XQ=DSQRT(LS*(1.0D0-X*X)) + XS=LS*(1.0D0-X*X) + DO 30 I=1,M +30 PM(I,I)=-LS*(2.0D0*I-1.0D0)*XQ*PM(I-1,I-1) + DO 35 I=0,M +35 PM(I,I+1)=(2.0D0*I+1.0D0)*X*PM(I,I) + + DO 40 I=0,M + DO 40 J=I+2,N + PM(I,J)=((2.0D0*J-1.0D0)*X*PM(I,J-1)- (I+J-1.0D0)*PM(I,J-2))/(J-I) +40 CONTINUE + END + + +! Y_l^m(theta,phi) = i^(m+|m|) ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 +! P_l^|m|(cos(theta)) exp(i m phi) + + double precision function fact(n) + implicit double precision(a-h,o-z) + fact=1.d0 + if(n.eq.0)return + do i=1,n + fact=fact*dfloat(i) + enddo + end + + subroutine erreur(x,n,rmoy,error) + implicit double precision(a-h,o-z) + dimension x(n) +! calcul de la moyenne + rmoy=0.d0 + do i=1,n + rmoy=rmoy+x(i) + enddo + rmoy=rmoy/dfloat(n) +! calcul de l'erreur + error=0.d0 + do i=1,n + error=error+(x(i)-rmoy)**2 + enddo + if(n.gt.1)then + rn=dfloat(n) + rn1=dfloat(n-1) + error=dsqrt(error)/dsqrt(rn*rn1) + else + write(2,*)'Seulement un block Erreur nondefinie' + error=0.d0 + endif + end + + subroutine initpseudos(nptsgrid) + implicit none + integer nptsgridmax,nptsgrid,ik + double precision coefs_pseudo,ptsgrid + double precision p,q,r,s + parameter(nptsgridmax=50) + common/pseudos/coefs_pseudo(nptsgridmax),ptsgrid(nptsgridmax,3) + + p=1.d0/dsqrt(2.d0) + q=1.d0/dsqrt(3.d0) + r=1.d0/dsqrt(11.d0) + s=3.d0/dsqrt(11.d0) + + if(nptsgrid.eq.4)then + + ptsgrid(1,1)=q + ptsgrid(1,2)=q + ptsgrid(1,3)=q + + ptsgrid(2,1)=q + ptsgrid(2,2)=-q + ptsgrid(2,3)=-q + + ptsgrid(3,1)=-q + ptsgrid(3,2)=q + ptsgrid(3,3)=-q + + ptsgrid(4,1)=-q + ptsgrid(4,2)=-q + ptsgrid(4,3)=q + + do ik=1,4 + coefs_pseudo(ik)=1.d0/4.d0 + enddo + return + endif + + ptsgrid(1,1)=1.d0 + ptsgrid(1,2)=0.d0 + ptsgrid(1,3)=0.d0 + + ptsgrid(2,1)=-1.d0 + ptsgrid(2,2)=0.d0 + ptsgrid(2,3)=0.d0 + + ptsgrid(3,1)=0.d0 + ptsgrid(3,2)=1.d0 + ptsgrid(3,3)=0.d0 + + ptsgrid(4,1)=0.d0 + ptsgrid(4,2)=-1.d0 + ptsgrid(4,3)=0.d0 + + ptsgrid(5,1)=0.d0 + ptsgrid(5,2)=0.d0 + ptsgrid(5,3)=1.d0 + + ptsgrid(6,1)=0.d0 + ptsgrid(6,2)=0.d0 + ptsgrid(6,3)=-1.d0 + + do ik=1,6 + coefs_pseudo(ik)=1.d0/6.d0 + enddo + + if(nptsgrid.eq.6)return + + ptsgrid(7,1)=p + ptsgrid(7,2)=p + ptsgrid(7,3)=0.d0 + + ptsgrid(8,1)=p + ptsgrid(8,2)=-p + ptsgrid(8,3)=0.d0 + + ptsgrid(9,1)=-p + ptsgrid(9,2)=p + ptsgrid(9,3)=0.d0 + + ptsgrid(10,1)=-p + ptsgrid(10,2)=-p + ptsgrid(10,3)=0.d0 + + ptsgrid(11,1)=p + ptsgrid(11,2)=0.d0 + ptsgrid(11,3)=p + + ptsgrid(12,1)=p + ptsgrid(12,2)=0.d0 + ptsgrid(12,3)=-p + + ptsgrid(13,1)=-p + ptsgrid(13,2)=0.d0 + ptsgrid(13,3)=p + + ptsgrid(14,1)=-p + ptsgrid(14,2)=0.d0 + ptsgrid(14,3)=-p + + ptsgrid(15,1)=0.d0 + ptsgrid(15,2)=p + ptsgrid(15,3)=p + + ptsgrid(16,1)=0.d0 + ptsgrid(16,2)=p + ptsgrid(16,3)=-p + + ptsgrid(17,1)=0.d0 + ptsgrid(17,2)=-p + ptsgrid(17,3)=p + + ptsgrid(18,1)=0.d0 + ptsgrid(18,2)=-p + ptsgrid(18,3)=-p + + do ik=1,6 + coefs_pseudo(ik)=1.d0/30.d0 + enddo + do ik=7,18 + coefs_pseudo(ik)=1.d0/15.d0 + enddo + + if(nptsgrid.eq.18)return + + ptsgrid(19,1)=q + ptsgrid(19,2)=q + ptsgrid(19,3)=q + + ptsgrid(20,1)=-q + ptsgrid(20,2)=q + ptsgrid(20,3)=q + + ptsgrid(21,1)=q + ptsgrid(21,2)=-q + ptsgrid(21,3)=q + + ptsgrid(22,1)=q + ptsgrid(22,2)=q + ptsgrid(22,3)=-q + + ptsgrid(23,1)=-q + ptsgrid(23,2)=-q + ptsgrid(23,3)=q + + ptsgrid(24,1)=-q + ptsgrid(24,2)=q + ptsgrid(24,3)=-q + + ptsgrid(25,1)=q + ptsgrid(25,2)=-q + ptsgrid(25,3)=-q + + ptsgrid(26,1)=-q + ptsgrid(26,2)=-q + ptsgrid(26,3)=-q + + do ik=1,6 + coefs_pseudo(ik)=1.d0/21.d0 + enddo + do ik=7,18 + coefs_pseudo(ik)=4.d0/105.d0 + enddo + do ik=19,26 + coefs_pseudo(ik)=27.d0/840.d0 + enddo + + if(nptsgrid.eq.26)return + + ptsgrid(27,1)=r + ptsgrid(27,2)=r + ptsgrid(27,3)=s + + ptsgrid(28,1)=r + ptsgrid(28,2)=-r + ptsgrid(28,3)=s + + ptsgrid(29,1)=-r + ptsgrid(29,2)=r + ptsgrid(29,3)=s + + ptsgrid(30,1)=-r + ptsgrid(30,2)=-r + ptsgrid(30,3)=s + + ptsgrid(31,1)=r + ptsgrid(31,2)=r + ptsgrid(31,3)=-s + + ptsgrid(32,1)=r + ptsgrid(32,2)=-r + ptsgrid(32,3)=-s + + ptsgrid(33,1)=-r + ptsgrid(33,2)=r + ptsgrid(33,3)=-s + + ptsgrid(34,1)=-r + ptsgrid(34,2)=-r + ptsgrid(34,3)=-s + + ptsgrid(35,1)=r + ptsgrid(35,2)=s + ptsgrid(35,3)=r + + ptsgrid(36,1)=-r + ptsgrid(36,2)=s + ptsgrid(36,3)=r + + ptsgrid(37,1)=r + ptsgrid(37,2)=s + ptsgrid(37,3)=-r + + ptsgrid(38,1)=-r + ptsgrid(38,2)=s + ptsgrid(38,3)=-r + + ptsgrid(39,1)=r + ptsgrid(39,2)=-s + ptsgrid(39,3)=r + + ptsgrid(40,1)=r + ptsgrid(40,2)=-s + ptsgrid(40,3)=-r + + ptsgrid(41,1)=-r + ptsgrid(41,2)=-s + ptsgrid(41,3)=r + + ptsgrid(42,1)=-r + ptsgrid(42,2)=-s + ptsgrid(42,3)=-r + + ptsgrid(43,1)=s + ptsgrid(43,2)=r + ptsgrid(43,3)=r + + ptsgrid(44,1)=s + ptsgrid(44,2)=r + ptsgrid(44,3)=-r + + ptsgrid(45,1)=s + ptsgrid(45,2)=-r + ptsgrid(45,3)=r + + ptsgrid(46,1)=s + ptsgrid(46,2)=-r + ptsgrid(46,3)=-r + + ptsgrid(47,1)=-s + ptsgrid(47,2)=r + ptsgrid(47,3)=r + + ptsgrid(48,1)=-s + ptsgrid(48,2)=r + ptsgrid(48,3)=-r + + ptsgrid(49,1)=-s + ptsgrid(49,2)=-r + ptsgrid(49,3)=r + + ptsgrid(50,1)=-s + ptsgrid(50,2)=-r + ptsgrid(50,3)=-r + + do ik=1,6 + coefs_pseudo(ik)=4.d0/315.d0 + enddo + do ik=7,18 + coefs_pseudo(ik)=64.d0/2835.d0 + enddo + do ik=19,26 + coefs_pseudo(ik)=27.d0/1280.d0 + enddo + do ik=27,50 + coefs_pseudo(ik)=14641.d0/725760.d0 + enddo + + if(nptsgrid.eq.50)return + + write(*,*)'Grid for pseudos not available!' + write(*,*)'N=4-6-18-26-50 only!' + stop + end + +double precision function dblefact(n) +implicit none +integer :: n,k +double precision prod +dblefact=1.d0 +if(n.lt.0)return +if(mod(n,2).eq.1)then + prod=1.d0 + do k=1,n,2 + prod=prod*dfloat(k) + enddo + dblefact=prod + return + endif + if(mod(n,2).eq.0)then + prod=1.d0 + do k=2,n,2 + prod=prod*dfloat(k) + enddo + dblefact=prod + return + endif +end +!! +!! R_{lambda,lamba',N}= exp(-ga_a AC**2 -g_b BC**2) /int_{0}{+infty} r**(2+n) exp(-(g_a+g_b+g_k)r**2) +!! * M_{lambda}( 2g_a ac r) M_{lambda'}(2g_b bc r) +!! + double precision function bigR(lambda,lambdap,n,g_a,g_b,ac,bc,g_k) + implicit none + integer lambda,lambdap,n,npts,i + double precision g_a,g_b,ac,bc,g_k,arg,factor,delta1,delta2,cc,rmax,dr,sum,x1,x2,r + double precision bessel_mod + arg=g_a*ac**2+g_b*bc**2 + factor=dexp(-arg) + delta1=2.d0*g_a*ac + delta2=2.d0*g_b*bc + cc=g_a+g_b+g_k + if(cc.eq.0.d0)stop 'pb. in bigR' + rmax=dsqrt(-dlog(10.d-20)/cc) + npts=500 + dr=rmax/npts + sum=0.d0 + do i=1,npts + r=(i-1)*dr + x1=delta1*r + x2=delta2*r + sum=sum+dr*r**(n+2)*dexp(-cc*r**2)*bessel_mod(x1,lambda)*bessel_mod(x2,lambdap) + enddo + bigR=sum*factor + end + + double precision function bessel_mod(x,n) + implicit none + integer n + double precision x,bessel_mod_exp,bessel_mod_recur + if(x.le.0.8d0)then + bessel_mod=bessel_mod_exp(n,x) + else + bessel_mod=bessel_mod_recur(n,x) + endif + end + + recursive function bessel_mod_recur(n,x) result(a) + implicit none + integer n + double precision x,a,bessel_mod_exp + if(x.le.0.8d0)then + a=bessel_mod_exp(n,x) + return + endif + if(n.eq.0)a=dsinh(x)/x + if(n.eq.1)a=(x*dcosh(x)-dsinh(x))/x**2 + if(n.ge.2)a=bessel_mod_recur(n-2,x)-(2*n-1)/x*bessel_mod_recur(n-1,x) + end + + double precision function bessel_mod_exp(n,x) + implicit none + integer n,k + double precision x,coef,accu,fact,dblefact + accu=0.d0 + do k=0,10 + coef=1.d0/fact(k)/dblefact(2*(n+k)+1) + accu=accu+(x**2/2.d0)**k*coef + enddo + bessel_mod_exp=x**n*accu + end + +! double precision function bessel_mod(x,n) +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! parameter(NBESSMAX=100) +! dimension SI(0:NBESSMAX),DI(0:NBESSMAX) +! if(n.lt.0.or.n.gt.NBESSMAX)stop 'pb with argument of bessel_mod' +! CALL SPHI(N,X,NBESSMAX,SI,DI) +! bessel_mod=si(n) +! end + + SUBROUTINE SPHI(N,X,NMAX,SI,DI) +! +! ======================================================== +! Purpose: Compute modified spherical Bessel functions +! of the first kind, in(x) and in'(x) +! Input : x --- Argument of in(x) +! n --- Order of in(x) ( n = 0,1,2,... ) +! Output: SI(n) --- in(x) +! DI(n) --- in'(x) +! NM --- Highest order computed +! Routines called: +! MSTA1 and MSTA2 for computing the starting +! point for backward recurrence +! ======================================================== +! + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION SI(0:NMAX),DI(0:NMAX) + NM=N + IF (DABS(X).LT.1.0D-100) THEN + DO 10 K=0,N + SI(K)=0.0D0 +10 DI(K)=0.0D0 + SI(0)=1.0D0 + DI(1)=0.333333333333333D0 + RETURN + ENDIF + SI(0)=DSINH(X)/X + SI(1)=-(DSINH(X)/X-DCOSH(X))/X + SI0=SI(0) + IF (N.GE.2) THEN + M=MSTA1(X,200) + + write(34,*)'m=',m + + IF (M.LT.N) THEN + NM=M + ELSE + M=MSTA2(X,N,15) + write(34,*)'m=',m + ENDIF + F0=0.0D0 + F1=1.0D0-100 + DO 15 K=M,0,-1 + F=(2.0D0*K+3.0D0)*F1/X+F0 + IF (K.LE.NM) SI(K)=F + F0=F1 +15 F1=F + CS=SI0/F + write(34,*)'cs=',cs + DO 20 K=0,NM +20 SI(K)=CS*SI(K) + ENDIF + DI(0)=SI(1) + DO 25 K=1,NM +25 DI(K)=SI(K-1)-(K+1.0D0)/X*SI(K) + RETURN + END + + + INTEGER FUNCTION MSTA1(X,MP) +! +! =================================================== +! Purpose: Determine the starting point for backward +! recurrence such that the magnitude of +! Jn(x) at that point is about 10^(-MP) +! Input : x --- Argument of Jn(x) +! MP --- Value of magnitude +! Output: MSTA1 --- Starting point +! =================================================== +! + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + A0=DABS(X) + N0=INT(1.1*A0)+1 + F0=ENVJ(N0,A0)-MP + N1=N0+5 + F1=ENVJ(N1,A0)-MP + DO 10 IT=1,20 + NN=N1-(N1-N0)/(1.0D0-F0/F1) + F=ENVJ(NN,A0)-MP + IF(ABS(NN-N1).LT.1) GO TO 20 + N0=N1 + F0=F1 + N1=NN + 10 F1=F + 20 MSTA1=NN + RETURN + END + + + INTEGER FUNCTION MSTA2(X,N,MP) +! +! =================================================== +! Purpose: Determine the starting point for backward +! recurrence such that all Jn(x) has MP +! significant digits +! Input : x --- Argument of Jn(x) +! n --- Order of Jn(x) +! MP --- Significant digit +! Output: MSTA2 --- Starting point +! =================================================== +! + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + A0=DABS(X) + HMP=0.5D0*MP + EJN=ENVJ(N,A0) + IF (EJN.LE.HMP) THEN + OBJ=MP + N0=INT(1.1*A0) + ELSE + OBJ=HMP+EJN + N0=N + ENDIF + F0=ENVJ(N0,A0)-OBJ + N1=N0+5 + F1=ENVJ(N1,A0)-OBJ + DO 10 IT=1,20 + NN=N1-(N1-N0)/(1.0D0-F0/F1) + F=ENVJ(NN,A0)-OBJ + IF (iABS(NN-N1).LT.1) GO TO 20 + N0=N1 + F0=F1 + N1=NN +10 F1=F +20 MSTA2=NN+10 + RETURN + END + + double precision FUNCTION ENVJ(N,X) + DOUBLE PRECISION X + integer N + ENVJ=0.5D0*DLOG10(6.28D0*N)-N*DLOG10(1.36D0*X/N) + RETURN + END + +!c Computation of real spherical harmonics Ylm(theta,phi) +!c +!c l=0,1,.... +!c m=-l,l +!c +!c m>0: Y_lm = sqrt(2) ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 P_l^|m|(cos(theta)) cos(m phi) +!c m=0: Y_l0 = ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 P_l^0 (cos(theta)) +!c m<0: Y_lm = sqrt(2) ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 P_l^|m|(cos(theta)) sin(|m|phi) + +!Examples(wikipedia http://en.wikipedia.org/wiki/Table_of_spherical_harmonics#Real_spherical_harmonics) + +! l = 0 + +! Y_00 = \sqrt{1/(4pi)} + +! l = 1 + +! Y_1-1= \sqrt{3/(4pi)} y/r +! Y_10 = \sqrt{3/(4pi)} z/r +! Y_11 = \sqrt{3/(4pi)} x/r +! +! l = 2 +! +! Y_2,-2= 1/2 \sqrt{15/pi} xy/r^2 +! Y_2,-1= 1/2 \sqrt{15/pi} yz/r^2 +! Y_20 = 1/4 \sqrt{15/pi} (-x^2-y^2 +2z^2)/r^2 +! Y_21 = 1/2 \sqrt{15/pi} zx/r^2 +! Y_22 = 1/4 \sqrt{15/pi} (x^2-y^2)/r^2 +! +!c +double precision function ylm(l,m,theta,phi) +implicit none +integer l,m +double precision theta,phi,pm,factor,pi,x,fact,sign +DIMENSION PM(0:100,0:100) +pi=dacos(-1.d0) +x=dcos(theta) +sign=(-1.d0)**m +CALL LPMN(100,l,l,X,PM) +factor=dsqrt( (2*l+1)*fact(l-iabs(m)) /(4.d0*pi*fact(l+iabs(m))) ) +if(m.gt.0)ylm=sign*dsqrt(2.d0)*factor*pm(m,l)*dcos(dfloat(m)*phi) +if(m.eq.0)ylm=factor*pm(m,l) +if(m.lt.0)ylm=sign*dsqrt(2.d0)*factor*pm(iabs(m),l)*dsin(dfloat(iabs(m))*phi) +end + +!c Explicit representation of Legendre polynomials P_n(x) +!! +!! P_n0(x) = P_n(x)= \sum_{k=0}^n a_k x^k +!! +!! with a_k= 2^n binom(n,k) binom( (n+k-1)/2, n ) +!! coef_pm(n,k) is the k_th coefficient of P_n(x) +double precision function coef_pm(n,k) +implicit none +integer n,k +double precision arg,binom,binom_gen +if(n.eq.0.and.k.ne.0)stop 'coef_pm not defined' +if(n.eq.0.and.k.eq.0)then +coef_pm=1.d0 +return +endif +arg=0.5d0*dfloat(n+k-1) +coef_pm=2.d0**n*binom(n,k)*binom_gen(arg,n) +end + +!! Ylm_bis uses the series expansion of Ylm in xchap^i ychap^j zchap^k +!! xchap=x/r etc. +!c m>0: Y_lm = sqrt(2)*factor* P_l^|m|(cos(theta)) cos(m phi) +!c m=0: Y_l0 = factor* P_l^0 (cos(theta)) +!c m<0: Y_lm = sqrt(2) factor* P_l^|m|(cos(theta)) sin(|m|phi) +!c factor= ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 + +!! P_l^m (x) = (-1)**m (1-x**2)^m/2 d^m/dx^m P_l(x) m >0 or 0 +!! the series expansion of P_m (x) is known +!! +!! sin(theta)**m cos(mphi) = \sum_0^[m/2] binom(m,2k) x^(m-2k) y^2k (-1)**k (easy to proove with +!! Moivre formula) +!! (here x = xchap...) +!! +!! Ylm m> 0 = \sum_{k=0}^[m/2] \sum_{i=0}^(l-m) c_ki x^(m-2k) y^2k z^i +!! +!! c_ki= (-1)^k sqrt(2)*factor*binom(m,2k)*(m+i)!/i!*coef_pm(l,i+m) +!! +!! Ylm m< 0 = \sum_{k=0}^[(m-1)/2] \sum_{i=0}^(l-m) c_ki x^(m-(2k+1)) y^(2k+1) z^i +!! +!! c_ki= (-1)^k sqrt(2)*factor*binom(m,2k+1)*(m+i)!/i!*coef_pm(l,i+m) + + +double precision function ylm_bis(l,m,theta,phi) +implicit none +integer l,m,k,i +double precision x,y,z,theta,phi,sum,factor,pi,binom,fact,coef_pm,cylm +pi=dacos(-1.d0) +x=dsin(theta)*dcos(phi) +y=dsin(theta)*dsin(phi) +z=dcos(theta) +factor=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +if(m.gt.0)then +sum=0.d0 +do k=0,m/2 + do i=0,l-m + cylm=(-1.d0)**k*factor*dsqrt(2.d0)*binom(m,2*k)*fact(m+i)/fact(i)*coef_pm(l,i+m) + sum=sum+cylm*x**(m-2*k)*y**(2*k)*z**i + enddo +enddo +ylm_bis=sum +return +endif +if(m.eq.0)then +sum=0.d0 +do i=0,l + sum=sum+factor*coef_pm(l,i)*z**i +enddo +ylm_bis=sum +return +endif +if(m.lt.0)then +m=-m +sum=0.d0 +do k=0,(m-1)/2 + do i=0,l-m + cylm=(-1.d0)**k*factor*dsqrt(2.d0)*binom(m,2*k+1)*fact(m+i)/fact(i)*coef_pm(l,i+m) + sum=sum+cylm*x**(m-(2*k+1))*y**(2*k+1)*z**i + enddo +enddo +ylm_bis=sum +m=-m +return +endif +end + +!c +!c Computation of associated Legendre Polynomials PM(m,n) for n=0,...,N +!c Here: +!c n=l (n=0,1,...) +!c m=0,1,...,n +!c x=cos(theta) 0 < x < 1 +!c +!c This routine computes: PM(m,n) for n=0,...,N (number N in input) and m=0,..,n +!c Exemples (see 'Associated Legendre Polynomilas wikipedia') +!c P_{0}^{0}(x)=1 +!c P_{1}^{-1}(x)=-1/2 P_{1}^{1}(x) +!c P_{1}^{0}(x)=x +!c P_{1}^{1}(x)=-(1-x^2)^{1/2} +!c P_{2}^{-2}(x)=1/24 P_{2}^{2}(x) +!c P_{2}^{-1}(x)=-1/6 P_{2}^{1}(x) +!c P_{2}^{0}(x)=1/2 (3x^{2}-1) +!c P_{2}^{1}(x)=-3x(1-x^2)^{1/2} +!c P_{2}^{2}(x)=3(1-x^2) +!c +!c Explicit representation: +!! +!! P_n0(x) = P_n(x)= \sum_{k=0}^n a_k x^k +!! +!! with a_k= 2^n binom(n,k) binom( (n+k-1)/2, n ) + +double precision function binom(i,j) + implicit none + integer :: i,j + double precision :: fact + binom = fact(i)/(fact(j)*fact(i-j)) +end + +double precision function binom_gen(alpha,n) + implicit none + integer :: n,k + double precision :: fact,alpha,prod + prod=1.d0 + do k=0,n-1 + prod=prod*(alpha-k) + binom_gen = prod/(fact(n)) + enddo +end + +double precision function test_int(g_a,g_b,g_c,ac,bc) +implicit none +double precision factor,g_a,g_b,g_c,ac,bc,x,dx,sum,alpha,beta,pi +integer i,npts +pi=dacos(-1.d0) +factor=0.5d0*pi/(g_a*g_b*ac*bc*dsqrt(g_a+g_b+g_c))*dexp(-g_a*ac**2-g_b*bc**2) +npts=2000 +dx=20.d0/npts +sum=0.d0 +alpha=(2.d0*g_a*ac+2.d0*g_b*bc)/dsqrt(g_c+g_a+g_b) +beta=(2.d0*g_b*bc-2.d0*g_b*bc)/dsqrt(g_c+g_a+g_b) +do i=1,npts + x=(i-1)*dx+0.5d0*dx + sum=sum+dx*dexp(-x**2)*(dcosh(alpha*x)-dcosh(beta*x)) +enddo +test_int=factor*sum +end + +recursive function fact1(n,a) result(x) +implicit none +integer n +double precision a,x,erf +if(n.eq.0)then +x=dsqrt(dacos(-1.d0))/2.d0*erf(a) +return +endif +if(n.eq.1)then +x=1.d0-dexp(-a**2) +return +endif +if(mod(n,2).eq.0)x=0.5d0*dfloat(n-1)*fact1(n-2,a)+a**n*dexp(-a**2) +if(mod(n,2).eq.1)x=0.5d0*dfloat(n-1)*fact1(n-2,a)+0.5d0*a**(n-1)*dexp(-a**2) +end + + double precision FUNCTION ERF(X) + implicit double precision(a-h,o-z) + IF(X.LT.0.d0)THEN + ERF=-GAMMP(.5d0,X**2) + ELSE + ERF=GAMMP(.5d0,X**2) + ENDIF + RETURN + END + + double precision FUNCTION GAMMLN(XX) + implicit double precision(a-h,o-z) + REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER + DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0, & + -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/ + DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/ + X=XX-ONE + TMP=X+FPF + TMP=(X+HALF)*DLOG(TMP)-TMP + SER=ONE + DO 11 J=1,6 + X=X+ONE + SER=SER+COF(J)/X +11 CONTINUE + GAMMLN=TMP+DLOG(STP*SER) + RETURN + END + FUNCTION GAMMP(A,X) + implicit double precision(a-h,o-z) + IF(X.LT.0.d0.OR.A.LE.0.d0)PAUSE + IF(X.LT.A+1.d0)THEN + CALL GSER(GAMMP,A,X,GLN) + ELSE + CALL GCF(GAMMCF,A,X,GLN) + GAMMP=1.d0-GAMMCF + ENDIF + RETURN + END + SUBROUTINE GCF(GAMMCF,A,X,GLN) + implicit double precision(a-h,o-z) + PARAMETER (ITMAX=100,EPS=3.D-7) + GLN=GAMMLN(A) + GOLD=0.d0 + A0=1.d0 + A1=X + B0=0.d0 + B1=1.d0 + FAC=1.d0 + DO 11 N=1,ITMAX + AN=DFLOAT(N) + ANA=AN-A + A0=(A1+A0*ANA)*FAC + B0=(B1+B0*ANA)*FAC + ANF=AN*FAC + A1=X*A0+ANF*A1 + B1=X*B0+ANF*B1 + IF(A1.NE.0.d0)THEN + FAC=1.d0/A1 + G=B1*FAC + IF(DABS((G-GOLD)/G).LT.EPS)GO TO 1 + GOLD=G + ENDIF +11 CONTINUE + PAUSE 'A TOO LARGE, ITMAX TOO SMALL' +1 GAMMCF=DEXP(-X+A*DLOG(X)-GLN)*G + RETURN + END + SUBROUTINE GSER(GAMSER,A,X,GLN) + implicit double precision(a-h,o-z) + PARAMETER (ITMAX=100,EPS=3.D-7) + GLN=GAMMLN(A) + IF(X.LE.0.d0)THEN + IF(X.LT.0.d0)PAUSE + GAMSER=0.d0 + RETURN + ENDIF + AP=A + SUM=1.d0/A + DEL=SUM + DO 11 N=1,ITMAX + AP=AP+1.d0 + DEL=DEL*X/AP + SUM=SUM+DEL + IF(DABS(DEL).LT.DABS(SUM)*EPS)GO TO 1 +11 CONTINUE + PAUSE 'A TOO LARGE, ITMAX TOO SMALL' +1 GAMSER=SUM*DEXP(-X+A*DLOG(X)-GLN) + RETURN + END + + + double precision function coef_nk(n,k) + implicit none + integer n,k + double precision gam,dblefact,fact + gam=dblefact(2*(n+k)+1) + coef_nk=1.d0/(2.d0**k*fact(k)*gam) + end + +!! Calculation of +!! +!! I= \int dx x**l *exp(-gam*x**2) M_n(ax) M_m(bx) +!! +!! M_n(x) modified spherical bessel function +!! + double precision function int_prod_bessel(l,gam,n,m,a,b) + implicit none + integer n,k,m,q,l,kcp + double precision gam,dblefact,fact,pi,a,b + double precision int,intold,sum,coef_nk,crochet + logical done + + if(a.ne.0.d0.and.b.ne.0.d0)then + q=0 + intold=-1.d0 + int=0.d0 + done=.false. + kcp=0 + do while (.not.done) + kcp=kcp+1 + sum=0.d0 + do k=0,q + sum=sum+coef_nk(n,k)*coef_nk(m,q-k)*a**(n+2*k)*b**(m-2*k+2*q) + enddo + int=int+sum*crochet(2*q+n+m+l,gam) + if(dabs(int-intold).lt.1d-15)then + done=.true. + else + q=q+1 + intold=int + endif + enddo + int_prod_bessel=int + if(kcp.gt.100)print*,'**WARNING** bad convergence in int_prod_bessel' + return + endif + + if(a.eq.0.d0.and.b.ne.0.d0)then + if(n.ne.0)then + int_prod_bessel=0.d0 + return + endif + q=0 + intold=-1.d0 + int=0.d0 + done=.false. + kcp=0 + do while (.not.done) + kcp=kcp+1 + int=int+coef_nk(m,q)*b**(m+2*q)*crochet(2*q+m+l,gam) + if(dabs(int-intold).lt.1d-15)then + done=.true. + else + q=q+1 + intold=int + endif + enddo + int_prod_bessel=int + if(kcp.gt.100)stop '**WARNING** bad convergence in int_prod_bessel' + return + endif + + if(a.ne.0.d0.and.b.eq.0.d0)then + if(m.ne.0)then + int_prod_bessel=0.d0 + return + endif + q=0 + intold=-1.d0 + int=0.d0 + done=.false. + kcp=0 + do while (.not.done) + kcp=kcp+1 + int=int+coef_nk(n,q)*a**(n+2*q)*crochet(2*q+n+l,gam) + if(dabs(int-intold).lt.1d-15)then + done=.true. + else + q=q+1 + intold=int + endif + enddo + int_prod_bessel=int + if(kcp.gt.100)stop '**WARNING** bad convergence in int_prod_bessel' + return + endif + + if(a.eq.0.d0.and.b.eq.0.d0)then + if(n.ne.0.or.m.ne.0)then + int_prod_bessel=0.d0 + return + endif + int_prod_bessel=crochet(l,gam) + return + endif + + stop 'pb in int_prod_bessel!!' + end + +!! Calculation of +!! +!! I= \int dx x**l *exp(-gam*x**2) M_n(ax) +!! +!! M_n(x) modified spherical bessel function +!! + double precision function int_prod_bessel_loc(l,gam,n,a) + implicit none + integer n,k,l,kcp + double precision gam,a + double precision int,intold,coef_nk,crochet + logical done + k=0 + intold=-1.d0 + int=0.d0 + done=.false. + kcp=0 + do while (.not.done) + kcp=kcp+1 + int=int+coef_nk(n,k)*a**(n+2*k)*crochet(2*k+n+l,gam) + if(dabs(int-intold).lt.1d-15)then + done=.true. + else + k=k+1 + intold=int + endif + enddo + int_prod_bessel_loc=int + if(kcp.gt.100)print*,'**WARNING** bad convergence in int_prod_bessel' + end + + double precision function int_prod_bessel_num(l,gam,n,m,a,b) + implicit none + integer n,m,l,i,npoints + double precision gam,a,b + double precision sum,dx,x,bessel_mod + sum=0.d0 + npoints=20000 + dx=30.d0/npoints + do i=1,npoints + x=(i-1)*dx+0.5d0*dx + sum=sum+dx*x**l*dexp(-gam*x**2)*bessel_mod(a*x,n)*bessel_mod(b*x,m) + enddo + int_prod_bessel_num=sum + end + + + From 37e049ea1a745123144586473c5779f5b1a70fff Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 3 Apr 2015 14:12:51 +0200 Subject: [PATCH 02/70] Add ezfio support --- scripts/pseudo/put_pseudo_in_ezfio.py | 183 +++++++++++++++++++++++++ setup_environment.sh | 4 +- src/Pseudo/NEEDED_MODULES | 1 + src/Pseudo/int.f90 | 66 --------- src/Pseudo/pseudo.ezfio_config | 10 ++ src/Pseudo/test_michel.irp.f | 188 ++++++++++++++++++++++++++ 6 files changed, 385 insertions(+), 67 deletions(-) create mode 100755 scripts/pseudo/put_pseudo_in_ezfio.py create mode 100644 src/Pseudo/pseudo.ezfio_config create mode 100644 src/Pseudo/test_michel.irp.f diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py new file mode 100755 index 00000000..792df9de --- /dev/null +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -0,0 +1,183 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- +""" +Create the pseudo potential for a given atom + +Usage: + put_pseudo_in_ezfio.py --ezfio= --atom=... +""" + + +import os +import sys +from docopt import docopt + +from subprocess import Popen, PIPE + +qpackage_root = os.environ['QPACKAGE_ROOT'] + +EZFIO = "{0}/EZFIO".format(qpackage_root) +sys.path = [EZFIO + "/Python"] + sys.path + +from ezfio import ezfio + +import re +p = re.compile(ur'\|(\d+)><\d+\|') + + +def get_pseudo_str(l_atom): + """ + Run EMSL_local for geting the str of the speudo potential + """ + + EMSL_root = "{0}/EMSL_Basis/".format(qpackage_root) + EMSL_path = "{0}/EMSL_api.py".format(EMSL_root) + db_path = "{0}/db/Pseudo.db".format(EMSL_root) + + l_cmd_atom = [] + for a in l_atom: + l_cmd_atom += ["--atom", a] + + l_cmd_head = [EMSL_path, "get_basis_data", + "--db_path", db_path, + "--basis", "BFD-Pseudo"] + + process = Popen(l_cmd_head + l_cmd_atom, stdout=PIPE, stderr=PIPE) + + stdout, _ = process.communicate() + return stdout.strip() + + +def get_v_n_dz_local(str_ele): + """ + From a str_ele of the pseudo (aka only one ele in the str) + get the list ussefull for the Local potential : v_k n_k and dz_k + """ + l_v_k = [] + l_n_k = [] + l_dz_k = [] + + for l in str_ele.splitlines(): + try: + v, n, dz = l.split() + v = float(v) + n = int(n) + dz = float(dz) + except ValueError: + pass + else: + l_v_k.append(v) + l_n_k.append(n) + l_dz_k.append(dz) + + return l_v_k, l_n_k, l_dz_k + + +def get_v_n_dz_l_nonlocal(str_ele): + """ + From a str_ele of the pseudo (aka only one ele in the str) + get the list ussefull for the non Local potential + v_kl (v, l) + n_k (v, l) + dz_k (dz ,l) + """ + l_v_kl = [] + l_n_kl = [] + l_dz_kl = [] + + for l in str_ele.splitlines(): + try: + v, n, dz, proj = l.split() + v = float(v) + n = int(n) + dz = float(dz) + l = int(p.match(proj).group(1)) + + except ValueError: + pass + else: + l_v_kl.append((v, l)) + l_n_kl.append((n, l)) + l_dz_kl.append((dz, l)) + + return l_v_kl, l_n_kl, l_dz_kl + + +if __name__ == "__main__": + arguments = docopt(__doc__) + + # ___ + # | ._ o _|_ + # _|_ | | | |_ + # + + # ~#~#~#~#~ # + # E Z F I O # + # ~#~#~#~#~ # + + ezfio_path = arguments["--ezfio"] + ezfio_path = os.path.expanduser(ezfio_path) + ezfio_path = os.path.expandvars(ezfio_path) + ezfio_path = os.path.abspath(ezfio_path) + + ezfio.set_file("{0}".format(ezfio_path)) + + # ~#~#~#~#~#~#~#~#~#~#~ # + # P s e u d o _ d a t a # + # ~#~#~#~#~#~#~#~#~#~#~ # + + l_ele = arguments["--atom"] + str_ = get_pseudo_str(l_ele) + + # _ + # |_) _. ._ _ _ + # | (_| | _> (/_ + # + + l_str_ele = [str_ele for str_ele in str_.split("Element Symbol: ") + if str_ele] + + for str_ele in l_str_ele: + + # ~#~#~#~#~ # + # S p l i t # + # ~#~#~#~#~ # + + l = str_ele.find("Local component:") + nl = str_ele.find("Non-local component") + + # ~#~#~#~#~ # + # L o c a l # + # ~#~#~#~#~ # + + print "local" + + l_v, l_n, l_dz = get_v_n_dz_local(str_ele[l:nl]) + + print l_v + print l_n + print l_dz + + ezfio.pseudo_klocmax = len(l_v) + ezfio.pseudo_v_k = l_v + ezfio.pseudo_n_k = l_n + ezfio.pseudo_dz_k = l_dz + + # ~#~#~#~#~#~#~#~#~ # + # N o n _ L o c a l # + # ~#~#~#~#~#~#~#~#~ # + + print "non local" + + l_v_kl, l_n_kl, l_dz_kl = get_v_n_dz_l_nonlocal(str_ele[nl:]) + + print l_v_kl + print l_n_kl + print l_dz_kl + + if l_v_kl: + ezfio.pseudo_lmax = max([i[1] for i in l_v_kl]) + 1 + ezfio.pseudo_kmax = len(l_v_kl) + ezfio.pseudo_v_kl = l_v_kl + ezfio.pseudo_n_kl = l_n_kl + ezfio.pseudo_dz_kl = l_dz_kl diff --git a/setup_environment.sh b/setup_environment.sh index c3dc4194..59f3af70 100755 --- a/setup_environment.sh +++ b/setup_environment.sh @@ -17,7 +17,9 @@ export QPACKAGE_ROOT=\$( cd \$(dirname "\${BASH_SOURCE}") ; pwd -P ) export LD_LIBRARY_PATH="\${QPACKAGE_ROOT}"/lib:\${LD_LIBRARY_PATH} export LIBRARY_PATH="\${QPACKAGE_ROOT}"/lib:\${LIBRARY_PATH} export C_INCLUDE_PATH="\${QPACKAGE_ROOT}"/include:\${C_INCLUDE_PATH} -export PYTHONPATH=\${PYTHONPATH}:"\${QPACKAGE_ROOT}"/scripts:"\${QPACKAGE_ROOT}"/scripts/ezfio_interface +export PYTHONPATH=\${PYTHONPATH}:"\${QPACKAGE_ROOT}"/scripts +export PYTHONPATH=\${PYTHONPATH}:"\${QPACKAGE_ROOT}"/scripts/ezfio_interface +export PYTHONPATH=\${PYTHONPATH}:"\${QPACKAGE_ROOT}"/scripts/pseudo export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/scripts:"\${QPACKAGE_ROOT}"/scripts/ezfio_interface export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/bin export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/ocaml diff --git a/src/Pseudo/NEEDED_MODULES b/src/Pseudo/NEEDED_MODULES index e69de29b..542760a9 100644 --- a/src/Pseudo/NEEDED_MODULES +++ b/src/Pseudo/NEEDED_MODULES @@ -0,0 +1 @@ +Ezfio_files Nuclei Output Utils \ No newline at end of file diff --git a/src/Pseudo/int.f90 b/src/Pseudo/int.f90 index 16aca8e0..b67e6102 100644 --- a/src/Pseudo/int.f90 +++ b/src/Pseudo/int.f90 @@ -1,60 +1,3 @@ -!! -!! Computation of Vps, matrix element of the -!! pseudo-potential centered at point C -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Vps= < Phi_A | Vloc(C) + Vpp(C) | Phi_B> -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Phi_M (M=A,B) Cartesian gaussian orbital centered at point M : -!! Phi_M = (x-M_x)**n^M_x *(y-M_y)**n^M_y *(z-M_z)**n^M_z exp(-g_M rM**2) -!! with rM**2=(x-M_x)**2 + (y-M_y)**2 + (z-M_z)**2 -!! -!!** Vloc(C)= \sum_{k=1}^klocmax v_k rC**n_k exp(-dz_k rC**2) -!! -!!** Vpp(C)= \sum_{l=0}^lmax v_l(rC) \sum_{m=-l}^{m=l} |Y_lm> : -!! function Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) -!! lmax of formula above -!! kmax of formula above -!! v_kl = array v_kl(kmax_max,0:lmax_max) -!! n_kl = array n_kl(kmax_max,0:lmax_max) -!! dz_kl = array dz_kl(kmax_max,0:lmax_max) -!! n_a(1),n_a(2),n_a(3) -!! a(1),a(2),a(3) -!! g_a -!! n_b(1),n_b(2),n_b(3) -!! b(1),b(2),b(3) -!! g_b -!! c(1),c(2),c(3) -!! -!! Routine computing : -!! function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) -!! klocmax of formula above -!! v_k = array v_k(klocmax_max) -!! n_k = array n_k(klocmax_max) -!! dz_k= array dz_k(klocmax_max) -!! Routine total matrix element : -!! function Vps(a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) -!! -!! Routines Vps_num, Vpseudo_num, and Vloc_num = brute force numerical -!! estimations of the same integrals - - !! Vps= !! !! with: Vloc(C)=\sum_{k=1}^klocmax v_k rC**n_k exp(-dz_k rC**2) @@ -1019,15 +962,6 @@ end ! Y_l^m(theta,phi) = i^(m+|m|) ([(2l+1)*(l-|m|)!]/[4pi*(l+|m|)!])^1/2 ! P_l^|m|(cos(theta)) exp(i m phi) - double precision function fact(n) - implicit double precision(a-h,o-z) - fact=1.d0 - if(n.eq.0)return - do i=1,n - fact=fact*dfloat(i) - enddo - end - subroutine erreur(x,n,rmoy,error) implicit double precision(a-h,o-z) dimension x(n) diff --git a/src/Pseudo/pseudo.ezfio_config b/src/Pseudo/pseudo.ezfio_config new file mode 100644 index 00000000..1ed75773 --- /dev/null +++ b/src/Pseudo/pseudo.ezfio_config @@ -0,0 +1,10 @@ +pseudo + klocmax integer + v_k double precision (pseudo_klocmax) + n_k integer (pseudo_klocmax) + dz_k double precision (pseudo_klocmax) + lmax integer + kmax integer + v_kl double precision (pseudo_kmax,pseudo_lmax) + n_kl integer (pseudo_kmax,pseudo_lmax) + dz_kl double precision (pseudo_kmax,pseudo_lmax) \ No newline at end of file diff --git a/src/Pseudo/test_michel.irp.f b/src/Pseudo/test_michel.irp.f new file mode 100644 index 00000000..e290ea4a --- /dev/null +++ b/src/Pseudo/test_michel.irp.f @@ -0,0 +1,188 @@ +!! +!! Computation of Vps, matrix element of the +!! pseudo-potential centered at point C +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Vps= < Phi_A | Vloc(C) + Vpp(C) | Phi_B> +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Phi_M (M=A,B) Cartesian gaussian orbital centered at point M : +!! Phi_M = (x-M_x)**n^M_x *(y-M_y)**n^M_y *(z-M_z)**n^M_z exp(-g_M rM**2) +!! with rM**2=(x-M_x)**2 + (y-M_y)**2 + (z-M_z)**2 +!! +!!** Vloc(C)= \sum_{k=1}^klocmax v_k rC**n_k exp(-dz_k rC**2) +!! +!!** Vpp(C)= \sum_{l=0}^lmax v_l(rC) \sum_{m=-l}^{m=l} |Y_lm> : +!! function Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) +!! lmax of formula above +!! kmax of formula above +!! v_kl = array v_kl(kmax_max,0:lmax_max) +!! n_kl = array n_kl(kmax_max,0:lmax_max) +!! dz_kl = array dz_kl(kmax_max,0:lmax_max) +!! n_a(1),n_a(2),n_a(3) +!! a(1),a(2),a(3) +!! g_a +!! n_b(1),n_b(2),n_b(3) +!! b(1),b(2),b(3) +!! g_b +!! c(1),c(2),c(3) +!! +!! Routine computing : +!! function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) +!! klocmax of formula above +!! v_k = array v_k(klocmax_max) +!! n_k = array n_k(klocmax_max) +!! dz_k= array dz_k(klocmax_max) +!! Routine total matrix element : +!! function Vps(a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) +!! +!! Routines Vps_num, Vpseudo_num, and Vloc_num = brute force numerical +!! estimations of the same integrals + + +program compute_integrals_pseudo + implicit none + integer n_a(3),n_b(3),npts + double precision g_a,g_b,a(3),b(3),c(3) + double precision Vpseudo,Vpseudo_num,Vloc,Vloc_num + double precision v3,v4 + + + double precision vps,vps_num + + ! PSEUDOS + integer nptsgridmax,nptsgrid + double precision coefs_pseudo,ptsgrid + + double precision rmax + double precision time_1,time_2,time_3,time_4,time_5 + integer kga,kgb,na1,na2,na3,nb1,nb2,nb3 + + CALL RANDOM_SEED() + + nptsgrid=50 + call initpseudos(nptsgrid) + + PROVIDE ezfio_filename + + ! + ! | _ _ _. | + ! |_ (_) (_ (_| | + ! + + integer klocmax + integer, allocatable :: n_k(:) + double precision, allocatable :: v_k(:), dz_k(:) + + call ezfio_get_pseudo_klocmax(klocmax) + + allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) + + call ezfio_get_pseudo_v_k(v_k) + call ezfio_get_pseudo_n_k(n_k) + call ezfio_get_pseudo_dz_k(dz_k) + + print*, "klocmax", klocmax + + print*, "n_k_ezfio", n_k + print*, "v_k_ezfio",v_k + print*, "dz_k_ezfio", dz_k + + ! + ! |\ | _ ._ | _ _ _. | + ! | \| (_) | | | (_) (_ (_| | + ! + + !! Parameters of non local part of pseudo: + + integer :: kmax,lmax + integer, allocatable :: n_kl(:,:) + double precision, allocatable :: v_kl(:,:), dz_kl(:,:) + + call ezfio_get_pseudo_lmax(lmax) + call ezfio_get_pseudo_kmax(kmax) + lmax = lmax - 1 + + allocate(n_kl(kmax,0:lmax), v_kl(kmax,0:lmax), dz_kl(kmax,0:lmax)) + + call ezfio_get_pseudo_n_kl(n_kl) + call ezfio_get_pseudo_v_kl(v_kl) + call ezfio_get_pseudo_dz_kl(dz_kl) + + + print*, "lmax",lmax + print*, "kmax", kmax + + print*,"n_kl_ezfio", n_kl + print*,"v_kl_ezfio", v_kl + print*,"dz_kl_ezfio", dz_kl + + ! _ + ! / _. | _ | + ! \_ (_| | (_ |_| | + ! + + write(*,*)'a?' + read*,a(1),a(2),a(3) + !write(*,*)'b?' + !read*,b(1),b(2),b(3) + b(1)=-0.1d0 + b(2)=-0.2d0 + b(3)=0.3d0 + !write(*,*)'a?' + !read*,c(1),c(2),c(3) + c(1)=0.1d0 + c(2)=0.2d0 + c(3)=0.3d0 + + print*,'ntps? rmax for brute force integration' + read*,npts,rmax + + do kga=0,5 + g_a=10.d0**kga + do kgb=0,5 + g_b=10.d0**kgb + + do na1=0,1 + do na2=0,1 + do na3=0,1 + do nb1=0,1 + do nb2=0,1 + do nb3=0,1 + n_a(1)=na1 + n_a(2)=na2 + n_a(3)=na3 + n_b(1)=nb1 + n_b(2)=nb2 + n_b(3)=nb3 + + v3=Vps(a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) + v4=Vps_num(npts,rmax,a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) + print*,'Vps= ',v3,' Vps_num=',v4,' diff=',v4-v3 + write(33,'(3f10.6)')v3,v4,v4-v3 + + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + +end From 5240e59d40d6db7e6335bf5e0bcfc2ca7c6fab80 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 7 Apr 2015 08:38:55 +0200 Subject: [PATCH 03/70] Mv Pseudo in MonoInts --- src/MonoInts/Makefile | 6 +++--- src/{Pseudo => MonoInts}/int.f90 | 0 src/{Pseudo => MonoInts}/pseudo.ezfio_config | 0 src/{Pseudo => MonoInts}/test_michel.irp.f | 0 src/NEEDED_MODULES | 2 +- src/Pseudo/ASSUMPTIONS.rst | 0 src/Pseudo/Makefile | 6 ------ src/Pseudo/NEEDED_MODULES | 1 - src/Pseudo/README.rst | 4 ---- 9 files changed, 4 insertions(+), 15 deletions(-) rename src/{Pseudo => MonoInts}/int.f90 (100%) rename src/{Pseudo => MonoInts}/pseudo.ezfio_config (100%) rename src/{Pseudo => MonoInts}/test_michel.irp.f (100%) delete mode 100644 src/Pseudo/ASSUMPTIONS.rst delete mode 100644 src/Pseudo/Makefile delete mode 100644 src/Pseudo/NEEDED_MODULES delete mode 100644 src/Pseudo/README.rst diff --git a/src/MonoInts/Makefile b/src/MonoInts/Makefile index 06dc50ff..8ae5c9fb 100644 --- a/src/MonoInts/Makefile +++ b/src/MonoInts/Makefile @@ -1,6 +1,6 @@ # Define here all new external source files and objects.Don't forget to prefix the # object files with IRPF90_temp/ -SRC= -OBJ= +SRC=int.f90 +OBJ=IRPF90_temp/int.o -include $(QPACKAGE_ROOT)/src/Makefile.common +include $(QPACKAGE_ROOT)/src/Makefile.common \ No newline at end of file diff --git a/src/Pseudo/int.f90 b/src/MonoInts/int.f90 similarity index 100% rename from src/Pseudo/int.f90 rename to src/MonoInts/int.f90 diff --git a/src/Pseudo/pseudo.ezfio_config b/src/MonoInts/pseudo.ezfio_config similarity index 100% rename from src/Pseudo/pseudo.ezfio_config rename to src/MonoInts/pseudo.ezfio_config diff --git a/src/Pseudo/test_michel.irp.f b/src/MonoInts/test_michel.irp.f similarity index 100% rename from src/Pseudo/test_michel.irp.f rename to src/MonoInts/test_michel.irp.f diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index 35aa5ec3..a144c42c 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Dets Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD_selected DDCI_selected MRCC Pseudo +AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Dets Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD_selected DDCI_selected MRCC diff --git a/src/Pseudo/ASSUMPTIONS.rst b/src/Pseudo/ASSUMPTIONS.rst deleted file mode 100644 index e69de29b..00000000 diff --git a/src/Pseudo/Makefile b/src/Pseudo/Makefile deleted file mode 100644 index 5cf11b78..00000000 --- a/src/Pseudo/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -# Define here all new external source files and objects.Don't forget to prefix the -# object files with IRPF90_temp/ -SRC=int.f90 -OBJ=IRPF90_temp/int.o - -include $(QPACKAGE_ROOT)/src/Makefile.common diff --git a/src/Pseudo/NEEDED_MODULES b/src/Pseudo/NEEDED_MODULES deleted file mode 100644 index 542760a9..00000000 --- a/src/Pseudo/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -Ezfio_files Nuclei Output Utils \ No newline at end of file diff --git a/src/Pseudo/README.rst b/src/Pseudo/README.rst deleted file mode 100644 index ebb762c1..00000000 --- a/src/Pseudo/README.rst +++ /dev/null @@ -1,4 +0,0 @@ -======= - Module -======= - From ef65e3e51362dc5454f3b82cee5e611b0de6f41e Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 7 Apr 2015 10:27:22 +0200 Subject: [PATCH 04/70] New int.f90 working with A=B=C --- src/MonoInts/int.f90 | 12 +++++++++- src/MonoInts/pot_ao_ints.irp.f | 42 ++++++++++++++++++++++++++++++---- src/MonoInts/test_michel.irp.f | 32 ++++++++++++++++++-------- 3 files changed, 70 insertions(+), 16 deletions(-) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index b67e6102..640688d0 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -560,12 +560,22 @@ double precision int_prod_bessel_loc,binom,accu,prod,ylm,bigI,arg Vloc=0.d0 return endif - freal=dexp(-g_a*ac**2-g_b*bc**2) ntotA=n_a(1)+n_a(2)+n_a(3) ntotB=n_b(1)+n_b(2)+n_b(3) ntot=ntotA+ntotB + if(ac.eq.0.d0.and.bc.eq.0.d0)then + accu=0.d0 + do k=1,klocmax + accu=accu+v_k(k)*crochet(n_k(k)+2+ntot,g_a+g_b+dz_k(k)) + enddo + Vloc=accu*fourpi*bigI(0,0,0,0,n_a(1)+n_b(1),n_a(2)+n_b(2),n_a(3)+n_b(3)) + return + endif + + freal=dexp(-g_a*ac**2-g_b*bc**2) + d2=0.d0 do i=1,3 d(i)=g_a*(a(i)-c(i))+g_b*(b(i)-c(i)) diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index f430ace9..6ad38d6a 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -8,19 +8,43 @@ double precision :: A_center(3),B_center(3),C_center(3) integer :: power_A(3),power_B(3) integer :: i,j,k,l,n_pt_in,m - double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult + double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult, Vloc integer :: nucl_numC ! Important for OpenMP ao_nucl_elec_integral = 0.d0 + ! + ! | _ _ _. | + ! |_ (_) (_ (_| | + ! + + integer klocmax + integer, allocatable :: n_k(:) + double precision, allocatable :: v_k(:), dz_k(:) + + call ezfio_get_pseudo_klocmax(klocmax) + + allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) + + call ezfio_get_pseudo_v_k(v_k) + call ezfio_get_pseudo_n_k(n_k) + call ezfio_get_pseudo_dz_k(dz_k) + + print*, "klocmax", klocmax + + print*, "n_k_ezfio", n_k + print*, "v_k_ezfio",v_k + print*, "dz_k_ezfio", dz_k + !$OMP PARALLEL & !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & - !$OMP num_A,num_B,Z,c,n_pt_in) & + !$OMP PRIVATE (i, j, k, l, m, alpha, beta, A_center, B_center, C_center, power_A, power_B, & + !$OMP num_A, num_B, Z, c, n_pt_in,& + !$OMP v_k, n_k, dz_k, klocmax) & !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & - !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) + !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) n_pt_in = n_pt_max_integrals !$OMP DO SCHEDULE (guided) do j = 1, ao_num @@ -50,7 +74,15 @@ C_center(1) = nucl_coord(k,1) C_center(2) = nucl_coord(k,2) C_center(3) = nucl_coord(k,3) - c = c+Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) + c = c + Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) + + print*, A_center + print*, B_center + print*, C_center + + print*, Vloc(klocmax,v_k,n_k,dz_k,A_center,power_A,alpha,B_center,power_B,beta,C_center) +! c = c + Z*Vloc(klocmax,v_k,n_k,dz_k,A_center,power_A,alpha,B_center,power_B,beta,C_center) + enddo ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) - & ao_coef_transp(l,j)*ao_coef_transp(m,i)*c diff --git a/src/MonoInts/test_michel.irp.f b/src/MonoInts/test_michel.irp.f index e290ea4a..c7e3c685 100644 --- a/src/MonoInts/test_michel.irp.f +++ b/src/MonoInts/test_michel.irp.f @@ -137,19 +137,31 @@ program compute_integrals_pseudo ! \_ (_| | (_ |_| | ! - write(*,*)'a?' - read*,a(1),a(2),a(3) +! write(*,*)'a?' +! read*,a(1),a(2),a(3) !write(*,*)'b?' !read*,b(1),b(2),b(3) - b(1)=-0.1d0 - b(2)=-0.2d0 - b(3)=0.3d0 - !write(*,*)'a?' - !read*,c(1),c(2),c(3) - c(1)=0.1d0 - c(2)=0.2d0 - c(3)=0.3d0 +! b(1)=-0.1d0 +! b(2)=-0.2d0 +! b(3)=0.3d0 +! !write(*,*)'a?' +! !read*,c(1),c(2),c(3) +! c(1)=0.1d0 +! c(2)=0.2d0 +! c(3)=0.3d0 + a(1)= 0.d0 + a(2)= 0.d0 + a(3)= 0.d0 + + b(1)= 0.d0 + b(2)= 0.d0 + b(3)= 0.d0 + + c(1)= 0.d0 + c(2)= 0.d0 + c(3)= 0.d0 + print*,'ntps? rmax for brute force integration' read*,npts,rmax From cca5ebc404ab3c6689a677b895afbe0b0ee80329 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 7 Apr 2015 14:24:05 +0200 Subject: [PATCH 05/70] Move need.irp.f into MonoInts --- src/MonoInts/need.irp.f | 289 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 289 insertions(+) create mode 100644 src/MonoInts/need.irp.f diff --git a/src/MonoInts/need.irp.f b/src/MonoInts/need.irp.f new file mode 100644 index 00000000..22cb6a48 --- /dev/null +++ b/src/MonoInts/need.irp.f @@ -0,0 +1,289 @@ + + double precision function SABpartial(zA,zB,A,B,nA,nB,gamA,gamB) + implicit double precision(a-h,o-z) + dimension nA(3),nB(3) + dimension A(3),B(3) + gamtot=gamA+gamB + SABpartial=1.d0 + + l=3 + u=gamA/gamtot*A(l)+gamB/gamtot*B(l) + arg=gamtot*u**2-gamA*A(l)**2-gamB*B(l)**2 + alpha=dexp(arg) + &/gamtot**((1.d0+dfloat(nA(l))+dfloat(nB(l)))/2.d0) + wA=dsqrt(gamtot)*(u-A(l)) + wB=dsqrt(gamtot)*(u-B(l)) + boundA=dsqrt(gamtot)*(zA-u) + boundB=dsqrt(gamtot)*(zB-u) + + accu=0.d0 + do n=0,nA(l) + do m=0,nB(l) + integ=nA(l)+nB(l)-n-m + accu=accu + & +wA**n*wB**m*binom(nA(l),n)*binom(nB(l),m) + & *(rinteg(integ,boundB)-rinteg(integ,boundA)) + enddo + enddo + SABpartial=SABpartial*accu*alpha + end + + double precision function rintgauss(n) + implicit double precision(a-h,o-z) + rintgauss=dsqrt(dacos(-1.d0)) + if(n.eq.0)return + if(n.eq.1)then + rintgauss=0.d0 + return + endif + if(iand(n,1).eq.1)then + rintgauss=0.d0 + return + endif + rintgauss=rintgauss/2.d0**(n/2) + rintgauss=rintgauss*ddfact2(n-1) + end + + double precision function rinteg(n,u) + implicit double precision(a-h,o-z) + include 'constants.F' +! pi=dacos(-1.d0) + ichange=1 + factor=1.d0 + if(u.lt.0.d0)then + u=-u + factor=(-1.d0)**(n+1) + ichange=-1 + endif + if(iand(n,1).eq.0)then + rinteg=0.d0 + do l=0,n-2,2 + prod=b_coef(l,u) + do k=l+2,n-2,2 + prod=prod*a_coef(k) + enddo + rinteg=rinteg+prod + enddo + prod=dsqrt(pi)/2.d0*erf0(u) + do k=0,n-2,2 + prod=prod*a_coef(k) + enddo + rinteg=rinteg+prod + endif + + if(iand(n,1).eq.1)then + rinteg=0.d0 + do l=1,n-2,2 + prod=b_coef(l,u) + do k=l+2,n-2,2 + prod=prod*a_coef(k) + enddo + rinteg=rinteg+prod + enddo + prod=0.5d0*(1.d0-dexp(-u**2)) + do k=1,n-2,2 + prod=prod*a_coef(k) + enddo + rinteg=rinteg+prod + endif + + rinteg=rinteg*factor + + if(ichange.eq.-1)u=-u + + end + +! +! +! +! +! +! +! +! + double precision function erf0(x) + implicit double precision (a-h,o-z) + if(x.lt.0.d0)then + erf0=-gammp(0.5d0,x**2) + else + erf0=gammp(0.5d0,x**2) + endif + end + + +! +! +! +! +! +! +! +! +! +! +! +! gcf +! gser +! +! +! + double precision function gammp(a,x) + implicit double precision (a-h,o-z) + if(x.lt.0..or.a.le.0.)stop 'error in gammp' + if(x.lt.a+1.)then + call gser(gammp,a,x,gln) + else + call gcf(gammcf,a,x,gln) + gammp=1.-gammcf + endif + return + end +! +! + + +! +! +! +! +! +! +! +! +! +! +! +! gammp +! +! +! + subroutine gser(gamser,a,x,gln) + implicit double precision (a-h,o-z) + parameter (itmax=100,eps=3.e-7) + gln=gammln(a) + if(x.le.0.)then + if(x.lt.0.) stop 'error in gser' + gamser=0. + return + endif + ap=a + sum=1./a + del=sum + do 11 n=1,itmax + ap=ap+1. + del=del*x/ap + sum=sum+del + if(abs(del).lt.abs(sum)*eps)go to 1 +11 continue + stop 'a too large, itmax too small' +1 gamser=sum*exp(-x+a*log(x)-gln) + return + end +! + +! +! +! +! +! +! +! +! +! +! +! +! +! gammp +! +! +! + subroutine gcf(gammcf,a,x,gln) + implicit double precision (a-h,o-z) + parameter (itmax=100,eps=3.e-7) + gln=gammln(a) + gold=0. + a0=1. + a1=x + b0=0. + b1=1. + fac=1. + do 11 n=1,itmax + an=float(n) + ana=an-a + a0=(a1+a0*ana)*fac + b0=(b1+b0*ana)*fac + anf=an*fac + a1=x*a0+anf*a1 + b1=x*b0+anf*b1 + if(a1.ne.0.)then + fac=1./a1 + g=b1*fac + if(abs((g-gold)/g).lt.eps)go to 1 + gold=g + endif +11 continue + stop 'a too large, itmax too small' +1 gammcf=exp(-x+a*log(x)-gln)*g + return + end + +! +! + double precision function ddfact2(n) + implicit double precision(a-h,o-z) + if(iand(n,1).eq.0)stop 'error in ddfact2' + ddfact2=1.d0 + do i=1,n,2 + ddfact2=ddfact2*dfloat(i) + enddo + end + + double precision function a_coef(n) + implicit double precision(a-h,o-z) + a_coef=dfloat(n+1)/2.d0 + end + + double precision function b_coef(n,u) + implicit double precision(a-h,o-z) + b_coef=-0.5d0*u**(n+1)*dexp(-u**2) + end + +! +! +! +! +! +! +! +! + double precision function gammln(xx) + implicit double precision (a-h,o-z) + real*8 cof(6),stp,half,one,fpf,x,tmp,ser + data cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0, + * -1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/ + data half,one,fpf/0.5d0,1.0d0,5.5d0/ + x=xx-one + tmp=x+fpf + tmp=(x+half)*log(tmp)-tmp + ser=one + do 11 j=1,6 + x=x+one + ser=ser+cof(j)/x +11 continue + gammln=tmp+log(stp*ser) + return + end +! +! From 64ea60c7277af739abeed790ab9d23b032535bff Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 7 Apr 2015 16:59:42 +0200 Subject: [PATCH 06/70] Working Local --- scripts/get_basis.sh | 6 +- src/MonoInts/int.f90 | 83 +--------- src/MonoInts/pot_ao_ints.irp.f | 63 +++++-- src/Properties/need.irp.f | 289 --------------------------------- 4 files changed, 54 insertions(+), 387 deletions(-) delete mode 100644 src/Properties/need.irp.f diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index 51b0a4f0..b5be03ac 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -42,9 +42,9 @@ then echo "ERROR" exit 1 fi -${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" $atoms - - +#${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" $atoms +cp He.dz_filipi.basis ${tmpfile} +echo ${tmpfile} diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index 640688d0..dc07fa54 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -550,7 +550,6 @@ double precision,allocatable :: array_R_loc(:,:,:) double precision,allocatable :: array_coefs(:,:,:,:,:,:) double precision int_prod_bessel_loc,binom,accu,prod,ylm,bigI,arg - fourpi=4.d0*dacos(-1.d0) f=fourpi**1.5d0 ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) @@ -567,6 +566,7 @@ double precision int_prod_bessel_loc,binom,accu,prod,ylm,bigI,arg if(ac.eq.0.d0.and.bc.eq.0.d0)then accu=0.d0 + do k=1,klocmax accu=accu+v_k(k)*crochet(n_k(k)+2+ntot,g_a+g_b+dz_k(k)) enddo @@ -1727,87 +1727,6 @@ end RETURN END - double precision FUNCTION GAMMLN(XX) - implicit double precision(a-h,o-z) - REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER - DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0, & - -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/ - DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/ - X=XX-ONE - TMP=X+FPF - TMP=(X+HALF)*DLOG(TMP)-TMP - SER=ONE - DO 11 J=1,6 - X=X+ONE - SER=SER+COF(J)/X -11 CONTINUE - GAMMLN=TMP+DLOG(STP*SER) - RETURN - END - FUNCTION GAMMP(A,X) - implicit double precision(a-h,o-z) - IF(X.LT.0.d0.OR.A.LE.0.d0)PAUSE - IF(X.LT.A+1.d0)THEN - CALL GSER(GAMMP,A,X,GLN) - ELSE - CALL GCF(GAMMCF,A,X,GLN) - GAMMP=1.d0-GAMMCF - ENDIF - RETURN - END - SUBROUTINE GCF(GAMMCF,A,X,GLN) - implicit double precision(a-h,o-z) - PARAMETER (ITMAX=100,EPS=3.D-7) - GLN=GAMMLN(A) - GOLD=0.d0 - A0=1.d0 - A1=X - B0=0.d0 - B1=1.d0 - FAC=1.d0 - DO 11 N=1,ITMAX - AN=DFLOAT(N) - ANA=AN-A - A0=(A1+A0*ANA)*FAC - B0=(B1+B0*ANA)*FAC - ANF=AN*FAC - A1=X*A0+ANF*A1 - B1=X*B0+ANF*B1 - IF(A1.NE.0.d0)THEN - FAC=1.d0/A1 - G=B1*FAC - IF(DABS((G-GOLD)/G).LT.EPS)GO TO 1 - GOLD=G - ENDIF -11 CONTINUE - PAUSE 'A TOO LARGE, ITMAX TOO SMALL' -1 GAMMCF=DEXP(-X+A*DLOG(X)-GLN)*G - RETURN - END - SUBROUTINE GSER(GAMSER,A,X,GLN) - implicit double precision(a-h,o-z) - PARAMETER (ITMAX=100,EPS=3.D-7) - GLN=GAMMLN(A) - IF(X.LE.0.d0)THEN - IF(X.LT.0.d0)PAUSE - GAMSER=0.d0 - RETURN - ENDIF - AP=A - SUM=1.d0/A - DEL=SUM - DO 11 N=1,ITMAX - AP=AP+1.d0 - DEL=DEL*X/AP - SUM=SUM+DEL - IF(DABS(DEL).LT.DABS(SUM)*EPS)GO TO 1 -11 CONTINUE - PAUSE 'A TOO LARGE, ITMAX TOO SMALL' -1 GAMSER=SUM*DEXP(-X+A*DLOG(X)-GLN) - RETURN - END - - double precision function coef_nk(n,k) implicit none integer n,k diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index 6ad38d6a..7fd24174 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -8,7 +8,7 @@ double precision :: A_center(3),B_center(3),C_center(3) integer :: power_A(3),power_B(3) integer :: i,j,k,l,n_pt_in,m - double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult, Vloc + double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult, Vloc, Vpseudo integer :: nucl_numC ! Important for OpenMP @@ -38,13 +38,55 @@ print*, "dz_k_ezfio", dz_k + call ezfio_get_pseudo_v_k(v_k) + call ezfio_get_pseudo_n_k(n_k) + call ezfio_get_pseudo_dz_k(dz_k) + + print*, "klocmax", klocmax + + print*, "n_k_ezfio", n_k + print*, "v_k_ezfio",v_k + print*, "dz_k_ezfio", dz_k + + + ! + ! |\ | _ ._ | _ _ _. | + ! | \| (_) | | | (_) (_ (_| | + ! + + !! Parameters of non local part of pseudo: + + integer :: kmax,lmax + integer, allocatable :: n_kl(:,:) + double precision, allocatable :: v_kl(:,:), dz_kl(:,:) + + call ezfio_get_pseudo_lmax(lmax) + call ezfio_get_pseudo_kmax(kmax) + lmax = lmax - 1 + + allocate(n_kl(kmax,0:lmax), v_kl(kmax,0:lmax), dz_kl(kmax,0:lmax)) + + call ezfio_get_pseudo_n_kl(n_kl) + call ezfio_get_pseudo_v_kl(v_kl) + call ezfio_get_pseudo_dz_kl(dz_kl) + + + print*, "lmax",lmax + print*, "kmax", kmax + + print*,"n_kl_ezfio", n_kl + print*,"v_kl_ezfio", v_kl + print*,"dz_kl_ezfio", dz_kl + + !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i, j, k, l, m, alpha, beta, A_center, B_center, C_center, power_A, power_B, & - !$OMP num_A, num_B, Z, c, n_pt_in,& - !$OMP v_k, n_k, dz_k, klocmax) & + !$OMP num_A, num_B, Z, c, n_pt_in) & !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & - !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) + !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge, & + !$OMP v_k, n_k, dz_k, klocmax, & + !$OMP lmax,kmax,v_kl,n_kl,dz_kl) n_pt_in = n_pt_max_integrals !$OMP DO SCHEDULE (guided) do j = 1, ao_num @@ -74,18 +116,13 @@ C_center(1) = nucl_coord(k,1) C_center(2) = nucl_coord(k,2) C_center(3) = nucl_coord(k,3) + c = c + Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - - print*, A_center - print*, B_center - print*, C_center - - print*, Vloc(klocmax,v_k,n_k,dz_k,A_center,power_A,alpha,B_center,power_B,beta,C_center) -! c = c + Z*Vloc(klocmax,v_k,n_k,dz_k,A_center,power_A,alpha,B_center,power_B,beta,C_center) - + c = c - Vloc(klocmax,v_k,n_k,dz_k,A_center,power_A,alpha,B_center,power_B,beta,C_center) + c = c - Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,C_center) enddo ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) - & - ao_coef_transp(l,j)*ao_coef_transp(m,i)*c + ao_coef_transp(l,j)*ao_coef_transp(m,i)*c enddo enddo enddo diff --git a/src/Properties/need.irp.f b/src/Properties/need.irp.f deleted file mode 100644 index 22cb6a48..00000000 --- a/src/Properties/need.irp.f +++ /dev/null @@ -1,289 +0,0 @@ - - double precision function SABpartial(zA,zB,A,B,nA,nB,gamA,gamB) - implicit double precision(a-h,o-z) - dimension nA(3),nB(3) - dimension A(3),B(3) - gamtot=gamA+gamB - SABpartial=1.d0 - - l=3 - u=gamA/gamtot*A(l)+gamB/gamtot*B(l) - arg=gamtot*u**2-gamA*A(l)**2-gamB*B(l)**2 - alpha=dexp(arg) - &/gamtot**((1.d0+dfloat(nA(l))+dfloat(nB(l)))/2.d0) - wA=dsqrt(gamtot)*(u-A(l)) - wB=dsqrt(gamtot)*(u-B(l)) - boundA=dsqrt(gamtot)*(zA-u) - boundB=dsqrt(gamtot)*(zB-u) - - accu=0.d0 - do n=0,nA(l) - do m=0,nB(l) - integ=nA(l)+nB(l)-n-m - accu=accu - & +wA**n*wB**m*binom(nA(l),n)*binom(nB(l),m) - & *(rinteg(integ,boundB)-rinteg(integ,boundA)) - enddo - enddo - SABpartial=SABpartial*accu*alpha - end - - double precision function rintgauss(n) - implicit double precision(a-h,o-z) - rintgauss=dsqrt(dacos(-1.d0)) - if(n.eq.0)return - if(n.eq.1)then - rintgauss=0.d0 - return - endif - if(iand(n,1).eq.1)then - rintgauss=0.d0 - return - endif - rintgauss=rintgauss/2.d0**(n/2) - rintgauss=rintgauss*ddfact2(n-1) - end - - double precision function rinteg(n,u) - implicit double precision(a-h,o-z) - include 'constants.F' -! pi=dacos(-1.d0) - ichange=1 - factor=1.d0 - if(u.lt.0.d0)then - u=-u - factor=(-1.d0)**(n+1) - ichange=-1 - endif - if(iand(n,1).eq.0)then - rinteg=0.d0 - do l=0,n-2,2 - prod=b_coef(l,u) - do k=l+2,n-2,2 - prod=prod*a_coef(k) - enddo - rinteg=rinteg+prod - enddo - prod=dsqrt(pi)/2.d0*erf0(u) - do k=0,n-2,2 - prod=prod*a_coef(k) - enddo - rinteg=rinteg+prod - endif - - if(iand(n,1).eq.1)then - rinteg=0.d0 - do l=1,n-2,2 - prod=b_coef(l,u) - do k=l+2,n-2,2 - prod=prod*a_coef(k) - enddo - rinteg=rinteg+prod - enddo - prod=0.5d0*(1.d0-dexp(-u**2)) - do k=1,n-2,2 - prod=prod*a_coef(k) - enddo - rinteg=rinteg+prod - endif - - rinteg=rinteg*factor - - if(ichange.eq.-1)u=-u - - end - -! -! -! -! -! -! -! -! - double precision function erf0(x) - implicit double precision (a-h,o-z) - if(x.lt.0.d0)then - erf0=-gammp(0.5d0,x**2) - else - erf0=gammp(0.5d0,x**2) - endif - end - - -! -! -! -! -! -! -! -! -! -! -! -! gcf -! gser -! -! -! - double precision function gammp(a,x) - implicit double precision (a-h,o-z) - if(x.lt.0..or.a.le.0.)stop 'error in gammp' - if(x.lt.a+1.)then - call gser(gammp,a,x,gln) - else - call gcf(gammcf,a,x,gln) - gammp=1.-gammcf - endif - return - end -! -! - - -! -! -! -! -! -! -! -! -! -! -! -! gammp -! -! -! - subroutine gser(gamser,a,x,gln) - implicit double precision (a-h,o-z) - parameter (itmax=100,eps=3.e-7) - gln=gammln(a) - if(x.le.0.)then - if(x.lt.0.) stop 'error in gser' - gamser=0. - return - endif - ap=a - sum=1./a - del=sum - do 11 n=1,itmax - ap=ap+1. - del=del*x/ap - sum=sum+del - if(abs(del).lt.abs(sum)*eps)go to 1 -11 continue - stop 'a too large, itmax too small' -1 gamser=sum*exp(-x+a*log(x)-gln) - return - end -! - -! -! -! -! -! -! -! -! -! -! -! -! -! gammp -! -! -! - subroutine gcf(gammcf,a,x,gln) - implicit double precision (a-h,o-z) - parameter (itmax=100,eps=3.e-7) - gln=gammln(a) - gold=0. - a0=1. - a1=x - b0=0. - b1=1. - fac=1. - do 11 n=1,itmax - an=float(n) - ana=an-a - a0=(a1+a0*ana)*fac - b0=(b1+b0*ana)*fac - anf=an*fac - a1=x*a0+anf*a1 - b1=x*b0+anf*b1 - if(a1.ne.0.)then - fac=1./a1 - g=b1*fac - if(abs((g-gold)/g).lt.eps)go to 1 - gold=g - endif -11 continue - stop 'a too large, itmax too small' -1 gammcf=exp(-x+a*log(x)-gln)*g - return - end - -! -! - double precision function ddfact2(n) - implicit double precision(a-h,o-z) - if(iand(n,1).eq.0)stop 'error in ddfact2' - ddfact2=1.d0 - do i=1,n,2 - ddfact2=ddfact2*dfloat(i) - enddo - end - - double precision function a_coef(n) - implicit double precision(a-h,o-z) - a_coef=dfloat(n+1)/2.d0 - end - - double precision function b_coef(n,u) - implicit double precision(a-h,o-z) - b_coef=-0.5d0*u**(n+1)*dexp(-u**2) - end - -! -! -! -! -! -! -! -! - double precision function gammln(xx) - implicit double precision (a-h,o-z) - real*8 cof(6),stp,half,one,fpf,x,tmp,ser - data cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0, - * -1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/ - data half,one,fpf/0.5d0,1.0d0,5.5d0/ - x=xx-one - tmp=x+fpf - tmp=(x+half)*log(tmp)-tmp - ser=one - do 11 j=1,6 - x=x+one - ser=ser+cof(j)/x -11 continue - gammln=tmp+log(stp*ser) - return - end -! -! From 1cb79a58a41b2abe46a9df4855bf1f2db308fade Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 10 Apr 2015 09:43:28 +0200 Subject: [PATCH 07/70] Realy ugly (need to use create_ez and set alpha and beta), but working --- scripts/get_basis.sh | 2 +- scripts/pseudo/create_ez.sh | 14 +++ scripts/pseudo/put_pseudo_in_ezfio.py | 27 +++--- src/MonoInts/int.f90 | 15 ++-- src/MonoInts/pot_ao_ints.irp.f | 122 ++++++++++++++++---------- src/MonoInts/pseudo.ezfio_config | 8 +- src/MonoInts/test_michel.irp.f | 2 +- 7 files changed, 124 insertions(+), 66 deletions(-) create mode 100755 scripts/pseudo/create_ez.sh diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index b5be03ac..1d4e7472 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -45,6 +45,6 @@ fi #${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" $atoms -cp He.dz_filipi.basis ${tmpfile} +cp /home/razoa/quantum_package/scripts/pseudo/burkatzki_dz.basis ${tmpfile} echo ${tmpfile} diff --git a/scripts/pseudo/create_ez.sh b/scripts/pseudo/create_ez.sh new file mode 100755 index 00000000..3821d6c2 --- /dev/null +++ b/scripts/pseudo/create_ez.sh @@ -0,0 +1,14 @@ +#!/bin/bash +# $1 name +# $2 mult + +echo "name" $1 +echo "mul" $2 +echo "Zeff" $3 +echo "\`get_basis.sh\` need to be changed" + +rm -R $1.ezfio +qp_create_ezfio_from_xyz $1.xyz -b "cc-pvdz" -m $2 + +~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py --ezfio $1.ezfio/ --atom $1 --zeff $3 +qp_edit -c $1.ezfio \ No newline at end of file diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 792df9de..7d15f090 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -4,7 +4,7 @@ Create the pseudo potential for a given atom Usage: - put_pseudo_in_ezfio.py --ezfio= --atom=... + put_pseudo_in_ezfio.py --ezfio= --atom=... --zeff=... """ @@ -96,9 +96,14 @@ def get_v_n_dz_l_nonlocal(str_ele): except ValueError: pass else: - l_v_kl.append((v, l)) - l_n_kl.append((n, l)) - l_dz_kl.append((dz, l)) + l_v_kl.append([v]) + l_n_kl.append([n]) + l_dz_kl.append([dz]) + + if not l_v_kl: + l_v_kl.append([0.]) + l_n_kl.append([0]) + l_dz_kl.append([0.]) return l_v_kl, l_n_kl, l_dz_kl @@ -175,9 +180,11 @@ if __name__ == "__main__": print l_n_kl print l_dz_kl - if l_v_kl: - ezfio.pseudo_lmax = max([i[1] for i in l_v_kl]) + 1 - ezfio.pseudo_kmax = len(l_v_kl) - ezfio.pseudo_v_kl = l_v_kl - ezfio.pseudo_n_kl = l_n_kl - ezfio.pseudo_dz_kl = l_dz_kl + ezfio.pseudo_lmaxpo = len(l_v_kl) + ezfio.pseudo_kmax = len(l_v_kl[0]) + ezfio.pseudo_v_kl = l_v_kl + ezfio.pseudo_n_kl = l_n_kl + ezfio.pseudo_dz_kl = l_dz_kl + + if arguments["--zeff"]: + ezfio.nuclei_nucl_charge = map(int, arguments["--zeff"]) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index dc07fa54..cb95c3c9 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -8,7 +8,7 @@ implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3) integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) +parameter (kmax_max=4,lmax_max=2) integer lmax,kmax,n_kl(kmax_max,0:lmax_max) double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) integer klocmax_max @@ -18,7 +18,7 @@ double precision v_k(klocmax_max),dz_k(klocmax_max) double precision Vloc,Vpseudo Vps=Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) & - +Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) + +Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) end !! !! Vps_num: brute force numerical evaluation of the same matrix element Vps @@ -29,7 +29,7 @@ implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3),rmax integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) +parameter (kmax_max=4,lmax_max=2) integer lmax,kmax,n_kl(kmax_max,0:lmax_max) double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) integer klocmax_max;parameter (klocmax_max=10) @@ -170,12 +170,13 @@ end double precision function Vpseudo & (lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) implicit none +double precision, intent(in) :: a(3),g_a,b(3),g_b,c(3) + integer kmax_max,lmax_max,ntot_max,nkl_max -parameter (kmax_max=2,lmax_max=2,nkl_max=4) +parameter (kmax_max=4,lmax_max=2,nkl_max=4) parameter (ntot_max=10) integer lmax,kmax,n_kl(kmax_max,0:lmax_max),l,k double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -double precision a(3),g_a,b(3),g_b,c(3) double precision fourpi,f,prod,prodp,binom,accu,bigR,bigI,ylm double precision theta_AC0,phi_AC0,theta_BC0,phi_BC0,ac,bc,big double precision areal,freal,breal,t1,t2,int_prod_bessel @@ -474,7 +475,7 @@ end double precision function Vpseudo_num(npts,rmax,lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) implicit none integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) +parameter (kmax_max=4,lmax_max=2) integer lmax,kmax, n_kl(kmax_max,0:lmax_max),l,m,k,kk double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) double precision a(3),g_a,b(3),g_b,c(3),ac(3),bc(3) @@ -486,6 +487,7 @@ do l=1,3 ac(l)=a(l)-c(l) bc(l)=b(l)-c(l) enddo + dr=rmax/npts sum=0.d0 do l=0,lmax @@ -571,6 +573,7 @@ double precision int_prod_bessel_loc,binom,accu,prod,ylm,bigI,arg accu=accu+v_k(k)*crochet(n_k(k)+2+ntot,g_a+g_b+dz_k(k)) enddo Vloc=accu*fourpi*bigI(0,0,0,0,n_a(1)+n_b(1),n_a(2)+n_b(2),n_a(3)+n_b(3)) + !bigI frequantly is null return endif diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index 7fd24174..820ae937 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -8,7 +8,8 @@ double precision :: A_center(3),B_center(3),C_center(3) integer :: power_A(3),power_B(3) integer :: i,j,k,l,n_pt_in,m - double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult, Vloc, Vpseudo + double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult, Vloc, Vpseudo, Vpseudo_num + double precision :: dump integer :: nucl_numC ! Important for OpenMP @@ -20,27 +21,34 @@ ! integer klocmax - integer, allocatable :: n_k(:) - double precision, allocatable :: v_k(:), dz_k(:) +! integer, allocatable :: n_k(:) +! double precision, allocatable :: v_k(:), dz_k(:) +! +! call ezfio_get_pseudo_klocmax(klocmax) +! +! allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) +! +! call ezfio_get_pseudo_v_k(v_k) +! call ezfio_get_pseudo_n_k(n_k) +! call ezfio_get_pseudo_dz_k(dz_k) - call ezfio_get_pseudo_klocmax(klocmax) + klocmax = 3 - allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) + integer :: n_k(3) + double precision :: v_k(3), dz_k(3) - call ezfio_get_pseudo_v_k(v_k) - call ezfio_get_pseudo_n_k(n_k) - call ezfio_get_pseudo_dz_k(dz_k) + v_k(1) = 1.00000000d0 + v_k(2) = 5.35838717 + v_k(3) = -2.07764789 - print*, "klocmax", klocmax + n_k(1) = -1 + n_k(2) = 1 + n_k(3) = 0 - print*, "n_k_ezfio", n_k - print*, "v_k_ezfio",v_k - print*, "dz_k_ezfio", dz_k - - - call ezfio_get_pseudo_v_k(v_k) - call ezfio_get_pseudo_n_k(n_k) - call ezfio_get_pseudo_dz_k(dz_k) + dz_k(1) = 5.35838717 + dz_k(2) = 3.67918975 + dz_k(3) = 1.60507673 + print*, "klocmax", klocmax @@ -56,72 +64,98 @@ !! Parameters of non local part of pseudo: - integer :: kmax,lmax - integer, allocatable :: n_kl(:,:) - double precision, allocatable :: v_kl(:,:), dz_kl(:,:) + integer :: kmax,lmax + integer, allocatable :: n_kl(:,:) + double precision, allocatable :: v_kl(:,:), dz_kl(:,:) - call ezfio_get_pseudo_lmax(lmax) + call ezfio_get_pseudo_lmaxpo(lmax) call ezfio_get_pseudo_kmax(kmax) + !lmax plus one -> lmax lmax = lmax - 1 - + allocate(n_kl(kmax,0:lmax), v_kl(kmax,0:lmax), dz_kl(kmax,0:lmax)) call ezfio_get_pseudo_n_kl(n_kl) call ezfio_get_pseudo_v_kl(v_kl) call ezfio_get_pseudo_dz_kl(dz_kl) + print*, "raw" - print*, "lmax",lmax print*, "kmax", kmax + print*, "lmax",lmax print*,"n_kl_ezfio", n_kl print*,"v_kl_ezfio", v_kl print*,"dz_kl_ezfio", dz_kl +! lmax = 1 +! kmax = 1 + +! integer :: n_kl(1,0:1) +! double precision :: v_kl(1,0:1), dz_kl(1,0:1) + +! v_kl(1,0) =10.69640234 +! n_kl(1,0) = 0 +! dz_kl(1,0) = 1.32389367 +! +! v_kl(1,1) = 10.11238853 +! n_kl(1,1) = 0 +! dz_kl(1,1) = 1.14052020 +! +! print*, "kmax", kmax +! print*, "lmax",lmax +! +! print*,"n_kl_ezfio", n_kl +! print*,"v_kl_ezfio", v_kl +! print*,"dz_kl_ezfio", dz_kl + + !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i, j, k, l, m, alpha, beta, A_center, B_center, C_center, power_A, power_B, & - !$OMP num_A, num_B, Z, c, n_pt_in) & + !$OMP num_A, num_B, Z, c, n_pt_in, dump) & !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge, & !$OMP v_k, n_k, dz_k, klocmax, & !$OMP lmax,kmax,v_kl,n_kl,dz_kl) + n_pt_in = n_pt_max_integrals !$OMP DO SCHEDULE (guided) do j = 1, ao_num - power_A(1)= ao_power(j,1) - power_A(2)= ao_power(j,2) - power_A(3)= ao_power(j,3) + num_A = ao_nucl(j) - A_center(1) = nucl_coord(num_A,1) - A_center(2) = nucl_coord(num_A,2) - A_center(3) = nucl_coord(num_A,3) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + do i = 1, ao_num - power_B(1)= ao_power(i,1) - power_B(2)= ao_power(i,2) - power_B(3)= ao_power(i,3) + num_B = ao_nucl(i) - B_center(1) = nucl_coord(num_B,1) - B_center(2) = nucl_coord(num_B,2) - B_center(3) = nucl_coord(num_B,3) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + do l=1,ao_prim_num(j) alpha = ao_expo_transp(l,j) + do m=1,ao_prim_num(i) beta = ao_expo_transp(m,i) + + double precision :: c c = 0.d0 do k = 1, nucl_num - double precision :: Z,c + double precision :: Z Z = nucl_charge(k) - C_center(1) = nucl_coord(k,1) - C_center(2) = nucl_coord(k,2) - C_center(3) = nucl_coord(k,3) - c = c + Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - c = c - Vloc(klocmax,v_k,n_k,dz_k,A_center,power_A,alpha,B_center,power_B,beta,C_center) - c = c - Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,C_center) + C_center(1:3) = nucl_coord(k,1:3) + + c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) + + c = c + Vloc( klocmax ,v_k ,n_k ,dz_k, A_center,power_A,alpha,B_center,power_B,beta,C_center) + c = c + Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) +! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) + enddo - ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) - & + ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) + & ao_coef_transp(l,j)*ao_coef_transp(m,i)*c enddo enddo diff --git a/src/MonoInts/pseudo.ezfio_config b/src/MonoInts/pseudo.ezfio_config index 1ed75773..941c8ee7 100644 --- a/src/MonoInts/pseudo.ezfio_config +++ b/src/MonoInts/pseudo.ezfio_config @@ -3,8 +3,8 @@ pseudo v_k double precision (pseudo_klocmax) n_k integer (pseudo_klocmax) dz_k double precision (pseudo_klocmax) - lmax integer + lmaxpo integer kmax integer - v_kl double precision (pseudo_kmax,pseudo_lmax) - n_kl integer (pseudo_kmax,pseudo_lmax) - dz_kl double precision (pseudo_kmax,pseudo_lmax) \ No newline at end of file + v_kl double precision (pseudo_kmax,pseudo_lmaxpo) + n_kl integer (pseudo_kmax,pseudo_lmaxpo) + dz_kl double precision (pseudo_kmax,pseudo_lmaxpo) \ No newline at end of file diff --git a/src/MonoInts/test_michel.irp.f b/src/MonoInts/test_michel.irp.f index c7e3c685..ef905479 100644 --- a/src/MonoInts/test_michel.irp.f +++ b/src/MonoInts/test_michel.irp.f @@ -114,7 +114,7 @@ program compute_integrals_pseudo integer, allocatable :: n_kl(:,:) double precision, allocatable :: v_kl(:,:), dz_kl(:,:) - call ezfio_get_pseudo_lmax(lmax) + call ezfio_get_pseudo_lmaxpo(lmax) call ezfio_get_pseudo_kmax(kmax) lmax = lmax - 1 From 0ebbe6f82070481ef47aa2229461c3573c6968ef Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 10 Apr 2015 10:52:55 +0200 Subject: [PATCH 08/70] Working put_pseudo_in_ezfio --- scripts/pseudo/create_ez.sh | 5 +- scripts/pseudo/elts_num_ele.py | 118 ++++++++++++++++++++++++++ scripts/pseudo/put_pseudo_in_ezfio.py | 110 ++++++++++++++++++++---- 3 files changed, 211 insertions(+), 22 deletions(-) create mode 100644 scripts/pseudo/elts_num_ele.py diff --git a/scripts/pseudo/create_ez.sh b/scripts/pseudo/create_ez.sh index 3821d6c2..ca94dc95 100755 --- a/scripts/pseudo/create_ez.sh +++ b/scripts/pseudo/create_ez.sh @@ -4,11 +4,8 @@ echo "name" $1 echo "mul" $2 -echo "Zeff" $3 echo "\`get_basis.sh\` need to be changed" rm -R $1.ezfio qp_create_ezfio_from_xyz $1.xyz -b "cc-pvdz" -m $2 - -~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py --ezfio $1.ezfio/ --atom $1 --zeff $3 -qp_edit -c $1.ezfio \ No newline at end of file +~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py --ezfio $1.ezfio/ --atom $1 \ No newline at end of file diff --git a/scripts/pseudo/elts_num_ele.py b/scripts/pseudo/elts_num_ele.py new file mode 100644 index 00000000..3c4ad09f --- /dev/null +++ b/scripts/pseudo/elts_num_ele.py @@ -0,0 +1,118 @@ +name_to_elec = {"H": 1, + "He": 2, + "Li": 3, + "Be": 4, + "B": 5, + "C": 6, + "N": 7, + "O": 8, + "F": 9, + "Ne": 10, + "Na": 11, + "Mg": 12, + "Al": 13, + "Si": 14, + "P": 15, + "S": 16, + "Cl": 17, + "Ar": 18, + "K": 19, + "Ca": 20, + "Sc": 21, + "Ti": 22, + "V": 23, + "Cr": 24, + "Mn": 25, + "Fe": 26, + "Co": 27, + "Ni": 28, + "Cu": 29, + "Zn": 30, + "Ga": 31, + "Ge": 32, + "As": 33, + "Se": 34, + "Br": 35, + "Kr": 36, + "Rb": 37, + "Sr": 38, + "Y": 39, + "Zr": 40, + "Nb": 41, + "Mo": 42, + "Tc": 43, + "Ru": 44, + "Rh": 45, + "Pd": 46, + "Ag": 47, + "Cd": 48, + "In": 49, + "Sn": 50, + "Sb": 51, + "Te": 52, + "I": 53, + "Xe": 54, + "Cs": 55, + "Ba": 56, + "La": 57, + "Ce": 58, + "Pr": 59, + "Nd": 60, + "Pm": 61, + "Sm": 62, + "Eu": 63, + "Gd": 64, + "Tb": 65, + "Dy": 66, + "Ho": 67, + "Er": 68, + "Tm": 69, + "Yb": 70, + "Lu": 71, + "Hf": 72, + "Ta": 73, + "W": 74, + "Re": 75, + "Os": 76, + "Ir": 77, + "Pt": 78, + "Au": 79, + "Hg": 80, + "Tl": 81, + "Pb": 82, + "Bi": 83, + "Po": 84, + "At": 85, + "Rn": 86, + "Fr": 87, + "Ra": 88, + "Ac": 89, + "Th": 90, + "Pa": 91, + "U": 92, + "Np": 93, + "Pu": 94, + "Am": 95, + "Cm": 96, + "Bk": 97, + "Cf": 98, + "Es": 99, + "Fm": 100, + "Md": 101, + "No": 102, + "Lr": 103, + "Rf": 104, + "Db": 105, + "Sg": 106, + "Bh": 107, + "Hs": 108, + "Mt": 109, + "Ds": 110, + "Rg": 111, + "Cn": 112, + "Uut": 113, + "Fl": 114, + "Uup": 115, + "Lv": 116, + "Uus": 117, + "Uuo": 118} diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 7d15f090..aa4d008b 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -4,7 +4,10 @@ Create the pseudo potential for a given atom Usage: - put_pseudo_in_ezfio.py --ezfio= --atom=... --zeff=... + put_pseudo_in_ezfio.py --ezfio= --atom=... + +Help: + atom is the Abreviation of the atom """ @@ -28,6 +31,24 @@ p = re.compile(ur'\|(\d+)><\d+\|') def get_pseudo_str(l_atom): """ Run EMSL_local for geting the str of the speudo potential + + str_ele : + Element Symbol: Na + Number of replaced protons: 10 + Number of projectors: 2 + + Pseudopotential data: + + Local component: + Coeff. r^n Exp. + 1.00000000 -1 5.35838717 + 5.35838717 1 3.67918975 + -2.07764789 0 1.60507673 + + Non-local component: + Coeff. r^n Exp. Proj. + 10.69640234 0 1.32389367 |0><0| + 10.11238853 0 1.14052020 |1><1| """ EMSL_root = "{0}/EMSL_Basis/".format(qpackage_root) @@ -101,13 +122,63 @@ def get_v_n_dz_l_nonlocal(str_ele): l_dz_kl.append([dz]) if not l_v_kl: - l_v_kl.append([0.]) - l_n_kl.append([0]) - l_dz_kl.append([0.]) + l_v_kl.append([0.]) + l_n_kl.append([0]) + l_dz_kl.append([0.]) return l_v_kl, l_n_kl, l_dz_kl +def get_zeff_alpha_beta(str_ele): + """ + Return the the zeff, alpha num elec and beta num elec + Assert ezfio_set_file alredy defined + """ + + import re + + # ___ + # | ._ o _|_ + # _|_ | | | |_ + # + + # ~#~#~#~#~#~#~ # + # s t r _ e l e # + # ~#~#~#~#~#~#~ # + + m = re.search('Element Symbol: ([a-zA-Z]+)', str_ele) + name = m.group(1).capitalize() + + m = re.search('Number of replaced protons: (\d+)', str_ele) + z_remove = int(m.group(1)) + + # ~#~#~#~#~#~#~#~#~#~ # + # F r o m _ e z f i o # + # ~#~#~#~#~#~#~#~#~#~ # + + alpha = ezfio.get_electrons_elec_alpha_num() + beta = ezfio.get_electrons_elec_beta_num() + + # _ + # |_) _. ._ _ _ + # | (_| | _> (/_ + # + + from elts_num_ele import name_to_elec + z = name_to_elec[name] + + z_eff = z - z_remove + + alpha = alpha - (z_remove / 2) + beta = beta - (z_remove / 2) + + # _ + # |_) _ _|_ ._ ._ + # | \ (/_ |_ |_| | | | + # + + return [z_eff, alpha, beta] + if __name__ == "__main__": arguments = docopt(__doc__) @@ -142,6 +213,10 @@ if __name__ == "__main__": l_str_ele = [str_ele for str_ele in str_.split("Element Symbol: ") if str_ele] + l_zeff = [] + alpha_tot = 0 + beta_tot = 0 + for str_ele in l_str_ele: # ~#~#~#~#~ # @@ -155,14 +230,8 @@ if __name__ == "__main__": # L o c a l # # ~#~#~#~#~ # - print "local" - l_v, l_n, l_dz = get_v_n_dz_local(str_ele[l:nl]) - print l_v - print l_n - print l_dz - ezfio.pseudo_klocmax = len(l_v) ezfio.pseudo_v_k = l_v ezfio.pseudo_n_k = l_n @@ -172,19 +241,24 @@ if __name__ == "__main__": # N o n _ L o c a l # # ~#~#~#~#~#~#~#~#~ # - print "non local" - l_v_kl, l_n_kl, l_dz_kl = get_v_n_dz_l_nonlocal(str_ele[nl:]) - print l_v_kl - print l_n_kl - print l_dz_kl - ezfio.pseudo_lmaxpo = len(l_v_kl) ezfio.pseudo_kmax = len(l_v_kl[0]) ezfio.pseudo_v_kl = l_v_kl ezfio.pseudo_n_kl = l_n_kl ezfio.pseudo_dz_kl = l_dz_kl - if arguments["--zeff"]: - ezfio.nuclei_nucl_charge = map(int, arguments["--zeff"]) + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # + # Z _ e f f , a l p h a / b e t a _ e l e c # + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # + + zeff, alpha, beta = get_zeff_alpha_beta(str_) + + alpha_tot += alpha + beta_tot += beta + l_zeff.append(zeff) + + ezfio.electrons_elec_alpha_num = alpha_tot + ezfio.electrons_elec_beta_num = beta_tot + ezfio.nuclei_nucl_charge = l_zeff From c1d69942c07f6d84e97e28d53ada6dcdd0e50685 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 10 Apr 2015 16:02:21 +0200 Subject: [PATCH 09/70] working bug ugly pot_ao_ints --- scripts/get_basis.sh | 6 ++--- src/MonoInts/pot_ao_ints.irp.f | 48 +++++++++++++++++----------------- 2 files changed, 27 insertions(+), 27 deletions(-) diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index 1d4e7472..9f959110 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -43,8 +43,8 @@ then exit 1 fi -#${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" $atoms -cp /home/razoa/quantum_package/scripts/pseudo/burkatzki_dz.basis ${tmpfile} -echo ${tmpfile} +#${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" + +${EMSL_API_ROOT}/EMSL_api.py get_basis_data --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index 820ae937..6f35a117 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -21,33 +21,33 @@ ! integer klocmax -! integer, allocatable :: n_k(:) -! double precision, allocatable :: v_k(:), dz_k(:) + integer, allocatable :: n_k(:) + double precision, allocatable :: v_k(:), dz_k(:) + + call ezfio_get_pseudo_klocmax(klocmax) + + allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) + + call ezfio_get_pseudo_v_k(v_k) + call ezfio_get_pseudo_n_k(n_k) + call ezfio_get_pseudo_dz_k(dz_k) + +! klocmax = 3 ! -! call ezfio_get_pseudo_klocmax(klocmax) +! integer :: n_k(3) +! double precision :: v_k(3), dz_k(3) ! -! allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) +! v_k(1) = 1.00000000d0 +! v_k(2) = 5.35838717 +! v_k(3) = -2.07764789 ! -! call ezfio_get_pseudo_v_k(v_k) -! call ezfio_get_pseudo_n_k(n_k) -! call ezfio_get_pseudo_dz_k(dz_k) - - klocmax = 3 - - integer :: n_k(3) - double precision :: v_k(3), dz_k(3) - - v_k(1) = 1.00000000d0 - v_k(2) = 5.35838717 - v_k(3) = -2.07764789 - - n_k(1) = -1 - n_k(2) = 1 - n_k(3) = 0 - - dz_k(1) = 5.35838717 - dz_k(2) = 3.67918975 - dz_k(3) = 1.60507673 +! n_k(1) = -1 +! n_k(2) = 1 +! n_k(3) = 0 +! +! dz_k(1) = 5.35838717 +! dz_k(2) = 3.67918975 +! dz_k(3) = 1.60507673 print*, "klocmax", klocmax From 96fed344efeb57c3d26a9b487672742d99ef357a Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 10 Apr 2015 16:08:06 +0200 Subject: [PATCH 10/70] Beter automisation for put_pseudo_in_ezfio.py --- scripts/pseudo/put_pseudo_in_ezfio.py | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index aa4d008b..182e699b 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -4,7 +4,7 @@ Create the pseudo potential for a given atom Usage: - put_pseudo_in_ezfio.py --ezfio= --atom=... + put_pseudo_in_ezfio.py Help: atom is the Abreviation of the atom @@ -181,7 +181,6 @@ def get_zeff_alpha_beta(str_ele): if __name__ == "__main__": arguments = docopt(__doc__) - # ___ # | ._ o _|_ # _|_ | | | |_ @@ -191,7 +190,7 @@ if __name__ == "__main__": # E Z F I O # # ~#~#~#~#~ # - ezfio_path = arguments["--ezfio"] + ezfio_path = arguments[""] ezfio_path = os.path.expanduser(ezfio_path) ezfio_path = os.path.expandvars(ezfio_path) ezfio_path = os.path.abspath(ezfio_path) @@ -202,7 +201,7 @@ if __name__ == "__main__": # P s e u d o _ d a t a # # ~#~#~#~#~#~#~#~#~#~#~ # - l_ele = arguments["--atom"] + l_ele = ezfio.get_nuclei_nucl_label() str_ = get_pseudo_str(l_ele) # _ From 409660b0c6fba64a858e5fd8791f56b77ae87108 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 10 Apr 2015 16:20:28 +0200 Subject: [PATCH 11/70] mend Beter automisation for put_pseudo_in_ezfio.py --- scripts/pseudo/create_ez.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/pseudo/create_ez.sh b/scripts/pseudo/create_ez.sh index ca94dc95..8de384b6 100755 --- a/scripts/pseudo/create_ez.sh +++ b/scripts/pseudo/create_ez.sh @@ -8,4 +8,4 @@ echo "\`get_basis.sh\` need to be changed" rm -R $1.ezfio qp_create_ezfio_from_xyz $1.xyz -b "cc-pvdz" -m $2 -~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py --ezfio $1.ezfio/ --atom $1 \ No newline at end of file +~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py --ezfio $1.ezfio \ No newline at end of file From 5962aff7eeee0b08d9813b1817d733fb28d2c20a Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 10 Apr 2015 16:51:46 +0200 Subject: [PATCH 12/70] mend Beter automisation for put_pseudo_in_ezfio.py --- scripts/pseudo/create_ez.sh | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/scripts/pseudo/create_ez.sh b/scripts/pseudo/create_ez.sh index 8de384b6..65c12c5e 100755 --- a/scripts/pseudo/create_ez.sh +++ b/scripts/pseudo/create_ez.sh @@ -3,9 +3,10 @@ # $2 mult echo "name" $1 -echo "mul" $2 +echo "basis" $2 +echo "mul" $3 echo "\`get_basis.sh\` need to be changed" rm -R $1.ezfio -qp_create_ezfio_from_xyz $1.xyz -b "cc-pvdz" -m $2 -~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py --ezfio $1.ezfio \ No newline at end of file +qp_create_ezfio_from_xyz $1.xyz -b $2 -m $3 +~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py $1.ezfio \ No newline at end of file From e07351c729d3d396eeebac40987e64f922136176 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 13 Apr 2015 13:36:01 +0200 Subject: [PATCH 13/70] Pseduo readme --- src/MonoInts/README.rst | 58 +++++++++++++++++++++++++++++++++-------- 1 file changed, 47 insertions(+), 11 deletions(-) diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index fdbb086b..688bc647 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -63,44 +63,77 @@ Documentation array of the mono electronic hamiltonian on the MOs basis : sum of the kinetic and nuclear electronic potential +`a_coef `_ + Undocumented + +`b_coef `_ + Undocumented + +`ddfact2 `_ + Undocumented + +`erf0 `_ + Undocumented + +`gammln `_ + Undocumented + +`gammp `_ + Undocumented + +`gcf `_ + Undocumented + +`gser `_ + Undocumented + +`rinteg `_ + Undocumented + +`rintgauss `_ + Undocumented + +`sabpartial `_ + Undocumented + `orthonormalize_mos `_ Undocumented `ao_nucl_elec_integral `_ interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented `mo_nucl_elec_integral `_ @@ -221,5 +254,8 @@ Documentation array of the integrals of MO_i * y^2 MO_j array of the integrals of MO_i * z^2 MO_j +`compute_integrals_pseudo `_ + Undocumented + From 25f3b2ee01edc7ad1db610dd719207baef90ea89 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 13 Apr 2015 15:04:27 +0200 Subject: [PATCH 14/70] Working for Li2 but with **WARNING** bad convergence in int_prod_bessel --- scripts/pseudo/put_pseudo_in_ezfio.py | 43 ++++++++++++++------------- src/MonoInts/pot_ao_ints.irp.f | 4 +-- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 182e699b..47e3d0d8 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -55,18 +55,21 @@ def get_pseudo_str(l_atom): EMSL_path = "{0}/EMSL_api.py".format(EMSL_root) db_path = "{0}/db/Pseudo.db".format(EMSL_root) - l_cmd_atom = [] + str_ = "" + for a in l_atom: - l_cmd_atom += ["--atom", a] + l_cmd_atom = ["--atom", a] - l_cmd_head = [EMSL_path, "get_basis_data", - "--db_path", db_path, - "--basis", "BFD-Pseudo"] + l_cmd_head = [EMSL_path, "get_basis_data", + "--db_path", db_path, + "--basis", "BFD-Pseudo"] - process = Popen(l_cmd_head + l_cmd_atom, stdout=PIPE, stderr=PIPE) + process = Popen(l_cmd_head + l_cmd_atom, stdout=PIPE, stderr=PIPE) - stdout, _ = process.communicate() - return stdout.strip() + stdout, _ = process.communicate() + str_ += stdout.strip() + "\n" + + return str_ def get_v_n_dz_local(str_ele): @@ -146,19 +149,13 @@ def get_zeff_alpha_beta(str_ele): # s t r _ e l e # # ~#~#~#~#~#~#~ # - m = re.search('Element Symbol: ([a-zA-Z]+)', str_ele) - name = m.group(1).capitalize() +# m = re.search('Element Symbol: ([a-zA-Z]+)', str_ele) +# name = m.group(1).capitalize() + name = str_ele.split("\n")[0].strip().capitalize() m = re.search('Number of replaced protons: (\d+)', str_ele) z_remove = int(m.group(1)) - # ~#~#~#~#~#~#~#~#~#~ # - # F r o m _ e z f i o # - # ~#~#~#~#~#~#~#~#~#~ # - - alpha = ezfio.get_electrons_elec_alpha_num() - beta = ezfio.get_electrons_elec_beta_num() - # _ # |_) _. ._ _ _ # | (_| | _> (/_ @@ -169,8 +166,8 @@ def get_zeff_alpha_beta(str_ele): z_eff = z - z_remove - alpha = alpha - (z_remove / 2) - beta = beta - (z_remove / 2) + alpha = (z_remove / 2) + beta = (z_remove / 2) # _ # |_) _ _|_ ._ ._ @@ -252,12 +249,16 @@ if __name__ == "__main__": # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # - zeff, alpha, beta = get_zeff_alpha_beta(str_) + zeff, alpha, beta = get_zeff_alpha_beta(str_ele) alpha_tot += alpha beta_tot += beta l_zeff.append(zeff) + ezfio.nuclei_nucl_charge = l_zeff + + alpha_tot = ezfio.get_electrons_elec_alpha_num() - alpha_tot + beta_tot = ezfio.get_electrons_elec_beta_num() - beta_tot + ezfio.electrons_elec_alpha_num = alpha_tot ezfio.electrons_elec_beta_num = beta_tot - ezfio.nuclei_nucl_charge = l_zeff diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index 6f35a117..bf01649d 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -150,8 +150,8 @@ c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - c = c + Vloc( klocmax ,v_k ,n_k ,dz_k, A_center,power_A,alpha,B_center,power_B,beta,C_center) - c = c + Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) + c = c + Vloc( klocmax ,v_k ,n_k ,dz_k, A_center,power_A,alpha,B_center,power_B,beta,C_center) + c = c + Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) enddo From 268b252e11d1bbafc60c49092537197897edf074 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 13 Apr 2015 18:38:46 +0200 Subject: [PATCH 15/70] Working for Li2 but with **WARNING** bad convergence in int_prod_bessel --- scripts/pseudo/put_pseudo_in_ezfio.py | 32 ++++++++++++++++++++++----- src/MonoInts/README.rst | 22 +++++++++--------- src/MonoInts/pot_ao_ints.irp.f | 17 ++++++-------- src/MonoInts/pseudo.ezfio_config | 6 ++--- 4 files changed, 48 insertions(+), 29 deletions(-) diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 47e3d0d8..2ddde4b8 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -209,7 +209,9 @@ if __name__ == "__main__": l_str_ele = [str_ele for str_ele in str_.split("Element Symbol: ") if str_ele] - l_zeff = [] + for i in "l_zeff v_k n_k dz_k v_kl n_kl dz_kl".split(): + exec("{0} = []".format(i)) + alpha_tot = 0 beta_tot = 0 @@ -228,10 +230,9 @@ if __name__ == "__main__": l_v, l_n, l_dz = get_v_n_dz_local(str_ele[l:nl]) - ezfio.pseudo_klocmax = len(l_v) - ezfio.pseudo_v_k = l_v - ezfio.pseudo_n_k = l_n - ezfio.pseudo_dz_k = l_dz + v_k.append(l_v) + n_k.append(l_n) + dz_k.append(l_dz) # ~#~#~#~#~#~#~#~#~ # # N o n _ L o c a l # @@ -255,10 +256,31 @@ if __name__ == "__main__": beta_tot += beta l_zeff.append(zeff) + # _ + # /\ _| _| _|_ _ _ _ _|_ o _ + # /--\ (_| (_| |_ (_) (/_ /_ | | (_) + # + + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # + # Z _ e f f , a l p h a / b e t a _ e l e c # + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # + ezfio.nuclei_nucl_charge = l_zeff + print "alpha tot", alpha_tot + print "beta tot", beta_tot + alpha_tot = ezfio.get_electrons_elec_alpha_num() - alpha_tot beta_tot = ezfio.get_electrons_elec_beta_num() - beta_tot ezfio.electrons_elec_alpha_num = alpha_tot ezfio.electrons_elec_beta_num = beta_tot + + # ~#~#~#~#~ # + # L o c a l # + # ~#~#~#~#~ # + + ezfio.pseudo_klocmax = len(v_k[0]) + ezfio.pseudo_v_k = zip(*v_k) + ezfio.pseudo_n_k = zip(*n_k) + ezfio.pseudo_dz_k = zip(*dz_k) diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index 688bc647..751407c7 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -102,38 +102,38 @@ Documentation `ao_nucl_elec_integral `_ interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented `mo_nucl_elec_integral `_ diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index bf01649d..e57ffaab 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -21,12 +21,12 @@ ! integer klocmax - integer, allocatable :: n_k(:) - double precision, allocatable :: v_k(:), dz_k(:) + integer, allocatable :: n_k(:,:) + double precision, allocatable :: v_k(:,:), dz_k(:,:) call ezfio_get_pseudo_klocmax(klocmax) - allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) + allocate(n_k(nucl_num,klocmax),v_k(nucl_num,klocmax), dz_k(nucl_num,klocmax)) call ezfio_get_pseudo_v_k(v_k) call ezfio_get_pseudo_n_k(n_k) @@ -49,14 +49,13 @@ ! dz_k(2) = 3.67918975 ! dz_k(3) = 1.60507673 - + print*, "nucl_num", nucl_num print*, "klocmax", klocmax print*, "n_k_ezfio", n_k print*, "v_k_ezfio",v_k print*, "dz_k_ezfio", dz_k - ! ! |\ | _ ._ | _ _ _. | ! | \| (_) | | | (_) (_ (_| | @@ -79,8 +78,6 @@ call ezfio_get_pseudo_v_kl(v_kl) call ezfio_get_pseudo_dz_kl(dz_kl) - print*, "raw" - print*, "kmax", kmax print*, "lmax",lmax @@ -116,7 +113,7 @@ !$OMP PRIVATE (i, j, k, l, m, alpha, beta, A_center, B_center, C_center, power_A, power_B, & !$OMP num_A, num_B, Z, c, n_pt_in, dump) & !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & - !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge, & + !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge,nucl_label, & !$OMP v_k, n_k, dz_k, klocmax, & !$OMP lmax,kmax,v_kl,n_kl,dz_kl) @@ -149,8 +146,8 @@ C_center(1:3) = nucl_coord(k,1:3) c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - - c = c + Vloc( klocmax ,v_k ,n_k ,dz_k, A_center,power_A,alpha,B_center,power_B,beta,C_center) + + c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) c = c + Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) diff --git a/src/MonoInts/pseudo.ezfio_config b/src/MonoInts/pseudo.ezfio_config index 941c8ee7..75e620ce 100644 --- a/src/MonoInts/pseudo.ezfio_config +++ b/src/MonoInts/pseudo.ezfio_config @@ -1,8 +1,8 @@ pseudo klocmax integer - v_k double precision (pseudo_klocmax) - n_k integer (pseudo_klocmax) - dz_k double precision (pseudo_klocmax) + v_k double precision (nuclei_nucl_num,pseudo_klocmax) + n_k integer (nuclei_nucl_num,pseudo_klocmax) + dz_k double precision (nuclei_nucl_num,pseudo_klocmax) lmaxpo integer kmax integer v_kl double precision (pseudo_kmax,pseudo_lmaxpo) From 79ee1f5a087728acb50f6e98b38b4ff985d8c567 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 13 Apr 2015 18:50:37 +0200 Subject: [PATCH 16/70] Working for the LOCAL part of NaCl --- scripts/pseudo/put_pseudo_in_ezfio.py | 22 ++++++++++++++-------- src/MonoInts/pot_ao_ints.irp.f | 8 ++++---- src/MonoInts/pseudo.ezfio_config | 6 +++--- 3 files changed, 21 insertions(+), 15 deletions(-) diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 2ddde4b8..53170271 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -240,11 +240,9 @@ if __name__ == "__main__": l_v_kl, l_n_kl, l_dz_kl = get_v_n_dz_l_nonlocal(str_ele[nl:]) - ezfio.pseudo_lmaxpo = len(l_v_kl) - ezfio.pseudo_kmax = len(l_v_kl[0]) - ezfio.pseudo_v_kl = l_v_kl - ezfio.pseudo_n_kl = l_n_kl - ezfio.pseudo_dz_kl = l_dz_kl + v_kl.append(l_v_kl) + n_kl.append(l_n_kl) + dz_kl.append(l_dz_kl) # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # @@ -267,9 +265,6 @@ if __name__ == "__main__": ezfio.nuclei_nucl_charge = l_zeff - print "alpha tot", alpha_tot - print "beta tot", beta_tot - alpha_tot = ezfio.get_electrons_elec_alpha_num() - alpha_tot beta_tot = ezfio.get_electrons_elec_beta_num() - beta_tot @@ -284,3 +279,14 @@ if __name__ == "__main__": ezfio.pseudo_v_k = zip(*v_k) ezfio.pseudo_n_k = zip(*n_k) ezfio.pseudo_dz_k = zip(*dz_k) + + # ~#~#~#~#~#~#~#~#~ # + # N o n _ L o c a l # + # ~#~#~#~#~#~#~#~#~ # + + ezfio.pseudo_lmaxpo = len(v_kl[0]) + ezfio.pseudo_kmax = len(v_kl[0][0]) + + ezfio.pseudo_v_kl = zip(*v_kl) + ezfio.pseudo_n_kl = zip(*n_kl) + ezfio.pseudo_dz_kl = zip(*dz_kl) diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index e57ffaab..4517bb51 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -64,15 +64,15 @@ !! Parameters of non local part of pseudo: integer :: kmax,lmax - integer, allocatable :: n_kl(:,:) - double precision, allocatable :: v_kl(:,:), dz_kl(:,:) + integer, allocatable :: n_kl(:,:,:) + double precision, allocatable :: v_kl(:,:,:), dz_kl(:,:,:) call ezfio_get_pseudo_lmaxpo(lmax) call ezfio_get_pseudo_kmax(kmax) !lmax plus one -> lmax lmax = lmax - 1 - allocate(n_kl(kmax,0:lmax), v_kl(kmax,0:lmax), dz_kl(kmax,0:lmax)) + allocate(n_kl(nucl_num,kmax,0:lmax), v_kl(nucl_num,kmax,0:lmax), dz_kl(nucl_num,kmax,0:lmax)) call ezfio_get_pseudo_n_kl(n_kl) call ezfio_get_pseudo_v_kl(v_kl) @@ -148,7 +148,7 @@ c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) - c = c + Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) + c = c + Vpseudo(lmax,kmax,v_kl(k,:,:),n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) enddo diff --git a/src/MonoInts/pseudo.ezfio_config b/src/MonoInts/pseudo.ezfio_config index 75e620ce..97f9e1be 100644 --- a/src/MonoInts/pseudo.ezfio_config +++ b/src/MonoInts/pseudo.ezfio_config @@ -5,6 +5,6 @@ pseudo dz_k double precision (nuclei_nucl_num,pseudo_klocmax) lmaxpo integer kmax integer - v_kl double precision (pseudo_kmax,pseudo_lmaxpo) - n_kl integer (pseudo_kmax,pseudo_lmaxpo) - dz_kl double precision (pseudo_kmax,pseudo_lmaxpo) \ No newline at end of file + v_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) + n_kl integer (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) + dz_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) \ No newline at end of file From 4a823050429887ebedd5bfd935f670d309b5f39b Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 13 Apr 2015 19:01:05 +0200 Subject: [PATCH 17/70] Print debug for n !! --- src/MonoInts/int.f90 | 5 +++++ src/MonoInts/pot_ao_ints.irp.f | 21 ++++++++++++++++++++- 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index cb95c3c9..2c944991 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -1288,6 +1288,11 @@ implicit none integer :: n,k double precision prod dblefact=1.d0 + +if (n.ge.3000) then + print*, n +endif + if(n.lt.0)return if(mod(n,2).eq.1)then prod=1.d0 diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index 4517bb51..cc699574 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -145,10 +145,29 @@ C_center(1:3) = nucl_coord(k,1:3) + print*, j, "j /", ao_num + print*, l, "l /", ao_prim_num(j) + print*, i, "i /", ao_num + print*, m, "m /", ao_prim_num(i) + c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) - c = c + Vpseudo(lmax,kmax,v_kl(k,:,:),n_kl,dz_kl,A_center,power_A,alpha,B_center,power_B,beta,C_center) + + print*, "lmax",lmax + print*, "kmax",kmax + print*, "v_kl",v_kl(k,:,:) + print*, "n_kl",n_kl(k,:,:) + print*, "dz_kl",dz_kl(k,:,:) + print*, "A_center", A_center + print*, "power_A",power_A + print*, "Alpha_B", alpha + print*, "B_center", B_center + print*, "power_B", power_B + print*, "beta", beta + print*, "C_center",C_center + + c = c + Vpseudo(lmax,kmax,v_kl(k,:,:),n_kl(k,:,:),dz_kl(k,:,:),A_center,power_A,alpha,B_center,power_B,beta,C_center) ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) enddo From 989fd4bc076504494648c26f4700ab103f709416 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 14 Apr 2015 09:38:51 +0200 Subject: [PATCH 18/70] Add qp_convert_ezfio_v1_to_v2.sh --- .../qp_convert_ezfio_v1_to_v2.sh | 36 +++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100755 scripts/ezfio_interface/qp_convert_ezfio_v1_to_v2.sh diff --git a/scripts/ezfio_interface/qp_convert_ezfio_v1_to_v2.sh b/scripts/ezfio_interface/qp_convert_ezfio_v1_to_v2.sh new file mode 100755 index 00000000..3ef9a5f3 --- /dev/null +++ b/scripts/ezfio_interface/qp_convert_ezfio_v1_to_v2.sh @@ -0,0 +1,36 @@ +#!/bin/bash +# Convert a old ezfio file (with option.irp.f ezfio_default) +# into a new EZFIO.cfg type + +# Hartree Fock +# Changin the case, don't know if is needed or not + +echo "Will tranform qp_v1.*_ezfio to qp_v2.*_ezfio" +echo "All action are irrevocable! And is by choice" +echo "You need to stop to use a old version! Plz..." + +echo "Change thresh_SCF > thresh_scf0" +mv $1/hartree_Fock/thresh_SCF $1/hartree_fock/thresh_scf 2> /dev/null + +# Set disk_acess +echo "Change {read,write}_ao_integrals > disk_access_ao_integrals" + +biint=$1/bielec_integrals + +if [[ -f $biint/read_ao_integrals ]]; then + if [[ `cat $1/bielec_integrals/read_ao_integrals` -eq "T" ]] + then + echo "Read" > $biint/disk_access_ao_integrals + + elif [[ `cat $biint/write_ao_integrals` -eq "T" ]] + then + echo "Write" > $biint/disk_access_ao_integrals + + else + echo "None" > $biint/disk_access_ao_integrals + + fi + rm $biint/read_ao_integrals $biint/write_ao_integrals $biint/write_ao_intergals 2> /dev/null +fi + +echo "Done" \ No newline at end of file From b964301fd64e0d99dc6d8b502167e4a08d7c8018 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 14 Apr 2015 16:14:58 +0200 Subject: [PATCH 19/70] Put all the same size and allocate in int.f90 --- src/MonoInts/int.f90 | 475 +++++++++++++++++++++++++++---------------- 1 file changed, 303 insertions(+), 172 deletions(-) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index 2c944991..c7d2ac84 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -8,7 +8,7 @@ implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3) integer kmax_max,lmax_max -parameter (kmax_max=4,lmax_max=2) +parameter (kmax_max=2,lmax_max=2) integer lmax,kmax,n_kl(kmax_max,0:lmax_max) double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) integer klocmax_max @@ -29,7 +29,7 @@ implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3),rmax integer kmax_max,lmax_max -parameter (kmax_max=4,lmax_max=2) +parameter (kmax_max=2,lmax_max=2) integer lmax,kmax,n_kl(kmax_max,0:lmax_max) double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) integer klocmax_max;parameter (klocmax_max=10) @@ -135,6 +135,14 @@ end if(l.gt.2)stop 'l > 2 not coded!' end +! _ +! | | +! __ __ _ __ ___ ___ _ _ __| | ___ +! \ \ / / | '_ \/ __|/ _ \ | | |/ _` |/ _ \ +! \ V / | |_) \__ \ __/ |_| | (_| | (_) | +! \_/ | .__/|___/\___|\__,_|\__,_|\___/ +! | | +! |_| !! Routine Vpseudo is based on formumla (66) !! of Kahn Baybutt TRuhlar J.Chem.Phys. vol.65 3826 (1976): @@ -170,27 +178,60 @@ end double precision function Vpseudo & (lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) implicit none + +! ___ +! | ._ ._ _|_ +! _|_ | | |_) |_| |_ +! | double precision, intent(in) :: a(3),g_a,b(3),g_b,c(3) integer kmax_max,lmax_max,ntot_max,nkl_max -parameter (kmax_max=4,lmax_max=2,nkl_max=4) +parameter (kmax_max=2,lmax_max=2,nkl_max=4) parameter (ntot_max=10) -integer lmax,kmax,n_kl(kmax_max,0:lmax_max),l,k -double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -double precision fourpi,f,prod,prodp,binom,accu,bigR,bigI,ylm -double precision theta_AC0,phi_AC0,theta_BC0,phi_BC0,ac,bc,big -double precision areal,freal,breal,t1,t2,int_prod_bessel -integer ntot,ntotA,m,mu,mup,k1,k2,k3,ntotB,k1p,k2p,k3p,lambda,lambdap,ktot -integer n_a(3),n_b(3) -double precision array_R(0:ntot_max+nkl_max,kmax_max,0:lmax_max,0:lmax_max+ntot_max,0:lmax_max+ntot_max) -double precision & -array_I_A(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max) -double precision & -array_I_B(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max) +integer, intent(in) :: lmax,kmax,n_kl(kmax_max,0:lmax_max) +integer, intent(in) :: n_a(3),n_b(3) +double precision, intent(in) :: v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) + + +! +! | _ _ _. | _ +! |_ (_) (_ (_| | (/_ +! + +double precision :: fourpi,f,prod,prodp,binom,accu,bigR,bigI,ylm +double precision :: theta_AC0,phi_AC0,theta_BC0,phi_BC0,ac,bc,big +double precision :: areal,freal,breal,t1,t2,int_prod_bessel +double precision :: arg + +integer :: ntot,ntotA,m,mu,mup,k1,k2,k3,ntotB,k1p,k2p,k3p,lambda,lambdap,ktot +integer :: l,k + +! _ +! |_) o _ _. ._ ._ _. +! |_) | (_| (_| | | (_| \/ +! _| / double precision array_coefs_A(0:ntot_max,0:ntot_max,0:ntot_max) double precision array_coefs_B(0:ntot_max,0:ntot_max,0:ntot_max) -double precision arg + +double precision, allocatable :: array_R(:,:,:,:,:) +double precision, allocatable :: array_I_A(:,:,:,:,:) +double precision, allocatable :: array_I_B(:,:,:,:,:) + +!=!=!=!=!=!=!=!=!=! +! A l l o c a t e ! +!=!=!=!=!=!=!=!=!=! + +allocate (array_R(0:ntot_max+nkl_max,kmax_max,0:lmax_max,0:lmax_max+ntot_max,0:lmax_max+ntot_max)) + +allocate (array_I_A(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) + +allocate (array_I_B(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) + +! _ +! / _. | _ | +! \_ (_| | (_ |_| | +! fourpi=4.d0*dacos(-1.d0) ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) @@ -212,7 +253,17 @@ if(ntot.gt.ntot_max)stop 'increase ntot_max' if(ac.eq.0.d0.and.bc.eq.0.d0)then + + !=!=!=!=!=! + ! I n i t ! + !=!=!=!=!=! + accu=0.d0 + + !=!=!=!=!=!=!=! + ! c a l c u l ! + !=!=!=!=!=!=!=! + do k=1,kmax do l=0,lmax ktot=ntot+n_kl(k,l) @@ -223,11 +274,18 @@ if(ac.eq.0.d0.and.bc.eq.0.d0)then enddo enddo enddo - Vpseudo=accu*fourpi - return -endif -if(ac.ne.0.d0.and.bc.ne.0.d0)then + !=!=!=!=! + ! E n d ! + !=!=!=!=! + + Vpseudo=accu*fourpi + +else if(ac.ne.0.d0.and.bc.ne.0.d0)then + + !=!=!=!=!=! + ! I n i t ! + !=!=!=!=!=! f=fourpi**2 @@ -236,24 +294,27 @@ if(ac.ne.0.d0.and.bc.ne.0.d0)then theta_BC0=dacos( (b(3)-c(3))/bc ) phi_BC0=datan2((b(2)-c(2))/bc,(b(1)-c(1))/bc) + + + do ktot=0,ntotA+ntotB+nkl_max - do lambda=0,lmax+ntotA - do lambdap=0,lmax+ntotB - do k=1,kmax - do l=0,lmax - array_R(ktot,k,l,lambda,lambdap)= & - freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal) - enddo - enddo - enddo - enddo + do lambda=0,lmax+ntotA + do lambdap=0,lmax+ntotB + do k=1,kmax + do l=0,lmax + array_R(ktot,k,l,lambda,lambdap)= freal & + *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal) + enddo + enddo + enddo + enddo enddo do k1=0,n_a(1) do k2=0,n_a(2) do k3=0,n_a(3) array_coefs_A(k1,k2,k3)=binom(n_a(1),k1)*binom(n_a(2),k2)*binom(n_a(3),k3) & - *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) + *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) enddo enddo enddo @@ -262,79 +323,94 @@ if(ac.ne.0.d0.and.bc.ne.0.d0)then do k2p=0,n_b(2) do k3p=0,n_b(3) array_coefs_B(k1p,k2p,k3p)=binom(n_b(1),k1p)*binom(n_b(2),k2p)*binom(n_b(3),k3p) & - *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) + *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) enddo enddo enddo + !=!=!=!=!=!=!=! + ! c a l c u l ! + !=!=!=!=!=!=!=! + accu=0.d0 do l=0,lmax do m=-l,l - do lambda=0,l+ntotA - do mu=-lambda,lambda - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) - enddo - enddo - enddo - enddo - enddo - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) - enddo - enddo - enddo - enddo - enddo - - do lambda=0,l+ntotA - do mu=-lambda,lambda - - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - - prod=ylm(lambda,mu,theta_AC0,phi_AC0)*array_coefs_A(k1,k2,k3)*array_I_A(lambda,mu,k1,k2,k3) - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - - prodp=ylm(lambdap,mup,theta_BC0,phi_BC0)*array_coefs_B(k1p,k2p,k3p)*array_I_B(lambdap,mup,k1p,k2p,k3p) - - do k=1,kmax - ktot=k1+k2+k3+k1p+k2p+k3p+n_kl(k,l) - accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,lambdap) - enddo - - enddo - enddo + do lambda=0,l+ntotA + do mu=-lambda,lambda + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + enddo + enddo + enddo enddo enddo - enddo - enddo - enddo - enddo - enddo - enddo + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) + enddo + enddo + enddo + enddo + enddo + + do lambda=0,l+ntotA + do mu=-lambda,lambda + + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + + prod=ylm(lambda,mu,theta_AC0,phi_AC0)*array_coefs_A(k1,k2,k3)*array_I_A(lambda,mu,k1,k2,k3) + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + + prodp=ylm(lambdap,mup,theta_BC0,phi_BC0)*array_coefs_B(k1p,k2p,k3p)*array_I_B(lambdap,mup,k1p,k2p,k3p) + + do k=1,kmax + ktot=k1+k2+k3+k1p+k2p+k3p+n_kl(k,l) + accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,lambdap) + enddo + + enddo + enddo + enddo + + enddo + enddo + + enddo + enddo + enddo + + enddo + enddo + enddo enddo - Vpseudo=f*accu - return -endif -if(ac.eq.0.d0.and.bc.ne.0.d0)then + !=!=!=!=! + ! E n d ! + !=!=!=!=! + + Vpseudo=f*accu + +else if(ac.eq.0.d0.and.bc.ne.0.d0)then + + !=!=!=!=!=! + ! I n i t ! + !=!=!=!=!=! f=fourpi**1.5d0 theta_BC0=dacos( (b(3)-c(3))/bc ) @@ -343,68 +419,85 @@ if(ac.eq.0.d0.and.bc.ne.0.d0)then areal=2.d0*g_a*ac breal=2.d0*g_b*bc freal=dexp(-g_a*ac**2-g_b*bc**2) + do ktot=0,ntotA+ntotB+nkl_max - do lambdap=0,lmax+ntotB - do k=1,kmax - do l=0,lmax - array_R(ktot,k,l,0,lambdap)= & - freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal) - enddo - enddo - enddo + do lambdap=0,lmax+ntotB + do k=1,kmax + do l=0,lmax + + array_R(ktot,k,l,0,lambdap)= freal & + *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal) + enddo + enddo + enddo enddo do k1p=0,n_b(1) do k2p=0,n_b(2) do k3p=0,n_b(3) + array_coefs_B(k1p,k2p,k3p)=binom(n_b(1),k1p)*binom(n_b(2),k2p)*binom(n_b(3),k3p) & - *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) + *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) enddo enddo enddo + !=!=!=!=!=!=!=! + ! c a l c u l ! + !=!=!=!=!=!=!=! + accu=0.d0 do l=0,lmax do m=-l,l - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) - enddo - enddo - enddo - enddo - enddo - - prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - - prodp=array_coefs_B(k1p,k2p,k3p)*ylm(lambdap,mup,theta_BC0,phi_BC0)*array_I_B(lambdap,mup,k1p,k2p,k3p) - - do k=1,kmax - ktot=ntotA+k1p+k2p+k3p+n_kl(k,l) - accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,0,lambdap) + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) + enddo + enddo + enddo enddo enddo - enddo + + prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) + + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + do k1p=0,n_b(1) + do k2p=0,n_b(2) + do k3p=0,n_b(3) + + prodp=array_coefs_B(k1p,k2p,k3p)*ylm(lambdap,mup,theta_BC0,phi_BC0)*array_I_B(lambdap,mup,k1p,k2p,k3p) + + do k=1,kmax + + ktot=ntotA+k1p+k2p+k3p+n_kl(k,l) + accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,0,lambdap) + + enddo + + enddo + enddo + enddo enddo enddo - enddo enddo enddo - Vpseudo=f*accu - return -endif -if(ac.ne.0.d0.and.bc.eq.0.d0)then + !=!=!=!=! + ! E n d ! + !=!=!=!=! + + Vpseudo=f*accu + +else if(ac.ne.0.d0.and.bc.eq.0.d0)then + + !=!=!=!=!=! + ! I n i t ! + !=!=!=!=!=! f=fourpi**1.5d0 theta_AC0=dacos( (a(3)-c(3))/ac ) @@ -413,69 +506,102 @@ if(ac.ne.0.d0.and.bc.eq.0.d0)then areal=2.d0*g_a*ac breal=2.d0*g_b*bc freal=dexp(-g_a*ac**2-g_b*bc**2) + do ktot=0,ntotA+ntotB+nkl_max - do lambda=0,lmax+ntotA - do k=1,kmax - do l=0,lmax - array_R(ktot,k,l,lambda,0)= & - freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal) - enddo - enddo - enddo + do lambda=0,lmax+ntotA + do k=1,kmax + do l=0,lmax + + array_R(ktot,k,l,lambda,0)= freal & + *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal) + + enddo + enddo + enddo enddo do k1=0,n_a(1) do k2=0,n_a(2) do k3=0,n_a(3) + array_coefs_A(k1,k2,k3)=binom(n_a(1),k1)*binom(n_a(2),k2)*binom(n_a(3),k3) & - *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) + *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) + enddo enddo enddo + !=!=!=!=!=!=!=! + ! c a l c u l ! + !=!=!=!=!=!=!=! + accu=0.d0 do l=0,lmax do m=-l,l - do lambda=0,l+ntotA - do mu=-lambda,lambda - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) - enddo - enddo - enddo - enddo - enddo - - do lambda=0,l+ntotA - do mu=-lambda,lambda - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - prod=array_coefs_A(k1,k2,k3)*ylm(lambda,mu,theta_AC0,phi_AC0)*array_I_A(lambda,mu,k1,k2,k3) - prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) - do k=1,kmax - ktot=k1+k2+k3+ntotB+n_kl(k,l) - accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,0) + do lambda=0,l+ntotA + do mu=-lambda,lambda + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + enddo + enddo + enddo enddo - enddo - enddo + enddo + + do lambda=0,l+ntotA + do mu=-lambda,lambda + do k1=0,n_a(1) + do k2=0,n_a(2) + do k3=0,n_a(3) + + prod=array_coefs_A(k1,k2,k3)*ylm(lambda,mu,theta_AC0,phi_AC0)*array_I_A(lambda,mu,k1,k2,k3) + prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) + + do k=1,kmax + ktot=k1+k2+k3+ntotB+n_kl(k,l) + accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,0) + enddo + + enddo + enddo + enddo enddo enddo - enddo + enddo enddo + + !=!=!=!=! + ! E n d ! + !=!=!=!=! + Vpseudo=f*accu - return endif + +! _ +! |_ o ._ _. | o _ _ +! | | | | (_| | | _> (/_ +! + deallocate (array_R, array_I_A, array_I_B) + return end +! _ +! | | +!__ __ _ __ ___ ___ _ _ __| | ___ _ __ _ _ _ __ ___ +!\ \ / / | '_ \/ __|/ _ \ | | |/ _` |/ _ \ | '_ \| | | | '_ ` _ \ +! \ V / | |_) \__ \ __/ |_| | (_| | (_) | | | | | |_| | | | | | | +! \_/ | .__/|___/\___|\__,_|\__,_|\___/ |_| |_|\__,_|_| |_| |_| +! | | +! |_| + double precision function Vpseudo_num(npts,rmax,lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) implicit none integer kmax_max,lmax_max -parameter (kmax_max=4,lmax_max=2) +parameter (kmax_max=2,lmax_max=2) integer lmax,kmax, n_kl(kmax_max,0:lmax_max),l,m,k,kk double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) double precision a(3),g_a,b(3),g_b,c(3),ac(3),bc(3) @@ -1289,10 +1415,6 @@ integer :: n,k double precision prod dblefact=1.d0 -if (n.ge.3000) then - print*, n -endif - if(n.lt.0)return if(mod(n,2).eq.1)then prod=1.d0 @@ -1777,7 +1899,16 @@ end endif enddo int_prod_bessel=int - if(kcp.gt.100)print*,'**WARNING** bad convergence in int_prod_bessel' + if(kcp.gt.100) then + print*,"l",l + print*, "gam", gam + print*, "n", n + print*, "m", m + print*, "a", a + print*, "b", b + print*, "kcp", kcp + print*,'**WARNING** bad convergence in int_prod_bessel' + endif return endif From 1fc1124d959b89048255a9abc692890d72e39c1a Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 09:41:16 +0200 Subject: [PATCH 20/70] Remove open mp and add tmp array --- src/MonoInts/README.rst | 22 +++++----- src/MonoInts/pot_ao_ints.irp.f | 77 ++++++++++++++++++++-------------- 2 files changed, 56 insertions(+), 43 deletions(-) diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index 751407c7..ec92eada 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -102,38 +102,38 @@ Documentation `ao_nucl_elec_integral `_ interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented `mo_nucl_elec_integral `_ diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index cc699574..ef2e8c8f 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -48,7 +48,10 @@ ! dz_k(1) = 5.35838717 ! dz_k(2) = 3.67918975 ! dz_k(3) = 1.60507673 - + print*, "=======================" + print*, "=======================" + print*, "=======================" + print*, "nucl_num", nucl_num print*, "klocmax", klocmax @@ -85,6 +88,10 @@ print*,"v_kl_ezfio", v_kl print*,"dz_kl_ezfio", dz_kl + print*, "=======================" + print*, "=======================" + print*, "=======================" + ! lmax = 1 ! kmax = 1 @@ -108,29 +115,31 @@ ! print*,"dz_kl_ezfio", dz_kl - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, k, l, m, alpha, beta, A_center, B_center, C_center, power_A, power_B, & - !$OMP num_A, num_B, Z, c, n_pt_in, dump) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & - !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge,nucl_label, & - !$OMP v_k, n_k, dz_k, klocmax, & - !$OMP lmax,kmax,v_kl,n_kl,dz_kl) + integer, allocatable :: n_kl_dump(:,:) + double precision, allocatable :: v_kl_dump(:,:), dz_kl_dump(:,:) + + allocate(n_kl_dump(kmax,0:lmax), v_kl_dump(kmax,0:lmax), dz_kl_dump(kmax,0:lmax)) + n_pt_in = n_pt_max_integrals - !$OMP DO SCHEDULE (guided) do j = 1, ao_num num_A = ao_nucl(j) power_A(1:3)= ao_power(j,1:3) A_center(1:3) = nucl_coord(num_A,1:3) + print*, "J", j, "/", ao_num + print*,"===================" + do i = 1, ao_num num_B = ao_nucl(i) power_B(1:3)= ao_power(i,1:3) B_center(1:3) = nucl_coord(num_B,1:3) + + print*, "i", i, "/", ao_num + do l=1,ao_prim_num(j) alpha = ao_expo_transp(l,j) @@ -145,31 +154,37 @@ C_center(1:3) = nucl_coord(k,1:3) - print*, j, "j /", ao_num - print*, l, "l /", ao_prim_num(j) - print*, i, "i /", ao_num - print*, m, "m /", ao_prim_num(i) - c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) - - print*, "lmax",lmax - print*, "kmax",kmax - print*, "v_kl",v_kl(k,:,:) - print*, "n_kl",n_kl(k,:,:) - print*, "dz_kl",dz_kl(k,:,:) - print*, "A_center", A_center - print*, "power_A",power_A - print*, "Alpha_B", alpha - print*, "B_center", B_center - print*, "power_B", power_B - print*, "beta", beta - print*, "C_center",C_center - c = c + Vpseudo(lmax,kmax,v_kl(k,:,:),n_kl(k,:,:),dz_kl(k,:,:),A_center,power_A,alpha,B_center,power_B,beta,C_center) -! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) + n_kl_dump = n_kl(k,1:kmax,0:lmax) + v_kl_dump = v_kl(k,1:kmax,0:lmax) + dz_kl_dump = dz_kl(k,1:kmax,0:lmax) + +! print*, "lmax",lmax +! print*, "kmax",kmax +! print*, "v_kl",v_kl_dump +! print*, "n_kl",n_kl_dump +! print*, n_kl_dump(1,0) +! print*, n_kl_dump(1,1) +! print*, "dz_kl",dz_kl_dump +! print*, dz_kl_dump(1,0) +! print*, dz_kl_dump(1,1) +! print*, "A_center", A_center +! print*, "power_A",power_A +! print*, "alpha", alpha +! print*, "B_center", B_center +! print*, "power_B", power_B +! print*, "beta", beta +! print*, "C_center",C_center + + ! c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) + +! print*, "#################" +! print*, "#################" enddo ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) + & ao_coef_transp(l,j)*ao_coef_transp(m,i)*c @@ -177,8 +192,6 @@ enddo enddo enddo - !$OMP END DO - !$OMP END PARALLEL END_PROVIDER From 374c2c003ceccd3243043861c06ddefbc1803376 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 10:59:45 +0200 Subject: [PATCH 21/70] Rename qp_convert and major cleaning in it --- .../ezfio_interface/ezfio_generate_ocaml.py | 8 +- .../qp_convert_output_to_ezfio.py | 292 ++++++++++++++++++ scripts/qp_convert.py | 210 ------------- 3 files changed, 299 insertions(+), 211 deletions(-) create mode 100755 scripts/ezfio_interface/qp_convert_output_to_ezfio.py delete mode 100755 scripts/qp_convert.py diff --git a/scripts/ezfio_interface/ezfio_generate_ocaml.py b/scripts/ezfio_interface/ezfio_generate_ocaml.py index 25b6c55f..37b6c6ad 100755 --- a/scripts/ezfio_interface/ezfio_generate_ocaml.py +++ b/scripts/ezfio_interface/ezfio_generate_ocaml.py @@ -1,7 +1,13 @@ #!/usr/bin/env python +""" +This programme generate all the +ocaml template needed by qp_edit + +You can see `ezfio_generate_provider.py` +for an example of utilisation +""" import sys -import os # If type in **kwargs from ei_handler import Type diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py new file mode 100755 index 00000000..6b5c5fcd --- /dev/null +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -0,0 +1,292 @@ +#!/usr/bin/env python +""" +This function acceep + +Usage: + qp_convert_output_to_ezfio.py [--ezfio=] + +Option: + file.out is the file to check (like gamess.out) + folder.ezfio is the name you whant for the ezfio + (by default is file.out.ezfio) + +""" + + +import sys +import os +from functools import reduce + + +# ~#~#~#~#~#~#~#~ # +# Add to the path # +# ~#~#~#~#~#~#~#~ # + + +try: + QPACKAGE_ROOT = os.environ["QPACKAGE_ROOT"] +except: + print "Error: QPACKAGE_ROOT environment variable not found." + sys.exit(1) +else: + sys.path = [QPACKAGE_ROOT + "/EZFIO/Python", + QPACKAGE_ROOT + "/resultsFile", + QPACKAGE_ROOT + "/scripts"] + sys.path + +# ~#~#~#~#~#~ # +# I m p o r t # +# ~#~#~#~#~#~ # + +from ezfio import ezfio + + +try: + from resultsFile import * +except: + print "Error: resultsFile Python library not installed" + sys.exit(1) + +from docopt import docopt + +# _ +# |_ ._ _ _|_ o _ ._ +# | |_| | | (_ |_ | (_) | | +# + + +def write_ezfio(res, filename): + + res.clean_uncontractions() + ezfio.set_file(filename) + + # _ + # |_ | _ _ _|_ ._ _ ._ _ + # |_ | (/_ (_ |_ | (_) | | _> + # + ezfio.set_electrons_elec_alpha_num(res.num_alpha) + ezfio.set_electrons_elec_beta_num(res.num_beta) + + # + # |\ | _ | _ o + # | \| |_| (_ | (/_ | + # + + # ~#~#~#~ # + # I n i t # + # ~#~#~#~ # + + charge = [] + coord_x = [] + coord_y = [] + coord_z = [] + + # ~#~#~#~#~#~#~ # + # P a r s i n g # + # ~#~#~#~#~#~#~ # + + for a in res.geometry: + charge.append(a.charge) + if res.units == 'BOHR': + coord_x.append(a.coord[0]) + coord_y.append(a.coord[1]) + coord_z.append(a.coord[2]) + else: + coord_x.append(a.coord[0] / a0) + coord_y.append(a.coord[1] / a0) + coord_z.append(a.coord[2] / a0) + + # ~#~#~#~#~ # + # W r i t e # + # ~#~#~#~#~ # + + ezfio.set_nuclei_nucl_num(len(res.geometry)) + ezfio.set_nuclei_nucl_charge(charge) + + # Transformt H1 into H + import re + p = re.compile(ur'(\d*)$') + label = [p.sub("", x.name) for x in res.geometry] + ezfio.set_nuclei_nucl_label(label) + + ezfio.set_nuclei_nucl_coord(coord_x + coord_y + coord_z) + + # _ + # /\ _ _ |_) _. _ o _ + # /--\ (_) _> |_) (_| _> | _> + # + + # ~#~#~#~ # + # I n i t # + # ~#~#~#~ # + + import string + at = [] + num_prim = [] + power_x = [] + power_y = [] + power_z = [] + coefficient = [] + exponent = [] + + res.clean_contractions() + res.convert_to_cartesian() + + # ~#~#~#~#~#~#~ # + # P a r s i n g # + # ~#~#~#~#~#~#~ # + + for b in res.basis: + c = b.center + for i, atom in enumerate(res.geometry): + if atom.coord == c: + at.append(i + 1) + num_prim.append(len(b.prim)) + s = b.sym + power_x.append(string.count(s, "x")) + power_y.append(string.count(s, "y")) + power_z.append(string.count(s, "z")) + coefficient.append(b.coef) + exponent.append([p.expo for p in b.prim]) + + # ~#~#~#~#~ # + # W r i t e # + # ~#~#~#~#~ # + + ezfio.set_ao_basis_ao_num(len(res.basis)) + ezfio.set_ao_basis_ao_nucl(at) + ezfio.set_ao_basis_ao_prim_num(num_prim) + ezfio.set_ao_basis_ao_power(power_x + power_y + power_z) + + # ~#~#~#~#~#~#~ # + # P a r s i n g # + # ~#~#~#~#~#~#~ # + + prim_num_max = ezfio.get_ao_basis_ao_prim_num_max() + + for i in range(len(res.basis)): + coefficient[ + i] += [0. for j in range(len(coefficient[i]), prim_num_max)] + exponent[i] += [0. for j in range(len(exponent[i]), prim_num_max)] + + coefficient = reduce(lambda x, y: x + y, coefficient, []) + exponent = reduce(lambda x, y: x + y, exponent, []) + + coef = [] + expo = [] + for i in range(prim_num_max): + for j in range(i, len(coefficient), prim_num_max): + coef.append(coefficient[j]) + expo.append(exponent[j]) + + # ~#~#~#~#~ # + # W r i t e # + # ~#~#~#~#~ # + + ezfio.set_ao_basis_ao_coef(coef) + ezfio.set_ao_basis_ao_expo(expo) + ezfio.set_ao_basis_ao_basis("Read by resultsFile") + + # _ + # |\/| _ _ |_) _. _ o _ + # | | (_) _> |_) (_| _> | _> + # + + # ~#~#~#~ # + # I n i t # + # ~#~#~#~ # + + MoTag = res.determinants_mo_type + ezfio.set_mo_basis_mo_label('Orthonormalized') + MO_type = MoTag + allMOs = res.mo_sets[MO_type] + + # ~#~#~#~#~#~#~ # + # P a r s i n g # + # ~#~#~#~#~#~#~ # + + try: + closed = [(allMOs[i].eigenvalue, i) for i in res.closed_mos] + active = [(allMOs[i].eigenvalue, i) for i in res.active_mos] + virtual = [(allMOs[i].eigenvalue, i) for i in res.virtual_mos] + except: + closed = [] + virtual = [] + active = [(allMOs[i].eigenvalue, i) for i in range(len(allMOs))] + + closed = map(lambda x: x[1], closed) + active = map(lambda x: x[1], active) + virtual = map(lambda x: x[1], virtual) + MOindices = closed + active + virtual + + MOs = [] + for i in MOindices: + MOs.append(allMOs[i]) + + mo_tot_num = len(MOs) + while len(MOindices) < mo_tot_num: + MOindices.append(len(MOindices)) + + MOmap = list(MOindices) + for i in range(len(MOindices)): + MOmap[i] = MOindices.index(i) + + energies = [] + for i in xrange(mo_tot_num): + energies.append(MOs[i].eigenvalue) + + if res.occ_num is not None: + OccNum = [] + for i in MOindices: + OccNum.append(res.occ_num[MO_type][i]) + + while len(OccNum) < mo_tot_num: + OccNum.append(0.) + + MoMatrix = [] + sym0 = [i.sym for i in res.mo_sets[MO_type]] + sym = [i.sym for i in res.mo_sets[MO_type]] + for i in xrange(len(sym)): + sym[MOmap[i]] = sym0[i] + + MoMatrix = [] + for i in xrange(len(MOs)): + m = MOs[i] + for coef in m.vector: + MoMatrix.append(coef) + + while len(MoMatrix) < len(MOs[0].vector) ** 2: + MoMatrix.append(0.) + + # ~#~#~#~#~ # + # W r i t e # + # ~#~#~#~#~ # + + ezfio.set_mo_basis_mo_tot_num(mo_tot_num) + ezfio.set_mo_basis_mo_occ(OccNum) + ezfio.set_mo_basis_mo_coef(MoMatrix) + + +def get_full_path(file_path): + file_path = os.path.expanduser(file_path) + file_path = os.path.expandvars(file_path) + file_path = os.path.abspath(file_path) + return file_path + +if __name__ == '__main__': + arguments = docopt(__doc__) + + file_ = get_full_path(arguments['']) + + if arguments["--ezfio"]: + ezfio_file = get_full_path(arguments["--ezfio"]) + else: + ezfio_file = "{0}.ezfio".format(file_) + + try: + res_file = getFile(file_) + except: + raise + else: + print file_, 'recognized as', str(res_file).split('.')[-1].split()[0] + + write_ezfio(res_file, ezfio_file) diff --git a/scripts/qp_convert.py b/scripts/qp_convert.py deleted file mode 100755 index ab008e9e..00000000 --- a/scripts/qp_convert.py +++ /dev/null @@ -1,210 +0,0 @@ -#!/usr/bin/env python - -import sys,os -try: - QPACKAGE_ROOT = os.environ["QPACKAGE_ROOT"] -except: - print "Error: QPACKAGE_ROOT environment variable not found." - sys.exit(1) - -sys.path = [ QPACKAGE_ROOT+"/EZFIO/Python", QPACKAGE_ROOT+"/resultsFile" ]+sys.path -from ezfio import ezfio -import ezfio as ez -print "EZFIO: ", os.path.dirname(ez.__file__) - -try: - from resultsFile import * -except: - print "Error: resultsFile Python library not installed" - sys.exit(1) - - -def write_ezfioFile(res,filename): - res.clean_uncontractions() - ezfio.set_file(filename) - -# Electrons - ezfio.set_electrons_elec_alpha_num(res.num_alpha) - ezfio.set_electrons_elec_beta_num(res.num_beta) - -# Nuclei - ezfio.set_nuclei_nucl_num(len(res.geometry)) - charge = [] - coord = [] - coord_x = [] - coord_y = [] - coord_z = [] - for a in res.geometry: - charge.append(a.charge) - if res.units == 'BOHR': - coord_x.append(a.coord[0]) - coord_y.append(a.coord[1]) - coord_z.append(a.coord[2]) - else: - coord_x.append(a.coord[0]/a0) - coord_y.append(a.coord[1]/a0) - coord_z.append(a.coord[2]/a0) - ezfio.set_nuclei_nucl_charge(charge) - label = map(lambda x: x.name, res.geometry) - ezfio.set_nuclei_nucl_label(label) - ezfio.set_nuclei_nucl_coord(coord_x+coord_y+coord_z) - -# Basis - basis = res.uncontracted_basis - geom = res.geometry - - res.clean_contractions() - # AO Basis - import string - at = [] - num_prim = [] - magnetic_number = [] - angular_number = [] - power_x = [] - power_y = [] - power_z = [] - coefficient = [] - exponent = [] - res.convert_to_cartesian() - for b in res.basis: - c = b.center - for i,atom in enumerate(res.geometry): - if atom.coord == c: - at.append(i+1) - num_prim.append(len(b.prim)) - s = b.sym - power_x.append( string.count(s,"x") ) - power_y.append( string.count(s,"y") ) - power_z.append( string.count(s,"z") ) - coefficient.append( b.coef ) - exponent.append( [ p.expo for p in b.prim ] ) - ezfio.set_ao_basis_ao_num(len(res.basis)) - ezfio.set_ao_basis_ao_nucl(at) - ezfio.set_ao_basis_ao_prim_num(num_prim) - ezfio.set_ao_basis_ao_power(power_x+power_y+power_z) - prim_num_max = ezfio.get_ao_basis_ao_prim_num_max() - len_res_basis = len(res.basis) - for i in range(len(res.basis)): - coefficient[i] += [ 0. for j in range(len(coefficient[i]),prim_num_max) ] - exponent[i] += [ 0. for j in range(len(exponent[i]),prim_num_max) ] - coefficient = reduce(lambda x, y: x+y, coefficient, []) - exponent = reduce(lambda x, y: x+y, exponent, []) - coef = [] - expo = [] - for i in range(prim_num_max): - for j in range(i,len(coefficient),prim_num_max): - coef.append ( coefficient[j] ) - expo.append ( exponent[j] ) - ezfio.set_ao_basis_ao_coef(coef) - ezfio.set_ao_basis_ao_expo(expo) - ezfio.set_ao_basis_ao_basis("Read by resultsFile") - - -# MO - MoTag = res.determinants_mo_type - ezfio.set_mo_basis_mo_label('Orthonormalized') - MO_type = MoTag - allMOs = res.mo_sets[MO_type] - - - try: - closed = [ (allMOs[i].eigenvalue,i) for i in res.closed_mos ] - active = [ (allMOs[i].eigenvalue,i) for i in res.active_mos ] - virtual =[ (allMOs[i].eigenvalue,i) for i in res.virtual_mos ] - except: - closed = [] - virtual = [] - active = [ (allMOs[i].eigenvalue,i) for i in range(len(allMOs)) ] - -# closed.sort() -# active.sort() -# virtual.sort() - closed = map( lambda x: x[1], closed) - active = map( lambda x: x[1], active) - virtual = map( lambda x: x[1], virtual) - MOindices = closed + active + virtual - - MOs = [] - for i in MOindices: - MOs.append(allMOs[i]) - - mo_tot_num = len(MOs) - while len(MOindices) < mo_tot_num: - MOindices.append(len(MOindices)) - - MOmap = list(MOindices) - for i in range(len(MOindices)): - MOmap[i] = MOindices.index(i) - - energies = [] - for i in xrange(mo_tot_num): - energies.append(MOs[i].eigenvalue) - - if res.occ_num is not None: - OccNum = [] - for i in MOindices: - OccNum.append(res.occ_num[MO_type][i]) - - while len(OccNum) < mo_tot_num: - OccNum.append(0.) - - MoMatrix = [] - sym0 = [ i.sym for i in res.mo_sets[MO_type] ] - sym = [ i.sym for i in res.mo_sets[MO_type] ] - for i in xrange(len(sym)): - sym[MOmap[i]] = sym0[i] - - MoMatrix = [] - for i in xrange(len(MOs)): - m = MOs[i] - for coef in m.vector: - MoMatrix.append(coef) - - while len(MoMatrix) < len(MOs[0].vector)**2: - MoMatrix.append(0.) - - mo = [] - for i in MOindices: - mo.append(res.mo_sets[MoTag][i]) - - if len(mo) < mo_tot_num: - newmo = orbital() - newmo.eigenvalue = 0. - newmo.vector = [0. for i in range(mo_tot_num)] - newmo.vector[len(mo)] = 1. - while len(mo) < mo_tot_num: - mo.append(newmo) - Energies = [ m.eigenvalue for m in mo ] - - ezfio.set_mo_basis_mo_tot_num(mo_tot_num) - ezfio.set_mo_basis_mo_occ(OccNum) - ezfio.set_mo_basis_mo_coef(MoMatrix) - - - - -if __name__ == '__main__': - # Check command line - - det_threshold = 0. - - if len(sys.argv) == 2: - State=0 - elif len(sys.argv) == 3: - State=int(sys.argv[2]) - else: - print "usage: "+sys.argv[0]+" file.out [state]" - sys.exit(2) - - firstArg = sys.argv[1] - - file = getFile(firstArg) - print firstArg, 'recognized as', str(file).split('.')[-1].split()[0] - - filename = firstArg+".ezfio" - write_ezfioFile(file,filename) - - - - - From d71be0bb7c47afa030e88de1ea1a115561858c4a Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 11:34:26 +0200 Subject: [PATCH 22/70] Add qp_convert_from_output to test --- tests/HBO.out | 619 +++++++++++++++++++++++++++++++++++ tests/unit_test/unit_test.py | 56 +++- 2 files changed, 672 insertions(+), 3 deletions(-) create mode 100644 tests/HBO.out diff --git a/tests/HBO.out b/tests/HBO.out new file mode 100644 index 00000000..ab71c53f --- /dev/null +++ b/tests/HBO.out @@ -0,0 +1,619 @@ +----- GAMESS execution script ----- +This job is running on host LPQLX15 +under operating system Linux at jeudi 16 avril 2015, 11:11:32 (UTC+0200) +Available scratch disk space (Kbyte units) at beginning of the job is +Filesystem 1K-blocks Used Available Use% Mounted on +/dev/sda1 464085784 81207016 359281456 19% / + + Distributed Data Interface kickoff program. + Initiating 1 compute processes on 1 nodes to run the following command: + /usr/local/gamess/gamess.01.x HBO + + ****************************************************** + * GAMESS VERSION = 22 FEB 2006 (R5) * + * FROM IOWA STATE UNIVERSITY * + * M.W.SCHMIDT, K.K.BALDRIDGE, J.A.BOATZ, S.T.ELBERT, * + * M.S.GORDON, J.H.JENSEN, S.KOSEKI, N.MATSUNAGA, * + * K.A.NGUYEN, S.J.SU, T.L.WINDUS, * + * TOGETHER WITH M.DUPUIS, J.A.MONTGOMERY * + * J.COMPUT.CHEM. 14, 1347-1363(1993) * + ***************** AMD 64 BIT VERSION ***************** + + SINCE 1993, STUDENTS AND POSTDOCS WORKING AT IOWA STATE UNIVERSITY + AND ALSO IN THEIR VARIOUS JOBS AFTER LEAVING ISU HAVE MADE IMPORTANT + CONTRIBUTIONS TO THE CODE: + IVANA ADAMOVIC, CHRISTINE AIKENS, YURI ALEXEEV, POOJA ARORA, ROB BELL, + PRADIPTA BANDYOPADHYAY, BRETT BODE, GALINA CHABAN, WEI CHEN, + CHEOL HO CHOI, PAUL DAY, TIM DUDLEY, DMITRI FEDOROV, GRAHAM FLETCHER, + MARK FREITAG, KURT GLAESEMANN, GRANT MERRILL, TAKESHI NAGATA, + HEATHER NETZLOFF, BOSILJKA NJEGIC, RYAN OLSON, MIKE PAK, JIM SHOEMAKER, + LYUDMILA SLIPCHENKO, JIE SONG, TETSUYA TAKETSUGU, SIMON WEBB. + + ADDITIONAL CODE HAS BEEN PROVIDED BY COLLABORATORS IN OTHER GROUPS: + IOWA STATE UNIVERSITY: JOE IVANIC, KLAUS RUEDENBERG + UNIVERSITY OF TOKYO: KIMIHIKO HIRAO, HARUYUKI NAKANO, TAKAHITO + NAKAJIMA, TAKAO TSUNEDA, MUNEAKI KAMIYA, SUSUMU YANAGISAWA, + KIYOSHI YAGI + UNIVERSITY OF SOUTHERN DENMARK: FRANK JENSEN + UNIVERSITY OF IOWA: VISVALDAS KAIRYS, HUI LI + NATIONAL INST. OF STANDARDS AND TECHNOLOGY: WALT STEVENS, DAVID GARMER + UNIVERSITY OF PISA: BENEDETTA MENNUCCI, JACOPO TOMASI + UNIVERSITY OF MEMPHIS: HENRY KURTZ, PRAKASHAN KORAMBATH + UNIVERSITY OF ALBERTA: MARIUSZ KLOBUKOWSKI + UNIVERSITY OF NEW ENGLAND: MARK SPACKMAN + MIE UNIVERSITY: HIROAKI UMEDA + MICHIGAN STATE UNIVERSITY: + KAROL KOWALSKI, MARTA WLOCH, PIOTR PIECUCH + UNIVERSITY OF SILESIA: MONIKA MUSIAL, STANISLAW KUCHARSKI + FACULTES UNIVERSITAIRES NOTRE-DAME DE LA PAIX: + OLIVIER QUINET, BENOIT CHAMPAGNE + UNIVERSITY OF CALIFORNIA - SANTA BARBARA: BERNARD KIRTMAN + INSTITUTE FOR MOLECULAR SCIENCE: KAZUYA ISHIMURA AND SHIGERU NAGASE + UNIVERSITY OF NOTRE DAME: DAN CHIPMAN + KYUSHU UNIVERSITY: + FENG LONG GU, JACEK KORCHOWIEC, MARCIN MAKOWSKI, AND YURIKO AOKI + PENNSYLVANIA STATE UNIVERSITY: + TZVETELIN IORDANOV, CHET SWALINA, SHARON HAMMES-SCHIFFER + + EXECUTION OF GAMESS BEGUN Thu Apr 16 11:11:32 2015 + + ECHO OF THE FIRST FEW INPUT CARDS - + INPUT CARD> + INPUT CARD> $CONTRL + INPUT CARD> RUNTYP=ENERGY + INPUT CARD> MULT=1 + INPUT CARD> SCFTYP=ROHF + INPUT CARD> $END + INPUT CARD> + INPUT CARD> $GUESS + INPUT CARD> GUESS=HCORE + INPUT CARD> $END + INPUT CARD> + INPUT CARD> $DATA + INPUT CARD> HBO + INPUT CARD>C1 + INPUT CARD>H 1.0 0. 0. 0. + INPUT CARD>S 3 + INPUT CARD> 1 18.7311370 0.0334946 + INPUT CARD> 2 2.8253944 0.2347269 + INPUT CARD> 3 0.6401217 0.8137573 + INPUT CARD>S 1 + INPUT CARD> 1 0.1612778 1.0000000 + INPUT CARD> + INPUT CARD>B 5.0 1.1660 0. 0. + INPUT CARD>S 4 + INPUT CARD> 1 330.7528500 0.0179942 + INPUT CARD> 2 49.8438650 0.1246937 + INPUT CARD> 3 11.1170540 0.4343354 + INPUT CARD> 4 2.9227243 0.5609794 + INPUT CARD>L 3 + INPUT CARD> 1 5.6812646 -0.1303871 0.0637429 + INPUT CARD> 2 1.4544046 -0.2514344 0.2761331 + INPUT CARD> 3 0.4283786 1.2051292 0.7773866 + INPUT CARD>L 1 + INPUT CARD> 1 0.1442192 1.0000000 1.0000000 + INPUT CARD> + INPUT CARD>B 8.0 2.3660 0. 0. + INPUT CARD>S 4 + INPUT CARD> 1 883.2728600 0.0175506 + INPUT CARD> 2 133.1292800 0.1228292 + INPUT CARD> 3 29.9064080 0.4348836 + INPUT CARD> 4 7.9786772 0.5600108 + INPUT CARD>L 3 + INPUT CARD> 1 16.1944470 -0.1134010 0.0685453 + INPUT CARD> 2 3.7800860 -0.1772865 0.3312254 + INPUT CARD> 3 1.0709836 1.1504079 0.7346079 + INPUT CARD>L 1 + INPUT CARD> 1 0.2838798 1.0000000 1.0000000 + INPUT CARD> + INPUT CARD> $END + + ..... DONE SETTING UP THE RUN ..... + 1000000 WORDS OF MEMORY AVAILABLE + + + RUN TITLE + --------- + HBO + + THE POINT GROUP OF THE MOLECULE IS C1 + THE ORDER OF THE PRINCIPAL AXIS IS 0 + + ATOM ATOMIC COORDINATES (BOHR) + CHARGE X Y Z + H 1.0 0.0000000000 0.0000000000 0.0000000000 + B 5.0 2.2034205017 0.0000000000 0.0000000000 + B 8.0 4.4710916869 0.0000000000 0.0000000000 + + INTERNUCLEAR DISTANCES (ANGS.) + ------------------------------ + + H B B + + 1 H 0.0000000 1.1660000 * 2.3660000 * + 2 B 1.1660000 * 0.0000000 1.2000000 * + 3 B 2.3660000 * 1.2000000 * 0.0000000 + + ATOMIC BASIS SET + ---------------- + THE CONTRACTED PRIMITIVE FUNCTIONS HAVE BEEN UNNORMALIZED + THE CONTRACTED BASIS FUNCTIONS ARE NOW NORMALIZED TO UNITY + + SHELL TYPE PRIMITIVE EXPONENT CONTRACTION COEFFICIENT(S) + + H + + 1 S 1 18.7311370 0.033494602358 + 1 S 2 2.8253944 0.234726916524 + 1 S 3 0.6401217 0.813757357284 + + 2 S 4 0.1612778 1.000000000000 + + B + + 3 S 5 330.7528500 0.017994199122 + 3 S 6 49.8438650 0.124693693914 + 3 S 7 11.1170540 0.434335378802 + 3 S 8 2.9227243 0.560979372621 + + 4 L 9 5.6812646 -0.130387101955 0.063742897507 + 4 L 10 1.4544046 -0.251434403769 0.276133089199 + 4 L 11 0.4283786 1.205129218067 0.777386569593 + + 5 L 12 0.1442192 1.000000000000 1.000000000000 + + B + + 6 S 13 883.2728600 0.017550600144 + 6 S 14 133.1292800 0.122829201010 + 6 S 15 29.9064080 0.434883603578 + 6 S 16 7.9786772 0.560010804607 + + 7 L 17 16.1944470 -0.113401005792 0.068545299729 + 7 L 18 3.7800860 -0.177286509055 0.331225398691 + 7 L 19 1.0709836 1.150407958755 0.734607897097 + + 8 L 20 0.2838798 1.000000000000 1.000000000000 + + TOTAL NUMBER OF BASIS SET SHELLS = 8 + NUMBER OF CARTESIAN GAUSSIAN BASIS FUNCTIONS = 20 + NUMBER OF ELECTRONS = 14 + CHARGE OF MOLECULE = 0 + SPIN MULTIPLICITY = 1 + NUMBER OF OCCUPIED ORBITALS (ALPHA) = 7 + NUMBER OF OCCUPIED ORBITALS (BETA ) = 7 + TOTAL NUMBER OF ATOMS = 3 + THE NUCLEAR REPULSION ENERGY IS 21.6977130101 + + THIS MOLECULE IS RECOGNIZED AS BEING LINEAR. + + $CONTRL OPTIONS + --------------- + SCFTYP=ROHF RUNTYP=ENERGY EXETYP=RUN + MPLEVL= 0 CITYP =NONE CCTYP =NONE VBTYP =NONE + MULT = 1 ICHARG= 0 NZVAR = 0 COORD =UNIQUE + PP =NONE RELWFN=NONE LOCAL =NONE NUMGRD= F + ISPHER= -1 NOSYM = 0 MAXIT = 30 UNITS =ANGS + PLTORB= F MOLPLT= F AIMPAC= F FRIEND= + NPRINT= 7 IREST = 0 GEOM =INPUT + NORMF = 0 NORMP = 0 ITOL = 20 ICUT = 9 + INTTYP=BEST GRDTYP=BEST QMTTOL= 1.0E-06 + + $SYSTEM OPTIONS + --------------- + REPLICATED MEMORY= 1000000 WORDS (ON EVERY NODE). + DISTRIBUTED MEMDDI= 0 MILLION WORDS IN AGGREGATE, + MEMDDI DISTRIBUTED OVER 1 PROCESSORS IS 0 WORDS/PROCESSOR. + TOTAL MEMORY REQUESTED ON EACH PROCESSOR= 1000000 WORDS. + TIMLIM= 525600.00 MINUTES, OR 365.00 DAYS. + PARALL= F BALTYP= NXTVAL KDIAG= 0 COREFL= F + + ---------------- + PROPERTIES INPUT + ---------------- + + MOMENTS FIELD POTENTIAL DENSITY + IEMOM = 1 IEFLD = 0 IEPOT = 0 IEDEN = 0 + WHERE =COMASS WHERE =NUCLEI WHERE =NUCLEI WHERE =NUCLEI + OUTPUT=BOTH OUTPUT=BOTH OUTPUT=BOTH OUTPUT=BOTH + IEMINT= 0 IEFINT= 0 IEDINT= 0 + MORB = 0 + EXTRAPOLATION IN EFFECT + SOSCF IN EFFECT + ORBITAL PRINTING OPTION: NPREO= 1 20 2 1 + + ------------------------------- + INTEGRAL TRANSFORMATION OPTIONS + ------------------------------- + NWORD = 0 CUTOFF = 1.0E-09 + MPTRAN = 0 DIRTRF = F + AOINTS =DUP + + ---------------------- + INTEGRAL INPUT OPTIONS + ---------------------- + NOPK = 1 NORDER= 0 SCHWRZ= F + + ------------------------------------------ + THE POINT GROUP IS C1 , NAXIS= 0, ORDER= 1 + ------------------------------------------ + + DIMENSIONS OF THE SYMMETRY SUBSPACES ARE + A = 20 + + ..... DONE SETTING UP THE RUN ..... + STEP CPU TIME = 0.01 TOTAL CPU TIME = 0.0 ( 0.0 MIN) + TOTAL WALL CLOCK TIME= 0.0 SECONDS, CPU UTILIZATION IS 100.00% + + ******************** + 1 ELECTRON INTEGRALS + ******************** + ...... END OF ONE-ELECTRON INTEGRALS ...... + STEP CPU TIME = 0.00 TOTAL CPU TIME = 0.0 ( 0.0 MIN) + TOTAL WALL CLOCK TIME= 0.0 SECONDS, CPU UTILIZATION IS 100.00% + + ------------- + GUESS OPTIONS + ------------- + GUESS =HCORE NORB = 0 NORDER= 0 + MIX = F PRTMO = F PUNMO = F + TOLZ = 1.0E-08 TOLE = 1.0E-05 + SYMDEN= F PURIFY= F + + INITIAL GUESS ORBITALS GENERATED BY HCORE ROUTINE. + + SYMMETRIES FOR INITIAL GUESS ORBITALS FOLLOW. ALPHA SET(S). + 7 ORBITALS ARE OCCUPIED ( 2 CORE ORBITALS). + 3=A 4=A 5=A 6=A 7=A 8=A 9=A + 10=A 11=A 12=A 13=A 14=A 15=A 16=A + 17=A + + SYMMETRIES FOR INITIAL GUESS ORBITALS FOLLOW. BETA SET(S). + 7 ORBITALS ARE OCCUPIED ( 2 CORE ORBITALS). + 3=A 4=A 5=A 6=A 7=A 8=A 9=A + 10=A 11=A 12=A 13=A 14=A 15=A 16=A + 17=A + ...... END OF INITIAL ORBITAL SELECTION ...... + STEP CPU TIME = 0.00 TOTAL CPU TIME = 0.0 ( 0.0 MIN) + TOTAL WALL CLOCK TIME= 0.0 SECONDS, CPU UTILIZATION IS 100.00% + + ---------------------- + AO INTEGRAL TECHNOLOGY + ---------------------- + S,P,L SHELL ROTATED AXIS INTEGRALS, REPROGRAMMED BY + KAZUYA ISHIMURA (IMS) AND JOSE SIERRA (SYNSTAR). + S,P,D,L SHELL ROTATED AXIS INTEGRALS PROGRAMMED BY + KAZUYA ISHIMURA (INSTITUTE FOR MOLECULAR SCIENCE). + S,P,D,F,G SHELL TO TOTAL QUARTET ANGULAR MOMENTUM SUM 5, + ERIC PROGRAM BY GRAHAM FLETCHER (ELORET AND NASA ADVANCED + SUPERCOMPUTING DIVISION, AMES RESEARCH CENTER). + S,P,D,F,G,L SHELL GENERAL RYS QUADRATURE PROGRAMMED BY + MICHEL DUPUIS (PACIFIC NORTHWEST NATIONAL LABORATORY). + + -------------------- + 2 ELECTRON INTEGRALS + -------------------- + + THE -PK- OPTION IS OFF, THE INTEGRALS ARE NOT IN SUPERMATRIX FORM. + STORING 15000 INTEGRALS/RECORD ON DISK, USING 12 BYTES/INTEGRAL. + TWO ELECTRON INTEGRAL EVALUATION REQUIRES 89392 WORDS OF MEMORY. + II,JST,KST,LST = 1 1 1 1 NREC = 1 INTLOC = 1 + II,JST,KST,LST = 2 1 1 1 NREC = 1 INTLOC = 2 + II,JST,KST,LST = 3 1 1 1 NREC = 1 INTLOC = 7 + II,JST,KST,LST = 4 1 1 1 NREC = 1 INTLOC = 22 + II,JST,KST,LST = 5 1 1 1 NREC = 1 INTLOC = 169 + II,JST,KST,LST = 6 1 1 1 NREC = 1 INTLOC = 678 + II,JST,KST,LST = 7 1 1 1 NREC = 1 INTLOC = 1045 + II,JST,KST,LST = 8 1 1 1 NREC = 1 INTLOC = 3095 + TOTAL NUMBER OF NONZERO TWO-ELECTRON INTEGRALS = 7058 + 1 INTEGRAL RECORDS WERE STORED ON DISK FILE 8. + ...... END OF TWO-ELECTRON INTEGRALS ..... + STEP CPU TIME = 0.01 TOTAL CPU TIME = 0.0 ( 0.0 MIN) + TOTAL WALL CLOCK TIME= 0.0 SECONDS, CPU UTILIZATION IS 100.00% + + --------------------------- + ROHF SCF CALCULATION + --------------------------- + + NUCLEAR ENERGY = 21.6977130101 + MAXIT = 30 NPUNCH= 2 MULT= 1 + EXTRAP=T DAMP=F SHIFT=F RSTRCT=F DIIS=F SOSCF=T + DENSITY MATRIX CONV= 1.00E-05 + ROHF CANONICALIZATION PARAMETERS + C-C O-O V-V + ALPHA -0.5000 0.5000 1.5000 + BETA 1.5000 0.5000 -0.5000 + SOSCF WILL OPTIMIZE 91 ORBITAL ROTATION ANGLES. SOGTOL= 2.500E-01 + MEMORY REQUIRED FOR UHF/ROHF STEP= 34446 WORDS. + + ITER EX TOTAL ENERGY E CHANGE DENSITY CHANGE ORB. GRAD + 1 0 -89.6780199978 -89.6780199978 13.802827629 0.000000000 + 2 1 -86.8672057689 2.8108142288 13.697658380 1.147034737 + 3 2 -90.7237904418 -3.8565846728 6.184375907 0.885015488 + 4 3 -88.5602746012 2.1635158406 6.139277282 0.784307787 + 5 0 -90.8787176080 -2.3184430069 2.371801774 0.897367372 + ---------------START SECOND ORDER SCF--------------- + 6 1 -99.6901335684 -8.8114159604 0.589370704 0.247448832 + 7 2 -99.6027127341 0.0874208344 0.282419417 0.261235193 + 8 3 -100.0104700579 -0.4077573239 0.097896975 0.028403161 + 9 4 -100.0166758568 -0.0062057989 0.041892588 0.022623440 + 10 5 -100.0185127886 -0.0018369318 0.005554114 0.004257220 + 11 6 -100.0185731832 -0.0000603946 0.002182788 0.001537483 + 12 7 -100.0185817542 -0.0000085710 0.000686329 0.000164155 + 13 8 -100.0185822279 -0.0000004737 0.000159733 0.000052231 + 14 9 -100.0185822583 -0.0000000304 0.000031771 0.000009807 + 15 10 -100.0185822589 -0.0000000006 0.000003729 0.000001197 + 16 11 -100.0185822589 -0.0000000000 0.000000462 0.000000205 + + ----------------- + DENSITY CONVERGED + ----------------- + + FINAL ROHF ENERGY IS -100.0185822589 AFTER 16 ITERATIONS + + -------------------- + SPIN SZ = 0.000 + S-SQUARED = -0.000 + -------------------- + + ------------ + EIGENVECTORS + ------------ + + 1 2 3 4 5 + -20.5358 -7.6507 -1.3450 -0.6694 -0.6084 + A A A A A + 1 H 1 S 0.000344 -0.001283 0.014215 0.292154 0.137956 + 2 H 1 S 0.009984 0.010621 -0.040706 0.189877 0.183728 + 3 B 2 S 0.001078 0.993835 -0.103615 -0.167500 0.038365 + 4 B 2 S 0.003671 0.056948 0.125777 0.229996 -0.092389 + 5 B 2 X 0.000735 0.002873 0.178961 -0.173521 -0.351664 + 6 B 2 Y 0.000000 0.000000 0.000000 0.000000 0.000000 + 7 B 2 Z 0.000000 0.000000 0.000000 0.000000 0.000000 + 8 B 2 S 0.007386 -0.022682 0.028991 0.265728 0.011974 + 9 B 2 X 0.019131 0.008736 -0.072950 -0.150274 0.027354 + 10 B 2 Y 0.000000 0.000000 0.000000 0.000000 0.000000 + 11 B 2 Z 0.000000 0.000000 0.000000 0.000000 0.000000 + 12 O 3 S 0.992054 -0.001164 -0.212590 0.045561 -0.066200 + 13 O 3 S 0.053959 0.001671 0.432154 -0.104949 0.138600 + 14 O 3 X -0.002799 -0.001577 -0.143624 -0.191121 0.522743 + 15 O 3 Y 0.000000 0.000000 0.000000 0.000000 0.000000 + 16 O 3 Z 0.000000 0.000000 0.000000 0.000000 0.000000 + 17 O 3 S -0.038715 -0.006953 0.509977 -0.099891 0.303790 + 18 O 3 X 0.008857 0.005154 -0.052386 -0.130143 0.293535 + 19 O 3 Y 0.000000 0.000000 0.000000 0.000000 0.000000 + 20 O 3 Z 0.000000 0.000000 0.000000 0.000000 0.000000 + + 6 7 8 9 10 + -0.5169 -0.5169 0.1699 0.1699 0.2267 + A A A A A + 1 H 1 S 0.000000 0.000000 0.000000 0.000000 -0.150419 + 2 H 1 S 0.000000 0.000000 0.000000 0.000000 -1.466998 + 3 B 2 S 0.000000 0.000000 0.000000 0.000000 -0.144359 + 4 B 2 S 0.000000 0.000000 0.000000 0.000000 -0.048306 + 5 B 2 X 0.000000 0.000000 0.000000 0.000000 -0.139034 + 6 B 2 Y -0.083449 0.221695 0.137663 0.278557 0.000000 + 7 B 2 Z 0.221695 0.083449 0.278557 -0.137663 0.000000 + 8 B 2 S 0.000000 0.000000 0.000000 0.000000 2.027943 + 9 B 2 X 0.000000 0.000000 0.000000 0.000000 -0.144405 + 10 B 2 Y -0.050412 0.133928 0.379815 0.768545 0.000000 + 11 B 2 Z 0.133928 0.050412 0.768545 -0.379815 0.000000 + 12 O 3 S 0.000000 0.000000 0.000000 0.000000 0.053464 + 13 O 3 S 0.000000 0.000000 0.000000 0.000000 -0.086787 + 14 O 3 X 0.000000 0.000000 0.000000 0.000000 0.153448 + 15 O 3 Y -0.190568 0.506276 -0.136229 -0.275656 0.000000 + 16 O 3 Z 0.506276 0.190568 -0.275656 0.136229 0.000000 + 17 O 3 S 0.000000 0.000000 0.000000 0.000000 -0.606405 + 18 O 3 X 0.000000 0.000000 0.000000 0.000000 0.320500 + 19 O 3 Y -0.148054 0.393331 -0.221558 -0.448317 0.000000 + 20 O 3 Z 0.393331 0.148054 -0.448317 0.221558 0.000000 + + 11 12 13 14 15 + 0.4316 0.7045 0.7045 0.7350 1.1048 + A A A A A + 1 H 1 S -0.197856 0.000000 0.000000 0.585371 -0.661822 + 2 H 1 S 2.428044 0.000000 0.000000 1.162180 1.538010 + 3 B 2 S 0.027852 0.000000 0.000000 0.045321 0.010878 + 4 B 2 S -0.331748 0.000000 0.000000 0.814476 1.936129 + 5 B 2 X 0.288153 0.000000 0.000000 -0.704191 0.333782 + 6 B 2 Y 0.000000 0.097971 1.207126 0.000000 0.000000 + 7 B 2 Z 0.000000 1.207126 -0.097971 0.000000 0.000000 + 8 B 2 S 0.216139 0.000000 0.000000 -1.451072 -1.909797 + 9 B 2 X 2.635346 0.000000 0.000000 2.283710 0.676105 + 10 B 2 Y 0.000000 -0.085320 -1.051252 0.000000 0.000000 + 11 B 2 Z 0.000000 -1.051252 0.085320 0.000000 0.000000 + 12 O 3 S 0.086152 0.000000 0.000000 0.027095 0.050912 + 13 O 3 S -0.030658 0.000000 0.000000 -0.048038 -0.187902 + 14 O 3 X 0.005711 0.000000 0.000000 -0.124028 0.248507 + 15 O 3 Y 0.000000 -0.002880 -0.035481 0.000000 0.000000 + 16 O 3 Z 0.000000 -0.035481 0.002880 0.000000 0.000000 + 17 O 3 S -1.936881 0.000000 0.000000 -0.740239 -0.345357 + 18 O 3 X 0.485099 0.000000 0.000000 -0.079803 0.535249 + 19 O 3 Y 0.000000 0.000732 0.009020 0.000000 0.000000 + 20 O 3 Z 0.000000 0.009020 -0.000732 0.000000 0.000000 + + 16 17 18 19 20 + 1.2423 1.3557 1.3557 1.4100 2.2399 + A A A A A + 1 H 1 S 0.719124 0.000000 0.000000 0.725323 -0.157789 + 2 H 1 S -1.191244 0.000000 0.000000 -0.477445 -1.225214 + 3 B 2 S 0.105177 0.000000 0.000000 -0.060885 -0.141177 + 4 B 2 S 0.511585 0.000000 0.000000 0.050787 -0.875118 + 5 B 2 X 1.035905 0.000000 0.000000 0.780799 -0.452459 + 6 B 2 Y 0.000000 0.002283 0.015609 0.000000 0.000000 + 7 B 2 Z 0.000000 0.015609 -0.002283 0.000000 0.000000 + 8 B 2 S 1.010217 0.000000 0.000000 0.112107 -0.746938 + 9 B 2 X -0.643431 0.000000 0.000000 -0.134607 -2.362585 + 10 B 2 Y 0.000000 -0.058566 -0.400461 0.000000 0.000000 + 11 B 2 Z 0.000000 -0.400461 0.058566 0.000000 0.000000 + 12 O 3 S 0.065107 0.000000 0.000000 0.020195 0.012799 + 13 O 3 S -0.268804 0.000000 0.000000 -0.067586 -1.977025 + 14 O 3 X -0.440790 0.000000 0.000000 0.885097 0.119422 + 15 O 3 Y 0.000000 -0.143987 -0.984542 0.000000 0.000000 + 16 O 3 Z 0.000000 -0.984542 0.143987 0.000000 0.000000 + 17 O 3 S -0.423279 0.000000 0.000000 -0.263857 4.377413 + 18 O 3 X 1.480677 0.000000 0.000000 -0.527277 -1.336333 + 19 O 3 Y 0.000000 0.174511 1.193260 0.000000 0.000000 + 20 O 3 Z 0.000000 1.193260 -0.174511 0.000000 0.000000 + ...... END OF ROHF CALCULATION ...... + STEP CPU TIME = 0.00 TOTAL CPU TIME = 0.0 ( 0.0 MIN) + TOTAL WALL CLOCK TIME= 0.0 SECONDS, CPU UTILIZATION IS 100.00% + + ---------------------------------------------------------------- + PROPERTY VALUES FOR THE ROHF SELF-CONSISTENT FIELD WAVEFUNCTION + ---------------------------------------------------------------- + + ----------------- + ENERGY COMPONENTS + ----------------- + + WAVEFUNCTION NORMALIZATION = 1.0000000000 + + ONE ELECTRON ENERGY = -179.7468005131 + TWO ELECTRON ENERGY = 58.0305052441 + NUCLEAR REPULSION ENERGY = 21.6977130101 + ------------------ + TOTAL ENERGY = -100.0185822589 + + ELECTRON-ELECTRON POTENTIAL ENERGY = 58.0305052441 + NUCLEUS-ELECTRON POTENTIAL ENERGY = -279.7201121919 + NUCLEUS-NUCLEUS POTENTIAL ENERGY = 21.6977130101 + ------------------ + TOTAL POTENTIAL ENERGY = -199.9918939377 + TOTAL KINETIC ENERGY = 99.9733116788 + VIRIAL RATIO (V/T) = 2.0004528267 + + ...... PI ENERGY ANALYSIS ...... + + ENERGY ANALYSIS: + FOCK ENERGY= -63.6857886983 + BARE H ENERGY= -179.7468005131 + ELECTRONIC ENERGY = -121.7162946057 + KINETIC ENERGY= 99.9733116788 + N-N REPULSION= 21.6977130101 + TOTAL ENERGY= -100.0185815956 + SIGMA PART(1+2)= -104.7962806542 + (K,V1,2)= 92.4442005381 -240.4183928275 43.1779116353 + PI PART(1+2)= -16.9200139514 + (K,V1,2)= 7.5291111407 -39.3017193643 14.8525942722 + SIGMA SKELETON, ERROR= -83.0985676441 -0.0000000000 + MIXED PART= 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 + ...... END OF PI ENERGY ANALYSIS ...... + + --------------------------------------- + MULLIKEN AND LOWDIN POPULATION ANALYSES + --------------------------------------- + + MULLIKEN ATOMIC POPULATION IN EACH MOLECULAR ORBITAL + + 1 2 3 4 5 + + 2.000000 2.000000 2.000000 2.000000 2.000000 + + 1 0.000109 0.002431 -0.009540 0.732140 0.208060 + 2 0.004773 2.000884 0.269059 0.988894 0.366310 + 3 1.995118 -0.003315 1.740481 0.278967 1.425630 + + 6 7 + + 2.000000 2.000000 + + 1 0.000000 0.000000 + 2 0.420558 0.420558 + 3 1.579442 1.579442 + + ATOMIC SPIN POPULATION (ALPHA MINUS BETA) + ATOM MULL.POP. LOW.POP. + 1 H 0.000000 0.000000 + 2 B 0.000000 0.000000 + 3 B 0.000000 0.000000 + + ----- POPULATIONS IN EACH AO ----- + MULLIKEN LOWDIN + 1 H 1 S 0.51411 0.47971 + 2 H 1 S 0.41909 0.48591 + 3 B 2 S 1.99770 1.98102 + 4 B 2 S 0.45972 0.43762 + 5 B 2 X 0.70045 0.64124 + 6 B 2 Y 0.25163 0.23600 + 7 B 2 Z 0.25163 0.23600 + 8 B 2 S 0.37344 0.43074 + 9 B 2 X 0.09860 0.36418 + 10 B 2 Y 0.16892 0.22234 + 11 B 2 Z 0.16892 0.22234 + 12 O 3 S 1.99590 1.99380 + 13 O 3 S 0.85319 0.83536 + 14 O 3 X 0.99185 0.94649 + 15 O 3 Y 0.86458 0.82908 + 16 O 3 Z 0.86458 0.82908 + 17 O 3 S 1.06945 0.76118 + 18 O 3 X 0.52649 0.64275 + 19 O 3 Y 0.71487 0.71259 + 20 O 3 Z 0.71487 0.71259 + + ----- MULLIKEN ATOMIC OVERLAP POPULATIONS ----- + (OFF-DIAGONAL ELEMENTS NEED TO BE MULTIPLIED BY 2) + + 1 2 3 + + 1 0.5637982 + 2 0.3833280 3.4279422 + 3 -0.0139266 0.6597650 7.9499266 + + TOTAL MULLIKEN AND LOWDIN ATOMIC POPULATIONS + ATOM MULL.POP. CHARGE LOW.POP. CHARGE + 1 H 0.933200 0.066800 0.965622 0.034378 + 2 B 4.471035 0.528965 4.771474 0.228526 + 3 B 8.595765 -0.595765 8.262905 -0.262905 + + ------------------------------- + BOND ORDER AND VALENCE ANALYSIS BOND ORDER THRESHOLD=0.050 + ------------------------------- + + BOND BOND BOND + ATOM PAIR DIST ORDER ATOM PAIR DIST ORDER ATOM PAIR DIST ORDER + 1 2 1.166 0.974 2 3 1.200 2.151 + + TOTAL BONDED FREE + ATOM VALENCE VALENCE VALENCE + 1 H 0.969 0.969 -0.000 + 2 B 3.125 3.125 -0.000 + 3 B 2.145 2.145 -0.000 + + ----------------------------------------- + ATOMIC SPIN DENSITY AT THE NUCLEUS (A.U.) + ----------------------------------------- + SPIN DENS ALPHA DENS BETA DENS + 1 H 1.0 0.0000000 0.19961 0.19961 + 2 B 5.0 0.0000000 30.17561 30.17561 + 3 B 8.0 0.0000000 131.78303 131.78303 + + --------------------- + ELECTROSTATIC MOMENTS + --------------------- + + POINT 1 X Y Z (BOHR) CHARGE + 3.418988 0.000000 0.000000 -0.00 (A.U.) + DX DY DZ /D/ (DEBYE) + -3.311042 0.000000 0.000000 3.311042 + ...... END OF PROPERTY EVALUATION ...... + STEP CPU TIME = 0.00 TOTAL CPU TIME = 0.0 ( 0.0 MIN) + TOTAL WALL CLOCK TIME= 0.0 SECONDS, CPU UTILIZATION IS 100.00% + 440000 WORDS OF DYNAMIC MEMORY USED + EXECUTION OF GAMESS TERMINATED NORMALLY Thu Apr 16 11:11:32 2015 + DDI: 1128 bytes (0.0 MB / 0 MWords) used by master data server. + + ---------------------------------------- + CPU timing information for all processes + ======================================== + 0: 0.029395 + 0.008325 = 0.037720 + ---------------------------------------- + ddikick.x: exited gracefully. +----- accounting info ----- +jeudi 16 avril 2015, 11:11:35 (UTC+0200) +Files used on the master node LPQLX15 were: +-rw-rw-r-- 1 razoa razoa 8438 avril 16 11:11 /tmp/gamess/HBO.dat +-rw-r--r-- 1 razoa razoa 1404 avril 16 11:11 /tmp/gamess/HBO.F05 +-rw-rw-r-- 1 razoa razoa 180016 avril 16 11:11 /tmp/gamess/HBO.F08 +-rw-rw-r-- 1 razoa razoa 4711680 avril 16 11:11 /tmp/gamess/HBO.F10 +0.104u 0.077s 0:03.22 5.2% 0+0k 0+16io 0pf+0w diff --git a/tests/unit_test/unit_test.py b/tests/unit_test/unit_test.py index eb9b1e79..c01b4974 100755 --- a/tests/unit_test/unit_test.py +++ b/tests/unit_test/unit_test.py @@ -62,7 +62,6 @@ def get_error_message(l_exepected, l_cur): # / |_ _ _ | o ._ ._ _|_ # \_ | | (/_ (_ |< | | | |_) |_| |_ # | - def check_disk_acess(geo, basis, mult=1): import uuid @@ -147,8 +146,6 @@ def check_mo_guess(geo, basis, mult=1): # / |_ _ _ | _. | _ _ # \_ | | (/_ (_ |< \/ (_| | |_| (/_ _> # - - def run_hf(geo, basis, mult=1): """ Run a simle by default hf @@ -286,6 +283,56 @@ def hf_then_10k_test(geo, basis): return return_code +# _ +# / |_ _ _ | _. ._ _ _ ._ _ ._ _|_ +# \_ | | (/_ (_ |< (_| |_) (_ (_) | | \/ (/_ | |_ +# | | __ +def check_convert(path_out): + ''' + Path_out is the out_file + ''' + + # ~#~#~#~#~#~#~#~#~#~ # + # R e f _ e n e r g y # + # ~#~#~#~#~#~#~#~#~#~ # + + ref_energy = defaultdict(dict) + + ref_energy["HBO.out"] = -100.0185822589 + + # ~#~#~#~#~#~#~#~#~#~#~#~#~ # + # S e t _ p a r a m e t e r # + # ~#~#~#~#~#~#~#~#~#~#~#~#~ # + + cmd = "cp {0}/tests/{1} .".format(qpackage_root, path_out) + subprocess.check_call([cmd], shell=True) + + cmd = "qp_convert_output_to_ezfio.py {0}".format(path_out) + subprocess.check_call([cmd], shell=True) + + # Test 2 + cmd = "qp_edit -c {0}.ezfio".format(path_out) + subprocess.check_call([cmd], shell=True) + + cmd = "qp_run SCF {0}.ezfio".format(path_out) + subprocess.check_call([cmd], shell=True) + + # ~#~#~#~#~ # + # C h e c k # + # ~#~#~#~#~ # + + ezfio.set_file("{0}.ezfio".format(path_out)) + + cur_e = ezfio.get_hartree_fock_energy() + ref_e = ref_energy[path_out] + + if abs(cur_e - ref_e) <= precision: + subprocess.call(["rm {0}".format(path_out)], shell=True) + subprocess.call(["rm -R {0}.ezfio".format(path_out)], shell=True) + return True + else: + raise ValueError(get_error_message([ref_e], [cur_e])) + # ___ # | _ _ _|_ # | (/_ _> |_ @@ -295,6 +342,9 @@ class ValueTest(unittest.TestCase): def test_full_ci_10k_pt2_end(self): self.assertTrue(hf_then_10k_test("methane", "sto-3g")) + def test_check_convert_hf_energy(self): + self.assertTrue(check_convert("HBO.out")) + class InputTest(unittest.TestCase): From 74c9e03e2a4cad0403854b6ea3384de53bbd37af Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 13:35:29 +0200 Subject: [PATCH 23/70] Try to solve the 'Bool.of_string: expected true or false but got True' --- scripts/ezfio_interface/ei_handler.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index a02b13d5..a940c584 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -70,9 +70,9 @@ def is_bool(str_): Take a string, if is a bool return the conversion into fortran and ocaml. """ - if "true" in str_.lower(): + if "true" in str_.stirp().lower(): return Type(None, "true", ".True.") - elif "false" in str_.lower(): + elif "false" in str_.stirp().lower(): return Type(None, "false", ".False") else: raise TypeError From 654b190506bf35a7a2bc32569412c19d80fe8ac2 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 13:57:00 +0200 Subject: [PATCH 24/70] stirp to strip() --- scripts/ezfio_interface/ei_handler.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index a940c584..220d368c 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -70,9 +70,9 @@ def is_bool(str_): Take a string, if is a bool return the conversion into fortran and ocaml. """ - if "true" in str_.stirp().lower(): + if "true" in str_.strip().lower(): return Type(None, "true", ".True.") - elif "false" in str_.stirp().lower(): + elif "false" in str_.strip().lower(): return Type(None, "false", ".False") else: raise TypeError From d45e611dadf92da9c7bba12c9145d8776bef5f3f Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 14:31:28 +0200 Subject: [PATCH 25/70] Print is_bool() to debug in travis ci, canot see the bug in my machine --- scripts/ezfio_interface/ei_handler.py | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index 220d368c..54b41197 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -278,6 +278,7 @@ def get_dict_config_file(config_file_path, module_lower): try: d[pvd]["default"] = is_bool(default_raw) + print is_bool(default_raw) except TypeError: d[pvd]["default"] = Type(None, default_raw, default_raw) From 030c89b957fa4d9df3fa3365ed5dec01577af198 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 19 Apr 2015 16:45:31 +0200 Subject: [PATCH 26/70] Solved True/true problem --- .../WILL_BE_DELETED.ezfio_default | 30 +++++++++---------- src/FCIdump/README.rst | 3 ++ 2 files changed, 18 insertions(+), 15 deletions(-) diff --git a/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default b/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default index cf54a1dd..0d9489d5 100644 --- a/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default +++ b/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default @@ -1,19 +1,19 @@ bielec_integrals - read_ao_integrals False - read_mo_integrals False - write_ao_integrals False - write_mo_integrals False + read_ao_integrals false + read_mo_integrals false + write_ao_integrals false + write_mo_integrals false threshold_ao 1.e-15 threshold_mo 1.e-15 - direct False + direct false cis_dressed n_state_cis 10 n_core_cis 0 n_act_cis mo_basis_mo_tot_num - mp2_dressing False - standard_doubles True - en_2_2 False + mp2_dressing false + standard_doubles true + en_2_2 false determinants n_states 1 @@ -21,27 +21,27 @@ determinants n_det_max_jacobi 1000 threshold_generators 0.99 threshold_selectors 0.999 - read_wf False - s2_eig False - only_single_double_dm False + read_wf false + s2_eig false + only_single_double_dm false full_ci n_det_max_fci 10000 n_det_max_fci_property 50000 pt2_max 1.e-4 - do_pt2_end True + do_pt2_end true var_pt2_ratio 0.75 cas_sd n_det_max_cas_sd 100000 pt2_max 1.e-4 - do_pt2_end True + do_pt2_end true var_pt2_ratio 0.75 all_singles n_det_max_fci 50000 pt2_max 1.e-8 - do_pt2_end False + do_pt2_end false hartree_fock n_it_scf_max 200 @@ -55,7 +55,7 @@ cisd_selected cisd_sc2_selected n_det_max_cisd_sc2 10000 pt2_max 1.e-4 - do_pt2_end True + do_pt2_end true properties z_one_point 3.9 diff --git a/src/FCIdump/README.rst b/src/FCIdump/README.rst index 580d0016..1fdd9660 100644 --- a/src/FCIdump/README.rst +++ b/src/FCIdump/README.rst @@ -10,6 +10,9 @@ Documentation .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. +`fcidump `_ + Undocumented + Needed Modules From db558258b21a2c0f52e4edefc54da72374608d5f Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 16 Apr 2015 13:57:00 +0200 Subject: [PATCH 27/70] Remove WILL be DELETED and change ezfio_with_default in concequance --- .../WILL_BE_DELETED.ezfio_default | 61 -- scripts/ezfio_interface/ei_handler.py | 4 +- scripts/ezfio_with_default.py | 18 +- src/Dets/README.rst | 134 ++--- src/Dets/connected_to_ref.irp.f | 67 +-- src/Dets/determinants.irp.f | 297 ---------- src/Dets/spindeterminants.ezfio_config | 5 +- src/Dets/spindeterminants.irp.f | 528 +++++++++++++++++- src/Makefile.config.ifort | 30 - 9 files changed, 617 insertions(+), 527 deletions(-) delete mode 100644 data/ezfio_defaults/WILL_BE_DELETED.ezfio_default delete mode 100644 src/Makefile.config.ifort diff --git a/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default b/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default deleted file mode 100644 index cf54a1dd..00000000 --- a/data/ezfio_defaults/WILL_BE_DELETED.ezfio_default +++ /dev/null @@ -1,61 +0,0 @@ -bielec_integrals - read_ao_integrals False - read_mo_integrals False - write_ao_integrals False - write_mo_integrals False - threshold_ao 1.e-15 - threshold_mo 1.e-15 - direct False - -cis_dressed - n_state_cis 10 - n_core_cis 0 - n_act_cis mo_basis_mo_tot_num - mp2_dressing False - standard_doubles True - en_2_2 False - -determinants - n_states 1 - n_states_diag determinants_n_states - n_det_max_jacobi 1000 - threshold_generators 0.99 - threshold_selectors 0.999 - read_wf False - s2_eig False - only_single_double_dm False - -full_ci - n_det_max_fci 10000 - n_det_max_fci_property 50000 - pt2_max 1.e-4 - do_pt2_end True - var_pt2_ratio 0.75 - -cas_sd - n_det_max_cas_sd 100000 - pt2_max 1.e-4 - do_pt2_end True - var_pt2_ratio 0.75 - -all_singles - n_det_max_fci 50000 - pt2_max 1.e-8 - do_pt2_end False - -hartree_fock - n_it_scf_max 200 - thresh_scf 1.e-10 - guess "Huckel" - -cisd_selected - n_det_max_cisd 10000 - pt2_max 1.e-4 - -cisd_sc2_selected - n_det_max_cisd_sc2 10000 - pt2_max 1.e-4 - do_pt2_end True - -properties - z_one_point 3.9 diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index a940c584..220d368c 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -70,9 +70,9 @@ def is_bool(str_): Take a string, if is a bool return the conversion into fortran and ocaml. """ - if "true" in str_.stirp().lower(): + if "true" in str_.strip().lower(): return Type(None, "true", ".True.") - elif "false" in str_.stirp().lower(): + elif "false" in str_.strip().lower(): return Type(None, "false", ".False") else: raise TypeError diff --git a/scripts/ezfio_with_default.py b/scripts/ezfio_with_default.py index 1b5f01a8..a2dfa430 100755 --- a/scripts/ezfio_with_default.py +++ b/scripts/ezfio_with_default.py @@ -90,13 +90,19 @@ END_PROVIDER self.default = t def get_default(self): - filename = '/'.join( [os.environ['QPACKAGE_ROOT'], 'data', - 'ezfio_defaults', - 'WILL_BE_DELETED.ezfio_default'] ) + mypath = '/'.join( [os.environ['QPACKAGE_ROOT'], 'data', + 'ezfio_defaults'] ) + + from os import listdir + from os.path import isfile, join + onlyfiles = [ join(mypath,f) for f in listdir(mypath) if isfile(join(mypath,f)) ] + + lines = [] + for filename in onlyfiles: + file = open(filename,'r') + lines.extend(file.readlines()) + file.close() - file = open(filename,'r') - lines = file.readlines() - file.close() k=-1 # Search directory for k,line in enumerate(lines): diff --git a/src/Dets/README.rst b/src/Dets/README.rst index f03df8da..e9077510 100644 --- a/src/Dets/README.rst +++ b/src/Dets/README.rst @@ -90,10 +90,6 @@ Documentation `connected_to_ref_by_mono `_ Undocumented -`det_is_not_or_may_be_in_ref `_ - If true, det is not in ref - If false, det may be in ref - `det_search_key `_ Return an integer*8 corresponding to a determinant index for searching @@ -103,9 +99,6 @@ Documentation `is_in_wavefunction `_ True if the determinant ``det`` is in the wave function -`key_pattern_not_in_ref `_ - Min and max values of the integers of the keys of the reference - `occ_pattern_search_key `_ Return an integer*8 corresponding to a determinant index for searching @@ -200,16 +193,10 @@ Documentation `det_svd `_ Computes the SVD of the Alpha x Beta determinant coefficient matrix -`create_wf_of_psi_svd_matrix `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`filter_3_highest_electrons `_ +`filter_3_highest_electrons `_ Returns a determinant with only the 3 highest electrons -`generate_all_alpha_beta_det_products `_ - Create a wave function from all possible alpha x beta determinants - -`int_of_3_highest_electrons `_ +`int_of_3_highest_electrons `_ Returns an integer*8 as : .br |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| @@ -226,32 +213,26 @@ Documentation `n_det `_ Number of determinants in the wave function -`n_det_alpha_unique `_ - Unique alpha determinants - -`n_det_beta_unique `_ - Unique beta determinants - `psi_average_norm_contrib `_ Contribution of determinants to the state-averaged density -`psi_average_norm_contrib_sorted `_ +`psi_average_norm_contrib_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) `psi_coef `_ The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file is empty -`psi_coef_sorted `_ +`psi_coef_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef_sorted_ab `_ +`psi_coef_sorted_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_coef_sorted_bit `_ +`psi_coef_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave @@ -261,80 +242,53 @@ Documentation The wave function determinants. Initialized with Hartree-Fock if the EZFIO file is empty -`psi_det_alpha `_ - List of alpha determinants of psi_det - -`psi_det_alpha_unique `_ - Unique alpha determinants - -`psi_det_beta `_ - List of beta determinants of psi_det - -`psi_det_beta_unique `_ - Unique beta determinants - `psi_det_size `_ Size of the psi_det/psi_coef arrays -`psi_det_sorted `_ +`psi_det_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_det_sorted_ab `_ +`psi_det_sorted_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_det_sorted_bit `_ +`psi_det_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave function. -`psi_det_sorted_next_ab `_ +`psi_det_sorted_next_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_svd_alpha `_ - SVD wave function - -`psi_svd_beta `_ - SVD wave function - -`psi_svd_coefs `_ - SVD wave function - -`psi_svd_matrix `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`read_dets `_ +`read_dets `_ Reads the determinants from the EZFIO file -`save_wavefunction `_ +`save_wavefunction `_ Save the wave function into the EZFIO file -`save_wavefunction_general `_ +`save_wavefunction_general `_ Save the wave function into the EZFIO file -`save_wavefunction_unsorted `_ +`save_wavefunction_unsorted `_ Save the wave function into the EZFIO file -`sort_dets_by_3_highest_electrons `_ +`sort_dets_by_3_highest_electrons `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`sort_dets_by_det_search_key `_ +`sort_dets_by_det_search_key `_ Determinants are sorted are sorted according to their det_search_key. Useful to accelerate the search of a random determinant in the wave function. -`spin_det_search_key `_ - Return an integer*8 corresponding to a determinant index for searching - `double_exc_bitmask `_ double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 @@ -675,7 +629,61 @@ Documentation `n_con_int `_ Number of integers to represent the connections between determinants -`write_spindeterminants `_ +`create_wf_of_psi_svd_matrix `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`generate_all_alpha_beta_det_products `_ + Create a wave function from all possible alpha x beta determinants + +`get_index_in_psi_det_alpha_unique `_ + Returns the index of the determinant in the ``psi_det_alpha_unique`` array + +`get_index_in_psi_det_beta_unique `_ + Returns the index of the determinant in the ``psi_det_beta_unique`` array + +`n_det_alpha_unique `_ + Unique alpha determinants + +`n_det_beta_unique `_ + Unique beta determinants + +`psi_det_alpha `_ + List of alpha determinants of psi_det + +`psi_det_alpha_unique `_ + Unique alpha determinants + +`psi_det_beta `_ + List of beta determinants of psi_det + +`psi_det_beta_unique `_ + Unique beta determinants + +`psi_svd_alpha `_ + SVD wave function + +`psi_svd_beta `_ + SVD wave function + +`psi_svd_coefs `_ + SVD wave function + +`psi_svd_matrix `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_columns `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_rows `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_values `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`spin_det_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`write_spindeterminants `_ Undocumented `cisd `_ diff --git a/src/Dets/connected_to_ref.irp.f b/src/Dets/connected_to_ref.irp.f index 3c7eb581..2d40b621 100644 --- a/src/Dets/connected_to_ref.irp.f +++ b/src/Dets/connected_to_ref.irp.f @@ -162,7 +162,7 @@ integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) integer :: N_past integer :: i, l integer :: degree_x2 - logical :: det_is_not_or_may_be_in_ref, t + logical :: t double precision :: hij_elec ! output : 0 : not connected @@ -260,7 +260,7 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) integer :: N_past integer :: i, l integer :: degree_x2 - logical :: det_is_not_or_may_be_in_ref, t + logical :: t double precision :: hij_elec ! output : 0 : not connected @@ -355,66 +355,3 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) end - -logical function det_is_not_or_may_be_in_ref(key,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! If true, det is not in ref - ! If false, det may be in ref - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key(Nint,2) - integer(bit_kind) :: key_int - integer*1 :: key_short(bit_kind) - !DIR$ ATTRIBUTES ALIGN : 32 :: key_short - equivalence (key_int,key_short) - - integer :: i, ispin, k - - det_is_not_or_may_be_in_ref = .False. - do ispin=1,2 - do i=1,Nint - key_int = key(i,ispin) - do k=1,bit_kind - det_is_not_or_may_be_in_ref = & - det_is_not_or_may_be_in_ref .or. & - key_pattern_not_in_ref(key_short(k), i, ispin) - enddo - if(det_is_not_or_may_be_in_ref) then - return - endif - enddo - enddo - -end - - -BEGIN_PROVIDER [ logical, key_pattern_not_in_ref, (-128:127,N_int,2) ] - use bitmasks - implicit none - BEGIN_DOC - ! Min and max values of the integers of the keys of the reference - END_DOC - - integer :: i, j, ispin - integer(bit_kind) :: key - integer*1 :: key_short(bit_kind) - equivalence (key,key_short) - integer :: idx, k - - key_pattern_not_in_ref = .True. - - do j=1,N_det - do ispin=1,2 - do i=1,N_int - key = psi_det(i,ispin,j) - do k=1,bit_kind - key_pattern_not_in_ref( key_short(k), i, ispin ) = .False. - enddo - enddo - enddo - enddo - -END_PROVIDER - diff --git a/src/Dets/determinants.irp.f b/src/Dets/determinants.irp.f index 00e683fc..104b868e 100644 --- a/src/Dets/determinants.irp.f +++ b/src/Dets/determinants.irp.f @@ -294,132 +294,6 @@ END_PROVIDER -!==============================================================================! -! ! -! Independent alpha/beta parts ! -! ! -!==============================================================================! - -integer*8 function spin_det_search_key(det,Nint) - use bitmasks - implicit none - BEGIN_DOC -! Return an integer*8 corresponding to a determinant index for searching - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det(Nint) - integer :: i - spin_det_search_key = det(1) - do i=2,Nint - spin_det_search_key = ieor(spin_det_search_key,det(i)) - enddo -end - - -BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] - implicit none - BEGIN_DOC -! List of alpha determinants of psi_det - END_DOC - integer :: i,k - - do i=1,N_det - do k=1,N_int - psi_det_alpha(k,i) = psi_det(k,1,i) - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] - implicit none - BEGIN_DOC -! List of beta determinants of psi_det - END_DOC - integer :: i,k - - do i=1,N_det - do k=1,N_int - psi_det_beta(k,i) = psi_det(k,2,i) - enddo - enddo -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha_unique, (N_int,psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_alpha_unique ] - implicit none - BEGIN_DOC - ! Unique alpha determinants - END_DOC - - integer :: i,k - integer, allocatable :: iorder(:) - integer*8, allocatable :: bit_tmp(:) - integer*8 :: last_key - integer*8, external :: spin_det_search_key - - allocate ( iorder(N_det), bit_tmp(N_det)) - - do i=1,N_det - iorder(i) = i - bit_tmp(i) = spin_det_search_key(psi_det_alpha(1,i),N_int) - enddo - - call i8sort(bit_tmp,iorder,N_det) - - N_det_alpha_unique = 0 - last_key = 0_8 - do i=1,N_det - if (bit_tmp(i) /= last_key) then - last_key = bit_tmp(i) - N_det_alpha_unique += 1 - do k=1,N_int - psi_det_alpha_unique(k,N_det_alpha_unique) = psi_det_alpha(k,iorder(i)) - enddo - endif - enddo - - deallocate (iorder, bit_tmp) -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta_unique, (N_int,psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_beta_unique ] - implicit none - BEGIN_DOC - ! Unique beta determinants - END_DOC - - integer :: i,k - integer, allocatable :: iorder(:) - integer*8, allocatable :: bit_tmp(:) - integer*8 :: last_key - integer*8, external :: spin_det_search_key - - allocate ( iorder(N_det), bit_tmp(N_det)) - - do i=1,N_det - iorder(i) = i - bit_tmp(i) = spin_det_search_key(psi_det_beta(1,i),N_int) - enddo - - call i8sort(bit_tmp,iorder,N_det) - - N_det_beta_unique = 0 - last_key = 0_8 - do i=1,N_det - if (bit_tmp(i) /= last_key) then - last_key = bit_tmp(i) - N_det_beta_unique += 1 - do k=1,N_int - psi_det_beta_unique(k,N_det_beta_unique) = psi_det_beta(k,iorder(i)) - enddo - endif - enddo - - deallocate (iorder, bit_tmp) -END_PROVIDER - - - !==============================================================================! ! ! ! Sorting providers ! @@ -700,177 +574,6 @@ subroutine sort_dets_by_3_highest_electrons(det_in,coef_in,det_out,coef_out, & end -!==============================================================================! -! ! -! Alpha x Beta Matrix ! -! ! -!==============================================================================! - -BEGIN_PROVIDER [ double precision, psi_svd_matrix, (N_det_alpha_unique,N_det_beta_unique,N_states) ] - use bitmasks - implicit none - BEGIN_DOC -! Matrix of wf coefficients. Outer product of alpha and beta determinants - END_DOC - integer :: i,j,k - integer(bit_kind) :: tmp_det(N_int,2) - integer :: idx - integer, external :: get_index_in_psi_det_sorted_bit - logical, external :: is_in_wavefunction - - psi_svd_matrix = 0.d0 - do j=1,N_det_beta_unique - do k=1,N_int - tmp_det(k,2) = psi_det_beta_unique(k,j) - enddo - do i=1,N_det_alpha_unique - do k=1,N_int - tmp_det(k,1) = psi_det_alpha_unique(k,i) - enddo - idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) - if (idx > 0) then - do k=1,N_states - psi_svd_matrix(i,j,k) = psi_coef_sorted_bit(idx,k) - enddo - endif - enddo - enddo - -END_PROVIDER - -subroutine create_wf_of_psi_svd_matrix - use bitmasks - implicit none - BEGIN_DOC -! Matrix of wf coefficients. Outer product of alpha and beta determinants - END_DOC - integer :: i,j,k - integer(bit_kind) :: tmp_det(N_int,2) - integer :: idx - integer, external :: get_index_in_psi_det_sorted_bit - logical, external :: is_in_wavefunction - double precision :: norm(N_states) - - call generate_all_alpha_beta_det_products - norm = 0.d0 - do j=1,N_det_beta_unique - do k=1,N_int - tmp_det(k,2) = psi_det_beta_unique(k,j) - enddo - do i=1,N_det_alpha_unique - do k=1,N_int - tmp_det(k,1) = psi_det_alpha_unique(k,i) - enddo - idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) - if (idx > 0) then - do k=1,N_states - psi_coef_sorted_bit(idx,k) = psi_svd_matrix(i,j,k) - norm(k) += psi_svd_matrix(i,j,k) - enddo - endif - enddo - enddo - do k=1,N_states - norm(k) = 1.d0/dsqrt(norm(k)) - do i=1,N_det - psi_coef_sorted_bit(i,k) = psi_coef_sorted_bit(i,k)*norm(k) - enddo - enddo - psi_det = psi_det_sorted_bit - psi_coef = psi_coef_sorted_bit - TOUCH psi_det psi_coef - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - norm(1) = 0.d0 - do i=1,N_det - norm(1) += psi_average_norm_contrib_sorted(i) - if (norm(1) >= 0.999999d0) then - exit - endif - enddo - N_det = min(i,N_det) - SOFT_TOUCH psi_det psi_coef N_det - -end - -subroutine generate_all_alpha_beta_det_products - implicit none - BEGIN_DOC -! Create a wave function from all possible alpha x beta determinants - END_DOC - integer :: i,j,k,l - integer :: idx - integer, external :: get_index_in_psi_det_sorted_bit - integer(bit_kind), allocatable :: tmp_det(:,:,:) - logical, external :: is_in_wavefunction - - allocate (tmp_det(N_int,2,N_det_alpha_unique)) - do j=1,N_det_beta_unique - l = 1 - do i=1,N_det_alpha_unique - do k=1,N_int - tmp_det(k,1,l) = psi_det_alpha_unique(k,i) - tmp_det(k,2,l) = psi_det_beta_unique (k,j) - enddo - if (.not.is_in_wavefunction(tmp_det(1,1,l),N_int,N_det)) then - l = l+1 - endif - enddo - call fill_H_apply_buffer_no_selection(l-1, tmp_det, N_int, 1) - enddo - deallocate (tmp_det) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH psi_det psi_coef N_det -end - - BEGIN_PROVIDER [ double precision, psi_svd_alpha, (N_det_alpha_unique,N_det_alpha_unique,N_states) ] -&BEGIN_PROVIDER [ double precision, psi_svd_beta , (N_det_beta_unique,N_det_beta_unique,N_states) ] -&BEGIN_PROVIDER [ double precision, psi_svd_coefs, (N_det_beta_unique,N_states) ] - implicit none - BEGIN_DOC - ! SVD wave function - END_DOC - - integer :: lwork, info, istate - double precision, allocatable :: work(:), tmp(:,:), copy(:,:) - allocate (work(1),tmp(N_det_beta_unique,N_det_beta_unique), & - copy(size(psi_svd_matrix,1),size(psi_svd_matrix,2))) - - do istate = 1,N_states - copy(:,:) = psi_svd_matrix(:,:,istate) - lwork=-1 - call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & - copy, size(copy,1), & - psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & - size(psi_svd_alpha,1), & - tmp, size(psi_svd_beta,2), & - work, lwork, info) - lwork = work(1) - deallocate(work) - allocate(work(lwork)) - call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & - copy, size(copy,1), & - psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & - size(psi_svd_alpha,1), & - tmp, size(psi_svd_beta,2), & - work, lwork, info) - deallocate(work) - if (info /= 0) then - print *, irp_here//': error in det SVD' - stop 1 - endif - integer :: i,j - do j=1,N_det_beta_unique - do i=1,N_det_beta_unique - psi_svd_beta(i,j,istate) = tmp(j,i) - enddo - enddo - deallocate(tmp,copy) - enddo - -END_PROVIDER - - !==============================================================================! ! ! ! Read/write routines ! diff --git a/src/Dets/spindeterminants.ezfio_config b/src/Dets/spindeterminants.ezfio_config index 1c7d81e3..39ccb82b 100644 --- a/src/Dets/spindeterminants.ezfio_config +++ b/src/Dets/spindeterminants.ezfio_config @@ -1,12 +1,15 @@ spindeterminants n_det_alpha integer n_det_beta integer + n_det integer n_int integer bit_kind integer n_states integer psi_det_alpha integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_alpha) psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta) - psi_coef_matrix double precision (spindeterminants_n_det_alpha,spindeterminants_n_det_beta,spindeterminants_n_states) + psi_coef_matrix_rows integer (spindeterminants_n_det) + psi_coef_matrix_columns integer (spindeterminants_n_det) + psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) n_svd_coefs integer psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states) psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states) diff --git a/src/Dets/spindeterminants.irp.f b/src/Dets/spindeterminants.irp.f index 4b426faa..ffd28f85 100644 --- a/src/Dets/spindeterminants.irp.f +++ b/src/Dets/spindeterminants.irp.f @@ -1,3 +1,296 @@ +!==============================================================================! +! ! +! Independent alpha/beta parts ! +! ! +!==============================================================================! + +use bitmasks + +integer*8 function spin_det_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint) + integer :: i + spin_det_search_key = det(1) + do i=2,Nint + spin_det_search_key = ieor(spin_det_search_key,det(i)) + enddo +end + + +BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] + implicit none + BEGIN_DOC +! List of alpha determinants of psi_det + END_DOC + integer :: i,k + + do i=1,N_det + do k=1,N_int + psi_det_alpha(k,i) = psi_det(k,1,i) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] + implicit none + BEGIN_DOC +! List of beta determinants of psi_det + END_DOC + integer :: i,k + + do i=1,N_det + do k=1,N_int + psi_det_beta(k,i) = psi_det(k,2,i) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha_unique, (N_int,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_alpha_unique ] + implicit none + BEGIN_DOC + ! Unique alpha determinants + END_DOC + + integer :: i,k + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key + + allocate ( iorder(N_det), bit_tmp(N_det)) + + do i=1,N_det + iorder(i) = i + bit_tmp(i) = spin_det_search_key(psi_det_alpha(1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,N_det) + + N_det_alpha_unique = 0 + last_key = 0_8 + do i=1,N_det + if (bit_tmp(i) /= last_key) then + last_key = bit_tmp(i) + N_det_alpha_unique += 1 + do k=1,N_int + psi_det_alpha_unique(k,N_det_alpha_unique) = psi_det_alpha(k,iorder(i)) + enddo + endif + enddo + + deallocate (iorder, bit_tmp) +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta_unique, (N_int,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_beta_unique ] + implicit none + BEGIN_DOC + ! Unique beta determinants + END_DOC + + integer :: i,k + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key + + allocate ( iorder(N_det), bit_tmp(N_det)) + + do i=1,N_det + iorder(i) = i + bit_tmp(i) = spin_det_search_key(psi_det_beta(1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,N_det) + + N_det_beta_unique = 0 + last_key = 0_8 + do i=1,N_det + if (bit_tmp(i) /= last_key) then + last_key = bit_tmp(i) + N_det_beta_unique += 1 + do k=1,N_int + psi_det_beta_unique(k,N_det_beta_unique) = psi_det_beta(k,iorder(i)) + enddo + endif + enddo + + deallocate (iorder, bit_tmp) +END_PROVIDER + + + + + +integer function get_index_in_psi_det_alpha_unique(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_alpha_unique`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: spin_det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_alpha_unique = 0 + ibegin = 1 + iend = N_det_alpha_unique + 1 + + !DIR$ FORCEINLINE + det_ref = spin_det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_alpha_unique(1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_alpha_unique(1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det_alpha_unique) then + return + endif + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) + if (key(1) /= psi_det_alpha_unique(1,i)) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if (key(l) /= psi_det_alpha_unique(l,i)) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_alpha_unique = i + return + endif + endif + i += 1 + if (i > N_det_alpha_unique) then + return + endif + + enddo + +end + +integer function get_index_in_psi_det_beta_unique(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_beta_unique`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: spin_det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_beta_unique = 0 + ibegin = 1 + iend = N_det_beta_unique + 1 + + !DIR$ FORCEINLINE + det_ref = spin_det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_beta_unique(1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_beta_unique(1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det_beta_unique) then + return + endif + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) + if (key(1) /= psi_det_beta_unique(1,i)) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if (key(l) /= psi_det_beta_unique(l,i)) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_beta_unique = i + return + endif + endif + i += 1 + if (i > N_det_beta_unique) then + return + endif + + enddo + +end + + subroutine write_spindeterminants use bitmasks implicit none @@ -11,6 +304,7 @@ subroutine write_spindeterminants N_int2 = (N_int*bit_kind)/8 call ezfio_set_spindeterminants_n_det_alpha(N_det_alpha_unique) call ezfio_set_spindeterminants_n_det_beta(N_det_beta_unique) + call ezfio_set_spindeterminants_n_det(N_det) call ezfio_set_spindeterminants_n_int(N_int) call ezfio_set_spindeterminants_bit_kind(bit_kind) call ezfio_set_spindeterminants_n_states(N_states) @@ -39,7 +333,9 @@ subroutine write_spindeterminants call ezfio_set_spindeterminants_psi_det_beta(psi_det_beta_unique) deallocate(tmpdet) - call ezfio_set_spindeterminants_psi_coef_matrix(psi_svd_matrix) + call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_svd_matrix_values) + call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_svd_matrix_rows) + call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_svd_matrix_columns) integer :: n_svd_coefs double precision :: norm, f @@ -49,7 +345,7 @@ subroutine write_spindeterminants do k=1,N_states norm -= psi_svd_coefs(n_svd_coefs,k)*psi_svd_coefs(n_svd_coefs,k) enddo - if (norm < 1.d-6) then + if (norm < 1.d-4) then exit endif enddo @@ -89,3 +385,231 @@ subroutine write_spindeterminants deallocate(dtmp) end + + +!==============================================================================! +! ! +! Alpha x Beta Matrix ! +! ! +!==============================================================================! + +BEGIN_PROVIDER [ double precision, psi_svd_matrix_values, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer, psi_svd_matrix_rows, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_svd_matrix_columns, (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k, l + integer(bit_kind) :: tmp_det(N_int,2) + integer :: idx + integer, external :: get_index_in_psi_det_sorted_bit + logical, external :: is_in_wavefunction + + + PROVIDE psi_coef_sorted_bit + +! l=0 +! do j=1,N_det_beta_unique +! do k=1,N_int +! tmp_det(k,2) = psi_det_beta_unique(k,j) +! enddo +! do i=1,N_det_alpha_unique +! do k=1,N_int +! tmp_det(k,1) = psi_det_alpha_unique(k,i) +! enddo +! idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) +! if (idx > 0) then +! l += 1 +! psi_svd_matrix_rows(l) = i +! psi_svd_matrix_columns(l) = j +! do k=1,N_states +! psi_svd_matrix_values(l,k) = psi_coef_sorted_bit(idx,k) +! enddo +! endif +! enddo +! enddo +! ASSERT (l == N_det) + + integer, allocatable :: iorder(:), to_sort(:) + integer, external :: get_index_in_psi_det_alpha_unique + integer, external :: get_index_in_psi_det_beta_unique + allocate(iorder(N_det), to_sort(N_det)) + do k=1,N_det + i = get_index_in_psi_det_alpha_unique(psi_det(1,1,k),N_int) + j = get_index_in_psi_det_beta_unique (psi_det(1,2,k),N_int) + do l=1,N_states + psi_svd_matrix_values(k,l) = psi_coef(k,l) + enddo + psi_svd_matrix_rows(k) = i + psi_svd_matrix_columns(k) = j + to_sort(k) = N_det_alpha_unique * (j-1) + i + iorder(k) = k + enddo + call isort(to_sort, iorder, N_det) + call iset_order(psi_svd_matrix_rows,iorder,N_det) + call iset_order(psi_svd_matrix_columns,iorder,N_det) + call dset_order(psi_svd_matrix_values,iorder,N_det) + deallocate(iorder,to_sort) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_svd_matrix, (N_det_alpha_unique,N_det_beta_unique,N_states) ] + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k,istate + psi_svd_matrix = 0.d0 + do k=1,N_det + i = psi_svd_matrix_rows(k) + j = psi_svd_matrix_columns(k) + do istate=1,N_states + psi_svd_matrix(i,j,istate) = psi_svd_matrix_values(k,istate) + enddo + enddo +END_PROVIDER + +subroutine create_wf_of_psi_svd_matrix + use bitmasks + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k + integer(bit_kind) :: tmp_det(N_int,2) + integer :: idx + integer, external :: get_index_in_psi_det_sorted_bit + logical, external :: is_in_wavefunction + double precision :: norm(N_states) + + call generate_all_alpha_beta_det_products + norm = 0.d0 + do j=1,N_det_beta_unique + do k=1,N_int + tmp_det(k,2) = psi_det_beta_unique(k,j) + enddo + do i=1,N_det_alpha_unique + do k=1,N_int + tmp_det(k,1) = psi_det_alpha_unique(k,i) + enddo + idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) + if (idx > 0) then + do k=1,N_states + psi_coef_sorted_bit(idx,k) = psi_svd_matrix(i,j,k) + norm(k) += psi_svd_matrix(i,j,k) + enddo + endif + enddo + enddo + do k=1,N_states + norm(k) = 1.d0/dsqrt(norm(k)) + do i=1,N_det + psi_coef_sorted_bit(i,k) = psi_coef_sorted_bit(i,k)*norm(k) + enddo + enddo + psi_det = psi_det_sorted_bit + psi_coef = psi_coef_sorted_bit + TOUCH psi_det psi_coef + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + norm(1) = 0.d0 + do i=1,N_det + norm(1) += psi_average_norm_contrib_sorted(i) + if (norm(1) >= 0.999999d0) then + exit + endif + enddo + N_det = min(i,N_det) + SOFT_TOUCH psi_det psi_coef N_det + +end + +subroutine generate_all_alpha_beta_det_products + implicit none + BEGIN_DOC +! Create a wave function from all possible alpha x beta determinants + END_DOC + integer :: i,j,k,l + integer :: idx, iproc + integer, external :: get_index_in_psi_det_sorted_bit + integer(bit_kind), allocatable :: tmp_det(:,:,:) + logical, external :: is_in_wavefunction + integer, external :: omp_get_thread_num + + !$OMP PARALLEL DEFAULT(NONE) SHARED(psi_coef_sorted_bit,N_det_beta_unique,& + !$OMP N_det_alpha_unique, N_int, psi_det_alpha_unique, psi_det_beta_unique,& + !$OMP N_det) & + !$OMP PRIVATE(i,j,k,l,tmp_det,idx,iproc) + !$ iproc = omp_get_thread_num() + allocate (tmp_det(N_int,2,N_det_alpha_unique)) + !$OMP DO + do j=1,N_det_beta_unique + l = 1 + do i=1,N_det_alpha_unique + do k=1,N_int + tmp_det(k,1,l) = psi_det_alpha_unique(k,i) + tmp_det(k,2,l) = psi_det_beta_unique (k,j) + enddo + if (.not.is_in_wavefunction(tmp_det(1,1,l),N_int,N_det)) then + l = l+1 + endif + enddo + call fill_H_apply_buffer_no_selection(l-1, tmp_det, N_int, iproc) + enddo + !$OMP END DO NOWAIT + deallocate(tmp_det) + !$OMP END PARALLEL + deallocate (tmp_det) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH psi_det psi_coef N_det +end + + BEGIN_PROVIDER [ double precision, psi_svd_alpha, (N_det_alpha_unique,N_det_alpha_unique,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_svd_beta , (N_det_beta_unique,N_det_beta_unique,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_svd_coefs, (N_det_beta_unique,N_states) ] + implicit none + BEGIN_DOC + ! SVD wave function + END_DOC + + integer :: lwork, info, istate + double precision, allocatable :: work(:), tmp(:,:), copy(:,:) + allocate (work(1),tmp(N_det_beta_unique,N_det_beta_unique), & + copy(size(psi_svd_matrix,1),size(psi_svd_matrix,2))) + + do istate = 1,N_states + copy(:,:) = psi_svd_matrix(:,:,istate) + lwork=-1 + call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & + copy, size(copy,1), & + psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & + size(psi_svd_alpha,1), & + tmp, size(psi_svd_beta,2), & + work, lwork, info) + lwork = work(1) + deallocate(work) + allocate(work(lwork)) + call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & + copy, size(copy,1), & + psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & + size(psi_svd_alpha,1), & + tmp, size(psi_svd_beta,2), & + work, lwork, info) + deallocate(work) + if (info /= 0) then + print *, irp_here//': error in det SVD' + stop 1 + endif + integer :: i,j + do j=1,N_det_beta_unique + do i=1,N_det_beta_unique + psi_svd_beta(i,j,istate) = tmp(j,i) + enddo + enddo + deallocate(tmp,copy) + enddo + +END_PROVIDER + + diff --git a/src/Makefile.config.ifort b/src/Makefile.config.ifort deleted file mode 100644 index 164d348e..00000000 --- a/src/Makefile.config.ifort +++ /dev/null @@ -1,30 +0,0 @@ -OPENMP =1 -PROFILE =0 -DEBUG = 0 - -IRPF90_FLAGS+= --align=32 -FC = ifort -g -FCFLAGS= -FCFLAGS+= -axAVX,SSE4.2 -FCFLAGS+= -O2 -FCFLAGS+= -ip -FCFLAGS+= -opt-prefetch -FCFLAGS+= -ftz -MKL=-mkl=parallel - -ifeq ($(PROFILE),1) -FC += -p -g -CXX += -pg -endif - -ifeq ($(OPENMP),1) -FC += -openmp -IRPF90_FLAGS += --openmp -CXX += -fopenmp -endif - -ifeq ($(DEBUG),1) -FC += -C -traceback -fpe0 -IRPF90_FLAGS += -a -#FCFLAGS =-O0 -endif From 78d42e245529e0bce6202c66d097fcba4cf4e0b5 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 09:22:28 +0200 Subject: [PATCH 28/70] Add ezfio_dir to optional keyword in EZFIO.cfg --- data/ezfio_defaults/properties.ezfio_default | 2 -- scripts/ezfio_interface/ei_handler.py | 11 +++++------ scripts/ezfio_interface/ezfio_generate_provider.py | 2 +- src/Properties/options.irp.f | 13 ------------- src/Properties/properties.ezfio_config | 2 -- 5 files changed, 6 insertions(+), 24 deletions(-) delete mode 100644 data/ezfio_defaults/properties.ezfio_default delete mode 100644 src/Properties/options.irp.f delete mode 100644 src/Properties/properties.ezfio_config diff --git a/data/ezfio_defaults/properties.ezfio_default b/data/ezfio_defaults/properties.ezfio_default deleted file mode 100644 index ce06d413..00000000 --- a/data/ezfio_defaults/properties.ezfio_default +++ /dev/null @@ -1,2 +0,0 @@ -properties - z_one_point 3.9 diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index 220d368c..dcfb394c 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -203,7 +203,7 @@ def get_dict_config_file(config_file_path, module_lower): - ezfio_name : Will be the name of the file - ezfio_dir : Will be the folder who containt the ezfio_name * /ezfio_dir/ezfio_name - * equal to MODULE_lower name for the moment. + * equal to MODULE_lower name by default. - interface : The provider is a imput or a output - default : The default value /!\ stored in a Type named type! if interface == output @@ -216,7 +216,7 @@ def get_dict_config_file(config_file_path, module_lower): d = defaultdict(dict) l_info_required = ["doc", "interface"] - l_info_optional = ["ezfio_name", "size"] + l_info_optional = ["ezfio_dir", "ezfio_name", "size"] # ~#~#~#~#~#~#~#~#~#~#~ # # L o a d _ C o n f i g # @@ -238,10 +238,8 @@ def get_dict_config_file(config_file_path, module_lower): pvd = section.lower() # Create the dictionary who containt the value per default - d_default = {"ezfio_name": pvd} - - # Set the ezfio_dir - d[pvd]["ezfio_dir"] = module_lower + d_default = {"ezfio_name": pvd, + "ezfio_dir": module_lower} # Check if type if avalaible type_ = config_file.get(section, "type") @@ -294,6 +292,7 @@ def create_ezfio_provider(dict_ezfio_cfg): default size} create the a list who containt all the code for the provider + output = output_dict_info['ezfio_dir' return [code, ...] """ from ezfio_generate_provider import EZFIO_Provider diff --git a/scripts/ezfio_interface/ezfio_generate_provider.py b/scripts/ezfio_interface/ezfio_generate_provider.py index af4fcd6a..7f3c8441 100755 --- a/scripts/ezfio_interface/ezfio_generate_provider.py +++ b/scripts/ezfio_interface/ezfio_generate_provider.py @@ -45,7 +45,7 @@ END_PROVIDER self.set_write() for v in self.values: if not v: - msg = "Error : %s is not set in ezfio_with_default.py" % (v) + msg = "Error : %s is not set in EZFIO.cfg" % (v) print >>sys.stderr, msg sys.exit(1) return self.data % self.__dict__ diff --git a/src/Properties/options.irp.f b/src/Properties/options.irp.f deleted file mode 100644 index 0fd5a4c1..00000000 --- a/src/Properties/options.irp.f +++ /dev/null @@ -1,13 +0,0 @@ -BEGIN_SHELL [ /usr/bin/python ] -from ezfio_with_default import EZFIO_Provider -T = EZFIO_Provider() -T.set_type ( "double precision" ) -T.set_name ( "z_one_point" ) -T.set_doc ( "z point on which the integrated delta rho is calculated" ) -T.set_ezfio_dir ( "properties" ) -T.set_ezfio_name( "z_one_point" ) -T.set_output ( "output_full_ci" ) -print T - -END_SHELL - diff --git a/src/Properties/properties.ezfio_config b/src/Properties/properties.ezfio_config deleted file mode 100644 index 018b56d0..00000000 --- a/src/Properties/properties.ezfio_config +++ /dev/null @@ -1,2 +0,0 @@ -properties - z_one_point double precision From 3b59fca0c73d606fdebddc10ee69f4a73d61d40b Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 10:12:08 +0200 Subject: [PATCH 29/70] Add EZFIO.cfg in determinants --- .../ezfio_defaults/determinants.ezfio_default | 9 - ocaml/Input.ml | 2 +- ocaml/Input_determinants.ml | 756 +++------- ocaml/Input_determinants_by_hand.ml | 447 ++++++ scripts/clean_modules.sh | 2 +- scripts/ezfio_interface/ei_handler.py | 6 +- scripts/ezfio_interface/qp_edit_template | 24 +- scripts/generate_h_apply.py | 12 +- src/CAS_SD/NEEDED_MODULES | 2 +- src/CAS_SD/README.rst | 2 +- src/CID/NEEDED_MODULES | 2 +- src/CID/README.rst | 2 +- src/CID_SC2_selected/NEEDED_MODULES | 2 +- src/CID_SC2_selected/README.rst | 2 +- src/CID_selected/NEEDED_MODULES | 2 +- src/CID_selected/README.rst | 2 +- src/CIS/NEEDED_MODULES | 2 +- src/CIS/README.rst | 2 +- src/CISD/NEEDED_MODULES | 2 +- src/CISD/README.rst | 2 +- src/CISD_SC2_selected/NEEDED_MODULES | 2 +- src/CISD_SC2_selected/README.rst | 2 +- src/CISD_selected/NEEDED_MODULES | 2 +- src/CISD_selected/README.rst | 2 +- src/DDCI_selected/NEEDED_MODULES | 2 +- src/DDCI_selected/README.rst | 2 +- src/{Dets => Determinants}/determinants.irp.f | 15 +- src/Dets/ASSUMPTIONS.rst | 7 - src/Dets/H_apply.irp.f | 229 --- src/Dets/H_apply_template.f | 542 ------- src/Dets/Makefile | 6 - src/Dets/NEEDED_MODULES | 1 - src/Dets/README.rst | 696 --------- src/Dets/SC2.irp.f | 215 --- src/Dets/connected_to_ref.irp.f | 357 ----- src/Dets/create_excitations.irp.f | 36 - src/Dets/davidson.irp.f | 418 ------ src/Dets/density_matrix.irp.f | 214 --- src/Dets/det_svd.irp.f | 61 - src/Dets/determinants.ezfio_config | 20 - src/Dets/determinants_bitmasks.irp.f | 57 - src/Dets/diagonalize_CI.irp.f | 109 -- src/Dets/diagonalize_CI_SC2.irp.f | 59 - src/Dets/diagonalize_CI_mono.irp.f | 72 - src/Dets/excitations_utils.irp.f | 16 - src/Dets/filter_connected.irp.f | 611 -------- src/Dets/guess_doublet.irp.f | 79 - src/Dets/guess_singlet.irp.f | 44 - src/Dets/guess_triplet.irp.f | 48 - src/Dets/occ_pattern.irp.f | 339 ----- src/Dets/options.irp.f | 61 - src/Dets/program_beginer_determinants.irp.f | 138 -- src/Dets/psi_cas.irp.f | 114 -- src/Dets/ref_bitmask.irp.f | 57 - src/Dets/s2.irp.f | 106 -- src/Dets/save_for_casino.irp.f | 268 ---- src/Dets/save_for_qmcchem.irp.f | 51 - src/Dets/save_natorb.irp.f | 6 - src/Dets/slater_rules.irp.f | 1301 ----------------- src/Dets/spindeterminants.ezfio_config | 17 - src/Dets/spindeterminants.irp.f | 615 -------- src/Dets/truncate_wf.irp.f | 18 - src/Dets/utils.irp.f | 20 - src/FCIdump/NEEDED_MODULES | 2 +- src/FCIdump/README.rst | 2 +- src/Full_CI/NEEDED_MODULES | 2 +- src/Full_CI/README.rst | 2 +- src/Generators_CAS/NEEDED_MODULES | 2 +- src/Generators_CAS/README.rst | 2 +- src/Generators_CAS/generators.irp.f | 4 +- src/Generators_full/NEEDED_MODULES | 2 +- src/Generators_full/README.rst | 14 +- src/Generators_full/generators.irp.f | 16 +- src/Generators_restart/NEEDED_MODULES | 2 +- src/Generators_restart/generators.irp.f | 2 +- src/MP2/NEEDED_MODULES | 2 +- src/MP2/README.rst | 2 +- src/MRCC/NEEDED_MODULES | 2 +- src/MRCC/README.rst | 2 +- src/MRCC/mrcc_utils.irp.f | 4 +- src/NEEDED_MODULES | 2 +- src/Perturbation/NEEDED_MODULES | 2 +- src/Perturbation/selection.irp.f | 2 +- src/Properties/NEEDED_MODULES | 2 +- src/Selectors_full/NEEDED_MODULES | 2 +- src/Selectors_full/README.rst | 18 +- src/Selectors_full/selectors.irp.f | 16 +- src/Selectors_no_sorted/NEEDED_MODULES | 2 +- src/Selectors_no_sorted/selectors.irp.f | 4 +- 89 files changed, 749 insertions(+), 7682 deletions(-) delete mode 100644 data/ezfio_defaults/determinants.ezfio_default create mode 100644 ocaml/Input_determinants_by_hand.ml rename src/{Dets => Determinants}/determinants.irp.f (98%) delete mode 100644 src/Dets/ASSUMPTIONS.rst delete mode 100644 src/Dets/H_apply.irp.f delete mode 100644 src/Dets/H_apply_template.f delete mode 100644 src/Dets/Makefile delete mode 100644 src/Dets/NEEDED_MODULES delete mode 100644 src/Dets/README.rst delete mode 100644 src/Dets/SC2.irp.f delete mode 100644 src/Dets/connected_to_ref.irp.f delete mode 100644 src/Dets/create_excitations.irp.f delete mode 100644 src/Dets/davidson.irp.f delete mode 100644 src/Dets/density_matrix.irp.f delete mode 100644 src/Dets/det_svd.irp.f delete mode 100644 src/Dets/determinants.ezfio_config delete mode 100644 src/Dets/determinants_bitmasks.irp.f delete mode 100644 src/Dets/diagonalize_CI.irp.f delete mode 100644 src/Dets/diagonalize_CI_SC2.irp.f delete mode 100644 src/Dets/diagonalize_CI_mono.irp.f delete mode 100644 src/Dets/excitations_utils.irp.f delete mode 100644 src/Dets/filter_connected.irp.f delete mode 100644 src/Dets/guess_doublet.irp.f delete mode 100644 src/Dets/guess_singlet.irp.f delete mode 100644 src/Dets/guess_triplet.irp.f delete mode 100644 src/Dets/occ_pattern.irp.f delete mode 100644 src/Dets/options.irp.f delete mode 100644 src/Dets/program_beginer_determinants.irp.f delete mode 100644 src/Dets/psi_cas.irp.f delete mode 100644 src/Dets/ref_bitmask.irp.f delete mode 100644 src/Dets/s2.irp.f delete mode 100644 src/Dets/save_for_casino.irp.f delete mode 100644 src/Dets/save_for_qmcchem.irp.f delete mode 100644 src/Dets/save_natorb.irp.f delete mode 100644 src/Dets/slater_rules.irp.f delete mode 100644 src/Dets/spindeterminants.ezfio_config delete mode 100644 src/Dets/spindeterminants.irp.f delete mode 100644 src/Dets/truncate_wf.irp.f delete mode 100644 src/Dets/utils.irp.f diff --git a/data/ezfio_defaults/determinants.ezfio_default b/data/ezfio_defaults/determinants.ezfio_default deleted file mode 100644 index 2cfbe3ea..00000000 --- a/data/ezfio_defaults/determinants.ezfio_default +++ /dev/null @@ -1,9 +0,0 @@ -determinants - n_states 1 - n_states_diag determinants_n_states - n_det_max_jacobi 1000 - threshold_generators 0.99 - threshold_selectors 0.999 - read_wf false - s2_eig false - only_single_double_dm false diff --git a/ocaml/Input.ml b/ocaml/Input.ml index 01bb54a0..2da3ba59 100644 --- a/ocaml/Input.ml +++ b/ocaml/Input.ml @@ -4,7 +4,7 @@ open Core.Std;; include Input_ao_basis;; include Input_bitmasks;; -include Input_determinants;; +include Input_determinants_by_hand;; include Input_electrons;; include Input_mo_basis;; include Input_nuclei;; diff --git a/ocaml/Input_determinants.ml b/ocaml/Input_determinants.ml index 9af2b7c0..df046231 100644 --- a/ocaml/Input_determinants.ml +++ b/ocaml/Input_determinants.ml @@ -1,603 +1,251 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + open Qptypes;; open Qputils;; open Core.Std;; module Determinants : sig - type t = - { n_int : N_int_number.t; - bit_kind : Bit_kind.t; - mo_label : MO_label.t; - n_det : Det_number.t; - n_states : States_number.t; - n_states_diag : States_number.t; - n_det_max_jacobi : Strictly_positive_int.t; - threshold_generators : Threshold.t; - threshold_selectors : Threshold.t; - read_wf : bool; - expected_s2 : Positive_float.t; - s2_eig : bool; - psi_coef : Det_coef.t array; - psi_det : Determinant.t array; - } with sexp +(* Generate type *) + type t = + { + n_det_max_jacobi : Strictly_positive_int.t; + threshold_generators : Threshold.t; + threshold_selectors : Threshold.t; + n_states : Strictly_positive_int.t; + s2_eig : bool; + read_wf : bool; + only_single_double_dm : bool; + } with sexp + ;; val read : unit -> t option - val write : t -> unit + val write : t-> unit val to_string : t -> string val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option end = struct - type t = - { n_int : N_int_number.t; - bit_kind : Bit_kind.t; - mo_label : MO_label.t; - n_det : Det_number.t; - n_states : States_number.t; - n_states_diag : States_number.t; - n_det_max_jacobi : Strictly_positive_int.t; - threshold_generators : Threshold.t; - threshold_selectors : Threshold.t; - read_wf : bool; - expected_s2 : Positive_float.t; - s2_eig : bool; - psi_coef : Det_coef.t array; - psi_det : Determinant.t array; - } with sexp - ;; +(* Generate type *) + type t = + { + n_det_max_jacobi : Strictly_positive_int.t; + threshold_generators : Threshold.t; + threshold_selectors : Threshold.t; + n_states : Strictly_positive_int.t; + s2_eig : bool; + read_wf : bool; + only_single_double_dm : bool; + } with sexp + ;; let get_default = Qpackage.get_ezfio_default "determinants";; - let read_n_int () = - if not (Ezfio.has_determinants_n_int()) then - Ezfio.get_mo_basis_mo_tot_num () - |> Bitlist.n_int_of_mo_tot_num - |> N_int_number.to_int - |> Ezfio.set_determinants_n_int - ; - Ezfio.get_determinants_n_int () - |> N_int_number.of_int - ;; - - let write_n_int n = - N_int_number.to_int n - |> Ezfio.set_determinants_n_int - ;; - - - let read_bit_kind () = - if not (Ezfio.has_determinants_bit_kind ()) then - Lazy.force Qpackage.bit_kind - |> Bit_kind.to_int - |> Ezfio.set_determinants_bit_kind - ; - Ezfio.get_determinants_bit_kind () - |> Bit_kind.of_int - ;; - - let write_bit_kind b = - Bit_kind.to_int b - |> Ezfio.set_determinants_bit_kind - ;; - - - let read_mo_label () = - if (not (Ezfio.has_determinants_mo_label ())) then - Ezfio.get_mo_basis_mo_label () - |> Ezfio.set_determinants_mo_label - ; - Ezfio.get_determinants_mo_label () - |> MO_label.of_string - ;; - - let write_mo_label l = - MO_label.to_string l - |> Ezfio.set_determinants_mo_label - ;; - - - let read_n_det () = - if not (Ezfio.has_determinants_n_det ()) then - Ezfio.set_determinants_n_det 1 - ; - Ezfio.get_determinants_n_det () - |> Det_number.of_int - ;; - - let write_n_det n = - Det_number.to_int n - |> Ezfio.set_determinants_n_det - ;; - - - let read_n_states () = - if not (Ezfio.has_determinants_n_states ()) then - Ezfio.set_determinants_n_states 1 - ; - Ezfio.get_determinants_n_states () - |> States_number.of_int - ;; - - let write_n_states n = - States_number.to_int n - |> Ezfio.set_determinants_n_states - ;; - - - let read_n_states_diag () = - if not (Ezfio.has_determinants_n_states_diag ()) then - read_n_states () - |> States_number.to_int - |> Ezfio.set_determinants_n_states_diag - ; - Ezfio.get_determinants_n_states_diag () - |> States_number.of_int - ;; - - let write_n_states_diag ~n_states n = - let n_states = States_number.to_int n_states - and n = States_number.to_int n - in - Ezfio.set_determinants_n_states_diag (max n_states n) - ;; - +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) +(* Read snippet for n_det_max_jacobi *) let read_n_det_max_jacobi () = if not (Ezfio.has_determinants_n_det_max_jacobi ()) then - get_default "n_det_max_jacobi" - |> Int.of_string - |> Ezfio.set_determinants_n_det_max_jacobi + get_default "n_det_max_jacobi" + |> Int.of_string + |> Ezfio.set_determinants_n_det_max_jacobi ; Ezfio.get_determinants_n_det_max_jacobi () - |> Strictly_positive_int.of_int + |> Strictly_positive_int.of_int ;; - - let write_n_det_max_jacobi n = - Strictly_positive_int.to_int n +(* Write snippet for n_det_max_jacobi *) + let write_n_det_max_jacobi var = + Strictly_positive_int.to_int var |> Ezfio.set_determinants_n_det_max_jacobi ;; - - let read_threshold_generators () = - if not (Ezfio.has_determinants_threshold_generators ()) then - get_default "threshold_generators" - |> Float.of_string - |> Ezfio.set_determinants_threshold_generators +(* Read snippet for n_states *) + let read_n_states () = + if not (Ezfio.has_determinants_n_states ()) then + get_default "n_states" + |> Int.of_string + |> Ezfio.set_determinants_n_states ; - Ezfio.get_determinants_threshold_generators () - |> Threshold.of_float + Ezfio.get_determinants_n_states () + |> Strictly_positive_int.of_int + ;; +(* Write snippet for n_states *) + let write_n_states var = + Strictly_positive_int.to_int var + |> Ezfio.set_determinants_n_states ;; - let write_threshold_generators t = - Threshold.to_float t - |> Ezfio.set_determinants_threshold_generators - ;; - - - let read_threshold_selectors () = - if not (Ezfio.has_determinants_threshold_selectors ()) then - get_default "threshold_selectors" - |> Float.of_string - |> Ezfio.set_determinants_threshold_selectors +(* Read snippet for only_single_double_dm *) + let read_only_single_double_dm () = + if not (Ezfio.has_determinants_only_single_double_dm ()) then + get_default "only_single_double_dm" + |> Bool.of_string + |> Ezfio.set_determinants_only_single_double_dm ; - Ezfio.get_determinants_threshold_selectors () - |> Threshold.of_float + Ezfio.get_determinants_only_single_double_dm () + ;; +(* Write snippet for only_single_double_dm *) + let write_only_single_double_dm = + Ezfio.set_determinants_only_single_double_dm ;; - let write_threshold_selectors t = - Threshold.to_float t - |> Ezfio.set_determinants_threshold_selectors - ;; - - +(* Read snippet for read_wf *) let read_read_wf () = if not (Ezfio.has_determinants_read_wf ()) then - get_default "read_wf" - |> Bool.of_string - |> Ezfio.set_determinants_read_wf + get_default "read_wf" + |> Bool.of_string + |> Ezfio.set_determinants_read_wf ; Ezfio.get_determinants_read_wf () ;; - - let write_read_wf = Ezfio.set_determinants_read_wf ;; - - - let read_expected_s2 () = - if not (Ezfio.has_determinants_expected_s2 ()) then - begin - let na = Ezfio.get_electrons_elec_alpha_num () - and nb = Ezfio.get_electrons_elec_beta_num () - in - let s = 0.5 *. (Float.of_int (na - nb)) - in - Ezfio.set_determinants_expected_s2 ( s *. (s +. 1.) ) - end - ; - Ezfio.get_determinants_expected_s2 () - |> Positive_float.of_float +(* Write snippet for read_wf *) + let write_read_wf = + Ezfio.set_determinants_read_wf ;; - let write_expected_s2 s2 = - Positive_float.to_float s2 - |> Ezfio.set_determinants_expected_s2 - ;; - - +(* Read snippet for s2_eig *) let read_s2_eig () = if not (Ezfio.has_determinants_s2_eig ()) then - get_default "s2_eig" - |> Bool.of_string - |> Ezfio.set_determinants_s2_eig + get_default "s2_eig" + |> Bool.of_string + |> Ezfio.set_determinants_s2_eig ; Ezfio.get_determinants_s2_eig () ;; - - let write_s2_eig = Ezfio.set_determinants_s2_eig ;; - - - let read_psi_coef () = - if not (Ezfio.has_determinants_psi_coef ()) then - begin - let n_states = - read_n_states () - |> States_number.to_int - in - Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| 1 ; n_states |] - ~data:(List.init n_states ~f:(fun i -> if (i=0) then 1. else 0. )) - |> Ezfio.set_determinants_psi_coef - end; - Ezfio.get_determinants_psi_coef () - |> Ezfio.flattened_ezfio - |> Array.map ~f:Det_coef.of_float +(* Write snippet for s2_eig *) + let write_s2_eig = + Ezfio.set_determinants_s2_eig ;; - let write_psi_coef ~n_det ~n_states c = - let n_det = Det_number.to_int n_det - and c = Array.to_list c - |> List.map ~f:Det_coef.to_float - and n_states = States_number.to_int n_states - in - Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c - |> Ezfio.set_determinants_psi_coef +(* Read snippet for threshold_generators *) + let read_threshold_generators () = + if not (Ezfio.has_determinants_threshold_generators ()) then + get_default "threshold_generators" + |> Float.of_string + |> Ezfio.set_determinants_threshold_generators + ; + Ezfio.get_determinants_threshold_generators () + |> Threshold.of_float + ;; +(* Write snippet for threshold_generators *) + let write_threshold_generators var = + Threshold.to_float var + |> Ezfio.set_determinants_threshold_generators ;; - - let read_psi_det () = - let n_int = read_n_int () - and n_alpha = Ezfio.get_electrons_elec_alpha_num () - |> Elec_alpha_number.of_int - and n_beta = Ezfio.get_electrons_elec_beta_num () - |> Elec_beta_number.of_int - in - if not (Ezfio.has_determinants_psi_det ()) then - begin - let mo_tot_num = MO_number.get_max () in - let rec build_data accu = function - | 0 -> accu - | n -> build_data ((MO_number.of_int ~max:mo_tot_num n)::accu) (n-1) - in - let det_a = build_data [] (Elec_alpha_number.to_int n_alpha) - |> Bitlist.of_mo_number_list n_int - and det_b = build_data [] (Elec_beta_number.to_int n_beta) - |> Bitlist.of_mo_number_list n_int - in - let data = ( (Bitlist.to_int64_list det_a) @ - (Bitlist.to_int64_list det_b) ) - in - Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; 1 |] ~data:data - |> Ezfio.set_determinants_psi_det ; - end ; - let n_int = N_int_number.to_int n_int in - let psi_det_array = Ezfio.get_determinants_psi_det () in - let dim = psi_det_array.Ezfio.dim - and data = Ezfio.flattened_ezfio psi_det_array - in - assert (n_int = dim.(0)); - assert (dim.(1) = 2); - assert (dim.(2) = (Det_number.to_int (read_n_det ()))); - List.init dim.(2) ~f:(fun i -> - Array.sub ~pos:(2*n_int*i) ~len:(2*n_int) data) - |> List.map ~f:(Determinant.of_int64_array - ~n_int:(N_int_number.of_int n_int) - ~alpha:n_alpha ~beta:n_beta ) - |> Array.of_list +(* Read snippet for threshold_selectors *) + let read_threshold_selectors () = + if not (Ezfio.has_determinants_threshold_selectors ()) then + get_default "threshold_selectors" + |> Float.of_string + |> Ezfio.set_determinants_threshold_selectors + ; + Ezfio.get_determinants_threshold_selectors () + |> Threshold.of_float + ;; +(* Write snippet for threshold_selectors *) + let write_threshold_selectors var = + Threshold.to_float var + |> Ezfio.set_determinants_threshold_selectors ;; - let write_psi_det ~n_int ~n_det d = - let data = Array.to_list d - |> Array.concat - |> Array.to_list - in - Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; Det_number.to_int n_det |] ~data:data - |> Ezfio.set_determinants_psi_det - ;; +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) - - let read () = - if (Ezfio.has_mo_basis_mo_tot_num ()) then - Some - { n_int = read_n_int () ; - bit_kind = read_bit_kind () ; - mo_label = read_mo_label () ; - n_det = read_n_det () ; - n_states = read_n_states () ; - n_states_diag = read_n_states_diag () ; - n_det_max_jacobi = read_n_det_max_jacobi () ; - threshold_generators = read_threshold_generators () ; - threshold_selectors = read_threshold_selectors () ; - read_wf = read_read_wf () ; - expected_s2 = read_expected_s2 () ; - s2_eig = read_s2_eig () ; - psi_coef = read_psi_coef () ; - psi_det = read_psi_det () ; - } - else - None - ;; - - let write { n_int ; - bit_kind ; - mo_label ; - n_det ; - n_states ; - n_states_diag ; - n_det_max_jacobi ; - threshold_generators ; - threshold_selectors ; - read_wf ; - expected_s2 ; - s2_eig ; - psi_coef ; - psi_det ; +(* Read all *) + let read() = + Some + { + n_det_max_jacobi = read_n_det_max_jacobi (); + threshold_generators = read_threshold_generators (); + threshold_selectors = read_threshold_selectors (); + n_states = read_n_states (); + s2_eig = read_s2_eig (); + read_wf = read_read_wf (); + only_single_double_dm = read_only_single_double_dm (); + } + ;; +(* Write all *) + let write{ + n_det_max_jacobi; + threshold_generators; + threshold_selectors; + n_states; + s2_eig; + read_wf; + only_single_double_dm; } = - write_n_int n_int ; - write_bit_kind bit_kind; - write_mo_label mo_label; - write_n_det n_det; - write_n_states n_states; - write_n_states_diag ~n_states:n_states n_states_diag; - write_n_det_max_jacobi n_det_max_jacobi; - write_threshold_generators threshold_generators; - write_threshold_selectors threshold_selectors; - write_read_wf read_wf; - write_expected_s2 expected_s2; - write_s2_eig s2_eig; - write_psi_coef ~n_det:n_det psi_coef ~n_states:n_states; - write_psi_det ~n_int:n_int ~n_det:n_det psi_det; - ;; - - - let to_rst b = - let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in - let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in - let det_text = - let nstates = - States_number.to_int b.n_states - and ndet = - Det_number.to_int b.n_det - in - let coefs_string i = - Array.init nstates (fun j -> - let ishift = - j*ndet - in - if (ishift < Array.length b.psi_coef) then - b.psi_coef.(i+ishift) - |> Det_coef.to_float - |> Float.to_string - else - "0." - ) - |> String.concat_array ~sep:"\t" - in - Array.init ndet ~f:(fun i -> - Printf.sprintf " %s\n%s\n" - (coefs_string i) - (Determinant.to_string ~mo_tot_num:mo_tot_num b.psi_det.(i) - |> String.split ~on:'\n' - |> List.map ~f:(fun x -> " "^x) - |> String.concat ~sep:"\n" - ) - ) - |> String.concat_array ~sep:"\n" - in - Printf.sprintf " -Read the current wave function :: - - read_wf = %s - -Label of the MOs on which the determinants were computed :: - - mo_label = %s - -Force the selected wave function to be an eigenfunction of S^2. -If true, input the expected value of S^2 :: - - s2_eig = %s - expected_s2 = %s - -Thresholds on generators and selectors (fraction of the norm) :: - - threshold_generators = %s - threshold_selectors = %s - -Number of requested states, and number of states used for the -Davidson diagonalization :: - - n_states = %s - n_states_diag = %s - -Maximum size of the Hamiltonian matrix that will be fully diagonalized :: - - n_det_max_jacobi = %s - -Number of determinants :: - - n_det = %s - -Determinants :: - -%s -" - (b.read_wf |> Bool.to_string) - (b.mo_label |> MO_label.to_string) - (b.s2_eig |> Bool.to_string) - (b.expected_s2 |> Positive_float.to_string) - (b.threshold_generators |> Threshold.to_string) - (b.threshold_selectors |> Threshold.to_string) - (b.n_states |> States_number.to_string) - (b.n_states_diag |> States_number.to_string) - (b.n_det_max_jacobi |> Strictly_positive_int.to_string) - (b.n_det |> Det_number.to_string) - det_text - |> Rst_string.of_string - ;; - - let to_string b = - let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in - let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in - Printf.sprintf " -n_int = %s -bit_kind = %s -mo_label = \"%s\" -n_det = %s -n_states = %s -n_states_diag = %s -n_det_max_jacobi = %s -threshold_generators = %s -threshold_selectors = %s -read_wf = %s -expected_s2 = %s -s2_eig = %s -psi_coef = %s -psi_det = %s -" - (b.n_int |> N_int_number.to_string) - (b.bit_kind |> Bit_kind.to_string) - (b.mo_label |> MO_label.to_string) - (b.n_det |> Det_number.to_string) - (b.n_states |> States_number.to_string) - (b.n_states_diag |> States_number.to_string) - (b.n_det_max_jacobi |> Strictly_positive_int.to_string) - (b.threshold_generators |> Threshold.to_string) - (b.threshold_selectors |> Threshold.to_string) - (b.read_wf |> Bool.to_string) - (b.expected_s2 |> Positive_float.to_string) - (b.s2_eig |> Bool.to_string) - (b.psi_coef |> Array.to_list |> List.map ~f:Det_coef.to_string - |> String.concat ~sep:", ") - (b.psi_det |> Array.to_list |> List.map ~f:(Determinant.to_string - ~mo_tot_num:mo_tot_num) |> String.concat ~sep:"\n\n") - ;; - - let of_rst r = - let r = Rst_string.to_string r - in - - (* Split into header and determinants data *) - let idx = String.substr_index_exn r ~pos:0 ~pattern:"\nDeterminants" - in - let (header, dets) = - (String.prefix r idx, String.suffix r ((String.length r)-idx) ) - in - - (* Handle header *) - let header = r - |> String.split ~on:'\n' - |> List.filter ~f:(fun line -> - if (line = "") then - false - else - ( (String.contains line '=') && (line.[0] = ' ') ) - ) - |> List.map ~f:(fun line -> - "("^( - String.tr line ~target:'=' ~replacement:' ' - |> String.strip - )^")" ) - |> String.concat - in - - (* Handle determinant coefs *) - let dets = match ( dets - |> String.split ~on:'\n' - |> List.map ~f:(String.strip) - ) with - | _::lines -> lines - | _ -> failwith "Error in determinants" - in - - let psi_coef = - let rec read_coefs accu = function - | [] -> List.rev accu - | ""::""::tail -> read_coefs accu tail - | ""::c::tail -> - let c = - String.split ~on:'\t' c - |> List.map ~f:(fun x -> Det_coef.of_float (Float.of_string x)) - |> Array.of_list - in - read_coefs (c::accu) tail - | _::tail -> read_coefs accu tail - in - let a = - let buffer = - read_coefs [] dets - in - let nstates = - List.hd_exn buffer - |> Array.length - in - let extract_state i = - let i = - i-1 - in - List.map ~f:(fun x -> Det_coef.to_string x.(i)) buffer - |> String.concat ~sep:" " - in - let rec build_result = function - | 1 -> extract_state 1 - | i -> (build_result (i-1))^" "^(extract_state i) - in - build_result nstates - in - "(psi_coef ("^a^"))" - in - - (* Handle determinants *) - let psi_det = - let n_alpha = Ezfio.get_electrons_elec_alpha_num () - |> Elec_alpha_number.of_int - and n_beta = Ezfio.get_electrons_elec_beta_num () - |> Elec_beta_number.of_int - in - let rec read_dets accu = function - | [] -> List.rev accu - | ""::c::alpha::beta::tail -> - begin - let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+' - and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+' - in - let newdet = Determinant.of_bitlist_couple - ~alpha:n_alpha ~beta:n_beta (alpha,beta) - |> Determinant.sexp_of_t |> Sexplib.Sexp.to_string - in - read_dets (newdet::accu) tail - end - | _::tail -> read_dets accu tail - in - let a = read_dets [] dets - |> String.concat - in - "(psi_det ("^a^"))" - in - - let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind - |> Bit_kind.to_int) - and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in - let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] - in - - Generic_input_of_rst.evaluate_sexp t_of_sexp s - ;; - -end - + write_n_det_max_jacobi n_det_max_jacobi; + write_threshold_generators threshold_generators; + write_threshold_selectors threshold_selectors; + write_n_states n_states; + write_s2_eig s2_eig; + write_read_wf read_wf; + write_only_single_double_dm only_single_double_dm; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + n_det_max_jacobi = %s + threshold_generators = %s + threshold_selectors = %s + n_states = %s + s2_eig = %s + read_wf = %s + only_single_double_dm = %s + " + (Strictly_positive_int.to_string b.n_det_max_jacobi) + (Threshold.to_string b.threshold_generators) + (Threshold.to_string b.threshold_selectors) + (Strictly_positive_int.to_string b.n_states) + (Bool.to_string b.s2_eig) + (Bool.to_string b.read_wf) + (Bool.to_string b.only_single_double_dm) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + Maximum number of determinants diagonalized by Jacobi :: + + n_det_max_jacobi = %s + + Percentage of the norm of the state-averaged wave function to consider for the generators :: + + threshold_generators = %s + + Percentage of the norm of the state-averaged wave function to consider for the selectors :: + + threshold_selectors = %s + + Number of states to consider :: + + n_states = %s + + Force the wave function to be an eigenfunction of S^2 :: + + s2_eig = %s + + If true, read the wave function from the EZFIO file :: + + read_wf = %s + + If true, The One body DM is calculated with ignoing the Double <-> Doubles extra diag elements :: + + only_single_double_dm = %s + + " + (Strictly_positive_int.to_string b.n_det_max_jacobi) + (Threshold.to_string b.threshold_generators) + (Threshold.to_string b.threshold_selectors) + (Strictly_positive_int.to_string b.n_states) + (Bool.to_string b.s2_eig) + (Bool.to_string b.read_wf) + (Bool.to_string b.only_single_double_dm) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; +end \ No newline at end of file diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml new file mode 100644 index 00000000..4c0453e6 --- /dev/null +++ b/ocaml/Input_determinants_by_hand.ml @@ -0,0 +1,447 @@ +open Qptypes;; +open Qputils;; +open Core.Std;; + +module Determinants_by_hand : sig + type t = + { n_int : N_int_number.t; + bit_kind : Bit_kind.t; + n_det : Det_number.t; + n_states : States_number.t; + n_states_diag : States_number.t; + expected_s2 : Positive_float.t; + psi_coef : Det_coef.t array; + psi_det : Determinant.t array; + } with sexp + val read : unit -> t option + val write : t -> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct + type t = + { n_int : N_int_number.t; + bit_kind : Bit_kind.t; + n_det : Det_number.t; + n_states : States_number.t; + n_states_diag : States_number.t; + expected_s2 : Positive_float.t; + psi_coef : Det_coef.t array; + psi_det : Determinant.t array; + } with sexp + ;; + + let get_default = Qpackage.get_ezfio_default "determinants";; + + let read_n_int () = + if not (Ezfio.has_determinants_n_int()) then + Ezfio.get_mo_basis_mo_tot_num () + |> Bitlist.n_int_of_mo_tot_num + |> N_int_number.to_int + |> Ezfio.set_determinants_n_int + ; + Ezfio.get_determinants_n_int () + |> N_int_number.of_int + ;; + + let write_n_int n = + N_int_number.to_int n + |> Ezfio.set_determinants_n_int + ;; + + + let read_bit_kind () = + if not (Ezfio.has_determinants_bit_kind ()) then + Lazy.force Qpackage.bit_kind + |> Bit_kind.to_int + |> Ezfio.set_determinants_bit_kind + ; + Ezfio.get_determinants_bit_kind () + |> Bit_kind.of_int + ;; + + let write_bit_kind b = + Bit_kind.to_int b + |> Ezfio.set_determinants_bit_kind + ;; + + let read_n_det () = + if not (Ezfio.has_determinants_n_det ()) then + Ezfio.set_determinants_n_det 1 + ; + Ezfio.get_determinants_n_det () + |> Det_number.of_int + ;; + + let write_n_det n = + Det_number.to_int n + |> Ezfio.set_determinants_n_det + ;; + + + let read_n_states () = + if not (Ezfio.has_determinants_n_states ()) then + Ezfio.set_determinants_n_states 1 + ; + Ezfio.get_determinants_n_states () + |> States_number.of_int + ;; + + let write_n_states n = + States_number.to_int n + |> Ezfio.set_determinants_n_states + ;; + + + let read_n_states_diag () = + if not (Ezfio.has_determinants_n_states_diag ()) then + read_n_states () + |> States_number.to_int + |> Ezfio.set_determinants_n_states_diag + ; + Ezfio.get_determinants_n_states_diag () + |> States_number.of_int + ;; + + let write_n_states_diag ~n_states n = + let n_states = States_number.to_int n_states + and n = States_number.to_int n + in + Ezfio.set_determinants_n_states_diag (max n_states n) + ;; + + let read_expected_s2 () = + if not (Ezfio.has_determinants_expected_s2 ()) then + begin + let na = Ezfio.get_electrons_elec_alpha_num () + and nb = Ezfio.get_electrons_elec_beta_num () + in + let s = 0.5 *. (Float.of_int (na - nb)) + in + Ezfio.set_determinants_expected_s2 ( s *. (s +. 1.) ) + end + ; + Ezfio.get_determinants_expected_s2 () + |> Positive_float.of_float + ;; + + let write_expected_s2 s2 = + Positive_float.to_float s2 + |> Ezfio.set_determinants_expected_s2 + ;; + + let read_psi_coef () = + if not (Ezfio.has_determinants_psi_coef ()) then + begin + let n_states = + read_n_states () + |> States_number.to_int + in + Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| 1 ; n_states |] + ~data:(List.init n_states ~f:(fun i -> if (i=0) then 1. else 0. )) + |> Ezfio.set_determinants_psi_coef + end; + Ezfio.get_determinants_psi_coef () + |> Ezfio.flattened_ezfio + |> Array.map ~f:Det_coef.of_float + ;; + + let write_psi_coef ~n_det ~n_states c = + let n_det = Det_number.to_int n_det + and c = Array.to_list c + |> List.map ~f:Det_coef.to_float + and n_states = States_number.to_int n_states + in + Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c + |> Ezfio.set_determinants_psi_coef + ;; + + + let read_psi_det () = + let n_int = read_n_int () + and n_alpha = Ezfio.get_electrons_elec_alpha_num () + |> Elec_alpha_number.of_int + and n_beta = Ezfio.get_electrons_elec_beta_num () + |> Elec_beta_number.of_int + in + if not (Ezfio.has_determinants_psi_det ()) then + begin + let mo_tot_num = MO_number.get_max () in + let rec build_data accu = function + | 0 -> accu + | n -> build_data ((MO_number.of_int ~max:mo_tot_num n)::accu) (n-1) + in + let det_a = build_data [] (Elec_alpha_number.to_int n_alpha) + |> Bitlist.of_mo_number_list n_int + and det_b = build_data [] (Elec_beta_number.to_int n_beta) + |> Bitlist.of_mo_number_list n_int + in + let data = ( (Bitlist.to_int64_list det_a) @ + (Bitlist.to_int64_list det_b) ) + in + Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; 1 |] ~data:data + |> Ezfio.set_determinants_psi_det ; + end ; + let n_int = N_int_number.to_int n_int in + let psi_det_array = Ezfio.get_determinants_psi_det () in + let dim = psi_det_array.Ezfio.dim + and data = Ezfio.flattened_ezfio psi_det_array + in + assert (n_int = dim.(0)); + assert (dim.(1) = 2); + assert (dim.(2) = (Det_number.to_int (read_n_det ()))); + List.init dim.(2) ~f:(fun i -> + Array.sub ~pos:(2*n_int*i) ~len:(2*n_int) data) + |> List.map ~f:(Determinant.of_int64_array + ~n_int:(N_int_number.of_int n_int) + ~alpha:n_alpha ~beta:n_beta ) + |> Array.of_list + ;; + + let write_psi_det ~n_int ~n_det d = + let data = Array.to_list d + |> Array.concat + |> Array.to_list + in + Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; Det_number.to_int n_det |] ~data:data + |> Ezfio.set_determinants_psi_det + ;; + + + let read () = + if (Ezfio.has_mo_basis_mo_tot_num ()) then + Some + { n_int = read_n_int () ; + bit_kind = read_bit_kind () ; + n_det = read_n_det () ; + n_states = read_n_states () ; + n_states_diag = read_n_states_diag () ; + expected_s2 = read_expected_s2 () ; + psi_coef = read_psi_coef () ; + psi_det = read_psi_det () ; + } + else + None + ;; + + let write { n_int ; + bit_kind ; + n_det ; + n_states ; + n_states_diag ; + expected_s2 ; + psi_coef ; + psi_det ; + } = + write_n_int n_int ; + write_bit_kind bit_kind; + write_n_det n_det; + write_n_states n_states; + write_n_states_diag ~n_states:n_states n_states_diag; + write_expected_s2 expected_s2; + write_psi_coef ~n_det:n_det psi_coef ~n_states:n_states; + write_psi_det ~n_int:n_int ~n_det:n_det psi_det; + ;; + + + let to_rst b = + let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in + let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in + let det_text = + let nstates = + States_number.to_int b.n_states + and ndet = + Det_number.to_int b.n_det + in + let coefs_string i = + Array.init nstates (fun j -> + let ishift = + j*ndet + in + if (ishift < Array.length b.psi_coef) then + b.psi_coef.(i+ishift) + |> Det_coef.to_float + |> Float.to_string + else + "0." + ) + |> String.concat_array ~sep:"\t" + in + Array.init ndet ~f:(fun i -> + Printf.sprintf " %s\n%s\n" + (coefs_string i) + (Determinant.to_string ~mo_tot_num:mo_tot_num b.psi_det.(i) + |> String.split ~on:'\n' + |> List.map ~f:(fun x -> " "^x) + |> String.concat ~sep:"\n" + ) + ) + |> String.concat_array ~sep:"\n" + in + Printf.sprintf " +Force the selected wave function to be an eigenfunction of S^2. +If true, input the expected value of S^2 :: + + expected_s2 = %s + +Number of requested states, and number of states used for the +Davidson diagonalization :: + + n_states = %s + n_states_diag = %s + +Number of determinants :: + + n_det = %s + +Determinants :: + +%s +" + (b.expected_s2 |> Positive_float.to_string) + (b.n_states |> States_number.to_string) + (b.n_states_diag |> States_number.to_string) + (b.n_det |> Det_number.to_string) + det_text + |> Rst_string.of_string + ;; + + let to_string b = + let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in + let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in + Printf.sprintf " +n_int = %s +bit_kind = %s +n_det = %s +n_states = %s +n_states_diag = %s +expected_s2 = %s +psi_coef = %s +psi_det = %s +" + (b.n_int |> N_int_number.to_string) + (b.bit_kind |> Bit_kind.to_string) + (b.n_det |> Det_number.to_string) + (b.n_states |> States_number.to_string) + (b.n_states_diag |> States_number.to_string) + (b.expected_s2 |> Positive_float.to_string) + (b.psi_coef |> Array.to_list |> List.map ~f:Det_coef.to_string + |> String.concat ~sep:", ") + (b.psi_det |> Array.to_list |> List.map ~f:(Determinant.to_string + ~mo_tot_num:mo_tot_num) |> String.concat ~sep:"\n\n") + ;; + + let of_rst r = + let r = Rst_string.to_string r + in + + (* Split into header and determinants data *) + let idx = String.substr_index_exn r ~pos:0 ~pattern:"\nDeterminants" + in + let (header, dets) = + (String.prefix r idx, String.suffix r ((String.length r)-idx) ) + in + + (* Handle header *) + let header = r + |> String.split ~on:'\n' + |> List.filter ~f:(fun line -> + if (line = "") then + false + else + ( (String.contains line '=') && (line.[0] = ' ') ) + ) + |> List.map ~f:(fun line -> + "("^( + String.tr line ~target:'=' ~replacement:' ' + |> String.strip + )^")" ) + |> String.concat + in + + (* Handle determinant coefs *) + let dets = match ( dets + |> String.split ~on:'\n' + |> List.map ~f:(String.strip) + ) with + | _::lines -> lines + | _ -> failwith "Error in determinants" + in + + let psi_coef = + let rec read_coefs accu = function + | [] -> List.rev accu + | ""::""::tail -> read_coefs accu tail + | ""::c::tail -> + let c = + String.split ~on:'\t' c + |> List.map ~f:(fun x -> Det_coef.of_float (Float.of_string x)) + |> Array.of_list + in + read_coefs (c::accu) tail + | _::tail -> read_coefs accu tail + in + let a = + let buffer = + read_coefs [] dets + in + let nstates = + List.hd_exn buffer + |> Array.length + in + let extract_state i = + let i = + i-1 + in + List.map ~f:(fun x -> Det_coef.to_string x.(i)) buffer + |> String.concat ~sep:" " + in + let rec build_result = function + | 1 -> extract_state 1 + | i -> (build_result (i-1))^" "^(extract_state i) + in + build_result nstates + in + "(psi_coef ("^a^"))" + in + + (* Handle determinants *) + let psi_det = + let n_alpha = Ezfio.get_electrons_elec_alpha_num () + |> Elec_alpha_number.of_int + and n_beta = Ezfio.get_electrons_elec_beta_num () + |> Elec_beta_number.of_int + in + let rec read_dets accu = function + | [] -> List.rev accu + | ""::c::alpha::beta::tail -> + begin + let alpha = String.rev alpha |> Bitlist.of_string ~zero:'-' ~one:'+' + and beta = String.rev beta |> Bitlist.of_string ~zero:'-' ~one:'+' + in + let newdet = Determinant.of_bitlist_couple + ~alpha:n_alpha ~beta:n_beta (alpha,beta) + |> Determinant.sexp_of_t |> Sexplib.Sexp.to_string + in + read_dets (newdet::accu) tail + end + | _::tail -> read_dets accu tail + in + let a = read_dets [] dets + |> String.concat + in + "(psi_det ("^a^"))" + in + + let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind + |> Bit_kind.to_int) + and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) in + let s = String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] + in + + Generic_input_of_rst.evaluate_sexp t_of_sexp s + ;; + +end + + diff --git a/scripts/clean_modules.sh b/scripts/clean_modules.sh index cc25cede..452724f2 100755 --- a/scripts/clean_modules.sh +++ b/scripts/clean_modules.sh @@ -14,7 +14,7 @@ function do_clean() { rm -rf -- \ IRPF90_temp IRPF90_man Makefile.depend $(cat NEEDED_MODULES) include \ - ezfio_interface.irp.f irpf90.make irpf90_entities tags $(ls_exe) + ezfio_interface.irp.f irpf90.make irpf90_entities tags $(ls_exe) *.mod } if [[ -z $1 ]] diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index dcfb394c..6d18d071 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -112,6 +112,8 @@ def get_type_dict(): # ~#~#~#~#~#~#~#~ # fancy_type['integer'] = Type(None, "int", "integer") + fancy_type['integer*8'] = Type(None, "int", "integer*8") + fancy_type['int'] = Type(None, "int", "integer") fancy_type['float'] = Type(None, "float", "double precision") @@ -121,7 +123,7 @@ def get_type_dict(): fancy_type['bool'] = Type(None, "bool", "logical") fancy_type['character*(32)'] = Type(None, "string", "character*(32)") - fancy_type['character*(60)'] = Type(None, "string", "character*(60)") + fancy_type['character*(64)'] = Type(None, "string", "character*(68)") fancy_type['character*(256)'] = Type(None, "string", "character*(256)") # ~#~#~#~#~#~#~#~ # @@ -267,7 +269,7 @@ def get_dict_config_file(config_file_path, module_lower): d[pvd][option] = d_default[option] # If interface is input we need a default value information - if d[pvd]["interface"] == "input": + if d[pvd]["interface"].lower() == "input": try: default_raw = config_file.get(section, "default") except ConfigParser.NoOptionError: diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template index 8d52acfd..2990a193 100644 --- a/scripts/ezfio_interface/qp_edit_template +++ b/scripts/ezfio_interface/qp_edit_template @@ -4,14 +4,16 @@ open Core.Std;; (** Interactive editing of the input. -@author A. Scemama +WARNING +This file is autogenerad by +`${{QP_ROOT}}/script/ezfio_interface/ei_handler.py` *) (** Keywords used to define input sections *) type keyword = | Ao_basis -| Determinants +| Determinants_by_hand | Electrons | Mo_basis | Nuclei @@ -20,11 +22,11 @@ type keyword = let keyword_to_string = function -| Ao_basis -> "AO basis" -| Determinants -> "Determinants" -| Electrons -> "Electrons" -| Mo_basis -> "MO basis" -| Nuclei -> "Molecule" +| Ao_basis -> "AO basis" +| Determinants_by_hand -> "Determinants_by_hand" +| Electrons -> "Electrons" +| Mo_basis -> "MO basis" +| Nuclei -> "Molecule" {keywords_to_string} ;; @@ -72,8 +74,8 @@ let get s = f Nuclei.(read, to_rst) | Ao_basis -> f Ao_basis.(read, to_rst) - | Determinants -> - f Determinants.(read, to_rst) + | Determinants_by_hand -> + f Determinants_by_hand.(read, to_rst) {section_to_rst} end with @@ -114,7 +116,7 @@ let set str s = match s with {write} | Electrons -> write Electrons.(of_rst, write) s - | Determinants -> write Determinants.(of_rst, write) s + | Determinants_by_hand -> write Determinants_by_hand.(of_rst, write) s | Nuclei -> write Nuclei.(of_rst, write) s | Ao_basis -> () (* TODO *) | Mo_basis -> () (* TODO *) @@ -162,7 +164,7 @@ let run check_only ezfio_filename = Electrons ; {tasks} Mo_basis; - Determinants ; + Determinants_by_hand ; ] in diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 280c9f72..072a8f1e 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -1,7 +1,7 @@ #!/usr/bin/env python import os -file = open(os.environ["QPACKAGE_ROOT"]+'/src/Dets/H_apply_template.f','r') +file = open(os.environ["QPACKAGE_ROOT"]+'/src/Determinants/H_apply_template.f','r') template = file.read() file.close() @@ -104,7 +104,7 @@ class H_apply(object): endif SOFT_TOUCH psi_det psi_coef N_det """ - s["printout_now"] = """write(output_Dets,*) & + s["printout_now"] = """write(output_determinants,*) & 100.*float(i_generator)/float(N_det_generators), '% in ', wall_1-wall_0, 's'""" self.data = s @@ -211,9 +211,9 @@ class H_apply(object): delta_pt2(k) = 0.d0 pt2_old(k) = 0.d0 enddo - write(output_Dets,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & + write(output_determinants,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & 'N_generators', 'Norm', 'Delta PT2', 'PT2', 'Est. PT2', 'secs' - write(output_Dets,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & + write(output_determinants,'(A12, X, A8, 3(2X, A9), 2X, A8, 2X, A8, 2X, A8)') & '============', '========', '=========', '=========', '=========', & '=========' """ @@ -226,7 +226,7 @@ class H_apply(object): """ self.data["printout_now"] = """ do k=1,N_st - write(output_Dets,'(I10, 4(2X, F9.6), 2X, F8.1)') & + write(output_determinants,'(I10, 4(2X, F9.6), 2X, F8.1)') & i_generator, norm_psi(k), delta_pt2(k), pt2(k), & pt2(k)/(norm_psi(k)*norm_psi(k)), & wall_1-wall_0 @@ -258,7 +258,7 @@ class H_apply(object): ! SOFT_TOUCH psi_det psi_coef N_det selection_criterion_min = min(selection_criterion_min, maxval(select_max))*0.1d0 selection_criterion = selection_criterion_min - call write_double(output_Dets,selection_criterion,'Selection criterion') + call write_double(output_determinants,selection_criterion,'Selection criterion') """ self.data["keys_work"] = """ e_2_pert_buffer = 0.d0 diff --git a/src/CAS_SD/NEEDED_MODULES b/src/CAS_SD/NEEDED_MODULES index cbf44be7..f20d16a0 100644 --- a/src/CAS_SD/NEEDED_MODULES +++ b/src/CAS_SD/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Generators_CAS Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_CAS Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils diff --git a/src/CAS_SD/README.rst b/src/CAS_SD/README.rst index 0dc4ea56..0b3293d5 100644 --- a/src/CAS_SD/README.rst +++ b/src/CAS_SD/README.rst @@ -27,7 +27,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Generators_CAS `_ diff --git a/src/CID/NEEDED_MODULES b/src/CID/NEEDED_MODULES index ac8e21ab..f7a1831f 100644 --- a/src/CID/NEEDED_MODULES +++ b/src/CID/NEEDED_MODULES @@ -1,3 +1,3 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils diff --git a/src/CID/README.rst b/src/CID/README.rst index 6adc4dcd..47cbc40b 100644 --- a/src/CID/README.rst +++ b/src/CID/README.rst @@ -18,7 +18,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/CID_SC2_selected/NEEDED_MODULES b/src/CID_SC2_selected/NEEDED_MODULES index 42d83610..67f77e87 100644 --- a/src/CID_SC2_selected/NEEDED_MODULES +++ b/src/CID_SC2_selected/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask CISD CISD_selected Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask CISD CISD_selected Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils diff --git a/src/CID_SC2_selected/README.rst b/src/CID_SC2_selected/README.rst index 720b6385..37680ebb 100644 --- a/src/CID_SC2_selected/README.rst +++ b/src/CID_SC2_selected/README.rst @@ -24,7 +24,7 @@ Needed Modules * `Bitmask `_ * `CISD `_ * `CISD_selected `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/CID_selected/NEEDED_MODULES b/src/CID_selected/NEEDED_MODULES index b27ab85e..ca89c5f3 100644 --- a/src/CID_selected/NEEDED_MODULES +++ b/src/CID_selected/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask CISD Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask CISD Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils diff --git a/src/CID_selected/README.rst b/src/CID_selected/README.rst index 2ee45ac6..d8f054ac 100644 --- a/src/CID_selected/README.rst +++ b/src/CID_selected/README.rst @@ -26,7 +26,7 @@ Needed Modules * `Bielec_integrals `_ * `Bitmask `_ * `CISD `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/CIS/NEEDED_MODULES b/src/CIS/NEEDED_MODULES index 010e60f5..5cdee2e5 100644 --- a/src/CIS/NEEDED_MODULES +++ b/src/CIS/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils diff --git a/src/CIS/README.rst b/src/CIS/README.rst index e9ba93db..59558a31 100644 --- a/src/CIS/README.rst +++ b/src/CIS/README.rst @@ -34,7 +34,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/CISD/NEEDED_MODULES b/src/CISD/NEEDED_MODULES index 010e60f5..5cdee2e5 100644 --- a/src/CISD/NEEDED_MODULES +++ b/src/CISD/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils diff --git a/src/CISD/README.rst b/src/CISD/README.rst index 07528e59..bcf7aee2 100644 --- a/src/CISD/README.rst +++ b/src/CISD/README.rst @@ -18,7 +18,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/CISD_SC2_selected/NEEDED_MODULES b/src/CISD_SC2_selected/NEEDED_MODULES index 42d83610..67f77e87 100644 --- a/src/CISD_SC2_selected/NEEDED_MODULES +++ b/src/CISD_SC2_selected/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask CISD CISD_selected Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask CISD CISD_selected Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils diff --git a/src/CISD_SC2_selected/README.rst b/src/CISD_SC2_selected/README.rst index 25f4368f..915c85f1 100644 --- a/src/CISD_SC2_selected/README.rst +++ b/src/CISD_SC2_selected/README.rst @@ -24,7 +24,7 @@ Needed Modules * `Bitmask `_ * `CISD `_ * `CISD_selected `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/CISD_selected/NEEDED_MODULES b/src/CISD_selected/NEEDED_MODULES index b27ab85e..ca89c5f3 100644 --- a/src/CISD_selected/NEEDED_MODULES +++ b/src/CISD_selected/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask CISD Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask CISD Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils diff --git a/src/CISD_selected/README.rst b/src/CISD_selected/README.rst index 1ba5f9c5..e2b6989e 100644 --- a/src/CISD_selected/README.rst +++ b/src/CISD_selected/README.rst @@ -32,7 +32,7 @@ Needed Modules * `Bielec_integrals `_ * `Bitmask `_ * `CISD `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/DDCI_selected/NEEDED_MODULES b/src/DDCI_selected/NEEDED_MODULES index cbf44be7..f20d16a0 100644 --- a/src/DDCI_selected/NEEDED_MODULES +++ b/src/DDCI_selected/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Generators_CAS Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_CAS Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils diff --git a/src/DDCI_selected/README.rst b/src/DDCI_selected/README.rst index db75b101..2b5823c7 100644 --- a/src/DDCI_selected/README.rst +++ b/src/DDCI_selected/README.rst @@ -22,7 +22,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Generators_CAS `_ diff --git a/src/Dets/determinants.irp.f b/src/Determinants/determinants.irp.f similarity index 98% rename from src/Dets/determinants.irp.f rename to src/Determinants/determinants.irp.f index 104b868e..03315836 100644 --- a/src/Dets/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -25,7 +25,7 @@ BEGIN_PROVIDER [ integer, N_det ] else N_det = 1 endif - call write_int(output_dets,N_det,'Number of determinants') + call write_int(output_determinants,N_det,'Number of determinants') ASSERT (N_det > 0) END_PROVIDER @@ -58,7 +58,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ] psi_det_size = 1 endif psi_det_size = max(psi_det_size,10000) - call write_int(output_dets,psi_det_size,'Dimension of the psi arrays') + call write_int(output_determinants,psi_det_size,'Dimension of the psi arrays') END_PROVIDER @@ -68,6 +68,9 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] ! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file ! is empty END_DOC + + PROVIDE ezfio_filename + integer :: i logical :: exists character*64 :: label @@ -234,6 +237,8 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states_diag) ] ! is empty END_DOC + PROVIDE ezfio_filename + integer :: i,k, N_int2 logical :: exists double precision, allocatable :: psi_coef_read(:,:) @@ -597,6 +602,8 @@ subroutine read_dets(det,Nint,Ndet) integer :: i,k equivalence (det_8, det_bk) + PROVIDE ezfio_filename + call ezfio_get_determinants_N_int(N_int2) ASSERT (N_int2 == Nint) call ezfio_get_determinants_bit_kind(k) @@ -665,6 +672,8 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,k PROVIDE progress_bar + PROVIDE ezfio_filename + call start_progress(7,'Saving wfunction',0.d0) progress_bar(1) = 1 @@ -727,7 +736,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) enddo call ezfio_set_determinants_psi_coef(psi_coef_save) - call write_int(output_dets,ndet,'Saved determinants') + call write_int(output_determinants,ndet,'Saved determinants') call stop_progress deallocate (psi_coef_save) end diff --git a/src/Dets/ASSUMPTIONS.rst b/src/Dets/ASSUMPTIONS.rst deleted file mode 100644 index e9e24d09..00000000 --- a/src/Dets/ASSUMPTIONS.rst +++ /dev/null @@ -1,7 +0,0 @@ -* The MOs are orthonormal -* All the determinants have the same number of electrons -* The determinants are orthonormal -* The number of generator determinants <= the number of determinants -* All the determinants in the H_apply buffer are supposed to be different from the - wave function determinants -* All the determinants in the H_apply buffer are supposed to be unique diff --git a/src/Dets/H_apply.irp.f b/src/Dets/H_apply.irp.f deleted file mode 100644 index 801d00a5..00000000 --- a/src/Dets/H_apply.irp.f +++ /dev/null @@ -1,229 +0,0 @@ -use bitmasks -use omp_lib - -type H_apply_buffer_type -integer :: N_det -integer :: sze -integer(bit_kind), pointer :: det(:,:,:) -double precision , pointer :: coef(:,:) -double precision , pointer :: e2(:,:) -end type H_apply_buffer_type - -type(H_apply_buffer_type), pointer :: H_apply_buffer(:) - - - BEGIN_PROVIDER [ logical, H_apply_buffer_allocated ] -&BEGIN_PROVIDER [ integer(omp_lock_kind), H_apply_buffer_lock, (64,0:nproc-1) ] - use omp_lib - implicit none - BEGIN_DOC - ! Buffer of determinants/coefficients/perturbative energy for H_apply. - ! Uninitialized. Filled by H_apply subroutines. - END_DOC - integer :: iproc, sze - sze = 10000 - if (.not.associated(H_apply_buffer)) then - allocate(H_apply_buffer(0:nproc-1)) - iproc = 0 - !$OMP PARALLEL PRIVATE(iproc) DEFAULT(NONE) & - !$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock) - !$ iproc = omp_get_thread_num() - H_apply_buffer(iproc)%N_det = 0 - H_apply_buffer(iproc)%sze = sze - allocate ( & - H_apply_buffer(iproc)%det(N_int,2,sze), & - H_apply_buffer(iproc)%coef(sze,N_states), & - H_apply_buffer(iproc)%e2(sze,N_states) & - ) - H_apply_buffer(iproc)%det = 0_bit_kind - H_apply_buffer(iproc)%coef = 0.d0 - H_apply_buffer(iproc)%e2 = 0.d0 - call omp_init_lock(H_apply_buffer_lock(1,iproc)) - !$OMP END PARALLEL - endif - -END_PROVIDER - - -subroutine resize_H_apply_buffer(new_size,iproc) - implicit none - integer, intent(in) :: new_size, iproc - integer(bit_kind), pointer :: buffer_det(:,:,:) - double precision, pointer :: buffer_coef(:,:) - double precision, pointer :: buffer_e2(:,:) - integer :: i,j,k - integer :: Ndet - PROVIDE H_apply_buffer_allocated - - ASSERT (new_size > 0) - ASSERT (iproc >= 0) - ASSERT (iproc < nproc) - - call omp_set_lock(H_apply_buffer_lock(1,iproc)) - allocate ( buffer_det(N_int,2,new_size), & - buffer_coef(new_size,N_states), & - buffer_e2(new_size,N_states) ) - - do i=1,min(new_size,H_apply_buffer(iproc)%N_det) - do k=1,N_int - buffer_det(k,1,i) = H_apply_buffer(iproc)%det(k,1,i) - buffer_det(k,2,i) = H_apply_buffer(iproc)%det(k,2,i) - enddo - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i))) == elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num ) - enddo - deallocate(H_apply_buffer(iproc)%det) - H_apply_buffer(iproc)%det => buffer_det - - do k=1,N_states - do i=1,min(new_size,H_apply_buffer(iproc)%N_det) - buffer_coef(i,k) = H_apply_buffer(iproc)%coef(i,k) - enddo - enddo - deallocate(H_apply_buffer(iproc)%coef) - H_apply_buffer(iproc)%coef => buffer_coef - - do k=1,N_states - do i=1,min(new_size,H_apply_buffer(iproc)%N_det) - buffer_e2(i,k) = H_apply_buffer(iproc)%e2(i,k) - enddo - enddo - deallocate(H_apply_buffer(iproc)%e2) - H_apply_buffer(iproc)%e2 => buffer_e2 - - H_apply_buffer(iproc)%sze = new_size - H_apply_buffer(iproc)%N_det = min(new_size,H_apply_buffer(iproc)%N_det) - call omp_unset_lock(H_apply_buffer_lock(1,iproc)) - -end - -subroutine copy_H_apply_buffer_to_wf - use omp_lib - implicit none - BEGIN_DOC -! Copies the H_apply buffer to psi_coef. You need to touch psi_det, psi_coef and N_det -! after calling this function. -! After calling this subroutine, N_det, psi_det and psi_coef need to be touched - END_DOC - integer(bit_kind), allocatable :: buffer_det(:,:,:) - double precision, allocatable :: buffer_coef(:,:) - integer :: i,j,k - integer :: N_det_old - integer :: iproc - - PROVIDE H_apply_buffer_allocated - - ASSERT (N_int > 0) - ASSERT (N_det > 0) - - allocate ( buffer_det(N_int,2,N_det), buffer_coef(N_det,N_states) ) - - do i=1,N_det - do k=1,N_int - ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) - ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num) - buffer_det(k,1,i) = psi_det(k,1,i) - buffer_det(k,2,i) = psi_det(k,2,i) - enddo - enddo - do k=1,N_states - do i=1,N_det - buffer_coef(i,k) = psi_coef(i,k) - enddo - enddo - - N_det_old = N_det - do j=0,nproc-1 - N_det = N_det + H_apply_buffer(j)%N_det - enddo - - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i=1,N_det_old - do k=1,N_int - psi_det(k,1,i) = buffer_det(k,1,i) - psi_det(k,2,i) = buffer_det(k,2,i) - enddo - ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) - ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num ) - enddo - do k=1,N_states - do i=1,N_det_old - psi_coef(i,k) = buffer_coef(i,k) - enddo - enddo - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & - !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states) - j=0 - !$ j=omp_get_thread_num() - do k=0,j-1 - N_det_old += H_apply_buffer(k)%N_det - enddo - do i=1,H_apply_buffer(j)%N_det - do k=1,N_int - psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i) - psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i) - enddo - ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num) - ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) - enddo - do k=1,N_states - do i=1,H_apply_buffer(j)%N_det - psi_coef(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) - enddo - enddo - !$OMP BARRIER - H_apply_buffer(j)%N_det = 0 - !$OMP END PARALLEL - call normalize(psi_coef,N_det) - SOFT_TOUCH N_det psi_det psi_coef - -end - - -subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) - use bitmasks - implicit none - BEGIN_DOC - ! Fill the H_apply buffer with determiants for CISD - END_DOC - - integer, intent(in) :: n_selected, Nint, iproc - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k - integer :: new_size - PROVIDE H_apply_buffer_allocated - new_size = H_apply_buffer(iproc)%N_det + n_selected - if (new_size > H_apply_buffer(iproc)%sze) then - call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc) - endif - call omp_set_lock(H_apply_buffer_lock(1,iproc)) - do i=1,H_apply_buffer(iproc)%N_det - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) - enddo - do i=1,n_selected - do j=1,N_int - H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) - H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) - enddo - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) - enddo - do j=1,N_states - do i=1,N_selected - H_apply_buffer(iproc)%coef(i,j) = 0.d0 - enddo - enddo - H_apply_buffer(iproc)%N_det = new_size - do i=1,H_apply_buffer(iproc)%N_det - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) - enddo - call omp_unset_lock(H_apply_buffer_lock(1,iproc)) -end - - diff --git a/src/Dets/H_apply_template.f b/src/Dets/H_apply_template.f deleted file mode 100644 index a9a282ae..00000000 --- a/src/Dets/H_apply_template.f +++ /dev/null @@ -1,542 +0,0 @@ -subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_generator, iproc_in $parameters ) - use omp_lib - use bitmasks - implicit none - BEGIN_DOC - ! Generate all double excitations of key_in using the bit masks of holes and - ! particles. - ! Assume N_int is already provided. - END_DOC - integer,parameter :: size_max = $size_max - $declarations - integer ,intent(in) :: i_generator - integer(bit_kind),intent(in) :: key_in(N_int,2) - integer(bit_kind),allocatable :: keys_out(:,:,:) - integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2) - integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2) - integer, intent(in) :: iproc_in - integer(bit_kind), allocatable :: hole_save(:,:) - integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:) - integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:) - integer :: ii,i,jj,j,k,ispin,l - integer, allocatable :: occ_particle(:,:), occ_hole(:,:) - integer, allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) - integer :: kk,pp,other_spin,key_idx - integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) - integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) - - double precision :: mo_bielec_integral - logical :: is_a_two_holes_two_particles - integer, allocatable :: ia_ja_pairs(:,:,:) - integer, allocatable :: ib_jb_pairs(:,:) - double precision :: diag_H_mat_elem - integer :: iproc - integer(omp_lock_kind), save :: lck, ifirst=0 - if (ifirst == 0) then -!$ call omp_init_lock(lck) - ifirst=1 - endif - - logical :: check_double_excitation - check_double_excitation = .True. - iproc = iproc_in - - - $initialization - - $omp_parallel -!$ iproc = omp_get_thread_num() - allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & - key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& - particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & - occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& - occ_hole_tmp(N_int*bit_kind_size,2)) - $init_thread - - - - !!!! First couple hole particle - do j = 1, N_int - hole(j,1) = iand(hole_1(j,1),key_in(j,1)) - hole(j,2) = iand(hole_1(j,2),key_in(j,2)) - particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) - particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) - enddo - call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) - call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) - call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int) - call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int) - allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), & - ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num)) - - do ispin=1,2 - i=0 - do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole - i_a = occ_hole(ii,ispin) - ASSERT (i_a > 0) - ASSERT (i_a <= mo_tot_num) - - do jj=1,N_elec_in_key_part_1(ispin) !particle - j_a = occ_particle(jj,ispin) - ASSERT (j_a > 0) - ASSERT (j_a <= mo_tot_num) - i += 1 - ia_ja_pairs(1,i,ispin) = i_a - ia_ja_pairs(2,i,ispin) = j_a - enddo - enddo - ia_ja_pairs(1,0,ispin) = i - enddo - - key_idx = 0 - - integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b - integer(bit_kind) :: test(N_int,2) - double precision :: accu - logical, allocatable :: array_pairs(:,:) - allocate(array_pairs(mo_tot_num,mo_tot_num)) - accu = 0.d0 - do ispin=1,2 - other_spin = iand(ispin,1)+1 - if (abort_here) then - exit - endif - $omp_do - do ii=1,ia_ja_pairs(1,0,ispin) - if (abort_here) then - cycle - endif - i_a = ia_ja_pairs(1,ii,ispin) - ASSERT (i_a > 0) - ASSERT (i_a <= mo_tot_num) - j_a = ia_ja_pairs(2,ii,ispin) - ASSERT (j_a > 0) - ASSERT (j_a <= mo_tot_num) - hole = key_in - k = ishft(i_a-1,-bit_kind_shift)+1 - j = i_a-ishft(k-1,bit_kind_shift)-1 - hole(k,ispin) = ibclr(hole(k,ispin),j) - k_a = ishft(j_a-1,-bit_kind_shift)+1 - l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 - hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) - - !!!! Second couple hole particle - do j = 1, N_int - hole_tmp(j,1) = iand(hole_2(j,1),hole(j,1)) - hole_tmp(j,2) = iand(hole_2(j,2),hole(j,2)) - particle_tmp(j,1) = iand(xor(particl_2(j,1),hole(j,1)),particl_2(j,1)) - particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2)) - enddo - - call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int) - call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int) - call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int) - call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int) - - ! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin) - hole_save = hole - - ! Build array of the non-zero integrals of second excitation - $filter_integrals - if (ispin == 1) then - integer :: jjj - - i=0 - do kk = 1,N_elec_in_key_hole_2(other_spin) - i_b = occ_hole_tmp(kk,other_spin) - ASSERT (i_b > 0) - ASSERT (i_b <= mo_tot_num) - do jjj=1,N_elec_in_key_part_2(other_spin) ! particule - j_b = occ_particle_tmp(jjj,other_spin) - ASSERT (j_b > 0) - ASSERT (j_b <= mo_tot_num) - if (array_pairs(i_b,j_b)) then - i+= 1 - ib_jb_pairs(1,i) = i_b - ib_jb_pairs(2,i) = j_b - endif - enddo - enddo - ib_jb_pairs(1,0) = i - - do kk = 1,ib_jb_pairs(1,0) - hole = hole_save - i_b = ib_jb_pairs(1,kk) - j_b = ib_jb_pairs(2,kk) - k = ishft(i_b-1,-bit_kind_shift)+1 - j = i_b-ishft(k-1,bit_kind_shift)-1 - hole(k,other_spin) = ibclr(hole(k,other_spin),j) - key = hole - k = ishft(j_b-1,-bit_kind_shift)+1 - l = j_b-ishft(k-1,bit_kind_shift)-1 - key(k,other_spin) = ibset(key(k,other_spin),l) - $filter2h2p - key_idx += 1 - do k=1,N_int - keys_out(k,1,key_idx) = key(k,1) - keys_out(k,2,key_idx) = key(k,2) - enddo - ASSERT (key_idx <= size_max) - if (key_idx == size_max) then - $keys_work - key_idx = 0 - endif - if (abort_here) then - exit - endif - enddo - endif - - ! does all the mono excitations of the same spin - i=0 - do kk = 1,N_elec_in_key_hole_2(ispin) - i_b = occ_hole_tmp(kk,ispin) - if (i_b <= i_a.or.i_b == j_a) cycle - ASSERT (i_b > 0) - ASSERT (i_b <= mo_tot_num) - do jjj=1,N_elec_in_key_part_2(ispin) ! particule - j_b = occ_particle_tmp(jjj,ispin) - ASSERT (j_b > 0) - ASSERT (j_b <= mo_tot_num) - if (j_b <= j_a) cycle - if (array_pairs(i_b,j_b)) then - i+= 1 - ib_jb_pairs(1,i) = i_b - ib_jb_pairs(2,i) = j_b - endif - enddo - enddo - ib_jb_pairs(1,0) = i - - do kk = 1,ib_jb_pairs(1,0) - hole = hole_save - i_b = ib_jb_pairs(1,kk) - j_b = ib_jb_pairs(2,kk) - k = ishft(i_b-1,-bit_kind_shift)+1 - j = i_b-ishft(k-1,bit_kind_shift)-1 - hole(k,ispin) = ibclr(hole(k,ispin),j) - key = hole - k = ishft(j_b-1,-bit_kind_shift)+1 - l = j_b-ishft(k-1,bit_kind_shift)-1 - key(k,ispin) = ibset(key(k,ispin),l) - $filter2h2p - key_idx += 1 - do k=1,N_int - keys_out(k,1,key_idx) = key(k,1) - keys_out(k,2,key_idx) = key(k,2) - enddo - ASSERT (key_idx <= size_max) - if (key_idx == size_max) then - $keys_work - key_idx = 0 - endif - if (abort_here) then - exit - endif - enddo ! kk - - enddo ! ii - $omp_enddo - enddo ! ispin - $keys_work - $deinit_thread - deallocate (ia_ja_pairs, ib_jb_pairs, & - keys_out, hole_save, & - key,hole, particle, hole_tmp,& - particle_tmp, occ_particle, & - occ_hole, occ_particle_tmp,& - occ_hole_tmp,array_pairs) - $omp_end_parallel - $finalization -end - -subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $parameters ) - use omp_lib - use bitmasks - implicit none - BEGIN_DOC - ! Generate all single excitations of key_in using the bit masks of holes and - ! particles. - ! Assume N_int is already provided. - END_DOC - integer,parameter :: size_max = $size_max - $declarations - integer ,intent(in) :: i_generator - integer(bit_kind),intent(in) :: key_in(N_int,2) - integer(bit_kind),intent(in) :: hole_1(N_int,2), particl_1(N_int,2) - integer, intent(in) :: iproc_in - integer(bit_kind),allocatable :: keys_out(:,:,:) - integer(bit_kind),allocatable :: hole_save(:,:) - integer(bit_kind),allocatable :: key(:,:),hole(:,:), particle(:,:) - integer(bit_kind),allocatable :: hole_tmp(:,:), particle_tmp(:,:) - integer(bit_kind),allocatable :: hole_2(:,:), particl_2(:,:) - integer :: ii,i,jj,j,k,ispin,l - integer,allocatable :: occ_particle(:,:), occ_hole(:,:) - integer,allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) - integer,allocatable :: ib_jb_pairs(:,:) - integer :: kk,pp,other_spin,key_idx - integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) - integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) - logical :: is_a_two_holes_two_particles - - integer, allocatable :: ia_ja_pairs(:,:,:) - logical, allocatable :: array_pairs(:,:) - double precision :: diag_H_mat_elem - integer(omp_lock_kind), save :: lck, ifirst=0 - integer :: iproc - - logical :: check_double_excitation - iproc = iproc_in - - check_double_excitation = .True. - $check_double_excitation - - - if (ifirst == 0) then - ifirst=1 -!$ call omp_init_lock(lck) - endif - - $initialization - - $omp_parallel -!$ iproc = omp_get_thread_num() - allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & - key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& - particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & - occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& - occ_hole_tmp(N_int*bit_kind_size,2)) - $init_thread - !!!! First couple hole particle - do j = 1, N_int - hole(j,1) = iand(hole_1(j,1),key_in(j,1)) - hole(j,2) = iand(hole_1(j,2),key_in(j,2)) - particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) - particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) - enddo - - call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) - call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) - call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int) - call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int) - allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2)) - - do ispin=1,2 - i=0 - do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole - i_a = occ_hole(ii,ispin) - do jj=1,N_elec_in_key_part_1(ispin) !particule - j_a = occ_particle(jj,ispin) - i += 1 - ia_ja_pairs(1,i,ispin) = i_a - ia_ja_pairs(2,i,ispin) = j_a - enddo - enddo - ia_ja_pairs(1,0,ispin) = i - enddo - - key_idx = 0 - - integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b - integer(bit_kind) :: test(N_int,2) - double precision :: accu - accu = 0.d0 - do ispin=1,2 - other_spin = iand(ispin,1)+1 - $omp_do - do ii=1,ia_ja_pairs(1,0,ispin) - i_a = ia_ja_pairs(1,ii,ispin) - j_a = ia_ja_pairs(2,ii,ispin) - hole = key_in - k = ishft(i_a-1,-bit_kind_shift)+1 - j = i_a-ishft(k-1,bit_kind_shift)-1 - $filterhole - hole(k,ispin) = ibclr(hole(k,ispin),j) - k_a = ishft(j_a-1,-bit_kind_shift)+1 - l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 - $filterparticle - hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) - $filter2h2p - key_idx += 1 - do k=1,N_int - keys_out(k,1,key_idx) = hole(k,1) - keys_out(k,2,key_idx) = hole(k,2) - enddo - if (key_idx == size_max) then - $keys_work - key_idx = 0 - endif - enddo ! ii - $omp_enddo - enddo ! ispin - $keys_work - $deinit_thread - deallocate (ia_ja_pairs, & - keys_out, hole_save, & - key,hole, particle, hole_tmp,& - particle_tmp, occ_particle, & - occ_hole, occ_particle_tmp,& - occ_hole_tmp) - $omp_end_parallel - $finalization - -end - - -subroutine $subroutine($params_main) - implicit none - use omp_lib - use bitmasks - BEGIN_DOC - ! Calls H_apply on the HF determinant and selects all connected single and double - ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - END_DOC - - $decls_main - - integer :: i_generator, nmax - double precision :: wall_0, wall_1 - integer(omp_lock_kind) :: lck - integer(bit_kind), allocatable :: mask(:,:,:) - integer :: ispin, k - integer :: iproc - - $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators - - - nmax = mod( N_det_generators,nproc ) - - - !$ call omp_init_lock(lck) - call start_progress(N_det_generators,'Selection (norm)',0.d0) - - call wall_time(wall_0) - - iproc = 0 - allocate( mask(N_int,2,6) ) - do i_generator=1,nmax - - progress_bar(1) = i_generator - - if (abort_here) then - exit - endif - $skip - - ! Create bit masks for holes and particles - do ispin=1,2 - do k=1,N_int - mask(k,ispin,s_hole) = & - iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,s_part) = & - iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole1) = & - iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part1) = & - iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole2) = & - iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part2) = & - iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - enddo - enddo - if($do_double_excitations)then - call $subroutine_diexc(psi_det_generators(1,1,i_generator), & - mask(1,1,d_hole1), mask(1,1,d_part1), & - mask(1,1,d_hole2), mask(1,1,d_part2), & - i_generator, iproc $params_post) - endif - if($do_mono_excitations)then - call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & - mask(1,1,s_hole ), mask(1,1,s_part ), & - i_generator, iproc $params_post) - endif - call wall_time(wall_1) - $printout_always - if (wall_1 - wall_0 > 2.d0) then - $printout_now - wall_0 = wall_1 - endif - enddo - - deallocate( mask ) - - !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc) - call wall_time(wall_0) - !$ iproc = omp_get_thread_num() - allocate( mask(N_int,2,6) ) - !$OMP DO SCHEDULE(dynamic,1) - do i_generator=nmax+1,N_det_generators - if (iproc == 0) then - progress_bar(1) = i_generator - endif - if (abort_here) then - cycle - endif - $skip - - ! Create bit masks for holes and particles - do ispin=1,2 - do k=1,N_int - mask(k,ispin,s_hole) = & - iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,s_part) = & - iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole1) = & - iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part1) = & - iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & - not(psi_det_generators(k,ispin,i_generator)) ) - mask(k,ispin,d_hole2) = & - iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & - psi_det_generators(k,ispin,i_generator) ) - mask(k,ispin,d_part2) = & - iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & - not (psi_det_generators(k,ispin,i_generator)) ) - enddo - enddo - - if($do_double_excitations)then - call $subroutine_diexc(psi_det_generators(1,1,i_generator), & - mask(1,1,d_hole1), mask(1,1,d_part1), & - mask(1,1,d_hole2), mask(1,1,d_part2), & - i_generator, iproc $params_post) - endif - if($do_mono_excitations)then - call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & - mask(1,1,s_hole ), mask(1,1,s_part ), & - i_generator, iproc $params_post) - endif - !$ call omp_set_lock(lck) - call wall_time(wall_1) - $printout_always - if (wall_1 - wall_0 > 2.d0) then - $printout_now - wall_0 = wall_1 - endif - !$ call omp_unset_lock(lck) - enddo - !$OMP END DO - deallocate( mask ) - !$OMP END PARALLEL - !$ call omp_destroy_lock(lck) - - abort_here = abort_all - call stop_progress - - $copy_buffer - $generate_psi_guess - -end - diff --git a/src/Dets/Makefile b/src/Dets/Makefile deleted file mode 100644 index 092d879d..00000000 --- a/src/Dets/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -# Define here all new external source files and objects.Don't forget to prefix the -# object files with IRPF90_temp/ -SRC=H_apply_template.f -OBJ= - -include $(QPACKAGE_ROOT)/src/Makefile.common diff --git a/src/Dets/NEEDED_MODULES b/src/Dets/NEEDED_MODULES deleted file mode 100644 index 824c75ed..00000000 --- a/src/Dets/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Dets/README.rst b/src/Dets/README.rst deleted file mode 100644 index e9077510..00000000 --- a/src/Dets/README.rst +++ /dev/null @@ -1,696 +0,0 @@ -=========== -Dets Module -=========== - -This module contains the determinants of the CI wave function. - -H is applied on the list of generator determinants. Selected determinants -are added into the *H_apply buffer*. Then the new wave function is -constructred as the concatenation of the odl wave function and -some determinants of the H_apply buffer. Generator determinants are built -as a subset of the determinants of the wave function. - - -Assumptions -=========== - -.. Do not edit this section. It was auto-generated from the -.. NEEDED_MODULES file. - -* The MOs are orthonormal -* All the determinants have the same number of electrons -* The determinants are orthonormal -* The number of generator determinants <= the number of determinants -* All the determinants in the H_apply buffer are supposed to be different from the - wave function determinants -* All the determinants in the H_apply buffer are supposed to be unique - - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. NEEDED_MODULES file. - -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Electrons `_ -* `Ezfio_files `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. NEEDED_MODULES file. - -`copy_h_apply_buffer_to_wf `_ - Copies the H_apply buffer to psi_coef. You need to touch psi_det, psi_coef and N_det - after calling this function. - After calling this subroutine, N_det, psi_det and psi_coef need to be touched - -`fill_h_apply_buffer_no_selection `_ - Fill the H_apply buffer with determiants for CISD - -`h_apply_buffer_allocated `_ - Buffer of determinants/coefficients/perturbative energy for H_apply. - Uninitialized. Filled by H_apply subroutines. - -`h_apply_buffer_lock `_ - Buffer of determinants/coefficients/perturbative energy for H_apply. - Uninitialized. Filled by H_apply subroutines. - -`resize_h_apply_buffer `_ - Undocumented - -`cisd_sc2 `_ - CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - Initial guess vectors are not necessarily orthonormal - -`connected_to_ref `_ - Undocumented - -`connected_to_ref_by_mono `_ - Undocumented - -`det_search_key `_ - Return an integer*8 corresponding to a determinant index for searching - -`get_index_in_psi_det_sorted_bit `_ - Returns the index of the determinant in the ``psi_det_sorted_bit`` array - -`is_in_wavefunction `_ - True if the determinant ``det`` is in the wave function - -`occ_pattern_search_key `_ - Return an integer*8 corresponding to a determinant index for searching - -`do_mono_excitation `_ - Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin - on key_in - ispin = 1 == alpha - ispin = 2 == beta - i_ok = 1 == the excitation is possible - i_ok = -1 == the excitation is not possible - -`davidson_converged `_ - True if the Davidson algorithm is converged - -`davidson_criterion `_ - Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] - -`davidson_diag `_ - Davidson diagonalization. - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit number for the I/O - .br - Initial guess vectors are not necessarily orthonormal - -`davidson_diag_hjj `_ - Davidson diagonalization with specific diagonal elements of the H matrix - .br - H_jj : specific diagonal H matrix elements to diagonalize de Davidson - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit for the I/O - .br - Initial guess vectors are not necessarily orthonormal - -`davidson_iter_max `_ - Max number of Davidson iterations - -`davidson_sze_max `_ - Max number of Davidson sizes - -`davidson_threshold `_ - Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] - -`one_body_dm_mo `_ - One-body density matrix - -`one_body_dm_mo_alpha `_ - Alpha and beta one-body density matrix for each state - -`one_body_dm_mo_beta `_ - Alpha and beta one-body density matrix for each state - -`one_body_single_double_dm_mo_alpha `_ - Alpha and beta one-body density matrix for each state - -`one_body_single_double_dm_mo_beta `_ - Alpha and beta one-body density matrix for each state - -`one_body_spin_density_mo `_ - rho(alpha) - rho(beta) - -`save_natural_mos `_ - Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis - -`set_natural_mos `_ - Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis - -`state_average_weight `_ - Weights in the state-average calculation of the density matrix - -`det_svd `_ - Computes the SVD of the Alpha x Beta determinant coefficient matrix - -`filter_3_highest_electrons `_ - Returns a determinant with only the 3 highest electrons - -`int_of_3_highest_electrons `_ - Returns an integer*8 as : - .br - |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| - .br - |0<--- i1 ---><--- i2 ---><--- i3 --->| - .br - It encodes the value of the indices of the 3 highest MOs - in descending order - .br - -`max_degree_exc `_ - Maximum degree of excitation in the wf - -`n_det `_ - Number of determinants in the wave function - -`psi_average_norm_contrib `_ - Contribution of determinants to the state-averaged density - -`psi_average_norm_contrib_sorted `_ - Wave function sorted by determinants contribution to the norm (state-averaged) - -`psi_coef `_ - The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file - is empty - -`psi_coef_sorted `_ - Wave function sorted by determinants contribution to the norm (state-averaged) - -`psi_coef_sorted_ab `_ - Determinants on which we apply . - They are sorted by the 3 highest electrons in the alpha part, - then by the 3 highest electrons in the beta part to accelerate - the research of connected determinants. - -`psi_coef_sorted_bit `_ - Determinants on which we apply for perturbation. - They are sorted by determinants interpreted as integers. Useful - to accelerate the search of a random determinant in the wave - function. - -`psi_det `_ - The wave function determinants. Initialized with Hartree-Fock if the EZFIO file - is empty - -`psi_det_size `_ - Size of the psi_det/psi_coef arrays - -`psi_det_sorted `_ - Wave function sorted by determinants contribution to the norm (state-averaged) - -`psi_det_sorted_ab `_ - Determinants on which we apply . - They are sorted by the 3 highest electrons in the alpha part, - then by the 3 highest electrons in the beta part to accelerate - the research of connected determinants. - -`psi_det_sorted_bit `_ - Determinants on which we apply for perturbation. - They are sorted by determinants interpreted as integers. Useful - to accelerate the search of a random determinant in the wave - function. - -`psi_det_sorted_next_ab `_ - Determinants on which we apply . - They are sorted by the 3 highest electrons in the alpha part, - then by the 3 highest electrons in the beta part to accelerate - the research of connected determinants. - -`read_dets `_ - Reads the determinants from the EZFIO file - -`save_wavefunction `_ - Save the wave function into the EZFIO file - -`save_wavefunction_general `_ - Save the wave function into the EZFIO file - -`save_wavefunction_unsorted `_ - Save the wave function into the EZFIO file - -`sort_dets_by_3_highest_electrons `_ - Determinants on which we apply . - They are sorted by the 3 highest electrons in the alpha part, - then by the 3 highest electrons in the beta part to accelerate - the research of connected determinants. - -`sort_dets_by_det_search_key `_ - Determinants are sorted are sorted according to their det_search_key. - Useful to accelerate the search of a random determinant in the wave - function. - -`double_exc_bitmask `_ - double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 - double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 - double_exc_bitmask(:,3,i) is the bitmask for holes of excitation 2 - double_exc_bitmask(:,4,i) is the bitmask for particles of excitation 2 - for a given couple of hole/particle excitations i. - -`n_double_exc_bitmasks `_ - Number of double excitation bitmasks - -`n_single_exc_bitmasks `_ - Number of single excitation bitmasks - -`single_exc_bitmask `_ - single_exc_bitmask(:,1,i) is the bitmask for holes - single_exc_bitmask(:,2,i) is the bitmask for particles - for a given couple of hole/particle excitations i. - -`ci_eigenvectors `_ - Eigenvectors/values of the CI matrix - -`ci_eigenvectors_s2 `_ - Eigenvectors/values of the CI matrix - -`ci_electronic_energy `_ - Eigenvectors/values of the CI matrix - -`ci_energy `_ - N_states lowest eigenvalues of the CI matrix - -`diag_algorithm `_ - Diagonalization algorithm (Davidson or Lapack) - -`diagonalize_ci `_ - Replace the coefficients of the CI states by the coefficients of the - eigenstates of the CI matrix - -`ci_sc2_eigenvectors `_ - Eigenvectors/values of the CI matrix - -`ci_sc2_electronic_energy `_ - Eigenvectors/values of the CI matrix - -`ci_sc2_energy `_ - N_states_diag lowest eigenvalues of the CI matrix - -`diagonalize_ci_sc2 `_ - Replace the coefficients of the CI states_diag by the coefficients of the - eigenstates of the CI matrix - -`threshold_convergence_sc2 `_ - convergence of the correlation energy of SC2 iterations - -`ci_eigenvectors_mono `_ - Eigenvectors/values of the CI matrix - -`ci_eigenvectors_s2_mono `_ - Eigenvectors/values of the CI matrix - -`ci_electronic_energy_mono `_ - Eigenvectors/values of the CI matrix - -`diagonalize_ci_mono `_ - Replace the coefficients of the CI states by the coefficients of the - eigenstates of the CI matrix - -`apply_mono `_ - Undocumented - -`filter_connected `_ - Filters out the determinants that are not connected by H - .br - returns the array idx which contains the index of the - .br - determinants in the array key1 that interact - .br - via the H operator with key2. - .br - idx(0) is the number of determinants that interact with key1 - -`filter_connected_davidson `_ - Filters out the determinants that are not connected by H - returns the array idx which contains the index of the - determinants in the array key1 that interact - via the H operator with key2. - .br - idx(0) is the number of determinants that interact with key1 - key1 should come from psi_det_sorted_ab. - -`filter_connected_i_h_psi0 `_ - returns the array idx which contains the index of the - .br - determinants in the array key1 that interact - .br - via the H operator with key2. - .br - idx(0) is the number of determinants that interact with key1 - -`filter_connected_i_h_psi0_sc2 `_ - standard filter_connected_i_H_psi but returns in addition - .br - the array of the index of the non connected determinants to key1 - .br - in order to know what double excitation can be repeated on key1 - .br - idx_repeat(0) is the number of determinants that can be used - .br - to repeat the excitations - -`filter_connected_sorted_ab `_ - Filters out the determinants that are not connected by H - returns the array idx which contains the index of the - determinants in the array key1 that interact - via the H operator with key2. - idx(0) is the number of determinants that interact with key1 - .br - Determinants are taken from the psi_det_sorted_ab array - -`put_gess `_ - Undocumented - -`det_to_occ_pattern `_ - Transform a determinant to an occupation pattern - -`make_s2_eigenfunction `_ - Undocumented - -`n_occ_pattern `_ - array of the occ_pattern present in the wf - psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation - psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation - -`occ_pattern_to_dets `_ - Generate all possible determinants for a give occ_pattern - -`occ_pattern_to_dets_size `_ - Number of possible determinants for a given occ_pattern - -`psi_occ_pattern `_ - array of the occ_pattern present in the wf - psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation - psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation - -`rec_occ_pattern_to_dets `_ - Undocumented - -`n_states_diag `_ - Number of states to consider for the diagonalization - -`pouet `_ - Undocumented - -`routine `_ - Undocumented - -`idx_cas `_ - CAS wave function, defined from the application of the CAS bitmask on the - determinants. idx_cas gives the indice of the CAS determinant in psi_det. - -`idx_non_cas `_ - Set of determinants which are not part of the CAS, defined from the application - of the CAS bitmask on the determinants. - idx_non_cas gives the indice of the determinant in psi_det. - -`n_det_cas `_ - CAS wave function, defined from the application of the CAS bitmask on the - determinants. idx_cas gives the indice of the CAS determinant in psi_det. - -`n_det_non_cas `_ - Set of determinants which are not part of the CAS, defined from the application - of the CAS bitmask on the determinants. - idx_non_cas gives the indice of the determinant in psi_det. - -`psi_cas `_ - CAS wave function, defined from the application of the CAS bitmask on the - determinants. idx_cas gives the indice of the CAS determinant in psi_det. - -`psi_cas_coef `_ - CAS wave function, defined from the application of the CAS bitmask on the - determinants. idx_cas gives the indice of the CAS determinant in psi_det. - -`psi_cas_coef_sorted_bit `_ - CAS determinants sorted to accelerate the search of a random determinant in the wave - function. - -`psi_cas_sorted_bit `_ - CAS determinants sorted to accelerate the search of a random determinant in the wave - function. - -`psi_non_cas `_ - Set of determinants which are not part of the CAS, defined from the application - of the CAS bitmask on the determinants. - idx_non_cas gives the indice of the determinant in psi_det. - -`psi_non_cas_coef `_ - Set of determinants which are not part of the CAS, defined from the application - of the CAS bitmask on the determinants. - idx_non_cas gives the indice of the determinant in psi_det. - -`psi_non_cas_coef_sorted_bit `_ - CAS determinants sorted to accelerate the search of a random determinant in the wave - function. - -`psi_non_cas_sorted_bit `_ - CAS determinants sorted to accelerate the search of a random determinant in the wave - function. - -`bi_elec_ref_bitmask_energy `_ - Energy of the reference bitmask used in Slater rules - -`kinetic_ref_bitmask_energy `_ - Energy of the reference bitmask used in Slater rules - -`mono_elec_ref_bitmask_energy `_ - Energy of the reference bitmask used in Slater rules - -`nucl_elec_ref_bitmask_energy `_ - Energy of the reference bitmask used in Slater rules - -`ref_bitmask_energy `_ - Energy of the reference bitmask used in Slater rules - -`expected_s2 `_ - Expected value of S2 : S*(S+1) - -`get_s2 `_ - Returns - -`get_s2_u0 `_ - Undocumented - -`s2_values `_ - array of the averaged values of the S^2 operator on the various states - -`s_z `_ - z component of the Spin - -`s_z2_sz `_ - z component of the Spin - -`prog_save_casino `_ - Undocumented - -`save_casino `_ - Undocumented - -`save_dets_qmcchem `_ - Undocumented - -`save_for_qmc `_ - Undocumented - -`save_natorb `_ - Undocumented - -`a_operator `_ - Needed for diag_H_mat_elem - -`ac_operator `_ - Needed for diag_H_mat_elem - -`decode_exc `_ - Decodes the exc arrays returned by get_excitation. - h1,h2 : Holes - p1,p2 : Particles - s1,s2 : Spins (1:alpha, 2:beta) - degree : Degree of excitation - -`det_connections `_ - Build connection proxy between determinants - -`diag_h_mat_elem `_ - Computes - -`get_double_excitation `_ - Returns the two excitation operators between two doubly excited determinants and the phase - -`get_excitation `_ - Returns the excitation operators between two determinants and the phase - -`get_excitation_degree `_ - Returns the excitation degree between two determinants - -`get_excitation_degree_vector `_ - Applies get_excitation_degree to an array of determinants - -`get_mono_excitation `_ - Returns the excitation operator between two singly excited determinants and the phase - -`get_occ_from_key `_ - Returns a list of occupation numbers from a bitstring - -`h_u_0 `_ - Computes v_0 = H|u_0> - .br - n : number of determinants - .br - H_jj : array of - -`i_h_j `_ - Returns where i and j are determinants - -`i_h_j_verbose `_ - Returns where i and j are determinants - -`i_h_psi `_ - for the various Nstates - -`i_h_psi_sc2 `_ - for the various Nstate - .br - returns in addition - .br - the array of the index of the non connected determinants to key1 - .br - in order to know what double excitation can be repeated on key1 - .br - idx_repeat(0) is the number of determinants that can be used - .br - to repeat the excitations - -`i_h_psi_sc2_verbose `_ - for the various Nstate - .br - returns in addition - .br - the array of the index of the non connected determinants to key1 - .br - in order to know what double excitation can be repeated on key1 - .br - idx_repeat(0) is the number of determinants that can be used - .br - to repeat the excitations - -`i_h_psi_sec_ord `_ - for the various Nstates - -`n_con_int `_ - Number of integers to represent the connections between determinants - -`create_wf_of_psi_svd_matrix `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`generate_all_alpha_beta_det_products `_ - Create a wave function from all possible alpha x beta determinants - -`get_index_in_psi_det_alpha_unique `_ - Returns the index of the determinant in the ``psi_det_alpha_unique`` array - -`get_index_in_psi_det_beta_unique `_ - Returns the index of the determinant in the ``psi_det_beta_unique`` array - -`n_det_alpha_unique `_ - Unique alpha determinants - -`n_det_beta_unique `_ - Unique beta determinants - -`psi_det_alpha `_ - List of alpha determinants of psi_det - -`psi_det_alpha_unique `_ - Unique alpha determinants - -`psi_det_beta `_ - List of beta determinants of psi_det - -`psi_det_beta_unique `_ - Unique beta determinants - -`psi_svd_alpha `_ - SVD wave function - -`psi_svd_beta `_ - SVD wave function - -`psi_svd_coefs `_ - SVD wave function - -`psi_svd_matrix `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`psi_svd_matrix_columns `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`psi_svd_matrix_rows `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`psi_svd_matrix_values `_ - Matrix of wf coefficients. Outer product of alpha and beta determinants - -`spin_det_search_key `_ - Return an integer*8 corresponding to a determinant index for searching - -`write_spindeterminants `_ - Undocumented - -`cisd `_ - Undocumented - -`h_matrix_all_dets `_ - H matrix on the basis of the slater determinants defined by psi_det - - - diff --git a/src/Dets/SC2.irp.f b/src/Dets/SC2.irp.f deleted file mode 100644 index 8a6c10d7..00000000 --- a/src/Dets/SC2.irp.f +++ /dev/null @@ -1,215 +0,0 @@ -subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence) - use bitmasks - implicit none - BEGIN_DOC - ! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) - double precision, intent(in) :: convergence - ASSERT (N_st > 0) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - integer :: iter - integer :: i,j,k,l,m - logical :: converged - double precision :: overlap(N_st,N_st) - double precision :: u_dot_v, u_dot_u - - integer :: degree,N_double,index_hf - double precision :: hij_elec, e_corr_double,e_corr,diag_h_mat_elem,inv_c0 - double precision :: e_corr_double_before,accu,cpu_2,cpu_1 - integer,allocatable :: degree_exc(:), index_double(:) - integer :: i_ok - double precision,allocatable :: e_corr_array(:),H_jj_ref(:),H_jj_dressed(:),hij_double(:) - integer(bit_kind), allocatable :: doubles(:,:,:) - - - allocate (doubles(Nint,2,sze),e_corr_array(sze),H_jj_ref(sze),H_jj_dressed(sze),& - index_double(sze), degree_exc(sze), hij_double(sze)) - call write_time(output_Dets) - write(output_Dets,'(A)') '' - write(output_Dets,'(A)') 'CISD SC2' - write(output_Dets,'(A)') '========' - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(sze,N_st, & - !$OMP H_jj_ref,Nint,dets_in,u_in) & - !$OMP PRIVATE(i) - - !$OMP DO SCHEDULE(guided) - do i=1,sze - H_jj_ref(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) - enddo - !$OMP END DO NOWAIT - !$OMP END PARALLEL - - N_double = 0 - e_corr = 0.d0 - e_corr_double = 0.d0 - do i = 1, sze - call get_excitation_degree(ref_bitmask,dets_in(1,1,i),degree,Nint) - degree_exc(i) = degree+1 - if(degree==0)then - index_hf=i - else if (degree == 2)then - N_double += 1 - index_double(N_double) = i - doubles(:,:,N_double) = dets_in(:,:,i) - call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) - hij_double(N_double) = hij_elec - e_corr_array(N_double) = u_in(i,1)* hij_elec - e_corr_double += e_corr_array(N_double) - e_corr += e_corr_array(N_double) - else if (degree == 1)then - call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) - e_corr += u_in(i,1)* hij_elec - endif - enddo - inv_c0 = 1.d0/u_in(index_hf,1) - do i = 1, N_double - e_corr_array(i) = e_corr_array(i) * inv_c0 - enddo - e_corr = e_corr * inv_c0 - e_corr_double = e_corr_double * inv_c0 - converged = .False. - e_corr_double_before = e_corr_double - iter = 0 - do while (.not.converged) - if (abort_here) then - exit - endif - iter +=1 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,degree,accu) & - !$OMP SHARED(H_jj_dressed,sze,H_jj_ref,index_hf,N_int,N_double,& - !$OMP dets_in,doubles,degree_exc,e_corr_array,e_corr_double) - !$OMP DO SCHEDULE(STATIC) - do i=1,sze - H_jj_dressed(i) = H_jj_ref(i) - if (i==index_hf)cycle - accu = -e_corr_double - select case (N_int) - case (1) - do j=1,N_double - degree = & - popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & - popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) - - if (degree<=ishft(degree_exc(i),1)) then - accu += e_corr_array(j) - endif - enddo - case (2) - do j=1,N_double - degree = & - popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & - popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & - popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & - popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) - - if (degree<=ishft(degree_exc(i),1)) then - accu += e_corr_array(j) - endif - enddo - case (3) - do j=1,N_double - degree = & - popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & - popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & - popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & - popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) + & - popcnt(xor( dets_in(3,1,i),doubles(3,1,j))) + & - popcnt(xor( dets_in(3,2,i),doubles(3,2,j))) - - if (degree<=ishft(degree_exc(i),1)) then - accu += e_corr_array(j) - endif - enddo - case default - do j=1,N_double - call get_excitation_degree(dets_in(1,1,i),doubles(1,1,j),degree,N_int) - if (degree<=degree_exc(i)) then - accu += e_corr_array(j) - endif - enddo - end select - H_jj_dressed(i) -= accu - enddo - !$OMP END DO - !$OMP END PARALLEL - - if(sze<=N_det_max_jacobi)then - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) - allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) - do j=1,sze - do i=1,sze - H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) - enddo - enddo - do i = 1,sze - H_matrix_tmp(i,i) = H_jj_dressed(i) - enddo - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_tmp,size(H_matrix_all_dets,1),sze) - do j=1,min(N_states_diag,sze) - do i=1,sze - u_in(i,j) = eigenvectors(i,j) - enddo - energies(j) = eigenvalues(j) - enddo - deallocate (H_matrix_tmp, eigenvalues, eigenvectors) - else - call davidson_diag_hjj(dets_in,u_in,H_jj_dressed,energies,dim_in,sze,N_st,Nint,output_Dets) - endif - - e_corr_double = 0.d0 - inv_c0 = 1.d0/u_in(index_hf,1) - do i = 1, N_double - e_corr_array(i) = u_in(index_double(i),1)*inv_c0 * hij_double(i) - e_corr_double += e_corr_array(i) - enddo - write(output_Dets,'(A,I3)') 'SC2 Iteration ', iter - write(output_Dets,'(A)') '------------------' - write(output_Dets,'(A)') '' - write(output_Dets,'(A)') '===== ================' - write(output_Dets,'(A)') 'State Energy ' - write(output_Dets,'(A)') '===== ================' - do i=1,N_st - write(output_Dets,'(I5,X,F16.10)') i, energies(i)+nuclear_repulsion - enddo - write(output_Dets,'(A)') '===== ================' - write(output_Dets,'(A)') '' - call write_double(output_Dets,(e_corr_double - e_corr_double_before),& - 'Delta(E_corr)') - converged = dabs(e_corr_double - e_corr_double_before) < convergence - converged = converged .or. abort_here - if (converged) then - exit - endif - e_corr_double_before = e_corr_double - - enddo - - call write_time(output_Dets) - deallocate (doubles,e_corr_array,H_jj_ref,H_jj_dressed, & - index_double, degree_exc, hij_double) - -end - - diff --git a/src/Dets/connected_to_ref.irp.f b/src/Dets/connected_to_ref.irp.f deleted file mode 100644 index 2d40b621..00000000 --- a/src/Dets/connected_to_ref.irp.f +++ /dev/null @@ -1,357 +0,0 @@ -integer*8 function det_search_key(det,Nint) - use bitmasks - implicit none - BEGIN_DOC -! Return an integer*8 corresponding to a determinant index for searching - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det(Nint,2) - integer :: i - det_search_key = iand(det(1,1),det(1,2)) - do i=2,Nint - det_search_key = ieor(det_search_key,iand(det(i,1),det(i,2))) - enddo -end - - -integer*8 function occ_pattern_search_key(det,Nint) - use bitmasks - implicit none - BEGIN_DOC -! Return an integer*8 corresponding to a determinant index for searching - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det(Nint,2) - integer :: i - occ_pattern_search_key = ieor(det(1,1),det(1,2)) - do i=2,Nint - occ_pattern_search_key = ieor(occ_pattern_search_key,iand(det(i,1),det(i,2))) - enddo -end - - - -logical function is_in_wavefunction(key,Nint,Ndet) - use bitmasks - implicit none - BEGIN_DOC -! True if the determinant ``det`` is in the wave function - END_DOC - integer, intent(in) :: Nint, Ndet - integer(bit_kind), intent(in) :: key(Nint,2) - integer, external :: get_index_in_psi_det_sorted_bit - - !DIR$ FORCEINLINE - is_in_wavefunction = get_index_in_psi_det_sorted_bit(key,Nint) > 0 -end - -integer function get_index_in_psi_det_sorted_bit(key,Nint) - use bitmasks - BEGIN_DOC -! Returns the index of the determinant in the ``psi_det_sorted_bit`` array - END_DOC - implicit none - - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key(Nint,2) - - integer :: i, ibegin, iend, istep, l - integer*8 :: det_ref, det_search - integer*8, external :: det_search_key - logical :: is_in_wavefunction - - is_in_wavefunction = .False. - get_index_in_psi_det_sorted_bit = 0 - ibegin = 1 - iend = N_det+1 - - !DIR$ FORCEINLINE - det_ref = det_search_key(key,Nint) - !DIR$ FORCEINLINE - det_search = det_search_key(psi_det_sorted_bit(1,1,1),Nint) - - istep = ishft(iend-ibegin,-1) - i=ibegin+istep - do while (istep > 0) - !DIR$ FORCEINLINE - det_search = det_search_key(psi_det_sorted_bit(1,1,i),Nint) - if ( det_search > det_ref ) then - iend = i - else if ( det_search == det_ref ) then - exit - else - ibegin = i - endif - istep = ishft(iend-ibegin,-1) - i = ibegin + istep - end do - - !DIR$ FORCEINLINE - do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) - i = i-1 - if (i == 0) then - exit - endif - enddo - i += 1 - - if (i > N_det) then - return - endif - - !DIR$ FORCEINLINE - do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) - if ( (key(1,1) /= psi_det_sorted_bit(1,1,i)).or. & - (key(1,2) /= psi_det_sorted_bit(1,2,i)) ) then - continue - else - is_in_wavefunction = .True. - !DIR$ IVDEP - !DIR$ LOOP COUNT MIN(3) - do l=2,Nint - if ( (key(l,1) /= psi_det_sorted_bit(l,1,i)).or. & - (key(l,2) /= psi_det_sorted_bit(l,2,i)) ) then - is_in_wavefunction = .False. - endif - enddo - if (is_in_wavefunction) then - get_index_in_psi_det_sorted_bit = i -! exit - return - endif - endif - i += 1 - if (i > N_det) then -! exit - return - endif - - enddo - -! DEBUG is_in_wf -! if (is_in_wavefunction) then -! degree = 1 -! do i=1,N_det -! integer :: degree -! call get_excitation_degree(key,psi_det(1,1,i),degree,N_int) -! if (degree == 0) then -! exit -! endif -! enddo -! if (degree /=0) then -! stop 'pouet 1' -! endif -! else -! do i=1,N_det -! call get_excitation_degree(key,psi_det(1,1,i),degree,N_int) -! if (degree == 0) then -! stop 'pouet 2' -! endif -! enddo -! endif -! END DEBUG is_in_wf -end - -integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) - use bitmasks - implicit none - integer, intent(in) :: Nint, N_past_in, Ndet - integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) - integer(bit_kind), intent(in) :: key(Nint,2) - - integer :: N_past - integer :: i, l - integer :: degree_x2 - logical :: t - double precision :: hij_elec - - ! output : 0 : not connected - ! i : connected to determinant i of the past - ! -i : is the ith determinant of the refernce wf keys - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - connected_to_ref = 0 - N_past = max(1,N_past_in) - if (Nint == 1) then - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) - if (degree_x2 > 4) then - cycle - else - connected_to_ref = i - return - endif - enddo - - return - - - else if (Nint==2) then - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) + & - popcnt(xor( key(2,1), keys(2,1,i))) + & - popcnt(xor( key(2,2), keys(2,2,i))) - if (degree_x2 > 4) then - cycle - else - connected_to_ref = i - return - endif - enddo - - return - - else if (Nint==3) then - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) + & - popcnt(xor( key(2,1), keys(2,1,i))) + & - popcnt(xor( key(2,2), keys(2,2,i))) + & - popcnt(xor( key(3,1), keys(3,1,i))) + & - popcnt(xor( key(3,2), keys(3,2,i))) - if (degree_x2 > 4) then - cycle - else - connected_to_ref = i - return - endif - enddo - - return - - else - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) - !DEC$ LOOP COUNT MIN(3) - do l=2,Nint - degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& - popcnt(xor( key(l,2), keys(l,2,i))) - enddo - if (degree_x2 > 4) then - cycle - else - connected_to_ref = i - return - endif - enddo - - endif - -end - - - -integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) - use bitmasks - implicit none - integer, intent(in) :: Nint, N_past_in, Ndet - integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) - integer(bit_kind), intent(in) :: key(Nint,2) - - integer :: N_past - integer :: i, l - integer :: degree_x2 - logical :: t - double precision :: hij_elec - - ! output : 0 : not connected - ! i : connected to determinant i of the past - ! -i : is the ith determinant of the refernce wf keys - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - connected_to_ref_by_mono = 0 - N_past = max(1,N_past_in) - if (Nint == 1) then - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) - if (degree_x2 > 3.and. degree_x2 <5) then - cycle - else if (degree_x2 == 4)then - cycle - else if(degree_x2 == 2)then - connected_to_ref_by_mono = i - return - endif - enddo - - return - - - else if (Nint==2) then - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) + & - popcnt(xor( key(2,1), keys(2,1,i))) + & - popcnt(xor( key(2,2), keys(2,2,i))) - if (degree_x2 > 3.and. degree_x2 <5) then - cycle - else if (degree_x2 == 4)then - cycle - else if(degree_x2 == 2)then - connected_to_ref_by_mono = i - return - endif - enddo - - return - - else if (Nint==3) then - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) + & - popcnt(xor( key(2,1), keys(2,1,i))) + & - popcnt(xor( key(2,2), keys(2,2,i))) + & - popcnt(xor( key(3,1), keys(3,1,i))) + & - popcnt(xor( key(3,2), keys(3,2,i))) - if (degree_x2 > 3.and. degree_x2 <5) then - cycle - else if (degree_x2 == 4)then - cycle - else if(degree_x2 == 2)then - connected_to_ref_by_mono = i - return - endif - enddo - - return - - else - - do i=N_past-1,1,-1 - degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & - popcnt(xor( key(1,2), keys(1,2,i))) - !DEC$ LOOP COUNT MIN(3) - do l=2,Nint - degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& - popcnt(xor( key(l,2), keys(l,2,i))) - enddo - if (degree_x2 > 3.and. degree_x2 <5) then - cycle - else if (degree_x2 == 4)then - cycle - else if(degree_x2 == 2)then - connected_to_ref_by_mono = i - return - endif - enddo - - endif - -end - - diff --git a/src/Dets/create_excitations.irp.f b/src/Dets/create_excitations.irp.f deleted file mode 100644 index a33525c7..00000000 --- a/src/Dets/create_excitations.irp.f +++ /dev/null @@ -1,36 +0,0 @@ -subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) - implicit none - BEGIN_DOC - ! Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin - ! on key_in - ! ispin = 1 == alpha - ! ispin = 2 == beta - ! i_ok = 1 == the excitation is possible - ! i_ok = -1 == the excitation is not possible - END_DOC - integer, intent(in) :: i_hole,i_particle,ispin - integer(bit_kind), intent(inout) :: key_in(N_int,2) - integer, intent(out) :: i_ok - integer :: k,j,i - use bitmasks - ASSERT (i_hole > 0 ) - ASSERT (i_particle <= mo_tot_num) - i_ok = 1 - ! hole - k = ishft(i_hole-1,-bit_kind_shift)+1 - j = i_hole-ishft(k-1,bit_kind_shift)-1 - key_in(k,ispin) = ibclr(key_in(k,ispin),j) - - ! particle - k = ishft(i_particle-1,-bit_kind_shift)+1 - j = i_particle-ishft(k-1,bit_kind_shift)-1 - key_in(k,ispin) = ibset(key_in(k,ispin),j) - integer :: n_elec_tmp - n_elec_tmp = 0 - do i = 1, N_int - n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) - enddo - if(n_elec_tmp .ne. elec_num)then - i_ok = -1 - endif -end diff --git a/src/Dets/davidson.irp.f b/src/Dets/davidson.irp.f deleted file mode 100644 index bdc979c4..00000000 --- a/src/Dets/davidson.irp.f +++ /dev/null @@ -1,418 +0,0 @@ -BEGIN_PROVIDER [ integer, davidson_iter_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson iterations - END_DOC - davidson_iter_max = 100 -END_PROVIDER - -BEGIN_PROVIDER [ integer, davidson_sze_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson sizes - END_DOC - ASSERT (davidson_sze_max <= davidson_iter_max) - davidson_sze_max = 8*N_states_diag -END_PROVIDER - -subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit) - use bitmasks - implicit none - BEGIN_DOC - ! Davidson diagonalization. - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! iunit : Unit number for the I/O - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint, iunit - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) - double precision, allocatable :: H_jj(:) - - double precision :: diag_h_mat_elem - integer :: i - ASSERT (N_st > 0) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - PROVIDE mo_bielec_integrals_in_map - allocate(H_jj(sze)) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(sze,H_jj,dets_in,Nint) & - !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) - do i=1,sze - H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) - enddo - !$OMP END DO - !$OMP END PARALLEL - - call davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) - deallocate (H_jj) -end - -subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) - use bitmasks - implicit none - BEGIN_DOC - ! Davidson diagonalization with specific diagonal elements of the H matrix - ! - ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! iunit : Unit for the I/O - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, Nint - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(in) :: H_jj(sze) - integer, intent(in) :: iunit - double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: energies(N_st) - - integer :: iter - integer :: i,j,k,l,m - logical :: converged - - double precision :: overlap(N_st,N_st) - double precision :: u_dot_v, u_dot_u - - integer, allocatable :: kl_pairs(:,:) - integer :: k_pairs, kl - - integer :: iter2 - double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:) - double precision, allocatable :: y(:,:,:,:), h(:,:,:,:), lambda(:) - double precision :: diag_h_mat_elem - double precision :: residual_norm(N_st) - character*(16384) :: write_buffer - double precision :: to_print(2,N_st) - double precision :: cpu, wall - - PROVIDE det_connections - - call write_time(iunit) - call wall_time(wall) - call cpu_time(cpu) - write(iunit,'(A)') '' - write(iunit,'(A)') 'Davidson Diagonalization' - write(iunit,'(A)') '------------------------' - write(iunit,'(A)') '' - call write_int(iunit,N_st,'Number of states') - call write_int(iunit,sze,'Number of determinants') - write(iunit,'(A)') '' - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ ================' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = ' Iter' - do i=1,N_st - write_buffer = trim(write_buffer)//' Energy Residual' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ ================' - enddo - write(iunit,'(A)') trim(write_buffer) - - allocate( & - kl_pairs(2,N_st*(N_st+1)/2), & - W(sze,N_st,davidson_sze_max), & - U(sze,N_st,davidson_sze_max), & - R(sze,N_st), & - h(N_st,davidson_sze_max,N_st,davidson_sze_max), & - y(N_st,davidson_sze_max,N_st,davidson_sze_max), & - lambda(N_st*davidson_sze_max)) - - ASSERT (N_st > 0) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - ! Initialization - ! ============== - - k_pairs=0 - do l=1,N_st - do k=1,l - k_pairs+=1 - kl_pairs(1,k_pairs) = k - kl_pairs(2,k_pairs) = l - enddo - enddo - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & - !$OMP Nint,dets_in,u_in) & - !$OMP PRIVATE(k,l,kl,i) - - - ! Orthonormalize initial guess - ! ============================ - - !$OMP DO - do kl=1,k_pairs - k = kl_pairs(1,kl) - l = kl_pairs(2,kl) - if (k/=l) then - overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze) - overlap(l,k) = overlap(k,l) - else - overlap(k,k) = u_dot_u(U_in(1,k),sze) - endif - enddo - !$OMP END DO - !$OMP END PARALLEL - - call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) - - ! Davidson iterations - ! =================== - - converged = .False. - - do while (.not.converged) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(k,i) SHARED(U,u_in,sze,N_st) - do k=1,N_st - !$OMP DO - do i=1,sze - U(i,k,1) = u_in(i,k) - enddo - !$OMP END DO - enddo - !$OMP END PARALLEL - - do iter=1,davidson_sze_max-1 - - ! Compute W_k = H |u_k> - ! ---------------------- - - do k=1,N_st - call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) - enddo - - ! Compute h_kl = = - ! ------------------------------------------- - - do l=1,N_st - do k=1,N_st - do iter2=1,iter-1 - h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) - h(k,iter,l,iter2) = h(k,iter2,l,iter) - enddo - enddo - do k=1,l - h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) - h(l,iter,k,iter) = h(k,iter,l,iter) - enddo - enddo - - !DEBUG H MATRIX - !do i=1,iter - ! print '(10(x,F16.10))', h(1,i,1,1:i) - !enddo - !print *, '' - !END - - ! Diagonalize h - ! ------------- - call lapack_diag(lambda,y,h,N_st*davidson_sze_max,N_st*iter) - - ! Express eigenvectors of h in the determinant basis - ! -------------------------------------------------- - - do k=1,N_st - do i=1,sze - U(i,k,iter+1) = 0.d0 - W(i,k,iter+1) = 0.d0 - do l=1,N_st - do iter2=1,iter - U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) - W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo - enddo - enddo - - ! Compute residual vector - ! ----------------------- - - do k=1,N_st - do i=1,sze - R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) - enddo - residual_norm(k) = u_dot_u(R(1,k),sze) - to_print(1,k) = lambda(k) + nuclear_repulsion - to_print(2,k) = residual_norm(k) - enddo - - write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))'), iter, to_print(:,1:N_st) - call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) - if (converged) then - exit - endif - - - ! Davidson step - ! ------------- - - do k=1,N_st - do i=1,sze - U(i,k,iter+1) = -1.d0/max(H_jj(i) - lambda(k),1.d-2) * R(i,k) - enddo - enddo - - ! Gram-Schmidt - ! ------------ - - double precision :: c - do k=1,N_st - do iter2=1,iter - do l=1,N_st - c = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter2) - enddo - enddo - enddo - do l=1,k-1 - c = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) - do i=1,sze - U(i,k,iter+1) -= c * U(i,l,iter+1) - enddo - enddo - call normalize( U(1,k,iter+1), sze ) - enddo - - !DEBUG : CHECK OVERLAP - !print *, '===' - !do k=1,iter+1 - ! do l=1,k - ! c = u_dot_v(U(1,1,k),U(1,1,l),sze) - ! print *, k,l, c - ! enddo - !enddo - !print *, '===' - !pause - !END DEBUG - - - enddo - - if (.not.converged) then - iter = davidson_sze_max-1 - endif - - ! Re-contract to u_in - ! ----------- - - do k=1,N_st - energies(k) = lambda(k) - do i=1,sze - u_in(i,k) = 0.d0 - do iter2=1,iter - do l=1,N_st - u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) - enddo - enddo - enddo - enddo - - enddo - - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ ================' - enddo - write(iunit,'(A)') trim(write_buffer) - write(iunit,'(A)') '' - call write_time(iunit) - - deallocate ( & - kl_pairs, & - W, & - U, & - R, & - h, & - y, & - lambda & - ) - abort_here = abort_all -end - - BEGIN_PROVIDER [ character(64), davidson_criterion ] -&BEGIN_PROVIDER [ double precision, davidson_threshold ] - implicit none - BEGIN_DOC - ! Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] - END_DOC - davidson_criterion = 'residual' - davidson_threshold = 1.d-6 -END_PROVIDER - -subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged) - implicit none - BEGIN_DOC -! True if the Davidson algorithm is converged - END_DOC - integer, intent(in) :: N_st, iterations - logical, intent(out) :: converged - double precision, intent(in) :: energy(N_st), residual(N_st) - double precision, intent(in) :: wall, cpu - double precision :: E(N_st), time - double precision, allocatable, save :: energy_old(:) - - if (.not.allocated(energy_old)) then - allocate(energy_old(N_st)) - energy_old = 0.d0 - endif - - E = energy - energy_old - energy_old = energy - if (davidson_criterion == 'energy') then - converged = dabs(maxval(E(1:N_st))) < davidson_threshold - else if (davidson_criterion == 'residual') then - converged = dabs(maxval(residual(1:N_st))) < davidson_threshold - else if (davidson_criterion == 'both') then - converged = dabs(maxval(residual(1:N_st))) + dabs(maxval(E(1:N_st)) ) & - < davidson_threshold - else if (davidson_criterion == 'wall_time') then - call wall_time(time) - converged = time - wall > davidson_threshold - else if (davidson_criterion == 'cpu_time') then - call cpu_time(time) - converged = time - cpu > davidson_threshold - else if (davidson_criterion == 'iterations') then - converged = iterations >= int(davidson_threshold) - endif - converged = converged.or.abort_here -end diff --git a/src/Dets/density_matrix.irp.f b/src/Dets/density_matrix.irp.f deleted file mode 100644 index f72b337c..00000000 --- a/src/Dets/density_matrix.irp.f +++ /dev/null @@ -1,214 +0,0 @@ - BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Alpha and beta one-body density matrix for each state - END_DOC - - integer :: j,k,l,m - integer :: occ(N_int*bit_kind_size,2) - double precision :: ck, cl, ckl - double precision :: phase - integer :: h1,h2,p1,p2,s1,s2, degree - integer :: exc(0:2,2,2),n_occ_alpha - double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) - - if(only_single_double_dm)then - print*,'ONLY DOUBLE DM' - one_body_dm_mo_alpha = one_body_single_double_dm_mo_alpha - one_body_dm_mo_beta = one_body_single_double_dm_mo_beta - else - one_body_dm_mo_alpha = 0.d0 - one_body_dm_mo_beta = 0.d0 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & - !$OMP tmp_a, tmp_b, n_occ_alpha)& - !$OMP SHARED(psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& - !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& - !$OMP mo_tot_num) - allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) - tmp_a = 0.d0 - tmp_b = 0.d0 - !$OMP DO SCHEDULE(dynamic) - do k=1,N_det - call bitstring_to_list(psi_det(1,1,k), occ(1,1), n_occ_alpha, N_int) - call bitstring_to_list(psi_det(1,2,k), occ(1,2), n_occ_alpha, N_int) - do m=1,N_states - ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) - do l=1,elec_alpha_num - j = occ(l,1) - tmp_a(j,j) += ck - enddo - do l=1,elec_beta_num - j = occ(l,2) - tmp_b(j,j) += ck - enddo - enddo - do l=1,k-1 - call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) - if (degree /= 1) then - cycle - endif - call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do m=1,N_states - ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) - if (s1==1) then - tmp_a(h1,p1) += ckl - tmp_a(p1,h1) += ckl - else - tmp_b(h1,p1) += ckl - tmp_b(p1,h1) += ckl - endif - enddo - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_dm_mo_alpha = one_body_dm_mo_alpha + tmp_a - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP BARRIER - !$OMP END PARALLEL - - endif -END_PROVIDER - - BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Alpha and beta one-body density matrix for each state - END_DOC - - integer :: j,k,l,m - integer :: occ(N_int*bit_kind_size,2) - double precision :: ck, cl, ckl - double precision :: phase - integer :: h1,h2,p1,p2,s1,s2, degree - integer :: exc(0:2,2,2),n_occ_alpha - double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) - integer :: degree_respect_to_HF_k - integer :: degree_respect_to_HF_l - - PROVIDE elec_alpha_num elec_beta_num - - one_body_single_double_dm_mo_alpha = 0.d0 - one_body_single_double_dm_mo_beta = 0.d0 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & - !$OMP tmp_a, tmp_b, n_occ_alpha,degree_respect_to_HF_k,degree_respect_to_HF_l)& - !$OMP SHARED(ref_bitmask,psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& - !$OMP elec_beta_num,one_body_single_double_dm_mo_alpha,one_body_single_double_dm_mo_beta,N_det,mo_tot_num_align,& - !$OMP mo_tot_num) - allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) - tmp_a = 0.d0 - tmp_b = 0.d0 - !$OMP DO SCHEDULE(dynamic) - do k=1,N_det - call bitstring_to_list(psi_det(1,1,k), occ(1,1), n_occ_alpha, N_int) - call bitstring_to_list(psi_det(1,2,k), occ(1,2), n_occ_alpha, N_int) - call get_excitation_degree(ref_bitmask,psi_det(1,1,k),degree_respect_to_HF_k,N_int) - - do m=1,N_states - ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) - call get_excitation_degree(ref_bitmask,psi_det(1,1,k),degree_respect_to_HF_l,N_int) - if(degree_respect_to_HF_l.le.0)then - do l=1,elec_alpha_num - j = occ(l,1) - tmp_a(j,j) += ck - enddo - do l=1,elec_beta_num - j = occ(l,2) - tmp_b(j,j) += ck - enddo - endif - enddo - do l=1,k-1 - call get_excitation_degree(ref_bitmask,psi_det(1,1,l),degree_respect_to_HF_l,N_int) - if(degree_respect_to_HF_k.ne.0)cycle - if(degree_respect_to_HF_l.eq.2.and.degree_respect_to_HF_k.ne.2)cycle - call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) - if (degree /= 1) then - cycle - endif - call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do m=1,N_states - ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) - if (s1==1) then - tmp_a(h1,p1) += ckl - tmp_a(p1,h1) += ckl - else - tmp_b(h1,p1) += ckl - tmp_b(p1,h1) += ckl - endif - enddo - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_single_double_dm_mo_alpha = one_body_single_double_dm_mo_alpha + tmp_a - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP BARRIER - !$OMP END PARALLEL -END_PROVIDER - -BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! One-body density matrix - END_DOC - one_body_dm_mo = one_body_dm_mo_alpha + one_body_dm_mo_beta -END_PROVIDER - -BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! rho(alpha) - rho(beta) - END_DOC - one_body_spin_density_mo = one_body_dm_mo_alpha - one_body_dm_mo_beta -END_PROVIDER - -subroutine set_natural_mos - implicit none - BEGIN_DOC - ! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis - END_DOC - character*(64) :: label - double precision, allocatable :: tmp(:,:) - allocate(tmp(size(one_body_dm_mo,1),size(one_body_dm_mo,2))) - - ! Negation to have the occupied MOs first after the diagonalization - tmp = -one_body_dm_mo - label = "Natural" - call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label) - deallocate(tmp) - -end -subroutine save_natural_mos - implicit none - BEGIN_DOC - ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis - END_DOC - call set_natural_mos - call save_mos - -end - - -BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ] - implicit none - BEGIN_DOC - ! Weights in the state-average calculation of the density matrix - END_DOC - state_average_weight = 1.d0/dble(N_states) -END_PROVIDER - diff --git a/src/Dets/det_svd.irp.f b/src/Dets/det_svd.irp.f deleted file mode 100644 index 0a57acf3..00000000 --- a/src/Dets/det_svd.irp.f +++ /dev/null @@ -1,61 +0,0 @@ -program det_svd - implicit none - BEGIN_DOC -! Computes the SVD of the Alpha x Beta determinant coefficient matrix - END_DOC - integer :: i,j,k - - read_wf = .True. - TOUCH read_wf - - print *, 'SVD matrix before filling' - print *, '=========================' - print *, '' - print *, 'N_det = ', N_det - print *, 'N_det_alpha = ', N_det_alpha_unique - print *, 'N_det_beta = ', N_det_beta_unique - print *, '' - -! do i=1,N_det_alpha_unique -! do j=1,N_det_beta_unique -! print *, i,j,psi_svd_matrix(i,j,:) -! enddo -! enddo - - print *, '' - print *, 'Energy = ', ci_energy - print *, '' - - print *, psi_svd_coefs(1:20,1) - - call generate_all_alpha_beta_det_products - print *, '' - print *, 'Energy = ', ci_energy - print *, '' - - print *, 'SVD matrix after filling' - print *, '========================' - print *, '' - print *, 'N_det = ', N_det - print *, 'N_det_alpha = ', N_det_alpha_unique - print *, 'N_det_beta = ', N_det_beta_unique - print *, '' - print *, '' - call diagonalize_ci - print *, 'Energy = ', ci_energy - - do i=1,N_det_alpha_unique - do j=1,N_det_beta_unique - do k=1,N_states - if (dabs(psi_svd_matrix(i,j,k)) < 1.d-15) then - psi_svd_matrix(i,j,k) = 0.d0 - endif - enddo - enddo - enddo - - print *, '' - print *, psi_svd_coefs(1:20,1) - call save_wavefunction - -end diff --git a/src/Dets/determinants.ezfio_config b/src/Dets/determinants.ezfio_config deleted file mode 100644 index 0937502a..00000000 --- a/src/Dets/determinants.ezfio_config +++ /dev/null @@ -1,20 +0,0 @@ -determinants - n_int integer - bit_kind integer - mo_label character*(64) - n_det integer - n_states integer - n_states_diag integer - psi_coef double precision (determinants_n_det,determinants_n_states) - psi_det integer*8 (determinants_n_int*determinants_bit_kind/8,2,determinants_n_det) - n_det_max_jacobi integer - threshold_generators double precision - threshold_selectors double precision - det_num integer - det_occ integer (electrons_elec_alpha_num,determinants_det_num,2) - det_coef double precision (determinants_det_num) - read_wf logical - expected_s2 double precision - s2_eig logical - only_single_double_dm logical - diff --git a/src/Dets/determinants_bitmasks.irp.f b/src/Dets/determinants_bitmasks.irp.f deleted file mode 100644 index 8343fa84..00000000 --- a/src/Dets/determinants_bitmasks.irp.f +++ /dev/null @@ -1,57 +0,0 @@ -use bitmasks - -integer, parameter :: hole_ = 1 -integer, parameter :: particle_ = 2 -integer, parameter :: hole2_ = 3 -integer, parameter :: particle2_= 4 - -BEGIN_PROVIDER [ integer, N_single_exc_bitmasks ] - implicit none - BEGIN_DOC - ! Number of single excitation bitmasks - END_DOC - N_single_exc_bitmasks = 1 - !TODO : Read from input! -END_PROVIDER - -BEGIN_PROVIDER [ integer(bit_kind), single_exc_bitmask, (N_int, 2, N_single_exc_bitmasks) ] - implicit none - BEGIN_DOC - ! single_exc_bitmask(:,1,i) is the bitmask for holes - ! single_exc_bitmask(:,2,i) is the bitmask for particles - ! for a given couple of hole/particle excitations i. - END_DOC - - single_exc_bitmask(:,hole_,1) = HF_bitmask(:,1) - single_exc_bitmask(:,particle_,1) = not(HF_bitmask(:,2)) - !TODO : Read from input! -END_PROVIDER - - -BEGIN_PROVIDER [ integer, N_double_exc_bitmasks ] - implicit none - BEGIN_DOC - ! Number of double excitation bitmasks - END_DOC - N_double_exc_bitmasks = 1 - !TODO : Read from input! -END_PROVIDER - -BEGIN_PROVIDER [ integer(bit_kind), double_exc_bitmask, (N_int, 4, N_double_exc_bitmasks) ] - implicit none - BEGIN_DOC - ! double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 - ! double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 - ! double_exc_bitmask(:,3,i) is the bitmask for holes of excitation 2 - ! double_exc_bitmask(:,4,i) is the bitmask for particles of excitation 2 - ! for a given couple of hole/particle excitations i. - END_DOC - - double_exc_bitmask(:,hole_,1) = HF_bitmask(:,1) - double_exc_bitmask(:,particle_,1) = not(HF_bitmask(:,2)) - double_exc_bitmask(:,hole2_,1) = HF_bitmask(:,1) - double_exc_bitmask(:,particle2_,1) = not(HF_bitmask(:,2)) - - !TODO : Read from input! -END_PROVIDER - diff --git a/src/Dets/diagonalize_CI.irp.f b/src/Dets/diagonalize_CI.irp.f deleted file mode 100644 index 55612920..00000000 --- a/src/Dets/diagonalize_CI.irp.f +++ /dev/null @@ -1,109 +0,0 @@ -BEGIN_PROVIDER [ character*(64), diag_algorithm ] - implicit none - BEGIN_DOC - ! Diagonalization algorithm (Davidson or Lapack) - END_DOC - if (N_det > N_det_max_jacobi) then - diag_algorithm = "Davidson" - else - diag_algorithm = "Lapack" - endif - - if (N_det < N_states_diag) then - diag_algorithm = "Lapack" - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] - implicit none - BEGIN_DOC - ! N_states lowest eigenvalues of the CI matrix - END_DOC - - integer :: j - character*(8) :: st - call write_time(output_Dets) - do j=1,N_states_diag - CI_energy(j) = CI_electronic_energy(j) + nuclear_repulsion - write(st,'(I4)') j - call write_double(output_Dets,CI_energy(j),'Energy of state '//trim(st)) - call write_double(output_Dets,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) - enddo - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_eigenvectors(i,j) = psi_coef(i,j) - enddo - enddo - - if (diag_algorithm == "Davidson") then - - call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & - size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_Dets) - - else if (diag_algorithm == "Lapack") then - - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy(:) = 0.d0 - do i=1,N_det - CI_eigenvectors(i,1) = eigenvectors(i,1) - enddo - integer :: i_state - double precision :: s2 - i_state = 0 - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - if(dabs(s2-expected_s2).le.0.3d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy(i_state) = eigenvalues(j) - CI_eigenvectors_s2(i_state) = s2 - endif - if (i_state.ge.N_states_diag) then - exit - endif - enddo -! if(i_state < min(N_states_diag,N_det))then -! print *, 'pb with the number of states' -! print *, 'i_state = ',i_state -! print *, 'N_states_diag ',N_states_diag -! print *,'stopping ...' -! stop -! endif - deallocate(eigenvectors,eigenvalues) - endif - -END_PROVIDER - -subroutine diagonalize_CI - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_eigenvectors_s2 -end diff --git a/src/Dets/diagonalize_CI_SC2.irp.f b/src/Dets/diagonalize_CI_SC2.irp.f deleted file mode 100644 index 86ba72b9..00000000 --- a/src/Dets/diagonalize_CI_SC2.irp.f +++ /dev/null @@ -1,59 +0,0 @@ -BEGIN_PROVIDER [ double precision, CI_SC2_energy, (N_states_diag) ] - implicit none - BEGIN_DOC - ! N_states_diag lowest eigenvalues of the CI matrix - END_DOC - - integer :: j - character*(8) :: st - call write_time(output_Dets) - do j=1,N_states_diag - CI_SC2_energy(j) = CI_SC2_electronic_energy(j) + nuclear_repulsion - write(st,'(I4)') j - call write_double(output_Dets,CI_SC2_energy(j),'Energy of state '//trim(st)) - enddo - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, threshold_convergence_SC2] - implicit none - BEGIN_DOC - ! convergence of the correlation energy of SC2 iterations - END_DOC - threshold_convergence_SC2 = 1.d-10 - - END_PROVIDER - BEGIN_PROVIDER [ double precision, CI_SC2_electronic_energy, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_SC2_eigenvectors, (N_det,N_states_diag) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_SC2_eigenvectors(i,j) = psi_coef(i,j) - enddo -! TODO : check comment -! CI_SC2_electronic_energy(j) = CI_electronic_energy(j) - enddo - - call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, & - size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) -END_PROVIDER - -subroutine diagonalize_CI_SC2 - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states_diag by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_SC2_eigenvectors(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors -end diff --git a/src/Dets/diagonalize_CI_mono.irp.f b/src/Dets/diagonalize_CI_mono.irp.f deleted file mode 100644 index a3c5b103..00000000 --- a/src/Dets/diagonalize_CI_mono.irp.f +++ /dev/null @@ -1,72 +0,0 @@ - BEGIN_PROVIDER [ double precision, CI_electronic_energy_mono, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_mono, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_mono, (N_states_diag) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_eigenvectors_mono(i,j) = psi_coef(i,j) - enddo - enddo - - if (diag_algorithm == "Davidson") then - - call davidson_diag(psi_det,CI_eigenvectors_mono,CI_electronic_energy, & - size(CI_eigenvectors_mono,1),N_det,N_states_diag,N_int,output_Dets) - - else if (diag_algorithm == "Lapack") then - - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy_mono(:) = 0.d0 - do i=1,N_det - CI_eigenvectors_mono(i,1) = eigenvectors(i,1) - enddo - integer :: i_state - double precision :: s2 - i_state = 0 - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) - if(dabs(s2-expected_s2).le.0.3d0)then - print*,'j = ',j - print*,'e = ',eigenvalues(j) - print*,'c = ',dabs(eigenvectors(1,j)) - if(dabs(eigenvectors(1,j)).gt.0.9d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_mono(i_state) = eigenvalues(j) - CI_eigenvectors_s2_mono(i_state) = s2 - endif - endif - if (i_state.ge.N_states_diag) then - exit - endif - enddo - deallocate(eigenvectors,eigenvalues) - endif - -END_PROVIDER - -subroutine diagonalize_CI_mono - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_mono(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_electronic_energy_mono CI_eigenvectors_mono CI_eigenvectors_s2_mono -end diff --git a/src/Dets/excitations_utils.irp.f b/src/Dets/excitations_utils.irp.f deleted file mode 100644 index 46e38b08..00000000 --- a/src/Dets/excitations_utils.irp.f +++ /dev/null @@ -1,16 +0,0 @@ -subroutine apply_mono(i_hole,i_particle,ispin_excit,key_in,Nint) - implicit none - integer, intent(in) :: i_hole,i_particle,ispin_excit,Nint - integer(bit_kind), intent(inout) :: key_in(Nint,2) - integer :: k,j - use bitmasks - ! hole - k = ishft(i_hole-1,-bit_kind_shift)+1 - j = i_hole-ishft(k-1,bit_kind_shift)-1 - key_in(k,ispin_excit) = ibclr(key_in(k,ispin_excit),j) - - k = ishft(i_particle-1,-bit_kind_shift)+1 - j = i_particle-ishft(k-1,bit_kind_shift)-1 - key_in(k,ispin_excit) = ibset(key_in(k,ispin_excit),j) - -end diff --git a/src/Dets/filter_connected.irp.f b/src/Dets/filter_connected.irp.f deleted file mode 100644 index 93a6ee7b..00000000 --- a/src/Dets/filter_connected.irp.f +++ /dev/null @@ -1,611 +0,0 @@ - -subroutine filter_connected(key1,key2,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! - ! returns the array idx which contains the index of the - ! - ! determinants in the array key1 that interact - ! - ! via the H operator with key2. - ! - ! idx(0) is the number of determinants that interact with key1 - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer :: i,j,l - integer :: degree_x2 - - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - - if (Nint==1) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) & - + popcnt( xor( key1(1,2,i), key2(1,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = i - l = l+1 - endif - enddo - - else if (Nint==2) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = i - l = l+1 - endif - enddo - - else if (Nint==3) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = i - l = l+1 - endif - enddo - - else - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = 0 - !DEC$ LOOP COUNT MIN(4) - do j=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +& - popcnt(xor( key1(j,2,i), key2(j,2))) - if (degree_x2 > 4) then - exit - endif - enddo - if (degree_x2 <= 5) then - idx(l) = i - l = l+1 - endif - enddo - - endif - idx(0) = l-1 -end - - -subroutine filter_connected_sorted_ab(key1,key2,next,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! returns the array idx which contains the index of the - ! determinants in the array key1 that interact - ! via the H operator with key2. - ! idx(0) is the number of determinants that interact with key1 - ! - ! Determinants are taken from the psi_det_sorted_ab array - END_DOC - integer, intent(in) :: Nint, sze - integer, intent(in) :: next(2,N_det) - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer :: i,j,l - integer :: degree_x2 - integer(bit_kind) :: det3_1(Nint,2), det3_2(Nint,2) - - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - - call filter_3_highest_electrons( key2(1,1), det3_2(1,1), Nint) - if (Nint==1) then - - i = 1 - do while ( i<= sze ) - call filter_3_highest_electrons( key1(1,1,i), det3_1(1,1), Nint) - degree_x2 = popcnt( xor( det3_1(1,1), det3_2(1,1))) - if (degree_x2 > 4) then - i = next(1,i) - cycle - else - degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1)) ) - if (degree_x2 <= 4) then - degree_x2 += popcnt( xor( key1(1,2,i), key2(1,2)) ) - if (degree_x2 <= 4) then - idx(l) = i - l += 1 - endif - endif - i += 1 - endif - enddo - - else - - print *, 'Not implemented', irp_here - stop 1 - - endif - idx(0) = l-1 -end - - - - -subroutine filter_connected_davidson(key1,key2,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! returns the array idx which contains the index of the - ! determinants in the array key1 that interact - ! via the H operator with key2. - ! - ! idx(0) is the number of determinants that interact with key1 - ! key1 should come from psi_det_sorted_ab. - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer :: i,j,k,l - integer :: degree_x2 - integer :: j_int, j_start - integer*8 :: itmp - - PROVIDE N_con_int det_connections - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - - if (Nint==1) then - - i = idx(0) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & - popcnt(xor( key1(1,2,j), key2(1,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - else if (Nint==2) then - - - i = idx(0) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & - popcnt(xor( key1(2,1,j), key2(2,1))) + & - popcnt(xor( key1(1,2,j), key2(1,2))) + & - popcnt(xor( key1(2,2,j), key2(2,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - else if (Nint==3) then - - !DIR$ LOOP COUNT (1000) - i = idx(0) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & - popcnt(xor( key1(1,2,j), key2(1,2))) + & - popcnt(xor( key1(2,1,j), key2(2,1))) + & - popcnt(xor( key1(2,2,j), key2(2,2))) + & - popcnt(xor( key1(3,1,j), key2(3,1))) + & - popcnt(xor( key1(3,2,j), key2(3,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - else - - !DIR$ LOOP COUNT (1000) - i = idx(0) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = 0 - !DEC$ LOOP COUNT MIN(4) - do k=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(k,1,j), key2(k,1))) +& - popcnt(xor( key1(k,2,j), key2(k,2))) - if (degree_x2 > 4) then - exit - endif - enddo - if (degree_x2 <= 5) then - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - endif - idx(0) = l-1 -end - -subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) - use bitmasks - BEGIN_DOC - ! returns the array idx which contains the index of the - ! - ! determinants in the array key1 that interact - ! - ! via the H operator with key2. - ! - ! idx(0) is the number of determinants that interact with key1 - END_DOC - implicit none - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer :: i,l,m - integer :: degree_x2 - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sze > 0) - - l=1 - - if (Nint==1) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - enddo - - else if (Nint==2) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - enddo - - else if (Nint==3) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - enddo - - else - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = 0 - !DEC$ LOOP COUNT MIN(4) - do m=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& - popcnt(xor( key1(m,2,i), key2(m,2))) - if (degree_x2 > 4) then - exit - endif - enddo - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - enddo - - endif - idx(0) = l-1 -end - -subroutine filter_connected_i_H_psi0_SC2(key1,key2,Nint,sze,idx,idx_repeat) - use bitmasks - BEGIN_DOC - ! standard filter_connected_i_H_psi but returns in addition - ! - ! the array of the index of the non connected determinants to key1 - ! - ! in order to know what double excitation can be repeated on key1 - ! - ! idx_repeat(0) is the number of determinants that can be used - ! - ! to repeat the excitations - END_DOC - implicit none - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - integer, intent(out) :: idx_repeat(0:sze) - - integer :: i,l,l_repeat,m - integer :: degree_x2 - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sze > 0) - - integer :: degree - degree = popcnt(xor( ref_bitmask(1,1), key2(1,1))) + & - popcnt(xor( ref_bitmask(1,2), key2(1,2))) - !DEC$ NOUNROLL - do m=2,Nint - degree = degree+ popcnt(xor( ref_bitmask(m,1), key2(m,1))) + & - popcnt(xor( ref_bitmask(m,2), key2(m,2))) - enddo - degree = ishft(degree,-1) - - l_repeat=1 - l=1 - if(degree == 2)then - if (Nint==1) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) - if (degree_x2 < 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - elseif(degree_x2>6)then - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - else if (Nint==2) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - if (degree_x2 < 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - elseif(degree_x2>6)then - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - else if (Nint==3) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - if(degree_x2>6)then - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - else if (degree_x2 < 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - endif - enddo - - else - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = 0 - !DEC$ LOOP COUNT MIN(4) - do m=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& - popcnt(xor( key1(m,2,i), key2(m,2))) - if (degree_x2 > 4) then - exit - endif - enddo - if (degree_x2 <= 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - elseif(degree_x2>6)then - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - endif - elseif(degree==1)then - if (Nint==1) then - - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) - if (degree_x2 < 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - else - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - else if (Nint==2) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - if (degree_x2 < 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - else - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - else if (Nint==3) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - if (degree_x2 < 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - else - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - else - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree_x2 = 0 - !DEC$ LOOP COUNT MIN(4) - do m=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& - popcnt(xor( key1(m,2,i), key2(m,2))) - if (degree_x2 > 4) then - exit - endif - enddo - if (degree_x2 <= 5) then - if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - else - idx_repeat(l_repeat) = i - l_repeat = l_repeat + 1 - endif - enddo - - endif - - else -! print*,'more than a double excitation, can not apply the ' -! print*,'SC2 dressing of the diagonal element .....' -! print*,'stop !!' -! print*,'degree = ',degree -! stop - idx(0) = 0 - idx_repeat(0) = 0 - endif - idx(0) = l-1 - idx_repeat(0) = l_repeat-1 -end - diff --git a/src/Dets/guess_doublet.irp.f b/src/Dets/guess_doublet.irp.f deleted file mode 100644 index a44697c1..00000000 --- a/src/Dets/guess_doublet.irp.f +++ /dev/null @@ -1,79 +0,0 @@ -program put_gess - use bitmasks - implicit none - integer :: i,j,N_det_tmp,N_states_tmp - integer :: list(N_int*bit_kind_size,2) - integer(bit_kind) :: string(N_int,2) - integer(bit_kind) :: psi_det_tmp(N_int,2,3) - double precision :: psi_coef_tmp(3,1) - - integer :: iorb,jorb,korb - print*,'which open shells ?' - read(5,*)iorb,jorb,korb - print*,iorb,jorb,korb - N_states= 1 - N_det= 3 - - - list = 0 - list(1,1) = 1 - list(1,2) = 1 - list(2,1) = 2 - list(2,2) = 2 - list(3,1) = iorb - list(4,1) = jorb - list(3,2) = korb - print*,'passed' - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - print*,'passed' - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - print*,'passed' - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,1) = string(i,j) - enddo - enddo - psi_coef(1,1) = 1.d0/dsqrt(3.d0) - - print*,'passed 1' - list = 0 - list(1,1) = 1 - list(1,2) = 1 - list(2,1) = 2 - list(2,2) = 2 - list(3,1) = iorb - list(4,1) = korb - list(3,2) = jorb - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,2) = string(i,j) - enddo - enddo - psi_coef(2,1) = 1.d0/dsqrt(3.d0) - - print*,'passed 2' - list = 0 - list(1,1) = 1 - list(1,2) = 1 - list(2,1) = 2 - list(2,2) = 2 - list(3,1) = korb - list(4,1) = jorb - list(3,2) = iorb - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,3) = string(i,j) - enddo - enddo - psi_coef(3,1) = 1.d0/dsqrt(3.d0) - print*,'passed 3' - - call save_wavefunction -end diff --git a/src/Dets/guess_singlet.irp.f b/src/Dets/guess_singlet.irp.f deleted file mode 100644 index 50f8dc4e..00000000 --- a/src/Dets/guess_singlet.irp.f +++ /dev/null @@ -1,44 +0,0 @@ -program put_gess - use bitmasks - implicit none - integer :: i,j,N_det_tmp,N_states_tmp - integer :: list(N_int*bit_kind_size,2) - integer(bit_kind) :: string(N_int,2) - integer(bit_kind) :: psi_det_tmp(N_int,2,2) - double precision :: psi_coef_tmp(2,1) - - integer :: iorb,jorb - print*,'which open shells ?' - read(5,*)iorb,jorb - N_states= 1 - N_det= 2 - - - list = 0 - list(1,1) = iorb - list(1,2) = jorb - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,1) = string(i,j) - enddo - enddo - psi_coef(1,1) = 1.d0/dsqrt(2.d0) - - list = 0 - list(1,1) = jorb - list(1,2) = iorb - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,2) = string(i,j) - enddo - enddo - psi_coef(2,1) = 1.d0/dsqrt(2.d0) - - call save_wavefunction -end diff --git a/src/Dets/guess_triplet.irp.f b/src/Dets/guess_triplet.irp.f deleted file mode 100644 index 77f88c3e..00000000 --- a/src/Dets/guess_triplet.irp.f +++ /dev/null @@ -1,48 +0,0 @@ -program put_gess - use bitmasks - implicit none - integer :: i,j,N_det_tmp,N_states_tmp - integer :: list(N_int*bit_kind_size,2) - integer(bit_kind) :: string(N_int,2) - integer(bit_kind) :: psi_det_tmp(N_int,2,2) - double precision :: psi_coef_tmp(2,1) - - integer :: iorb,jorb - print*,'which open shells ?' - read(5,*)iorb,jorb - N_states= 1 - N_det= 2 - print*,'iorb = ',iorb - print*,'jorb = ',jorb - - - list = 0 - list(1,1) = iorb - list(1,2) = jorb - string = 0 - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,1) = string(i,j) - enddo - enddo - psi_coef(1,1) = 1.d0/dsqrt(2.d0) - - list = 0 - list(1,1) = jorb - list(1,2) = iorb - string = 0 - call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) - call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) - call print_det(string,N_int) - do j = 1,2 - do i = 1, N_int - psi_det(i,j,2) = string(i,j) - enddo - enddo - psi_coef(2,1) = -1.d0/dsqrt(2.d0) - - call save_wavefunction -end diff --git a/src/Dets/occ_pattern.irp.f b/src/Dets/occ_pattern.irp.f deleted file mode 100644 index 29d0dacf..00000000 --- a/src/Dets/occ_pattern.irp.f +++ /dev/null @@ -1,339 +0,0 @@ -use bitmasks -subroutine det_to_occ_pattern(d,o,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Transform a determinant to an occupation pattern - END_DOC - integer ,intent(in) :: Nint - integer(bit_kind),intent(in) :: d(Nint,2) - integer(bit_kind),intent(out) :: o(Nint,2) - - integer :: k - - do k=1,Nint - o(k,1) = ieor(d(k,1),d(k,2)) - o(k,2) = iand(d(k,1),d(k,2)) - enddo -end - -subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) - use bitmasks - implicit none - BEGIN_DOC -! Number of possible determinants for a given occ_pattern - END_DOC - integer ,intent(in) :: Nint, n_alpha - integer(bit_kind),intent(in) :: o(Nint,2) - integer, intent(out) :: sze - integer :: amax,bmax,k - double precision, external :: binom_func - - amax = n_alpha - bmax = 0 - do k=1,Nint - bmax += popcnt( o(k,1) ) - amax -= popcnt( o(k,2) ) - enddo - sze = int( min(binom_func(bmax, amax), 1.d8) ) - -end - -subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Generate all possible determinants for a give occ_pattern - END_DOC - integer ,intent(in) :: Nint, n_alpha - integer ,intent(inout) :: sze - integer(bit_kind),intent(in) :: o(Nint,2) - integer(bit_kind),intent(out) :: d(Nint,2,sze) - - integer :: i, k, nt, na, nd, amax - integer :: list_todo(n_alpha) - integer :: list_a(n_alpha) - - amax = n_alpha - do k=1,Nint - amax -= popcnt( o(k,2) ) - enddo - - call bitstring_to_list(o(1,1), list_todo, nt, Nint) - - na = 0 - nd = 0 - d = 0 - call rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) - - sze = nd - - do i=1,nd - ! Doubly occupied orbitals - do k=1,Nint - d(k,1,i) = ior(d(k,1,i),o(k,2)) - d(k,2,i) = ior(d(k,2,i),o(k,2)) - enddo - enddo - -! !TODO DEBUG -! integer :: j,s -! do i=1,nd -! do j=1,i-1 -! na=0 -! do k=1,Nint -! if((d(k,1,j) /= d(k,1,i)).or. & -! (d(k,2,j) /= d(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( j== 0 ) then -! print *, 'det ',i,' and ',j,' equal:' -! call debug_det(d(1,1,j),Nint) -! call debug_det(d(1,1,i),Nint) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG -end - -recursive subroutine rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) - use bitmasks - implicit none - - integer, intent(in) :: nt, sze, amax, Nint,na - integer,intent(inout) :: list_todo(nt) - integer, intent(inout) :: list_a(na+1),nd - integer(bit_kind),intent(inout) :: d(Nint,2,sze) - - if (na == amax) then - nd += 1 - if (na > 0) then - call list_to_bitstring( d(1,1,nd), list_a, na, Nint) - endif - if (nt > 0) then - call list_to_bitstring( d(1,2,nd), list_todo, nt, Nint) - endif - else - integer :: i, j, k - integer :: list_todo_tmp(nt) - do i=1,nt - if (na > 0) then - if (list_todo(i) < list_a(na)) then - cycle - endif - endif - list_a(na+1) = list_todo(i) - k=1 - do j=1,nt - if (i/=j) then - list_todo_tmp(k) = list_todo(j) - k += 1 - endif - enddo - call rec_occ_pattern_to_dets(list_todo_tmp,nt-1,list_a,na+1,d,nd,sze,amax,Nint) - enddo - endif - -end - - BEGIN_PROVIDER [ integer(bit_kind), psi_occ_pattern, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_occ_pattern ] - implicit none - BEGIN_DOC - ! array of the occ_pattern present in the wf - ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation - ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation - END_DOC - integer :: i,j,k - - ! create - do i = 1, N_det - do k = 1, N_int - psi_occ_pattern(k,1,i) = ieor(psi_det(k,1,i),psi_det(k,2,i)) - psi_occ_pattern(k,2,i) = iand(psi_det(k,1,i),psi_det(k,2,i)) - enddo - enddo - - ! Sort - integer, allocatable :: iorder(:) - integer*8, allocatable :: bit_tmp(:) - integer*8, external :: occ_pattern_search_key - integer(bit_kind), allocatable :: tmp_array(:,:,:) - logical,allocatable :: duplicate(:) - - - allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) - - do i=1,N_det - iorder(i) = i - !$DIR FORCEINLINE - bit_tmp(i) = occ_pattern_search_key(psi_occ_pattern(1,1,i),N_int) - enddo - call i8sort(bit_tmp,iorder,N_det) - !DIR$ IVDEP - do i=1,N_det - do k=1,N_int - tmp_array(k,1,i) = psi_occ_pattern(k,1,iorder(i)) - tmp_array(k,2,i) = psi_occ_pattern(k,2,iorder(i)) - enddo - duplicate(i) = .False. - enddo - - i=1 - integer (bit_kind) :: occ_pattern_tmp - do i=1,N_det - duplicate(i) = .False. - enddo - - do i=1,N_det-1 - if (duplicate(i)) then - cycle - endif - j = i+1 - do while (bit_tmp(j)==bit_tmp(i)) - if (duplicate(j)) then - j+=1 - cycle - endif - duplicate(j) = .True. - do k=1,N_int - if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & - .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then - duplicate(j) = .False. - exit - endif - enddo - j+=1 - if (j>N_det) then - exit - endif - enddo - enddo - - N_occ_pattern=0 - do i=1,N_det - if (duplicate(i)) then - cycle - endif - N_occ_pattern += 1 - do k=1,N_int - psi_occ_pattern(k,1,N_occ_pattern) = tmp_array(k,1,i) - psi_occ_pattern(k,2,N_occ_pattern) = tmp_array(k,2,i) - enddo - enddo - - deallocate(iorder,duplicate,bit_tmp,tmp_array) -! !TODO DEBUG -! integer :: s -! do i=1,N_occ_pattern -! do j=i+1,N_occ_pattern -! s = 0 -! do k=1,N_int -! if((psi_occ_pattern(k,1,j) /= psi_occ_pattern(k,1,i)).or. & -! (psi_occ_pattern(k,2,j) /= psi_occ_pattern(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error : occ ', j, 'already in wf' -! call debug_det(psi_occ_pattern(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG -END_PROVIDER - -subroutine make_s2_eigenfunction - implicit none - integer :: i,j,k - integer :: smax, s - integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new - integer, parameter :: bufsze = 1000 - logical, external :: is_in_wavefunction - -! !TODO DEBUG -! do i=1,N_det -! do j=i+1,N_det -! s = 0 -! do k=1,N_int -! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & -! (psi_det(k,2,j) /= psi_det(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error0: det ', j, 'already in wf' -! call debug_det(psi_det(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG - - allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) - smax = 1 - N_det_new = 0 - - do i=1,N_occ_pattern - call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) - s += 1 - if (s > smax) then - deallocate(d) - allocate ( d(N_int,2,s) ) - smax = s - endif - call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int) - do j=1,s - if (.not. is_in_wavefunction( d(1,1,j), N_int, N_det)) then - N_det_new += 1 - do k=1,N_int - det_buffer(k,1,N_det_new) = d(k,1,j) - det_buffer(k,2,N_det_new) = d(k,2,j) - enddo - if (N_det_new == bufsze) then - call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) - N_det_new = 0 - endif - endif - enddo - enddo - - if (N_det_new > 0) then - call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH N_det psi_coef psi_det - endif - - deallocate(d,det_buffer) - - -! !TODO DEBUG -! do i=1,N_det -! do j=i+1,N_det -! s = 0 -! do k=1,N_int -! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & -! (psi_det(k,2,j) /= psi_det(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error : det ', j, 'already in wf at ', i -! call debug_det(psi_det(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG - call write_int(output_dets,N_det_new, 'Added deteminants for S^2') - -end - diff --git a/src/Dets/options.irp.f b/src/Dets/options.irp.f deleted file mode 100644 index dda5c04a..00000000 --- a/src/Dets/options.irp.f +++ /dev/null @@ -1,61 +0,0 @@ -BEGIN_SHELL [ /usr/bin/python ] -from ezfio_with_default import EZFIO_Provider -T = EZFIO_Provider() -T.set_type ( "integer" ) -T.set_name ( "N_states" ) -T.set_doc ( "Number of states to consider" ) -T.set_ezfio_dir ( "determinants" ) -T.set_ezfio_name( "N_states" ) -T.set_output ( "output_dets" ) -print T - - -T.set_name ( "N_det_max_jacobi" ) -T.set_doc ( "Maximum number of determinants diagonalized by Jacobi" ) -T.set_ezfio_name( "N_det_max_jacobi" ) -print T - -T.set_type ( "logical" ) -T.set_name ( "read_wf" ) -T.set_doc ( "If true, read the wave function from the EZFIO file" ) -T.set_ezfio_name( "read_wf" ) -T.set_output ( "output_dets" ) -print T - -T.set_type ( "logical" ) -T.set_name ( "only_single_double_dm" ) -T.set_doc ( "If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements" ) -T.set_ezfio_name( "only_single_double_dm" ) -T.set_output ( "output_dets" ) -print T - - -T.set_name ( "s2_eig" ) -T.set_doc ( "Force the wave function to be an eigenfunction of S^2" ) -T.set_ezfio_name( "s2_eig" ) -print T - -END_SHELL - -BEGIN_PROVIDER [ integer, N_states_diag ] - implicit none - BEGIN_DOC -! Number of states to consider for the diagonalization - END_DOC - - logical :: has - PROVIDE ezfio_filename - call ezfio_has_determinants_n_states_diag(has) - if (has) then - call ezfio_get_determinants_n_states_diag(N_states_diag) - else - N_states_diag = N_states - endif - - call write_time(output_dets) - call write_int(output_dets, N_states_diag, & - 'N_states_diag') - - -END_PROVIDER - diff --git a/src/Dets/program_beginer_determinants.irp.f b/src/Dets/program_beginer_determinants.irp.f deleted file mode 100644 index 6375af22..00000000 --- a/src/Dets/program_beginer_determinants.irp.f +++ /dev/null @@ -1,138 +0,0 @@ -program pouet - implicit none - print*,'HF energy = ',ref_bitmask_energy + nuclear_repulsion - call routine - -end -subroutine routine - use bitmasks - implicit none - integer :: i,j,k,l - double precision :: hij,get_mo_bielec_integral - double precision :: hmono,h_bi_ispin,h_bi_other_spin - integer(bit_kind),allocatable :: key_tmp(:,:) - integer, allocatable :: occ(:,:) - integer :: n_occ_alpha, n_occ_beta - ! First checks - print*,'N_int = ',N_int - print*,'mo_tot_num = ',mo_tot_num - print*,'mo_tot_num / 64+1= ',mo_tot_num/64+1 - ! We print the HF determinant - do i = 1, N_int - print*,'ref_bitmask(i,1) = ',ref_bitmask(i,1) - print*,'ref_bitmask(i,2) = ',ref_bitmask(i,2) - enddo - print*,'' - print*,'Hartree Fock determinant ...' - call debug_det(ref_bitmask,N_int) - allocate(key_tmp(N_int,2)) - ! We initialize key_tmp to the Hartree Fock one - key_tmp = ref_bitmask - integer :: i_hole,i_particle,ispin,i_ok,other_spin - ! We do a mono excitation on the top of the HF determinant - write(*,*)'Enter the (hole, particle) couple for the mono excitation ...' - read(5,*)i_hole,i_particle -!!i_hole = 4 -!!i_particle = 20 - write(*,*)'Enter the ispin variable ...' - write(*,*)'ispin = 1 ==> alpha ' - write(*,*)'ispin = 2 ==> beta ' - read(5,*)ispin - if(ispin == 1)then - other_spin = 2 - else if(ispin == 2)then - other_spin = 1 - else - print*,'PB !! ' - print*,'ispin must be 1 or 2 !' - stop - endif -!!ispin = 1 - call do_mono_excitation(key_tmp,i_hole,i_particle,ispin,i_ok) - ! We check if it the excitation was possible with "i_ok" - if(i_ok == -1)then - print*,'i_ok = ',i_ok - print*,'You can not do this excitation because of Pauli principle ...' - print*,'check your hole particle couple, there must be something wrong ...' - stop - - endif - print*,'New det = ' - call debug_det(key_tmp,N_int) - call i_H_j(key_tmp,ref_bitmask,N_int,hij) - ! We calculate the H matrix element between the new determinant and HF - print*,' = ',hij - print*,'' - print*,'' - print*,'Recalculating it old school style ....' - print*,'' - print*,'' - ! We recalculate this old school style !!! - ! Mono electronic part - hmono = mo_mono_elec_integral(i_hole,i_particle) - print*,'' - print*,'Mono electronic part ' - print*,'' - print*,' = ',hmono - h_bi_ispin = 0.d0 - h_bi_other_spin = 0.d0 - print*,'' - print*,'Getting all the info for the calculation of the bi electronic part ...' - print*,'' - allocate (occ(N_int*bit_kind_size,2)) - ! We get the occupation of the alpha electrons in occ(:,1) - call bitstring_to_list(key_tmp(1,1), occ(1,1), n_occ_alpha, N_int) - print*,'n_occ_alpha = ',n_occ_alpha - print*,'elec_alpha_num = ',elec_alpha_num - ! We get the occupation of the beta electrons in occ(:,2) - call bitstring_to_list(key_tmp(1,2), occ(1,2), n_occ_beta, N_int) - print*,'n_occ_beta = ',n_occ_beta - print*,'elec_beta_num = ',elec_beta_num - ! We print the occupation of the alpha electrons - print*,'Alpha electrons !' - do i = 1, n_occ_alpha - print*,'i = ',i - print*,'occ(i,1) = ',occ(i,1) - enddo - ! We print the occupation of the beta electrons - print*,'Alpha electrons !' - do i = 1, n_occ_beta - print*,'i = ',i - print*,'occ(i,2) = ',occ(i,2) - enddo - integer :: exc(0:2,2,2),degree,h1,p1,h2,p2,s1,s2 - double precision :: phase - - call get_excitation_degree(key_tmp,ref_bitmask,degree,N_int) - print*,'degree = ',degree - call get_mono_excitation(ref_bitmask,key_tmp,exc,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - print*,'h1 = ',h1 - print*,'p1 = ',p1 - print*,'s1 = ',s1 - print*,'phase = ',phase - do i = 1, elec_num_tab(ispin) - integer :: orb_occupied - orb_occupied = occ(i,ispin) - h_bi_ispin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) & - -get_mo_bielec_integral(i_hole,i_particle,orb_occupied,orb_occupied,mo_integrals_map) - enddo - print*,'h_bi_ispin = ',h_bi_ispin - - do i = 1, elec_num_tab(other_spin) - orb_occupied = occ(i,other_spin) - h_bi_other_spin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) - enddo - print*,'h_bi_other_spin = ',h_bi_other_spin - print*,'h_bi_ispin + h_bi_other_spin = ',h_bi_ispin + h_bi_other_spin - - print*,'Total matrix element = ',phase*(h_bi_ispin + h_bi_other_spin + hmono) -!i = 1 -!j = 1 -!k = 1 -!l = 1 -!hij = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) -!print*,' = ',hij - - -end diff --git a/src/Dets/psi_cas.irp.f b/src/Dets/psi_cas.irp.f deleted file mode 100644 index 299e5e8f..00000000 --- a/src/Dets/psi_cas.irp.f +++ /dev/null @@ -1,114 +0,0 @@ -use bitmasks - - BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_cas_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_cas, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_cas ] - implicit none - BEGIN_DOC - ! CAS wave function, defined from the application of the CAS bitmask on the - ! determinants. idx_cas gives the indice of the CAS determinant in psi_det. - END_DOC - integer :: i, k, l - logical :: good - N_det_cas = 0 - do i=1,N_det - do l=1,n_cas_bitmask - good = .True. - do k=1,N_int - good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,1)) ) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,1)) ) - enddo - if (good) then - exit - endif - enddo - if (good) then - N_det_cas = N_det_cas+1 - do k=1,N_int - psi_cas(k,1,N_det_cas) = psi_det(k,1,i) - psi_cas(k,2,N_det_cas) = psi_det(k,2,i) - enddo - idx_cas(N_det_cas) = i - do k=1,N_states - psi_cas_coef(N_det_cas,k) = psi_coef(i,k) - enddo - endif - enddo - call write_int(output_dets,N_det_cas, 'Number of determinants in the CAS') - -END_PROVIDER - - - BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (psi_det_size,N_states) ] - implicit none - BEGIN_DOC - ! CAS determinants sorted to accelerate the search of a random determinant in the wave - ! function. - END_DOC - call sort_dets_by_det_search_key(N_det_cas, psi_cas, psi_cas_coef, & - psi_cas_sorted_bit, psi_cas_coef_sorted_bit) - -END_PROVIDER - - - - BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_non_cas, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_non_cas ] - implicit none - BEGIN_DOC - ! Set of determinants which are not part of the CAS, defined from the application - ! of the CAS bitmask on the determinants. - ! idx_non_cas gives the indice of the determinant in psi_det. - END_DOC - integer :: i_non_cas,j,k - integer :: degree - logical :: in_cas - i_non_cas =0 - do k=1,N_det - in_cas = .False. - do j=1,N_det_cas - call get_excitation_degree(psi_cas(1,1,j), psi_det(1,1,k), degree, N_int) - if (degree == 0) then - in_cas = .True. - exit - endif - enddo - if (.not.in_cas) then - double precision :: hij - i_non_cas += 1 - do j=1,N_int - psi_non_cas(j,1,i_non_cas) = psi_det(j,1,k) - psi_non_cas(j,2,i_non_cas) = psi_det(j,2,k) - enddo - do j=1,N_states - psi_non_cas_coef(i_non_cas,j) = psi_coef(k,j) - enddo - idx_non_cas(i_non_cas) = k - endif - enddo - N_det_non_cas = i_non_cas -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (psi_det_size,N_states) ] - implicit none - BEGIN_DOC - ! CAS determinants sorted to accelerate the search of a random determinant in the wave - ! function. - END_DOC - call sort_dets_by_det_search_key(N_det_cas, psi_non_cas, psi_non_cas_coef, & - psi_non_cas_sorted_bit, psi_non_cas_coef_sorted_bit) - -END_PROVIDER - - - - - diff --git a/src/Dets/ref_bitmask.irp.f b/src/Dets/ref_bitmask.irp.f deleted file mode 100644 index 7f760562..00000000 --- a/src/Dets/ref_bitmask.irp.f +++ /dev/null @@ -1,57 +0,0 @@ - BEGIN_PROVIDER [ double precision, ref_bitmask_energy ] -&BEGIN_PROVIDER [ double precision, mono_elec_ref_bitmask_energy ] -&BEGIN_PROVIDER [ double precision, kinetic_ref_bitmask_energy ] -&BEGIN_PROVIDER [ double precision, nucl_elec_ref_bitmask_energy ] -&BEGIN_PROVIDER [ double precision, bi_elec_ref_bitmask_energy ] - use bitmasks - implicit none - BEGIN_DOC - ! Energy of the reference bitmask used in Slater rules - END_DOC - - integer :: occ(N_int*bit_kind_size,2) - integer :: i,j - - call bitstring_to_list(ref_bitmask(1,1), occ(1,1), i, N_int) - call bitstring_to_list(ref_bitmask(1,2), occ(1,2), i, N_int) - - - ref_bitmask_energy = 0.d0 - mono_elec_ref_bitmask_energy = 0.d0 - kinetic_ref_bitmask_energy = 0.d0 - nucl_elec_ref_bitmask_energy = 0.d0 - bi_elec_ref_bitmask_energy = 0.d0 - - do i = 1, elec_beta_num - ref_bitmask_energy += mo_mono_elec_integral(occ(i,1),occ(i,1)) + mo_mono_elec_integral(occ(i,2),occ(i,2)) - kinetic_ref_bitmask_energy += mo_kinetic_integral(occ(i,1),occ(i,1)) + mo_kinetic_integral(occ(i,2),occ(i,2)) - nucl_elec_ref_bitmask_energy += mo_nucl_elec_integral(occ(i,1),occ(i,1)) + mo_nucl_elec_integral(occ(i,2),occ(i,2)) - enddo - - do i = elec_beta_num+1,elec_alpha_num - ref_bitmask_energy += mo_mono_elec_integral(occ(i,1),occ(i,1)) - kinetic_ref_bitmask_energy += mo_kinetic_integral(occ(i,1),occ(i,1)) - nucl_elec_ref_bitmask_energy += mo_nucl_elec_integral(occ(i,1),occ(i,1)) - enddo - - do j= 1, elec_alpha_num - do i = j+1, elec_alpha_num - bi_elec_ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,1),occ(j,1)) - ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - do j= 1, elec_beta_num - do i = j+1, elec_beta_num - bi_elec_ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,2),occ(j,2)) - ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,2),occ(j,2)) - enddo - do i= 1, elec_alpha_num - bi_elec_ref_bitmask_energy += mo_bielec_integral_jj(occ(i,1),occ(j,2)) - ref_bitmask_energy += mo_bielec_integral_jj(occ(i,1),occ(j,2)) - enddo - enddo - mono_elec_ref_bitmask_energy = kinetic_ref_bitmask_energy + nucl_elec_ref_bitmask_energy - -END_PROVIDER - diff --git a/src/Dets/s2.irp.f b/src/Dets/s2.irp.f deleted file mode 100644 index cd1d9fda..00000000 --- a/src/Dets/s2.irp.f +++ /dev/null @@ -1,106 +0,0 @@ -subroutine get_s2(key_i,key_j,phase,Nint) - implicit none - use bitmasks - BEGIN_DOC -! Returns - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer(bit_kind), intent(in) :: key_j(Nint,2) - double precision, intent(out) :: phase - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase_spsm - integer :: nup, i - - phase = 0.d0 - !$FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case(2) - call get_double_excitation(key_i,key_j,exc,phase_spsm,Nint) - if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta - if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then - phase = -phase_spsm - endif - endif - case(0) - nup = 0 - do i=1,Nint - nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) - enddo - phase = dble(nup) - end select -end - -BEGIN_PROVIDER [ double precision, S_z ] -&BEGIN_PROVIDER [ double precision, S_z2_Sz ] - implicit none - BEGIN_DOC -! z component of the Spin - END_DOC - - S_z = 0.5d0*dble(elec_alpha_num-elec_beta_num) - S_z2_Sz = S_z*(S_z-1.d0) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, expected_s2] - implicit none - BEGIN_DOC -! Expected value of S2 : S*(S+1) - END_DOC - logical :: has_expected_s2 - - call ezfio_has_determinants_expected_s2(has_expected_s2) - if (has_expected_s2) then - call ezfio_get_determinants_expected_s2(expected_s2) - else - double precision :: S - S = (elec_alpha_num-elec_beta_num)*0.5d0 - expected_s2 = S * (S+1.d0) -! expected_s2 = elec_alpha_num - elec_beta_num + 0.5d0 * ((elec_alpha_num - elec_beta_num)**2*0.5d0 - (elec_alpha_num-elec_beta_num)) - endif - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] - implicit none - BEGIN_DOC -! array of the averaged values of the S^2 operator on the various states - END_DOC - integer :: i - double precision :: s2 - do i = 1, N_states - call get_s2_u0(psi_det,psi_coef(1,i),n_det,psi_det_size,s2) - s2_values(i) = s2 - enddo - -END_PROVIDER - - -subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) - implicit none - use bitmasks - integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) - integer, intent(in) :: n,nmax - double precision, intent(in) :: psi_coefs_tmp(nmax) - double precision, intent(out) :: s2 - integer :: i,j,l - double precision :: s2_tmp - s2 = S_z2_Sz - !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP PRIVATE(i,j,s2_tmp) SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int) & - !$OMP REDUCTION(+:s2) SCHEDULE(dynamic) - do i = 1, n - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) -! print*,'s2_tmp = ',s2_tmp - do j = 1, n - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),s2_tmp,N_int) - if (s2_tmp == 0.d0) cycle - s2 += psi_coefs_tmp(i)*psi_coefs_tmp(j)*s2_tmp - enddo - enddo - !$OMP END PARALLEL DO -end - diff --git a/src/Dets/save_for_casino.irp.f b/src/Dets/save_for_casino.irp.f deleted file mode 100644 index 631f79bd..00000000 --- a/src/Dets/save_for_casino.irp.f +++ /dev/null @@ -1,268 +0,0 @@ -subroutine save_casino - use bitmasks - implicit none - character*(128) :: message - integer :: getUnitAndOpen, iunit - integer, allocatable :: itmp(:) - integer :: n_ao_new - real, allocatable :: rtmp(:) - PROVIDE ezfio_filename - - iunit = getUnitAndOpen('gwfn.data','w') - print *, 'Title?' - read(*,*) message - write(iunit,'(A)') trim(message) - write(iunit,'(A)') '' - write(iunit,'(A)') 'BASIC_INFO' - write(iunit,'(A)') '----------' - write(iunit,'(A)') 'Generated by:' - write(iunit,'(A)') 'Quantum package' - write(iunit,'(A)') 'Method:' - print *, 'Method?' - read(*,*) message - write(iunit,'(A)') trim(message) - write(iunit,'(A)') 'DFT Functional:' - write(iunit,'(A)') 'none' - write(iunit,'(A)') 'Periodicity:' - write(iunit,'(A)') '0' - write(iunit,'(A)') 'Spin unrestricted:' - write(iunit,'(A)') '.false.' - write(iunit,'(A)') 'nuclear-nuclear repulsion energy (au/atom):' - write(iunit,*) nuclear_repulsion - write(iunit,'(A)') 'Number of electrons per primitive cell:' - write(iunit,*) elec_num - write(iunit,*) '' - - - write(iunit,*) 'GEOMETRY' - write(iunit,'(A)') '--------' - write(iunit,'(A)') 'Number of atoms:' - write(iunit,*) nucl_num - write(iunit,'(A)') 'Atomic positions (au):' - integer :: i - do i=1,nucl_num - write(iunit,'(3(1PE20.13))') nucl_coord(i,1:3) - enddo - write(iunit,'(A)') 'Atomic numbers for each atom:' - ! Add 200 if pseudopotential - allocate(itmp(nucl_num)) - do i=1,nucl_num - itmp(i) = int(nucl_charge(i)) - enddo - write(iunit,'(8(I10))') itmp(1:nucl_num) - deallocate(itmp) - write(iunit,'(A)') 'Valence charges for each atom:' - write(iunit,'(4(1PE20.13))') nucl_charge(1:nucl_num) - write(iunit,'(A)') '' - - - write(iunit,'(A)') 'BASIS SET' - write(iunit,'(A)') '---------' - write(iunit,'(A)') 'Number of Gaussian centres' - write(iunit,*) nucl_num - write(iunit,'(A)') 'Number of shells per primitive cell' - integer :: icount - icount = 0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - icount += 1 - endif - enddo - write(iunit,*) icount - write(iunit,'(A)') 'Number of basis functions (''AO'') per primitive cell' - icount = 0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - icount += 2*ao_l(i)+1 - endif - enddo - n_ao_new = icount - write(iunit,*) n_ao_new - write(iunit,'(A)') 'Number of Gaussian primitives per primitive cell' - allocate(itmp(ao_num)) - integer :: l - l=0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - l += 1 - itmp(l) = ao_prim_num(i) - endif - enddo - write(iunit,'(8(I10))') sum(itmp(1:l)) - write(iunit,'(A)') 'Highest shell angular momentum (s/p/d/f... 1/2/3/4...)' - write(iunit,*) maxval(ao_l(1:ao_num))+1 - write(iunit,'(A)') 'Code for shell types (s/sp/p/d/f... 1/2/3/4/5...)' - l=0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - l += 1 - if (ao_l(i) > 0) then - itmp(l) = ao_l(i)+2 - else - itmp(l) = ao_l(i)+1 - endif - endif - enddo - write(iunit,'(8(I10))') itmp(1:l) - write(iunit,'(A)') 'Number of primitive Gaussians in each shell' - l=0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - l += 1 - itmp(l) = ao_prim_num(i) - endif - enddo - write(iunit,'(8(I10))') itmp(1:l) - deallocate(itmp) - write(iunit,'(A)') 'Sequence number of first shell on each centre' - allocate(itmp(nucl_num)) - l=0 - icount = 1 - itmp(icount) = 1 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - l = l+1 - if (ao_nucl(i) == icount) then - continue - else if (ao_nucl(i) == icount+1) then - icount += 1 - itmp(icount) = l - else - print *, 'Problem in order of centers of basis functions' - stop 1 - endif - endif - enddo - ! Check - if (icount /= nucl_num) then - print *, 'Error :' - print *, ' icount :', icount - print *, ' nucl_num:', nucl_num - stop 2 - endif - write(iunit,'(8(I10))') itmp(1:nucl_num) - deallocate(itmp) - write(iunit,'(A)') 'Exponents of Gaussian primitives' - allocate(rtmp(ao_num)) - l=0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - do j=1,ao_prim_num(i) - l+=1 - rtmp(l) = ao_expo(i,ao_prim_num(i)-j+1) - enddo - endif - enddo - write(iunit,'(4(1PE20.13))') rtmp(1:l) - write(iunit,'(A)') 'Normalized contraction coefficients' - l=0 - integer :: j - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - do j=1,ao_prim_num(i) - l+=1 - rtmp(l) = ao_coef(i,ao_prim_num(i)-j+1) - enddo - endif - enddo - write(iunit,'(4(1PE20.13))') rtmp(1:l) - deallocate(rtmp) - write(iunit,'(A)') 'Position of each shell (au)' - l=0 - do i=1,ao_num - if (ao_l(i) == ao_power(i,1)) then - write(iunit,'(3(1PE20.13))') nucl_coord( ao_nucl(i), 1:3 ) - endif - enddo - write(iunit,'(A)') - - - write(iunit,'(A)') 'MULTIDETERMINANT INFORMATION' - write(iunit,'(A)') '----------------------------' - write(iunit,'(A)') 'GS' - write(iunit,'(A)') 'ORBITAL COEFFICIENTS' - write(iunit,'(A)') '------------------------' - - ! Transformation cartesian -> spherical - double precision :: tf2(6,5), tf3(10,7), tf4(15,9) - integer :: check2(3,6), check3(3,10), check4(3,15) - check2(:,1) = (/ 2, 0, 0 /) - check2(:,2) = (/ 1, 1, 0 /) - check2(:,3) = (/ 1, 0, 1 /) - check2(:,4) = (/ 0, 2, 0 /) - check2(:,5) = (/ 0, 1, 1 /) - check2(:,6) = (/ 0, 0, 2 /) - - check3(:,1) = (/ 3, 0, 0 /) - check3(:,2) = (/ 2, 1, 0 /) - check3(:,3) = (/ 2, 0, 1 /) - check3(:,4) = (/ 1, 2, 0 /) - check3(:,5) = (/ 1, 1, 1 /) - check3(:,6) = (/ 1, 0, 2 /) - check3(:,7) = (/ 0, 3, 0 /) - check3(:,8) = (/ 0, 2, 1 /) - check3(:,9) = (/ 0, 1, 2 /) - check3(:,10) = (/ 0, 0, 3 /) - - check4(:,1) = (/ 4, 0, 0 /) - check4(:,2) = (/ 3, 1, 0 /) - check4(:,3) = (/ 3, 0, 1 /) - check4(:,4) = (/ 2, 2, 0 /) - check4(:,5) = (/ 2, 1, 1 /) - check4(:,6) = (/ 2, 0, 2 /) - check4(:,7) = (/ 1, 3, 0 /) - check4(:,8) = (/ 1, 2, 1 /) - check4(:,9) = (/ 1, 1, 2 /) - check4(:,10) = (/ 1, 0, 3 /) - check4(:,11) = (/ 0, 4, 0 /) - check4(:,12) = (/ 0, 3, 1 /) - check4(:,13) = (/ 0, 2, 2 /) - check4(:,14) = (/ 0, 1, 3 /) - check4(:,15) = (/ 0, 0, 4 /) - -! tf2 = (/ -! -0.5, 0, 0, -0.5, 0, 1.0, & -! 0, 0, 1.0, 0, 0, 0, & -! 0, 0, 0, 0, 1.0, 0, & -! 0.86602540378443864676, 0, 0, -0.86602540378443864676, 0, 0, & -! 0, 1.0, 0, 0, 0, 0, & -! /) -! tf3 = (/ -! 0, 0, -0.67082039324993690892, 0, 0, 0, 0, -0.67082039324993690892, 0, 1.0, & -! -0.61237243569579452455, 0, 0, -0.27386127875258305673, 0, 1.0954451150103322269, 0, 0, 0, 0, & -! 0, -0.27386127875258305673, 0, 0, 0, 0, -0.61237243569579452455, 0, 1.0954451150103322269, 0, & -! 0, 0, 0.86602540378443864676, 0, 0, 0, 0, -0.86602540378443864676, 0, 0, & -! 0, 0, 0, 0, 1.0, 0, 0, 0, 0, 0, & -! 0.790569415042094833, 0, 0, -1.0606601717798212866, 0, 0, 0, 0, 0, 0, & -! 0, 1.0606601717798212866, 0, 0, 0, 0, -0.790569415042094833, 0, 0, 0, & -! /) -! tf4 = (/ -! 0.375, 0, 0, 0.21957751641341996535, 0, -0.87831006565367986142, 0, 0, 0, 0, 0.375, 0, -0.87831006565367986142, 0, 1.0, & -! 0, 0, -0.89642145700079522998, 0, 0, 0, 0, -0.40089186286863657703, 0, 1.19522860933439364, 0, 0, 0, 0, 0, & -! 0, 0, 0, 0, -0.40089186286863657703, 0, 0, 0, 0, 0, 0, -0.89642145700079522998, 0, 1.19522860933439364, 0, & -! -0.5590169943749474241, 0, 0, 0, 0, 0.9819805060619657157, 0, 0, 0, 0, 0.5590169943749474241, 0, -0.9819805060619657157, 0, 0, & -! 0, -0.42257712736425828875, 0, 0, 0, 0, -0.42257712736425828875, 0, 1.1338934190276816816, 0, 0, 0, 0, 0, 0, & -! 0, 0, 0.790569415042094833, 0, 0, 0, 0, -1.0606601717798212866, 0, 0, 0, 0, 0, 0, 0, & -! 0, 0, 0, 0, 1.0606601717798212866, 0, 0, 0, 0, 0, 0, -0.790569415042094833, 0, 0, 0, & -! 0.73950997288745200532, 0, 0, -1.2990381056766579701, 0, 0, 0, 0, 0, 0, 0.73950997288745200532, 0, 0, 0, 0, & -! 0, 1.1180339887498948482, 0, 0, 0, 0, -1.1180339887498948482, 0, 0, 0, 0, 0, 0, 0, 0, & -! /) -! - - - allocate(rtmp(ao_num*mo_tot_num)) - l=0 - do i=1,mo_tot_num - do j=1,ao_num - l += 1 - rtmp(l) = mo_coef(j,i) - enddo - enddo - write(iunit,'(4(1PE20.13))') rtmp(1:l) - deallocate(rtmp) - close(iunit) -end - -program prog_save_casino - call save_casino -end diff --git a/src/Dets/save_for_qmcchem.irp.f b/src/Dets/save_for_qmcchem.irp.f deleted file mode 100644 index 7dea70c6..00000000 --- a/src/Dets/save_for_qmcchem.irp.f +++ /dev/null @@ -1,51 +0,0 @@ -subroutine save_dets_qmcchem - use bitmasks - implicit none - character :: c(mo_tot_num) - integer :: i,k - - integer, allocatable :: occ(:,:,:), occ_tmp(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: occ, occ_tmp - - read_wf = .True. - TOUCH read_wf - call ezfio_set_determinants_det_num(N_det) - call ezfio_set_determinants_det_coef(psi_coef_sorted(1,1)) - - allocate (occ(elec_alpha_num,N_det,2)) - ! OMP PARALLEL DEFAULT(NONE) & - ! OMP PRIVATE(occ_tmp,i,k)& - ! OMP SHARED(N_det,psi_det_sorted,elec_alpha_num, & - ! OMP occ,elec_beta_num,N_int) - allocate (occ_tmp(N_int*bit_kind_size,2)) - occ_tmp = 0 - ! OMP DO - do i=1,N_det - call bitstring_to_list(psi_det_sorted(1,1,i), occ_tmp(1,1), elec_alpha_num, N_int ) - call bitstring_to_list(psi_det_sorted(1,2,i), occ_tmp(1,2), elec_beta_num, N_int ) - do k=1,elec_alpha_num - occ(k,i,1) = occ_tmp(k,1) - occ(k,i,2) = occ_tmp(k,2) - enddo - enddo - ! OMP END DO - deallocate(occ_tmp) - ! OMP END PARALLEL - call ezfio_set_determinants_det_occ(occ) - call write_int(output_dets,N_det,'Determinants saved for QMC') - deallocate(occ) - open(unit=31,file=trim(ezfio_filename)//'/mo_basis/mo_classif') - write(31,'(I1)') 1 - write(31,*) mo_tot_num - do i=1,mo_tot_num - write(31,'(A)') 'a' - enddo - close(31) - call system('gzip -f '//trim(ezfio_filename)//'/mo_basis/mo_classif') - -end - -program save_for_qmc - call save_dets_qmcchem - call write_spindeterminants -end diff --git a/src/Dets/save_natorb.irp.f b/src/Dets/save_natorb.irp.f deleted file mode 100644 index e56f9821..00000000 --- a/src/Dets/save_natorb.irp.f +++ /dev/null @@ -1,6 +0,0 @@ -program save_natorb - read_wf = .True. - touch read_wf - call save_natural_mos -end - diff --git a/src/Dets/slater_rules.irp.f b/src/Dets/slater_rules.irp.f deleted file mode 100644 index 7d431879..00000000 --- a/src/Dets/slater_rules.irp.f +++ /dev/null @@ -1,1301 +0,0 @@ -subroutine get_excitation_degree(key1,key2,degree,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Returns the excitation degree between two determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key1(Nint,2) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: degree - - integer :: l - - ASSERT (Nint > 0) - - degree = popcnt(xor( key1(1,1), key2(1,1))) + & - popcnt(xor( key1(1,2), key2(1,2))) - !DEC$ NOUNROLL - do l=2,Nint - degree = degree+ popcnt(xor( key1(l,1), key2(l,1))) + & - popcnt(xor( key1(l,2), key2(l,2))) - enddo - ASSERT (degree >= 0) - degree = ishft(degree,-1) - -end - - - -subroutine get_excitation(det1,det2,exc,degree,phase,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Returns the excitation operators between two determinants and the phase - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det1(Nint,2) - integer(bit_kind), intent(in) :: det2(Nint,2) - integer, intent(out) :: exc(0:2,2,2) - integer, intent(out) :: degree - double precision, intent(out) :: phase - ! exc(number,hole/particle,spin) - ! ex : - ! exc(0,1,1) = number of holes alpha - ! exc(0,2,1) = number of particle alpha - ! exc(0,2,2) = number of particle beta - ! exc(1,2,1) = first particle alpha - ! exc(1,1,1) = first hole alpha - ! exc(1,2,2) = first particle beta - ! exc(1,1,2) = first hole beta - - ASSERT (Nint > 0) - - !DIR$ FORCEINLINE - call get_excitation_degree(det1,det2,degree,Nint) - select case (degree) - - case (3:) - degree = -1 - return - - case (2) - call get_double_excitation(det1,det2,exc,phase,Nint) - return - - case (1) - call get_mono_excitation(det1,det2,exc,phase,Nint) - return - - case(0) - return - - end select -end - -subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - use bitmasks - implicit none - BEGIN_DOC - ! Decodes the exc arrays returned by get_excitation. - ! h1,h2 : Holes - ! p1,p2 : Particles - ! s1,s2 : Spins (1:alpha, 2:beta) - ! degree : Degree of excitation - END_DOC - integer, intent(in) :: exc(0:2,2,2),degree - integer, intent(out) :: h1,h2,p1,p2,s1,s2 - ASSERT (degree > 0) - ASSERT (degree < 3) - - select case(degree) - case(2) - if (exc(0,1,1) == 2) then - h1 = exc(1,1,1) - h2 = exc(2,1,1) - p1 = exc(1,2,1) - p2 = exc(2,2,1) - s1 = 1 - s2 = 1 - else if (exc(0,1,2) == 2) then - h1 = exc(1,1,2) - h2 = exc(2,1,2) - p1 = exc(1,2,2) - p2 = exc(2,2,2) - s1 = 2 - s2 = 2 - else - h1 = exc(1,1,1) - h2 = exc(1,1,2) - p1 = exc(1,2,1) - p2 = exc(1,2,2) - s1 = 1 - s2 = 2 - endif - case(1) - if (exc(0,1,1) == 1) then - h1 = exc(1,1,1) - h2 = 0 - p1 = exc(1,2,1) - p2 = 0 - s1 = 1 - s2 = 0 - else - h1 = exc(1,1,2) - h2 = 0 - p1 = exc(1,2,2) - p2 = 0 - s1 = 2 - s2 = 0 - endif - case(0) - h1 = 0 - p1 = 0 - h2 = 0 - p2 = 0 - s1 = 0 - s2 = 0 - end select -end - -subroutine get_double_excitation(det1,det2,exc,phase,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Returns the two excitation operators between two doubly excited determinants and the phase - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det1(Nint,2) - integer(bit_kind), intent(in) :: det2(Nint,2) - integer, intent(out) :: exc(0:2,2,2) - double precision, intent(out) :: phase - integer :: tz - integer :: l, ispin, idx_hole, idx_particle, ishift - integer :: nperm - integer :: i,j,k,m,n - integer :: high, low - integer :: a,b,c,d - integer(bit_kind) :: hole, particle, tmp - double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) - - ASSERT (Nint > 0) - nperm = 0 - exc(0,1,1) = 0 - exc(0,2,1) = 0 - exc(0,1,2) = 0 - exc(0,2,2) = 0 - do ispin = 1,2 - idx_particle = 0 - idx_hole = 0 - ishift = 1-bit_kind_size - do l=1,Nint - ishift = ishift + bit_kind_size - if (det1(l,ispin) == det2(l,ispin)) then - cycle - endif - tmp = xor( det1(l,ispin), det2(l,ispin) ) - particle = iand(tmp, det2(l,ispin)) - hole = iand(tmp, det1(l,ispin)) - do while (particle /= 0_bit_kind) - tz = trailz(particle) - idx_particle = idx_particle + 1 - exc(0,2,ispin) = exc(0,2,ispin) + 1 - exc(idx_particle,2,ispin) = tz+ishift - particle = iand(particle,particle-1_bit_kind) - enddo - if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)==2 - exit - endif - do while (hole /= 0_bit_kind) - tz = trailz(hole) - idx_hole = idx_hole + 1 - exc(0,1,ispin) = exc(0,1,ispin) + 1 - exc(idx_hole,1,ispin) = tz+ishift - hole = iand(hole,hole-1_bit_kind) - enddo - if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin) - exit - endif - enddo - - ! TODO : Voir si il faut sortir i,n,k,m du case. - - select case (exc(0,1,ispin)) - case(0) - cycle - - case(1) - low = min(exc(1,1,ispin), exc(1,2,ispin)) - high = max(exc(1,1,ispin), exc(1,2,ispin)) - - ASSERT (low > 0) - j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) - n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) - ASSERT (high > 0) - k = ishft(high-1,-bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - - if (j==k) then - nperm = nperm + popcnt(iand(det1(j,ispin), & - iand( ibset(0_bit_kind,m-1)-1_bit_kind, & - ibclr(-1_bit_kind,n)+1_bit_kind ) )) - else - nperm = nperm + popcnt(iand(det1(k,ispin), & - ibset(0_bit_kind,m-1)-1_bit_kind)) + & - popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) - do i=j+1,k-1 - nperm = nperm + popcnt(det1(i,ispin)) - end do - endif - - case (2) - - do i=1,2 - low = min(exc(i,1,ispin), exc(i,2,ispin)) - high = max(exc(i,1,ispin), exc(i,2,ispin)) - - ASSERT (low > 0) - j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) - n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) - ASSERT (high > 0) - k = ishft(high-1,-bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - - if (j==k) then - nperm = nperm + popcnt(iand(det1(j,ispin), & - iand( ibset(0_bit_kind,m-1)-1_bit_kind, & - ibclr(-1_bit_kind,n)+1_bit_kind ) )) - else - nperm = nperm + popcnt(iand(det1(k,ispin), & - ibset(0_bit_kind,m-1)-1_bit_kind)) + & - popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) - do l=j+1,k-1 - nperm = nperm + popcnt(det1(l,ispin)) - end do - endif - - enddo - - a = min(exc(1,1,ispin), exc(1,2,ispin)) - b = max(exc(1,1,ispin), exc(1,2,ispin)) - c = min(exc(2,1,ispin), exc(2,2,ispin)) - d = max(exc(2,1,ispin), exc(2,2,ispin)) - if (c>a .and. cb) then - nperm = nperm + 1 - endif - exit - end select - - enddo - phase = phase_dble(iand(nperm,1)) - -end - -subroutine get_mono_excitation(det1,det2,exc,phase,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Returns the excitation operator between two singly excited determinants and the phase - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det1(Nint,2) - integer(bit_kind), intent(in) :: det2(Nint,2) - integer, intent(out) :: exc(0:2,2,2) - double precision, intent(out) :: phase - integer :: tz - integer :: l, ispin, idx_hole, idx_particle, ishift - integer :: nperm - integer :: i,j,k,m,n - integer :: high, low - integer :: a,b,c,d - integer(bit_kind) :: hole, particle, tmp - double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) - - ASSERT (Nint > 0) - nperm = 0 - exc(0,1,1) = 0 - exc(0,2,1) = 0 - exc(0,1,2) = 0 - exc(0,2,2) = 0 - do ispin = 1,2 - ishift = 1-bit_kind_size - do l=1,Nint - ishift = ishift + bit_kind_size - if (det1(l,ispin) == det2(l,ispin)) then - cycle - endif - tmp = xor( det1(l,ispin), det2(l,ispin) ) - particle = iand(tmp, det2(l,ispin)) - hole = iand(tmp, det1(l,ispin)) - if (particle /= 0_bit_kind) then - tz = trailz(particle) - exc(0,2,ispin) = 1 - exc(1,2,ispin) = tz+ishift - endif - if (hole /= 0_bit_kind) then - tz = trailz(hole) - exc(0,1,ispin) = 1 - exc(1,1,ispin) = tz+ishift - endif - - if ( iand(exc(0,1,ispin),exc(0,2,ispin)) /= 1) then ! exc(0,1,ispin)/=1 and exc(0,2,ispin) /= 1 - cycle - endif - - low = min(exc(1,1,ispin),exc(1,2,ispin)) - high = max(exc(1,1,ispin),exc(1,2,ispin)) - - ASSERT (low > 0) - j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) - n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) - ASSERT (high > 0) - k = ishft(high-1,-bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - if (j==k) then - nperm = popcnt(iand(det1(j,ispin), & - iand(ibset(0_bit_kind,m-1)-1_bit_kind,ibclr(-1_bit_kind,n)+1_bit_kind))) - else - nperm = nperm + popcnt(iand(det1(k,ispin),ibset(0_bit_kind,m-1)-1_bit_kind)) +& - popcnt(iand(det1(j,ispin),ibclr(-1_bit_kind,n)+1_bit_kind)) - do i=j+1,k-1 - nperm = nperm + popcnt(det1(i,ispin)) - end do - endif - phase = phase_dble(iand(nperm,1)) - return - - enddo - enddo -end - - - - - -subroutine i_H_j(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem, phase,phase_2 - integer :: n_occ_alpha, n_occ_beta - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DEC$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_map) - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) - call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) - has_mipi = .False. - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) - enddo - do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p)) - - case (0) - hij = diag_H_mat_elem(key_i,Nint) - end select -end - - - - -subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij,hmono,hdouble - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem, phase,phase_2 - integer :: n_occ_alpha, n_occ_beta - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - hmono = 0.d0 - hdouble = 0.d0 - !DEC$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_map) - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) - call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) - has_mipi = .False. - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1)) - enddo - do k = 1, elec_beta_num - hdouble = hdouble + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hdouble = hdouble + mipi(occ(k,1)) - enddo - do k = 1, elec_beta_num - hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2)) - enddo - - endif - hmono = mo_mono_elec_integral(m,p) - hij = phase*(hdouble + hmono) - - case (0) - hij = diag_H_mat_elem(key_i,Nint) - end select -end - - - -subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) - use bitmasks - implicit none - integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate - integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) - integer(bit_kind), intent(in) :: key(Nint,2) - double precision, intent(in) :: coef(Ndet_max,Nstate) - double precision, intent(out) :: i_H_psi_array(Nstate) - - integer :: i, ii,j - double precision :: phase - integer :: exc(0:2,2,2) - double precision :: hij - integer :: idx(0:Ndet) - BEGIN_DOC - ! for the various Nstates - END_DOC - - ASSERT (Nint > 0) - ASSERT (N_int == Nint) - ASSERT (Nstate > 0) - ASSERT (Ndet > 0) - ASSERT (Ndet_max >= Ndet) - i_H_psi_array = 0.d0 - call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) - do ii=1,idx(0) - i = idx(ii) - !DEC$ FORCEINLINE - call i_H_j(keys(1,1,i),key,Nint,hij) - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij - enddo - enddo -end - -subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) - use bitmasks - implicit none - integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate - integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) - integer(bit_kind), intent(in) :: key(Nint,2) - double precision, intent(in) :: coef(Ndet_max,Nstate) - double precision, intent(out) :: i_H_psi_array(Nstate) - double precision, intent(out) :: interactions(Ndet) - integer,intent(out) :: idx_interaction(0:Ndet) - - integer :: i, ii,j - double precision :: phase - integer :: exc(0:2,2,2) - double precision :: hij - integer :: idx(0:Ndet),n_interact - BEGIN_DOC - ! for the various Nstates - END_DOC - - ASSERT (Nint > 0) - ASSERT (N_int == Nint) - ASSERT (Nstate > 0) - ASSERT (Ndet > 0) - ASSERT (Ndet_max >= Ndet) - i_H_psi_array = 0.d0 - call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) - n_interact = 0 - do ii=1,idx(0) - i = idx(ii) - !DEC$ FORCEINLINE - call i_H_j(keys(1,1,i),key,Nint,hij) - if(dabs(hij).ge.1.d-8)then - if(i.ne.1)then - n_interact += 1 - interactions(n_interact) = hij - idx_interaction(n_interact) = i - endif - endif - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij - enddo - enddo - idx_interaction(0) = n_interact -end - - -subroutine i_H_psi_SC2(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_repeat) - use bitmasks - BEGIN_DOC - ! for the various Nstate - ! - ! returns in addition - ! - ! the array of the index of the non connected determinants to key1 - ! - ! in order to know what double excitation can be repeated on key1 - ! - ! idx_repeat(0) is the number of determinants that can be used - ! - ! to repeat the excitations - END_DOC - implicit none - integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate - integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) - integer(bit_kind), intent(in) :: key(Nint,2) - double precision, intent(in) :: coef(Ndet_max,Nstate) - double precision, intent(out) :: i_H_psi_array(Nstate) - integer , intent(out) :: idx_repeat(0:Ndet) - - integer :: i, ii,j - double precision :: phase - integer :: exc(0:2,2,2) - double precision :: hij - integer :: idx(0:Ndet) - - ASSERT (Nint > 0) - ASSERT (N_int == Nint) - ASSERT (Nstate > 0) - ASSERT (Ndet > 0) - ASSERT (Ndet_max >= Ndet) - i_H_psi_array = 0.d0 - call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) - do ii=1,idx(0) - i = idx(ii) - !DEC$ FORCEINLINE - call i_H_j(keys(1,1,i),key,Nint,hij) - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij - enddo - enddo -end - - -subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_repeat) - use bitmasks - BEGIN_DOC - ! for the various Nstate - ! - ! returns in addition - ! - ! the array of the index of the non connected determinants to key1 - ! - ! in order to know what double excitation can be repeated on key1 - ! - ! idx_repeat(0) is the number of determinants that can be used - ! - ! to repeat the excitations - END_DOC - implicit none - integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate - integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) - integer(bit_kind), intent(in) :: key(Nint,2) - double precision, intent(in) :: coef(Ndet_max,Nstate) - double precision, intent(out) :: i_H_psi_array(Nstate) - integer , intent(out) :: idx_repeat(0:Ndet) - - integer :: i, ii,j - double precision :: phase - integer :: exc(0:2,2,2) - double precision :: hij - integer :: idx(0:Ndet) - - ASSERT (Nint > 0) - ASSERT (N_int == Nint) - ASSERT (Nstate > 0) - ASSERT (Ndet > 0) - ASSERT (Ndet_max >= Ndet) - i_H_psi_array = 0.d0 - call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) - print*,'--------' - do ii=1,idx(0) - print*,'--' - i = idx(ii) - !DEC$ FORCEINLINE - call i_H_j(keys(1,1,i),key,Nint,hij) - if (i==1)then - print*,'i==1 !!' - endif - print*,coef(i,1) * hij,coef(i,1),hij - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij - enddo - print*,i_H_psi_array(1) - enddo - print*,'------' -end - - - -subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Applies get_excitation_degree to an array of determinants - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: degree(sze) - integer, intent(out) :: idx(0:sze) - - integer :: i,l - - ASSERT (Nint > 0) - ASSERT (sze > 0) - - l=1 - if (Nint==1) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))),-1) - if (degree(l) < 3) then - idx(l) = i - l = l+1 - endif - enddo - - else if (Nint==2) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))),-1) - if (degree(l) < 3) then - idx(l) = i - l = l+1 - endif - enddo - - else if (Nint==3) then - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree(l) = ishft( popcnt(xor( key1(1,1,i), key2(1,1))) + & - popcnt(xor( key1(1,2,i), key2(1,2))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))),-1) - if (degree(l) < 3) then - idx(l) = i - l = l+1 - endif - enddo - - else - - !DIR$ LOOP COUNT (1000) - do i=1,sze - degree(l) = 0 - !DEC$ LOOP COUNT MIN(4) - do l=1,Nint - degree(l) = degree(l)+ popcnt(xor( key1(l,1,i), key2(l,1))) +& - popcnt(xor( key1(l,2,i), key2(l,2))) - enddo - degree(l) = ishft(degree(l),-1) - if (degree(l) < 3) then - idx(l) = i - l = l+1 - endif - enddo - - endif - idx(0) = l-1 -end - - - - -double precision function diag_H_mat_elem(det_in,Nint) - implicit none - BEGIN_DOC - ! Computes - END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - - integer(bit_kind) :: hole(Nint,2) - integer(bit_kind) :: particle(Nint,2) - integer :: i, nexc(2), ispin - integer :: occ_particle(Nint*bit_kind_size,2) - integer :: occ_hole(Nint*bit_kind_size,2) - integer(bit_kind) :: det_tmp(Nint,2) - integer :: na, nb - - ASSERT (Nint > 0) - ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num) - - nexc(1) = 0 - nexc(2) = 0 - do i=1,Nint - hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) - hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) - particle(i,1) = iand(hole(i,1),det_in(i,1)) - particle(i,2) = iand(hole(i,2),det_in(i,2)) - hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) - hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) - nexc(1) += popcnt(hole(i,1)) - nexc(2) += popcnt(hole(i,2)) - enddo - - diag_H_mat_elem = ref_bitmask_energy - if (nexc(1)+nexc(2) == 0) then - return - endif - - !call debug_det(det_in,Nint) - integer :: tmp - call bitstring_to_list(particle(1,1), occ_particle(1,1), tmp, Nint) - ASSERT (tmp == nexc(1)) - call bitstring_to_list(particle(1,2), occ_particle(1,2), tmp, Nint) - ASSERT (tmp == nexc(2)) - call bitstring_to_list(hole(1,1), occ_hole(1,1), tmp, Nint) - ASSERT (tmp == nexc(1)) - call bitstring_to_list(hole(1,2), occ_hole(1,2), tmp, Nint) - ASSERT (tmp == nexc(2)) - - det_tmp = ref_bitmask - do ispin=1,2 - na = elec_num_tab(ispin) - nb = elec_num_tab(iand(ispin,1)+1) - do i=1,nexc(ispin) - !DIR$ FORCEINLINE - call ac_operator( occ_particle(i,ispin), ispin, det_tmp, diag_H_mat_elem, Nint,na,nb) - !DIR$ FORCEINLINE - call a_operator ( occ_hole (i,ispin), ispin, det_tmp, diag_H_mat_elem, Nint,na,nb) - enddo - enddo -end - -subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb) - use bitmasks - implicit none - BEGIN_DOC - ! Needed for diag_H_mat_elem - END_DOC - integer, intent(in) :: iorb, ispin, Nint - integer, intent(inout) :: na, nb - integer(bit_kind), intent(inout) :: key(Nint,2) - double precision, intent(inout) :: hjj - - integer :: occ(Nint*bit_kind_size,2) - integer :: other_spin - integer :: k,l,i - - ASSERT (iorb > 0) - ASSERT (ispin > 0) - ASSERT (ispin < 3) - ASSERT (Nint > 0) - - k = ishft(iorb-1,-bit_kind_shift)+1 - ASSERT (k > 0) - l = iorb - ishft(k-1,bit_kind_shift)-1 - key(k,ispin) = ibclr(key(k,ispin),l) - other_spin = iand(ispin,1)+1 - - !DIR$ FORCEINLINE - call get_occ_from_key(key,occ,Nint) - na -= 1 - - hjj -= mo_mono_elec_integral(iorb,iorb) - - ! Same spin - do i=1,na - hjj -= mo_bielec_integral_jj_anti(occ(i,ispin),iorb) - enddo - - ! Opposite spin - do i=1,nb - hjj -= mo_bielec_integral_jj(occ(i,other_spin),iorb) - enddo - -end - - -subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb) - use bitmasks - implicit none - BEGIN_DOC - ! Needed for diag_H_mat_elem - END_DOC - integer, intent(in) :: iorb, ispin, Nint - integer, intent(inout) :: na, nb - integer(bit_kind), intent(inout) :: key(Nint,2) - double precision, intent(inout) :: hjj - - integer :: occ(Nint*bit_kind_size,2) - integer :: other_spin - integer :: k,l,i - - ASSERT (iorb > 0) - ASSERT (ispin > 0) - ASSERT (ispin < 3) - ASSERT (Nint > 0) - - integer :: tmp - !DIR$ FORCEINLINE - call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) - ASSERT (tmp == elec_alpha_num) - !DIR$ FORCEINLINE - call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) - ASSERT (tmp == elec_beta_num) - - k = ishft(iorb-1,-bit_kind_shift)+1 - ASSERT (k > 0) - l = iorb - ishft(k-1,bit_kind_shift)-1 - key(k,ispin) = ibset(key(k,ispin),l) - other_spin = iand(ispin,1)+1 - - hjj += mo_mono_elec_integral(iorb,iorb) - - ! Same spin - do i=1,na - hjj += mo_bielec_integral_jj_anti(occ(i,ispin),iorb) - enddo - - ! Opposite spin - do i=1,nb - hjj += mo_bielec_integral_jj(occ(i,other_spin),iorb) - enddo - na += 1 -end - -subroutine get_occ_from_key(key,occ,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Returns a list of occupation numbers from a bitstring - END_DOC - integer(bit_kind), intent(in) :: key(Nint,2) - integer , intent(in) :: Nint - integer , intent(out) :: occ(Nint*bit_kind_size,2) - integer :: tmp - - call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) - call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) - -end - -subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - END_DOC - integer, intent(in) :: n,Nint - double precision, intent(out) :: v_0(n) - double precision, intent(in) :: u_0(n) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - integer, allocatable :: idx(:) - double precision :: hij - double precision, allocatable :: vt(:) - integer :: i,j,k,l, jj - integer :: i0, j0 - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - integer, parameter :: block_size = 157 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,vt) & - !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0) - !$OMP DO SCHEDULE(static) - do i=1,n - v_0(i) = H_jj(i) * u_0(i) - enddo - !$OMP END DO - allocate(idx(0:n), vt(n)) - Vt = 0.d0 - !$OMP DO SCHEDULE(guided) - do i=1,n - idx(0) = i - call filter_connected_davidson(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) - do jj=1,idx(0) - j = idx(jj) - if ( (dabs(u_0(j)) > 1.d-7).or.((dabs(u_0(i)) > 1.d-7)) ) then - call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) - vt (i) = vt (i) + hij*u_0(j) - vt (j) = vt (j) + hij*u_0(i) - endif - enddo - enddo - !$OMP END DO - !$OMP CRITICAL - do i=1,n - v_0(i) = v_0(i) + vt(i) - enddo - !$OMP END CRITICAL - deallocate(idx,vt) - !$OMP END PARALLEL -end - - - -BEGIN_PROVIDER [ integer, N_con_int ] - implicit none - BEGIN_DOC - ! Number of integers to represent the connections between determinants - END_DOC - N_con_int = 1 + ishft(N_det-1,-11) -END_PROVIDER - -BEGIN_PROVIDER [ integer*8, det_connections, (N_con_int,N_det) ] - implicit none - BEGIN_DOC - ! Build connection proxy between determinants - END_DOC - integer :: i,j - integer :: degree - integer :: j_int, j_k, j_l - integer, allocatable :: idx(:) - integer :: thread_num - integer :: omp_get_thread_num - - PROVIDE progress_bar - call start_progress(N_det,'Det connections',0.d0) - - select case(N_int) - - case(1) - - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections, & - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & - popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) - if (degree < 5) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - case(2) - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & - popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & - popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & - popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) - if (degree < 5) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - case(3) - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & - popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & - popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & - popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) + & - popcnt(xor( psi_det(3,1,i),psi_det(3,1,j))) + & - popcnt(xor( psi_det(3,2,i),psi_det(3,2,j))) - if (degree < 5) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - case default - - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - !DIR$ FORCEINLINE - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if (degree < 3) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - end select - call stop_progress - -END_PROVIDER - diff --git a/src/Dets/spindeterminants.ezfio_config b/src/Dets/spindeterminants.ezfio_config deleted file mode 100644 index 39ccb82b..00000000 --- a/src/Dets/spindeterminants.ezfio_config +++ /dev/null @@ -1,17 +0,0 @@ -spindeterminants - n_det_alpha integer - n_det_beta integer - n_det integer - n_int integer - bit_kind integer - n_states integer - psi_det_alpha integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_alpha) - psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta) - psi_coef_matrix_rows integer (spindeterminants_n_det) - psi_coef_matrix_columns integer (spindeterminants_n_det) - psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) - n_svd_coefs integer - psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states) - psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states) - psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states) - diff --git a/src/Dets/spindeterminants.irp.f b/src/Dets/spindeterminants.irp.f deleted file mode 100644 index ffd28f85..00000000 --- a/src/Dets/spindeterminants.irp.f +++ /dev/null @@ -1,615 +0,0 @@ -!==============================================================================! -! ! -! Independent alpha/beta parts ! -! ! -!==============================================================================! - -use bitmasks - -integer*8 function spin_det_search_key(det,Nint) - use bitmasks - implicit none - BEGIN_DOC -! Return an integer*8 corresponding to a determinant index for searching - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: det(Nint) - integer :: i - spin_det_search_key = det(1) - do i=2,Nint - spin_det_search_key = ieor(spin_det_search_key,det(i)) - enddo -end - - -BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] - implicit none - BEGIN_DOC -! List of alpha determinants of psi_det - END_DOC - integer :: i,k - - do i=1,N_det - do k=1,N_int - psi_det_alpha(k,i) = psi_det(k,1,i) - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] - implicit none - BEGIN_DOC -! List of beta determinants of psi_det - END_DOC - integer :: i,k - - do i=1,N_det - do k=1,N_int - psi_det_beta(k,i) = psi_det(k,2,i) - enddo - enddo -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha_unique, (N_int,psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_alpha_unique ] - implicit none - BEGIN_DOC - ! Unique alpha determinants - END_DOC - - integer :: i,k - integer, allocatable :: iorder(:) - integer*8, allocatable :: bit_tmp(:) - integer*8 :: last_key - integer*8, external :: spin_det_search_key - - allocate ( iorder(N_det), bit_tmp(N_det)) - - do i=1,N_det - iorder(i) = i - bit_tmp(i) = spin_det_search_key(psi_det_alpha(1,i),N_int) - enddo - - call i8sort(bit_tmp,iorder,N_det) - - N_det_alpha_unique = 0 - last_key = 0_8 - do i=1,N_det - if (bit_tmp(i) /= last_key) then - last_key = bit_tmp(i) - N_det_alpha_unique += 1 - do k=1,N_int - psi_det_alpha_unique(k,N_det_alpha_unique) = psi_det_alpha(k,iorder(i)) - enddo - endif - enddo - - deallocate (iorder, bit_tmp) -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta_unique, (N_int,psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_beta_unique ] - implicit none - BEGIN_DOC - ! Unique beta determinants - END_DOC - - integer :: i,k - integer, allocatable :: iorder(:) - integer*8, allocatable :: bit_tmp(:) - integer*8 :: last_key - integer*8, external :: spin_det_search_key - - allocate ( iorder(N_det), bit_tmp(N_det)) - - do i=1,N_det - iorder(i) = i - bit_tmp(i) = spin_det_search_key(psi_det_beta(1,i),N_int) - enddo - - call i8sort(bit_tmp,iorder,N_det) - - N_det_beta_unique = 0 - last_key = 0_8 - do i=1,N_det - if (bit_tmp(i) /= last_key) then - last_key = bit_tmp(i) - N_det_beta_unique += 1 - do k=1,N_int - psi_det_beta_unique(k,N_det_beta_unique) = psi_det_beta(k,iorder(i)) - enddo - endif - enddo - - deallocate (iorder, bit_tmp) -END_PROVIDER - - - - - -integer function get_index_in_psi_det_alpha_unique(key,Nint) - use bitmasks - BEGIN_DOC -! Returns the index of the determinant in the ``psi_det_alpha_unique`` array - END_DOC - implicit none - - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key(Nint) - - integer :: i, ibegin, iend, istep, l - integer*8 :: det_ref, det_search - integer*8, external :: spin_det_search_key - logical :: is_in_wavefunction - - is_in_wavefunction = .False. - get_index_in_psi_det_alpha_unique = 0 - ibegin = 1 - iend = N_det_alpha_unique + 1 - - !DIR$ FORCEINLINE - det_ref = spin_det_search_key(key,Nint) - !DIR$ FORCEINLINE - det_search = spin_det_search_key(psi_det_alpha_unique(1,1),Nint) - - istep = ishft(iend-ibegin,-1) - i=ibegin+istep - do while (istep > 0) - !DIR$ FORCEINLINE - det_search = spin_det_search_key(psi_det_alpha_unique(1,i),Nint) - if ( det_search > det_ref ) then - iend = i - else if ( det_search == det_ref ) then - exit - else - ibegin = i - endif - istep = ishft(iend-ibegin,-1) - i = ibegin + istep - end do - - !DIR$ FORCEINLINE - do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) - i = i-1 - if (i == 0) then - exit - endif - enddo - i += 1 - - if (i > N_det_alpha_unique) then - return - endif - - !DIR$ FORCEINLINE - do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) - if (key(1) /= psi_det_alpha_unique(1,i)) then - continue - else - is_in_wavefunction = .True. - !DIR$ IVDEP - !DIR$ LOOP COUNT MIN(3) - do l=2,Nint - if (key(l) /= psi_det_alpha_unique(l,i)) then - is_in_wavefunction = .False. - endif - enddo - if (is_in_wavefunction) then - get_index_in_psi_det_alpha_unique = i - return - endif - endif - i += 1 - if (i > N_det_alpha_unique) then - return - endif - - enddo - -end - -integer function get_index_in_psi_det_beta_unique(key,Nint) - use bitmasks - BEGIN_DOC -! Returns the index of the determinant in the ``psi_det_beta_unique`` array - END_DOC - implicit none - - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key(Nint) - - integer :: i, ibegin, iend, istep, l - integer*8 :: det_ref, det_search - integer*8, external :: spin_det_search_key - logical :: is_in_wavefunction - - is_in_wavefunction = .False. - get_index_in_psi_det_beta_unique = 0 - ibegin = 1 - iend = N_det_beta_unique + 1 - - !DIR$ FORCEINLINE - det_ref = spin_det_search_key(key,Nint) - !DIR$ FORCEINLINE - det_search = spin_det_search_key(psi_det_beta_unique(1,1),Nint) - - istep = ishft(iend-ibegin,-1) - i=ibegin+istep - do while (istep > 0) - !DIR$ FORCEINLINE - det_search = spin_det_search_key(psi_det_beta_unique(1,i),Nint) - if ( det_search > det_ref ) then - iend = i - else if ( det_search == det_ref ) then - exit - else - ibegin = i - endif - istep = ishft(iend-ibegin,-1) - i = ibegin + istep - end do - - !DIR$ FORCEINLINE - do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) - i = i-1 - if (i == 0) then - exit - endif - enddo - i += 1 - - if (i > N_det_beta_unique) then - return - endif - - !DIR$ FORCEINLINE - do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) - if (key(1) /= psi_det_beta_unique(1,i)) then - continue - else - is_in_wavefunction = .True. - !DIR$ IVDEP - !DIR$ LOOP COUNT MIN(3) - do l=2,Nint - if (key(l) /= psi_det_beta_unique(l,i)) then - is_in_wavefunction = .False. - endif - enddo - if (is_in_wavefunction) then - get_index_in_psi_det_beta_unique = i - return - endif - endif - i += 1 - if (i > N_det_beta_unique) then - return - endif - - enddo - -end - - -subroutine write_spindeterminants - use bitmasks - implicit none - integer*8, allocatable :: tmpdet(:,:) - integer :: N_int2 - integer :: i,j,k - integer*8 :: det_8(100) - integer(bit_kind) :: det_bk((100*8)/bit_kind) - equivalence (det_8, det_bk) - - N_int2 = (N_int*bit_kind)/8 - call ezfio_set_spindeterminants_n_det_alpha(N_det_alpha_unique) - call ezfio_set_spindeterminants_n_det_beta(N_det_beta_unique) - call ezfio_set_spindeterminants_n_det(N_det) - call ezfio_set_spindeterminants_n_int(N_int) - call ezfio_set_spindeterminants_bit_kind(bit_kind) - call ezfio_set_spindeterminants_n_states(N_states) - - allocate(tmpdet(N_int2,N_det_alpha_unique)) - do i=1,N_det_alpha_unique - do k=1,N_int - det_bk(k) = psi_det_alpha_unique(k,i) - enddo - do k=1,N_int2 - tmpdet(k,i) = det_8(k) - enddo - enddo - call ezfio_set_spindeterminants_psi_det_alpha(psi_det_alpha_unique) - deallocate(tmpdet) - - allocate(tmpdet(N_int2,N_det_beta_unique)) - do i=1,N_det_beta_unique - do k=1,N_int - det_bk(k) = psi_det_beta_unique(k,i) - enddo - do k=1,N_int2 - tmpdet(k,i) = det_8(k) - enddo - enddo - call ezfio_set_spindeterminants_psi_det_beta(psi_det_beta_unique) - deallocate(tmpdet) - - call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_svd_matrix_values) - call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_svd_matrix_rows) - call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_svd_matrix_columns) - - integer :: n_svd_coefs - double precision :: norm, f - f = 1.d0/dble(N_states) - norm = 1.d0 - do n_svd_coefs=1,N_det_alpha_unique - do k=1,N_states - norm -= psi_svd_coefs(n_svd_coefs,k)*psi_svd_coefs(n_svd_coefs,k) - enddo - if (norm < 1.d-4) then - exit - endif - enddo - n_svd_coefs -= 1 - call ezfio_set_spindeterminants_n_svd_coefs(n_svd_coefs) - - double precision, allocatable :: dtmp(:,:,:) - allocate(dtmp(N_det_alpha_unique,n_svd_coefs,N_states)) - do k=1,N_states - do j=1,n_svd_coefs - do i=1,N_det_alpha_unique - dtmp(i,j,k) = psi_svd_alpha(i,j,k) - enddo - enddo - enddo - call ezfio_set_spindeterminants_psi_svd_alpha(dtmp) - deallocate(dtmp) - - allocate(dtmp(N_det_beta_unique,n_svd_coefs,N_states)) - do k=1,N_states - do j=1,n_svd_coefs - do i=1,N_det_beta_unique - dtmp(i,j,k) = psi_svd_beta(i,j,k) - enddo - enddo - enddo - call ezfio_set_spindeterminants_psi_svd_beta(dtmp) - deallocate(dtmp) - - allocate(dtmp(n_svd_coefs,N_states,1)) - do k=1,N_states - do j=1,n_svd_coefs - dtmp(j,k,1) = psi_svd_coefs(j,k) - enddo - enddo - call ezfio_set_spindeterminants_psi_svd_coefs(dtmp) - deallocate(dtmp) - -end - - -!==============================================================================! -! ! -! Alpha x Beta Matrix ! -! ! -!==============================================================================! - -BEGIN_PROVIDER [ double precision, psi_svd_matrix_values, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer, psi_svd_matrix_rows, (N_det) ] -&BEGIN_PROVIDER [ integer, psi_svd_matrix_columns, (N_det) ] - use bitmasks - implicit none - BEGIN_DOC -! Matrix of wf coefficients. Outer product of alpha and beta determinants - END_DOC - integer :: i,j,k, l - integer(bit_kind) :: tmp_det(N_int,2) - integer :: idx - integer, external :: get_index_in_psi_det_sorted_bit - logical, external :: is_in_wavefunction - - - PROVIDE psi_coef_sorted_bit - -! l=0 -! do j=1,N_det_beta_unique -! do k=1,N_int -! tmp_det(k,2) = psi_det_beta_unique(k,j) -! enddo -! do i=1,N_det_alpha_unique -! do k=1,N_int -! tmp_det(k,1) = psi_det_alpha_unique(k,i) -! enddo -! idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) -! if (idx > 0) then -! l += 1 -! psi_svd_matrix_rows(l) = i -! psi_svd_matrix_columns(l) = j -! do k=1,N_states -! psi_svd_matrix_values(l,k) = psi_coef_sorted_bit(idx,k) -! enddo -! endif -! enddo -! enddo -! ASSERT (l == N_det) - - integer, allocatable :: iorder(:), to_sort(:) - integer, external :: get_index_in_psi_det_alpha_unique - integer, external :: get_index_in_psi_det_beta_unique - allocate(iorder(N_det), to_sort(N_det)) - do k=1,N_det - i = get_index_in_psi_det_alpha_unique(psi_det(1,1,k),N_int) - j = get_index_in_psi_det_beta_unique (psi_det(1,2,k),N_int) - do l=1,N_states - psi_svd_matrix_values(k,l) = psi_coef(k,l) - enddo - psi_svd_matrix_rows(k) = i - psi_svd_matrix_columns(k) = j - to_sort(k) = N_det_alpha_unique * (j-1) + i - iorder(k) = k - enddo - call isort(to_sort, iorder, N_det) - call iset_order(psi_svd_matrix_rows,iorder,N_det) - call iset_order(psi_svd_matrix_columns,iorder,N_det) - call dset_order(psi_svd_matrix_values,iorder,N_det) - deallocate(iorder,to_sort) -END_PROVIDER - -BEGIN_PROVIDER [ double precision, psi_svd_matrix, (N_det_alpha_unique,N_det_beta_unique,N_states) ] - implicit none - BEGIN_DOC -! Matrix of wf coefficients. Outer product of alpha and beta determinants - END_DOC - integer :: i,j,k,istate - psi_svd_matrix = 0.d0 - do k=1,N_det - i = psi_svd_matrix_rows(k) - j = psi_svd_matrix_columns(k) - do istate=1,N_states - psi_svd_matrix(i,j,istate) = psi_svd_matrix_values(k,istate) - enddo - enddo -END_PROVIDER - -subroutine create_wf_of_psi_svd_matrix - use bitmasks - implicit none - BEGIN_DOC -! Matrix of wf coefficients. Outer product of alpha and beta determinants - END_DOC - integer :: i,j,k - integer(bit_kind) :: tmp_det(N_int,2) - integer :: idx - integer, external :: get_index_in_psi_det_sorted_bit - logical, external :: is_in_wavefunction - double precision :: norm(N_states) - - call generate_all_alpha_beta_det_products - norm = 0.d0 - do j=1,N_det_beta_unique - do k=1,N_int - tmp_det(k,2) = psi_det_beta_unique(k,j) - enddo - do i=1,N_det_alpha_unique - do k=1,N_int - tmp_det(k,1) = psi_det_alpha_unique(k,i) - enddo - idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) - if (idx > 0) then - do k=1,N_states - psi_coef_sorted_bit(idx,k) = psi_svd_matrix(i,j,k) - norm(k) += psi_svd_matrix(i,j,k) - enddo - endif - enddo - enddo - do k=1,N_states - norm(k) = 1.d0/dsqrt(norm(k)) - do i=1,N_det - psi_coef_sorted_bit(i,k) = psi_coef_sorted_bit(i,k)*norm(k) - enddo - enddo - psi_det = psi_det_sorted_bit - psi_coef = psi_coef_sorted_bit - TOUCH psi_det psi_coef - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - norm(1) = 0.d0 - do i=1,N_det - norm(1) += psi_average_norm_contrib_sorted(i) - if (norm(1) >= 0.999999d0) then - exit - endif - enddo - N_det = min(i,N_det) - SOFT_TOUCH psi_det psi_coef N_det - -end - -subroutine generate_all_alpha_beta_det_products - implicit none - BEGIN_DOC -! Create a wave function from all possible alpha x beta determinants - END_DOC - integer :: i,j,k,l - integer :: idx, iproc - integer, external :: get_index_in_psi_det_sorted_bit - integer(bit_kind), allocatable :: tmp_det(:,:,:) - logical, external :: is_in_wavefunction - integer, external :: omp_get_thread_num - - !$OMP PARALLEL DEFAULT(NONE) SHARED(psi_coef_sorted_bit,N_det_beta_unique,& - !$OMP N_det_alpha_unique, N_int, psi_det_alpha_unique, psi_det_beta_unique,& - !$OMP N_det) & - !$OMP PRIVATE(i,j,k,l,tmp_det,idx,iproc) - !$ iproc = omp_get_thread_num() - allocate (tmp_det(N_int,2,N_det_alpha_unique)) - !$OMP DO - do j=1,N_det_beta_unique - l = 1 - do i=1,N_det_alpha_unique - do k=1,N_int - tmp_det(k,1,l) = psi_det_alpha_unique(k,i) - tmp_det(k,2,l) = psi_det_beta_unique (k,j) - enddo - if (.not.is_in_wavefunction(tmp_det(1,1,l),N_int,N_det)) then - l = l+1 - endif - enddo - call fill_H_apply_buffer_no_selection(l-1, tmp_det, N_int, iproc) - enddo - !$OMP END DO NOWAIT - deallocate(tmp_det) - !$OMP END PARALLEL - deallocate (tmp_det) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH psi_det psi_coef N_det -end - - BEGIN_PROVIDER [ double precision, psi_svd_alpha, (N_det_alpha_unique,N_det_alpha_unique,N_states) ] -&BEGIN_PROVIDER [ double precision, psi_svd_beta , (N_det_beta_unique,N_det_beta_unique,N_states) ] -&BEGIN_PROVIDER [ double precision, psi_svd_coefs, (N_det_beta_unique,N_states) ] - implicit none - BEGIN_DOC - ! SVD wave function - END_DOC - - integer :: lwork, info, istate - double precision, allocatable :: work(:), tmp(:,:), copy(:,:) - allocate (work(1),tmp(N_det_beta_unique,N_det_beta_unique), & - copy(size(psi_svd_matrix,1),size(psi_svd_matrix,2))) - - do istate = 1,N_states - copy(:,:) = psi_svd_matrix(:,:,istate) - lwork=-1 - call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & - copy, size(copy,1), & - psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & - size(psi_svd_alpha,1), & - tmp, size(psi_svd_beta,2), & - work, lwork, info) - lwork = work(1) - deallocate(work) - allocate(work(lwork)) - call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & - copy, size(copy,1), & - psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & - size(psi_svd_alpha,1), & - tmp, size(psi_svd_beta,2), & - work, lwork, info) - deallocate(work) - if (info /= 0) then - print *, irp_here//': error in det SVD' - stop 1 - endif - integer :: i,j - do j=1,N_det_beta_unique - do i=1,N_det_beta_unique - psi_svd_beta(i,j,istate) = tmp(j,i) - enddo - enddo - deallocate(tmp,copy) - enddo - -END_PROVIDER - - diff --git a/src/Dets/truncate_wf.irp.f b/src/Dets/truncate_wf.irp.f deleted file mode 100644 index f867ad7e..00000000 --- a/src/Dets/truncate_wf.irp.f +++ /dev/null @@ -1,18 +0,0 @@ -program cisd - implicit none - integer :: i,k - - - double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) - integer :: N_st, degree - N_det=10000 - do i=1,N_det - do k=1,N_int - psi_det(k,1,i) = psi_det_sorted(k,1,i) - psi_det(k,2,i) = psi_det_sorted(k,2,i) - enddo - psi_coef(k,:) = psi_coef_sorted(k,:) - enddo - TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det - call save_wavefunction -end diff --git a/src/Dets/utils.irp.f b/src/Dets/utils.irp.f deleted file mode 100644 index 22faee83..00000000 --- a/src/Dets/utils.irp.f +++ /dev/null @@ -1,20 +0,0 @@ -BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] - implicit none - BEGIN_DOC - ! H matrix on the basis of the slater determinants defined by psi_det - END_DOC - integer :: i,j - double precision :: hij - call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij) & - !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) - do i =1,N_det - do j =i,N_det - call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) - H_matrix_all_dets(i,j) = hij - H_matrix_all_dets(j,i) = hij - enddo - enddo - !$OMP END PARALLEL DO -END_PROVIDER - diff --git a/src/FCIdump/NEEDED_MODULES b/src/FCIdump/NEEDED_MODULES index 7f2f0ca8..c5e6c2d3 100644 --- a/src/FCIdump/NEEDED_MODULES +++ b/src/FCIdump/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/FCIdump/README.rst b/src/FCIdump/README.rst index 1fdd9660..bf39955b 100644 --- a/src/FCIdump/README.rst +++ b/src/FCIdump/README.rst @@ -24,7 +24,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `MonoInts `_ diff --git a/src/Full_CI/NEEDED_MODULES b/src/Full_CI/NEEDED_MODULES index 5e074d3c..f225090c 100644 --- a/src/Full_CI/NEEDED_MODULES +++ b/src/Full_CI/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Generators_full Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_full Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils diff --git a/src/Full_CI/README.rst b/src/Full_CI/README.rst index 0b37ca69..53fdc1d5 100644 --- a/src/Full_CI/README.rst +++ b/src/Full_CI/README.rst @@ -27,7 +27,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Generators_full `_ diff --git a/src/Generators_CAS/NEEDED_MODULES b/src/Generators_CAS/NEEDED_MODULES index 7f2f0ca8..c5e6c2d3 100644 --- a/src/Generators_CAS/NEEDED_MODULES +++ b/src/Generators_CAS/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Generators_CAS/README.rst b/src/Generators_CAS/README.rst index 53e8c5a0..3fca0916 100644 --- a/src/Generators_CAS/README.rst +++ b/src/Generators_CAS/README.rst @@ -46,7 +46,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `MonoInts `_ diff --git a/src/Generators_CAS/generators.irp.f b/src/Generators_CAS/generators.irp.f index 511877a0..f47341de 100644 --- a/src/Generators_CAS/generators.irp.f +++ b/src/Generators_CAS/generators.irp.f @@ -7,7 +7,7 @@ BEGIN_PROVIDER [ integer, N_det_generators ] END_DOC integer :: i,k,l logical :: good - call write_time(output_dets) + call write_time(output_determinants) N_det_generators = 0 do i=1,N_det do l=1,n_cas_bitmask @@ -28,7 +28,7 @@ BEGIN_PROVIDER [ integer, N_det_generators ] endif enddo N_det_generators = max(N_det_generators,1) - call write_int(output_dets,N_det_generators,'Number of generators') + call write_int(output_determinants,N_det_generators,'Number of generators') END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] diff --git a/src/Generators_full/NEEDED_MODULES b/src/Generators_full/NEEDED_MODULES index 7d973bce..a848a687 100644 --- a/src/Generators_full/NEEDED_MODULES +++ b/src/Generators_full/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Utils diff --git a/src/Generators_full/README.rst b/src/Generators_full/README.rst index a8492dbc..79f4037c 100644 --- a/src/Generators_full/README.rst +++ b/src/Generators_full/README.rst @@ -11,25 +11,25 @@ Documentation .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -`degree_max_generators `_ +`degree_max_generators `_ Max degree of excitation (respect to HF) of the generators -`n_det_generators `_ +`n_det_generators `_ For Single reference wave functions, the number of generators is 1 : the Hartree-Fock determinant -`psi_coef_generators `_ +`psi_coef_generators `_ For Single reference wave functions, the generator is the Hartree-Fock determinant -`psi_det_generators `_ +`psi_det_generators `_ For Single reference wave functions, the generator is the Hartree-Fock determinant -`select_max `_ +`select_max `_ Memo to skip useless selectors -`size_select_max `_ +`size_select_max `_ Size of the select_max array @@ -43,7 +43,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/Generators_full/generators.irp.f b/src/Generators_full/generators.irp.f index 4d261acd..a61fc5c5 100644 --- a/src/Generators_full/generators.irp.f +++ b/src/Generators_full/generators.irp.f @@ -1,17 +1,5 @@ use bitmasks -BEGIN_SHELL [ /usr/bin/python ] -from ezfio_with_default import EZFIO_Provider -T = EZFIO_Provider() -T.set_type ( "double precision" ) -T.set_name ( "threshold_generators" ) -T.set_doc ( "Percentage of the norm of the state-averaged wave function to consider for the generators" ) -T.set_ezfio_dir ( "determinants" ) -T.set_ezfio_name( "threshold_generators" ) -T.set_output ( "output_dets" ) -print T -END_SHELL - BEGIN_PROVIDER [ integer, N_det_generators ] implicit none BEGIN_DOC @@ -20,7 +8,7 @@ BEGIN_PROVIDER [ integer, N_det_generators ] END_DOC integer :: i double precision :: norm - call write_time(output_dets) + call write_time(output_determinants) norm = 0.d0 N_det_generators = N_det do i=1,N_det @@ -31,7 +19,7 @@ BEGIN_PROVIDER [ integer, N_det_generators ] endif enddo N_det_generators = max(N_det_generators,1) - call write_int(output_dets,N_det_generators,'Number of generators') + call write_int(output_determinants,N_det_generators,'Number of generators') END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] diff --git a/src/Generators_restart/NEEDED_MODULES b/src/Generators_restart/NEEDED_MODULES index 7f2f0ca8..c5e6c2d3 100644 --- a/src/Generators_restart/NEEDED_MODULES +++ b/src/Generators_restart/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Generators_restart/generators.irp.f b/src/Generators_restart/generators.irp.f index 2e0bc375..0a82e6f9 100644 --- a/src/Generators_restart/generators.irp.f +++ b/src/Generators_restart/generators.irp.f @@ -13,7 +13,7 @@ BEGIN_PROVIDER [ integer, N_det_generators ] N_det_generators = N_det ifirst = 1 endif - call write_int(output_dets,N_det_generators,'Number of generators') + call write_int(output_determinants,N_det_generators,'Number of generators') END_PROVIDER diff --git a/src/MP2/NEEDED_MODULES b/src/MP2/NEEDED_MODULES index 076746d1..b7a006c3 100644 --- a/src/MP2/NEEDED_MODULES +++ b/src/MP2/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils diff --git a/src/MP2/README.rst b/src/MP2/README.rst index 92d915b6..74db8039 100644 --- a/src/MP2/README.rst +++ b/src/MP2/README.rst @@ -22,7 +22,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/MRCC/NEEDED_MODULES b/src/MRCC/NEEDED_MODULES index 5e074d3c..f225090c 100644 --- a/src/MRCC/NEEDED_MODULES +++ b/src/MRCC/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Generators_full Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_full Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils diff --git a/src/MRCC/README.rst b/src/MRCC/README.rst index 702d19aa..f96f329f 100644 --- a/src/MRCC/README.rst +++ b/src/MRCC/README.rst @@ -11,7 +11,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Generators_full `_ diff --git a/src/MRCC/mrcc_utils.irp.f b/src/MRCC/mrcc_utils.irp.f index d33b7902..9b4add38 100644 --- a/src/MRCC/mrcc_utils.irp.f +++ b/src/MRCC/mrcc_utils.irp.f @@ -94,7 +94,7 @@ END_PROVIDER stop 'use Lapack' ! call davidson_diag(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed, & -! size(CI_eigenvectors_dressed,1),N_det,N_states_diag,N_int,output_Dets) +! size(CI_eigenvectors_dressed,1),N_det,N_states_diag,N_int,output_determinants) else if (diag_algorithm == "Lapack") then @@ -137,7 +137,7 @@ BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ] integer :: j character*(8) :: st - call write_time(output_Dets) + call write_time(output_determinants) do j=1,N_states_diag CI_energy_dressed(j) = CI_electronic_energy_dressed(j) + nuclear_repulsion enddo diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index efe8b8f8..80176c68 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Dets Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC +AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Determinants Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC diff --git a/src/Perturbation/NEEDED_MODULES b/src/Perturbation/NEEDED_MODULES index 4fa6ff4b..4e0f218e 100644 --- a/src/Perturbation/NEEDED_MODULES +++ b/src/Perturbation/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Properties Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Properties Utils diff --git a/src/Perturbation/selection.irp.f b/src/Perturbation/selection.irp.f index 4230293a..77313888 100644 --- a/src/Perturbation/selection.irp.f +++ b/src/Perturbation/selection.irp.f @@ -135,7 +135,7 @@ subroutine remove_small_contributions if (N_removed > 0) then N_det = N_det - N_removed SOFT_TOUCH N_det psi_det psi_coef - call write_int(output_dets,N_removed, 'Removed determinants') + call write_int(output_determinants,N_removed, 'Removed determinants') endif end diff --git a/src/Properties/NEEDED_MODULES b/src/Properties/NEEDED_MODULES index 9095dbdf..62dbbe42 100644 --- a/src/Properties/NEEDED_MODULES +++ b/src/Properties/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Selectors_full/NEEDED_MODULES b/src/Selectors_full/NEEDED_MODULES index 7d973bce..a848a687 100644 --- a/src/Selectors_full/NEEDED_MODULES +++ b/src/Selectors_full/NEEDED_MODULES @@ -1,2 +1,2 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Utils diff --git a/src/Selectors_full/README.rst b/src/Selectors_full/README.rst index aaa07bbd..2ca9380a 100644 --- a/src/Selectors_full/README.rst +++ b/src/Selectors_full/README.rst @@ -123,38 +123,38 @@ Documentation .br n_double_selectors = number of double excitations in the selectors determinants -`n_det_selectors `_ +`n_det_selectors `_ For Single reference wave functions, the number of selectors is 1 : the Hartree-Fock determinant -`psi_selectors `_ +`psi_selectors `_ Determinants on which we apply for perturbation. -`psi_selectors_ab `_ +`psi_selectors_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_selectors_coef `_ +`psi_selectors_coef `_ Determinants on which we apply for perturbation. -`psi_selectors_coef_ab `_ +`psi_selectors_coef_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_selectors_diag_h_mat `_ +`psi_selectors_diag_h_mat `_ Diagonal elements of the H matrix for each selectors -`psi_selectors_next_ab `_ +`psi_selectors_next_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_selectors_size `_ +`psi_selectors_size `_ Undocumented @@ -168,7 +168,7 @@ Needed Modules * `AOs `_ * `Bielec_integrals `_ * `Bitmask `_ -* `Dets `_ +* `Determinants `_ * `Electrons `_ * `Ezfio_files `_ * `Hartree_Fock `_ diff --git a/src/Selectors_full/selectors.irp.f b/src/Selectors_full/selectors.irp.f index 986241f5..73ae6371 100644 --- a/src/Selectors_full/selectors.irp.f +++ b/src/Selectors_full/selectors.irp.f @@ -1,17 +1,5 @@ use bitmasks -BEGIN_SHELL [ /usr/bin/python ] -from ezfio_with_default import EZFIO_Provider -T = EZFIO_Provider() -T.set_type ( "double precision" ) -T.set_name ( "threshold_selectors" ) -T.set_doc ( "Percentage of the norm of the state-averaged wave function to consider for the selectors" ) -T.set_ezfio_dir ( "determinants" ) -T.set_ezfio_name( "threshold_selectors" ) -T.set_output ( "output_dets" ) -print T -END_SHELL - BEGIN_PROVIDER [ integer, psi_selectors_size ] implicit none psi_selectors_size = psi_det_size @@ -25,7 +13,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors] END_DOC integer :: i double precision :: norm - call write_time(output_dets) + call write_time(output_determinants) norm = 0.d0 N_det_selectors = N_det do i=1,N_det @@ -36,7 +24,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors] endif enddo N_det_selectors = max(N_det_selectors,1) - call write_int(output_dets,N_det_selectors,'Number of selectors') + call write_int(output_determinants,N_det_selectors,'Number of selectors') END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ] diff --git a/src/Selectors_no_sorted/NEEDED_MODULES b/src/Selectors_no_sorted/NEEDED_MODULES index 7f2f0ca8..c5e6c2d3 100644 --- a/src/Selectors_no_sorted/NEEDED_MODULES +++ b/src/Selectors_no_sorted/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask Dets Electrons Ezfio_files MonoInts MOs Nuclei Output Utils +AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Selectors_no_sorted/selectors.irp.f b/src/Selectors_no_sorted/selectors.irp.f index d6c20804..8080e99c 100644 --- a/src/Selectors_no_sorted/selectors.irp.f +++ b/src/Selectors_no_sorted/selectors.irp.f @@ -15,11 +15,11 @@ BEGIN_PROVIDER [ integer, N_det_selectors] END_DOC integer :: i double precision :: norm - call write_time(output_dets) + call write_time(output_determinants) norm = 0.d0 N_det_selectors = N_det N_det_selectors = max(N_det_selectors,1) - call write_int(output_dets,N_det_selectors,'Number of selectors') + call write_int(output_determinants,N_det_selectors,'Number of selectors') END_PROVIDER From 3e2a3dfe0e9562712e59035a1366f21cb30d2b89 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 15:41:19 +0200 Subject: [PATCH 30/70] Put ezfio_filanme in output_ --- src/Output/NEEDED_MODULES | 2 +- src/Output/output.irp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Output/NEEDED_MODULES b/src/Output/NEEDED_MODULES index 5d0065cc..f684b5aa 100644 --- a/src/Output/NEEDED_MODULES +++ b/src/Output/NEEDED_MODULES @@ -1 +1 @@ -Utils +Utils Ezfio_files diff --git a/src/Output/output.irp.f b/src/Output/output.irp.f index d227dda8..85f5cc0e 100644 --- a/src/Output/output.irp.f +++ b/src/Output/output.irp.f @@ -19,7 +19,7 @@ BEGIN_SHELL [ /bin/bash ] BEGIN_DOC ! Output file for $NAME END_DOC - PROVIDE output_wall_time_0 output_cpu_time_0 + PROVIDE output_wall_time_0 output_cpu_time_0 ezfio_filename integer :: getUnitAndOpen call ezfio_set_output_empty(.False.) IRP_IF COARRAY From 242f7b0612bac8054bb7985de720de35907a0b3e Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 16:45:06 +0200 Subject: [PATCH 31/70] Add H_apply_template.f --- scripts/ezfio_interface/ei_handler.py | 1 - src/Determinants/H_apply_template.f | 542 ++++++++++++++++++++++++++ 2 files changed, 542 insertions(+), 1 deletion(-) create mode 100644 src/Determinants/H_apply_template.f diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index e5c08895..6d18d071 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -278,7 +278,6 @@ def get_dict_config_file(config_file_path, module_lower): try: d[pvd]["default"] = is_bool(default_raw) - print is_bool(default_raw) except TypeError: d[pvd]["default"] = Type(None, default_raw, default_raw) diff --git a/src/Determinants/H_apply_template.f b/src/Determinants/H_apply_template.f new file mode 100644 index 00000000..a9a282ae --- /dev/null +++ b/src/Determinants/H_apply_template.f @@ -0,0 +1,542 @@ +subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_generator, iproc_in $parameters ) + use omp_lib + use bitmasks + implicit none + BEGIN_DOC + ! Generate all double excitations of key_in using the bit masks of holes and + ! particles. + ! Assume N_int is already provided. + END_DOC + integer,parameter :: size_max = $size_max + $declarations + integer ,intent(in) :: i_generator + integer(bit_kind),intent(in) :: key_in(N_int,2) + integer(bit_kind),allocatable :: keys_out(:,:,:) + integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2) + integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2) + integer, intent(in) :: iproc_in + integer(bit_kind), allocatable :: hole_save(:,:) + integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:) + integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:) + integer :: ii,i,jj,j,k,ispin,l + integer, allocatable :: occ_particle(:,:), occ_hole(:,:) + integer, allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer :: kk,pp,other_spin,key_idx + integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) + integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) + + double precision :: mo_bielec_integral + logical :: is_a_two_holes_two_particles + integer, allocatable :: ia_ja_pairs(:,:,:) + integer, allocatable :: ib_jb_pairs(:,:) + double precision :: diag_H_mat_elem + integer :: iproc + integer(omp_lock_kind), save :: lck, ifirst=0 + if (ifirst == 0) then +!$ call omp_init_lock(lck) + ifirst=1 + endif + + logical :: check_double_excitation + check_double_excitation = .True. + iproc = iproc_in + + + $initialization + + $omp_parallel +!$ iproc = omp_get_thread_num() + allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & + key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& + particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & + occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& + occ_hole_tmp(N_int*bit_kind_size,2)) + $init_thread + + + + !!!! First couple hole particle + do j = 1, N_int + hole(j,1) = iand(hole_1(j,1),key_in(j,1)) + hole(j,2) = iand(hole_1(j,2),key_in(j,2)) + particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) + particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) + enddo + call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) + call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) + call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int) + call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), & + ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num)) + + do ispin=1,2 + i=0 + do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole + i_a = occ_hole(ii,ispin) + ASSERT (i_a > 0) + ASSERT (i_a <= mo_tot_num) + + do jj=1,N_elec_in_key_part_1(ispin) !particle + j_a = occ_particle(jj,ispin) + ASSERT (j_a > 0) + ASSERT (j_a <= mo_tot_num) + i += 1 + ia_ja_pairs(1,i,ispin) = i_a + ia_ja_pairs(2,i,ispin) = j_a + enddo + enddo + ia_ja_pairs(1,0,ispin) = i + enddo + + key_idx = 0 + + integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b + integer(bit_kind) :: test(N_int,2) + double precision :: accu + logical, allocatable :: array_pairs(:,:) + allocate(array_pairs(mo_tot_num,mo_tot_num)) + accu = 0.d0 + do ispin=1,2 + other_spin = iand(ispin,1)+1 + if (abort_here) then + exit + endif + $omp_do + do ii=1,ia_ja_pairs(1,0,ispin) + if (abort_here) then + cycle + endif + i_a = ia_ja_pairs(1,ii,ispin) + ASSERT (i_a > 0) + ASSERT (i_a <= mo_tot_num) + j_a = ia_ja_pairs(2,ii,ispin) + ASSERT (j_a > 0) + ASSERT (j_a <= mo_tot_num) + hole = key_in + k = ishft(i_a-1,-bit_kind_shift)+1 + j = i_a-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + k_a = ishft(j_a-1,-bit_kind_shift)+1 + l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 + hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + + !!!! Second couple hole particle + do j = 1, N_int + hole_tmp(j,1) = iand(hole_2(j,1),hole(j,1)) + hole_tmp(j,2) = iand(hole_2(j,2),hole(j,2)) + particle_tmp(j,1) = iand(xor(particl_2(j,1),hole(j,1)),particl_2(j,1)) + particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2)) + enddo + + call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int) + call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int) + call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int) + call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int) + + ! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin) + hole_save = hole + + ! Build array of the non-zero integrals of second excitation + $filter_integrals + if (ispin == 1) then + integer :: jjj + + i=0 + do kk = 1,N_elec_in_key_hole_2(other_spin) + i_b = occ_hole_tmp(kk,other_spin) + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(other_spin) ! particule + j_b = occ_particle_tmp(jjj,other_spin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (array_pairs(i_b,j_b)) then + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + endif + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,other_spin) = ibclr(hole(k,other_spin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,other_spin) = ibset(key(k,other_spin),l) + $filter2h2p + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + if (abort_here) then + exit + endif + enddo + endif + + ! does all the mono excitations of the same spin + i=0 + do kk = 1,N_elec_in_key_hole_2(ispin) + i_b = occ_hole_tmp(kk,ispin) + if (i_b <= i_a.or.i_b == j_a) cycle + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(ispin) ! particule + j_b = occ_particle_tmp(jjj,ispin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (j_b <= j_a) cycle + if (array_pairs(i_b,j_b)) then + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + endif + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + $filter2h2p + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + if (abort_here) then + exit + endif + enddo ! kk + + enddo ! ii + $omp_enddo + enddo ! ispin + $keys_work + $deinit_thread + deallocate (ia_ja_pairs, ib_jb_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp,& + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp,& + occ_hole_tmp,array_pairs) + $omp_end_parallel + $finalization +end + +subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $parameters ) + use omp_lib + use bitmasks + implicit none + BEGIN_DOC + ! Generate all single excitations of key_in using the bit masks of holes and + ! particles. + ! Assume N_int is already provided. + END_DOC + integer,parameter :: size_max = $size_max + $declarations + integer ,intent(in) :: i_generator + integer(bit_kind),intent(in) :: key_in(N_int,2) + integer(bit_kind),intent(in) :: hole_1(N_int,2), particl_1(N_int,2) + integer, intent(in) :: iproc_in + integer(bit_kind),allocatable :: keys_out(:,:,:) + integer(bit_kind),allocatable :: hole_save(:,:) + integer(bit_kind),allocatable :: key(:,:),hole(:,:), particle(:,:) + integer(bit_kind),allocatable :: hole_tmp(:,:), particle_tmp(:,:) + integer(bit_kind),allocatable :: hole_2(:,:), particl_2(:,:) + integer :: ii,i,jj,j,k,ispin,l + integer,allocatable :: occ_particle(:,:), occ_hole(:,:) + integer,allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer,allocatable :: ib_jb_pairs(:,:) + integer :: kk,pp,other_spin,key_idx + integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) + integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) + logical :: is_a_two_holes_two_particles + + integer, allocatable :: ia_ja_pairs(:,:,:) + logical, allocatable :: array_pairs(:,:) + double precision :: diag_H_mat_elem + integer(omp_lock_kind), save :: lck, ifirst=0 + integer :: iproc + + logical :: check_double_excitation + iproc = iproc_in + + check_double_excitation = .True. + $check_double_excitation + + + if (ifirst == 0) then + ifirst=1 +!$ call omp_init_lock(lck) + endif + + $initialization + + $omp_parallel +!$ iproc = omp_get_thread_num() + allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & + key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& + particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & + occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& + occ_hole_tmp(N_int*bit_kind_size,2)) + $init_thread + !!!! First couple hole particle + do j = 1, N_int + hole(j,1) = iand(hole_1(j,1),key_in(j,1)) + hole(j,2) = iand(hole_1(j,2),key_in(j,2)) + particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) + particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) + enddo + + call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) + call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) + call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int) + call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2)) + + do ispin=1,2 + i=0 + do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole + i_a = occ_hole(ii,ispin) + do jj=1,N_elec_in_key_part_1(ispin) !particule + j_a = occ_particle(jj,ispin) + i += 1 + ia_ja_pairs(1,i,ispin) = i_a + ia_ja_pairs(2,i,ispin) = j_a + enddo + enddo + ia_ja_pairs(1,0,ispin) = i + enddo + + key_idx = 0 + + integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b + integer(bit_kind) :: test(N_int,2) + double precision :: accu + accu = 0.d0 + do ispin=1,2 + other_spin = iand(ispin,1)+1 + $omp_do + do ii=1,ia_ja_pairs(1,0,ispin) + i_a = ia_ja_pairs(1,ii,ispin) + j_a = ia_ja_pairs(2,ii,ispin) + hole = key_in + k = ishft(i_a-1,-bit_kind_shift)+1 + j = i_a-ishft(k-1,bit_kind_shift)-1 + $filterhole + hole(k,ispin) = ibclr(hole(k,ispin),j) + k_a = ishft(j_a-1,-bit_kind_shift)+1 + l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 + $filterparticle + hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + $filter2h2p + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = hole(k,1) + keys_out(k,2,key_idx) = hole(k,2) + enddo + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + enddo ! ii + $omp_enddo + enddo ! ispin + $keys_work + $deinit_thread + deallocate (ia_ja_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp,& + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp,& + occ_hole_tmp) + $omp_end_parallel + $finalization + +end + + +subroutine $subroutine($params_main) + implicit none + use omp_lib + use bitmasks + BEGIN_DOC + ! Calls H_apply on the HF determinant and selects all connected single and double + ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + END_DOC + + $decls_main + + integer :: i_generator, nmax + double precision :: wall_0, wall_1 + integer(omp_lock_kind) :: lck + integer(bit_kind), allocatable :: mask(:,:,:) + integer :: ispin, k + integer :: iproc + + $initialization + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + + + nmax = mod( N_det_generators,nproc ) + + + !$ call omp_init_lock(lck) + call start_progress(N_det_generators,'Selection (norm)',0.d0) + + call wall_time(wall_0) + + iproc = 0 + allocate( mask(N_int,2,6) ) + do i_generator=1,nmax + + progress_bar(1) = i_generator + + if (abort_here) then + exit + endif + $skip + + ! Create bit masks for holes and particles + do ispin=1,2 + do k=1,N_int + mask(k,ispin,s_hole) = & + iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + enddo + enddo + if($do_double_excitations)then + call $subroutine_diexc(psi_det_generators(1,1,i_generator), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + i_generator, iproc $params_post) + endif + if($do_mono_excitations)then + call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + i_generator, iproc $params_post) + endif + call wall_time(wall_1) + $printout_always + if (wall_1 - wall_0 > 2.d0) then + $printout_now + wall_0 = wall_1 + endif + enddo + + deallocate( mask ) + + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc) + call wall_time(wall_0) + !$ iproc = omp_get_thread_num() + allocate( mask(N_int,2,6) ) + !$OMP DO SCHEDULE(dynamic,1) + do i_generator=nmax+1,N_det_generators + if (iproc == 0) then + progress_bar(1) = i_generator + endif + if (abort_here) then + cycle + endif + $skip + + ! Create bit masks for holes and particles + do ispin=1,2 + do k=1,N_int + mask(k,ispin,s_hole) = & + iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not (psi_det_generators(k,ispin,i_generator)) ) + enddo + enddo + + if($do_double_excitations)then + call $subroutine_diexc(psi_det_generators(1,1,i_generator), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + i_generator, iproc $params_post) + endif + if($do_mono_excitations)then + call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + i_generator, iproc $params_post) + endif + !$ call omp_set_lock(lck) + call wall_time(wall_1) + $printout_always + if (wall_1 - wall_0 > 2.d0) then + $printout_now + wall_0 = wall_1 + endif + !$ call omp_unset_lock(lck) + enddo + !$OMP END DO + deallocate( mask ) + !$OMP END PARALLEL + !$ call omp_destroy_lock(lck) + + abort_here = abort_all + call stop_progress + + $copy_buffer + $generate_psi_guess + +end + From 952e3f2954737f69b083b8f4979b0f869b1fcd31 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 16:58:16 +0200 Subject: [PATCH 32/70] Update README.rst --- src/Output/README.rst | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Output/README.rst b/src/Output/README.rst index adcae302..7b510fc1 100644 --- a/src/Output/README.rst +++ b/src/Output/README.rst @@ -32,6 +32,7 @@ Needed Modules .. NEEDED_MODULES file. * `Utils `_ +* `Ezfio_files `_ Documentation ============= From 8054b1e58ace6286a628fad6983c7084ee7a946e Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 17:17:36 +0200 Subject: [PATCH 33/70] New version of int.f90 for big alpha but not to much --- src/MonoInts/int.f90 | 70 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 62 insertions(+), 8 deletions(-) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index c7d2ac84..85b5c71e 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -140,7 +140,7 @@ end ! __ __ _ __ ___ ___ _ _ __| | ___ ! \ \ / / | '_ \/ __|/ _ \ | | |/ _` |/ _ \ ! \ V / | |_) \__ \ __/ |_| | (_| | (_) | -! \_/ | .__/|___/\___|\__,_|\__,_|\___/ +! \_/ | .__/|___/\___|\__,_|\____|\___/ ! | | ! |_| @@ -200,7 +200,7 @@ double precision, intent(in) :: v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_ double precision :: fourpi,f,prod,prodp,binom,accu,bigR,bigI,ylm double precision :: theta_AC0,phi_AC0,theta_BC0,phi_BC0,ac,bc,big -double precision :: areal,freal,breal,t1,t2,int_prod_bessel +double precision :: areal,freal,breal,t1,t2,int_prod_bessel, int_prod_bessel_num_soph_p double precision :: arg integer :: ntot,ntotA,m,mu,mup,k1,k2,k3,ntotB,k1p,k2p,k3p,lambda,lambdap,ktot @@ -270,7 +270,9 @@ if(ac.eq.0.d0.and.bc.eq.0.d0)then do m=-l,l prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) - accu=accu+prod*prodp*v_kl(k,l)*freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal) + + accu=accu+prod*prodp*v_kl(k,l)*int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal,arg) + enddo enddo enddo @@ -303,7 +305,7 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then do k=1,kmax do l=0,lmax array_R(ktot,k,l,lambda,lambdap)= freal & - *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal) + *int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal,arg) enddo enddo enddo @@ -426,8 +428,8 @@ else if(ac.eq.0.d0.and.bc.ne.0.d0)then do l=0,lmax array_R(ktot,k,l,0,lambdap)= freal & - *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal) - enddo + * int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal,arg) + enddo enddo enddo enddo @@ -513,8 +515,7 @@ else if(ac.ne.0.d0.and.bc.eq.0.d0)then do l=0,lmax array_R(ktot,k,l,lambda,0)= freal & - *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal) - + * int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal,arg) enddo enddo enddo @@ -1974,6 +1975,59 @@ end stop 'pb in int_prod_bessel!!' end + + double precision function int_prod_bessel_num_soph_p(l,gam,n,m,a,b,arg) + implicit none + integer n,m,l + double precision gam,a,b,arg,arg_new + double precision bessel_mod,factor +logical not_done +double precision bigA,xold,x,dx,accu,intnew,intold,intold2,u,v,freal +integer iter +double precision n0,nI,i,eps + u=(a+b)/(2.d0*dsqrt(gam)) + arg_new=u**2-arg + freal=dexp(arg_new) + v=u/dsqrt(gam) + +bigA=v+dsqrt(-dlog(1.d-15)/gam) +n0=5 +accu=0.d0 +dx=bigA/(n0-1.d0) +iter=0 +do i=1.d0,n0 + x=(i-1.d0)*dx + accu=accu+x**l*dexp(-gam*(x-v)**2)*bessel_mod(a*x,n)*bessel_mod(b*x,m)*dexp(-(a+b)*x) +enddo +accu=accu*freal +intold=accu*dx + +eps=1.d-08 +nI=n0-1.d0 +dx=dx/2.d0 +not_done=.true. + +do while(not_done) + iter=iter+1 + accu=0.d0 + do i=1.d0,nI + x=dx+(i-1.d0)*2.d0*dx + accu=accu+dx*x**l*dexp(-gam*(x-v)**2)*bessel_mod(a*x,n)*bessel_mod(b*x,m)*dexp(-(a+b)*x) + enddo + accu=accu*freal + intnew=intold/2.d0+accu + if(iter.gt.1.and.dabs(intnew-intold).lt.eps.and.dabs(intnew-intold2).lt.eps)then + not_done=.false. + else + intold2=intold + intold=intnew + dx=dx/2.d0 + nI=2.d0*nI + endif +enddo +int_prod_bessel_num_soph_p=intold +end + !! Calculation of !! !! I= \int dx x**l *exp(-gam*x**2) M_n(ax) From 67a44ee43cc96113c41679af9bf0545c28c8f7d7 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 17:21:27 +0200 Subject: [PATCH 34/70] Add all the mising file... --- ocaml/Input_determinants.ml | 32 +- src/Determinants/ASSUMPTIONS.rst | 7 + src/Determinants/EZFIO.cfg | 100 ++ src/Determinants/H_apply.irp.f | 229 +++ src/Determinants/Makefile | 6 + src/Determinants/NEEDED_MODULES | 1 + src/Determinants/README.rst | 696 +++++++++ src/Determinants/SC2.irp.f | 215 +++ src/Determinants/connected_to_ref.irp.f | 357 +++++ src/Determinants/create_excitations.irp.f | 36 + src/Determinants/davidson.irp.f | 418 ++++++ src/Determinants/density_matrix.irp.f | 214 +++ src/Determinants/det_svd.irp.f | 61 + src/Determinants/determinants.irp.f | 9 - src/Determinants/determinants_bitmasks.irp.f | 57 + src/Determinants/diagonalize_CI.irp.f | 109 ++ src/Determinants/diagonalize_CI_SC2.irp.f | 59 + src/Determinants/diagonalize_CI_mono.irp.f | 72 + src/Determinants/excitations_utils.irp.f | 16 + src/Determinants/filter_connected.irp.f | 611 ++++++++ src/Determinants/guess_doublet.irp.f | 79 + src/Determinants/guess_singlet.irp.f | 44 + src/Determinants/guess_triplet.irp.f | 48 + src/Determinants/occ_pattern.irp.f | 339 +++++ src/Determinants/options.irp.f | 22 + .../program_beginer_determinants.irp.f | 138 ++ src/Determinants/psi_cas.irp.f | 114 ++ src/Determinants/ref_bitmask.irp.f | 57 + src/Determinants/s2.irp.f | 106 ++ src/Determinants/save_for_casino.irp.f | 268 ++++ src/Determinants/save_for_qmcchem.irp.f | 51 + src/Determinants/save_natorb.irp.f | 6 + src/Determinants/slater_rules.irp.f | 1301 +++++++++++++++++ .../spindeterminants.ezfio_config | 17 + src/Determinants/spindeterminants.irp.f | 615 ++++++++ src/Determinants/truncate_wf.irp.f | 18 + src/Determinants/utils.irp.f | 20 + src/Properties/EZFIO.cfg | 5 + 38 files changed, 6527 insertions(+), 26 deletions(-) create mode 100644 src/Determinants/ASSUMPTIONS.rst create mode 100644 src/Determinants/EZFIO.cfg create mode 100644 src/Determinants/H_apply.irp.f create mode 100644 src/Determinants/Makefile create mode 100644 src/Determinants/NEEDED_MODULES create mode 100644 src/Determinants/README.rst create mode 100644 src/Determinants/SC2.irp.f create mode 100644 src/Determinants/connected_to_ref.irp.f create mode 100644 src/Determinants/create_excitations.irp.f create mode 100644 src/Determinants/davidson.irp.f create mode 100644 src/Determinants/density_matrix.irp.f create mode 100644 src/Determinants/det_svd.irp.f create mode 100644 src/Determinants/determinants_bitmasks.irp.f create mode 100644 src/Determinants/diagonalize_CI.irp.f create mode 100644 src/Determinants/diagonalize_CI_SC2.irp.f create mode 100644 src/Determinants/diagonalize_CI_mono.irp.f create mode 100644 src/Determinants/excitations_utils.irp.f create mode 100644 src/Determinants/filter_connected.irp.f create mode 100644 src/Determinants/guess_doublet.irp.f create mode 100644 src/Determinants/guess_singlet.irp.f create mode 100644 src/Determinants/guess_triplet.irp.f create mode 100644 src/Determinants/occ_pattern.irp.f create mode 100644 src/Determinants/options.irp.f create mode 100644 src/Determinants/program_beginer_determinants.irp.f create mode 100644 src/Determinants/psi_cas.irp.f create mode 100644 src/Determinants/ref_bitmask.irp.f create mode 100644 src/Determinants/s2.irp.f create mode 100644 src/Determinants/save_for_casino.irp.f create mode 100644 src/Determinants/save_for_qmcchem.irp.f create mode 100644 src/Determinants/save_natorb.irp.f create mode 100644 src/Determinants/slater_rules.irp.f create mode 100644 src/Determinants/spindeterminants.ezfio_config create mode 100644 src/Determinants/spindeterminants.irp.f create mode 100644 src/Determinants/truncate_wf.irp.f create mode 100644 src/Determinants/utils.irp.f create mode 100644 src/Properties/EZFIO.cfg diff --git a/ocaml/Input_determinants.ml b/ocaml/Input_determinants.ml index df046231..fa08e72b 100644 --- a/ocaml/Input_determinants.ml +++ b/ocaml/Input_determinants.ml @@ -10,10 +10,10 @@ module Determinants : sig (* Generate type *) type t = { - n_det_max_jacobi : Strictly_positive_int.t; + n_det_max_jacobi : int; threshold_generators : Threshold.t; threshold_selectors : Threshold.t; - n_states : Strictly_positive_int.t; + n_states : States_number.t; s2_eig : bool; read_wf : bool; only_single_double_dm : bool; @@ -28,10 +28,10 @@ end = struct (* Generate type *) type t = { - n_det_max_jacobi : Strictly_positive_int.t; + n_det_max_jacobi : int; threshold_generators : Threshold.t; threshold_selectors : Threshold.t; - n_states : Strictly_positive_int.t; + n_states : States_number.t; s2_eig : bool; read_wf : bool; only_single_double_dm : bool; @@ -52,12 +52,10 @@ end = struct |> Ezfio.set_determinants_n_det_max_jacobi ; Ezfio.get_determinants_n_det_max_jacobi () - |> Strictly_positive_int.of_int ;; (* Write snippet for n_det_max_jacobi *) - let write_n_det_max_jacobi var = - Strictly_positive_int.to_int var - |> Ezfio.set_determinants_n_det_max_jacobi + let write_n_det_max_jacobi = + Ezfio.set_determinants_n_det_max_jacobi ;; (* Read snippet for n_states *) @@ -68,11 +66,11 @@ end = struct |> Ezfio.set_determinants_n_states ; Ezfio.get_determinants_n_states () - |> Strictly_positive_int.of_int + |> States_number.of_int ;; (* Write snippet for n_states *) let write_n_states var = - Strictly_positive_int.to_int var + States_number.to_int var |> Ezfio.set_determinants_n_states ;; @@ -196,10 +194,10 @@ end = struct read_wf = %s only_single_double_dm = %s " - (Strictly_positive_int.to_string b.n_det_max_jacobi) + (Int.to_string b.n_det_max_jacobi) (Threshold.to_string b.threshold_generators) (Threshold.to_string b.threshold_selectors) - (Strictly_positive_int.to_string b.n_states) + (States_number.to_string b.n_states) (Bool.to_string b.s2_eig) (Bool.to_string b.read_wf) (Bool.to_string b.only_single_double_dm) @@ -211,11 +209,11 @@ end = struct n_det_max_jacobi = %s - Percentage of the norm of the state-averaged wave function to consider for the generators :: + Thresholds on generators (fraction of the norm) :: threshold_generators = %s - Percentage of the norm of the state-averaged wave function to consider for the selectors :: + Thresholds on selectors (fraction of the norm) :: threshold_selectors = %s @@ -231,15 +229,15 @@ end = struct read_wf = %s - If true, The One body DM is calculated with ignoing the Double <-> Doubles extra diag elements :: + If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements :: only_single_double_dm = %s " - (Strictly_positive_int.to_string b.n_det_max_jacobi) + (Int.to_string b.n_det_max_jacobi) (Threshold.to_string b.threshold_generators) (Threshold.to_string b.threshold_selectors) - (Strictly_positive_int.to_string b.n_states) + (States_number.to_string b.n_states) (Bool.to_string b.s2_eig) (Bool.to_string b.read_wf) (Bool.to_string b.only_single_double_dm) diff --git a/src/Determinants/ASSUMPTIONS.rst b/src/Determinants/ASSUMPTIONS.rst new file mode 100644 index 00000000..e9e24d09 --- /dev/null +++ b/src/Determinants/ASSUMPTIONS.rst @@ -0,0 +1,7 @@ +* The MOs are orthonormal +* All the determinants have the same number of electrons +* The determinants are orthonormal +* The number of generator determinants <= the number of determinants +* All the determinants in the H_apply buffer are supposed to be different from the + wave function determinants +* All the determinants in the H_apply buffer are supposed to be unique diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg new file mode 100644 index 00000000..32b4d5f7 --- /dev/null +++ b/src/Determinants/EZFIO.cfg @@ -0,0 +1,100 @@ +[N_states] +type: States_number +doc: Number of states to consider +interface: input +default: 1 + +[N_det_max_jacobi] +type: integer +doc: Maximum number of determinants diagonalized by Jacobi +interface: input +default: 1000 + +[n_states_diag] +type: integer +doc: n_states_diag +interface: Ocaml + +[read_wf] +type: logical +doc: If true, read the wave function from the EZFIO file +interface: input +default: False + +[only_single_double_dm] +type: logical +doc: If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements +interface: input +default: False + +[s2_eig] +type: logical +doc: Force the wave function to be an eigenfunction of S^2 +interface: input +default: False + +[threshold_generators] +type: Threshold +doc: Thresholds on generators (fraction of the norm) +interface: input +default: 0.99 + +[threshold_selectors] +type: Threshold +doc: Thresholds on selectors (fraction of the norm) +interface: input +default: 0.999 + +[n_int] +interface: OCaml +doc: n_int +type: N_int_number + +[bit_kind] +interface: OCaml +doc: bit_kind +type: Bit_kind + +[mo_label] +interface: OCaml +doc: o_label +type: character*(64) + +[n_det] +interface: OCaml +doc: n_det +type: integer + +[psi_coef] +interface: OCaml +doc: psi_coef +type: double precision +size: (determinants_n_det,determinants_n_states) + +[psi_det] +interface: OCaml +doc: psi_det +type: integer*8 +size: (determinants_n_int*determinants_bit_kind/8,2,determinants_n_det) + +[det_num] +interface: OCaml +doc: det_num +type: integer + +[det_occ] +interface: OCaml +doc: det_occ +type: integer +size: (electrons_elec_alpha_num,determinants_det_num,2) + +[det_coef] +interface: OCaml +doc: det_coef +type: double precision +size: (determinants_det_num) + +[expected_s2] +interface: OCaml +doc: expcted_s2 +type: double precision \ No newline at end of file diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f new file mode 100644 index 00000000..801d00a5 --- /dev/null +++ b/src/Determinants/H_apply.irp.f @@ -0,0 +1,229 @@ +use bitmasks +use omp_lib + +type H_apply_buffer_type +integer :: N_det +integer :: sze +integer(bit_kind), pointer :: det(:,:,:) +double precision , pointer :: coef(:,:) +double precision , pointer :: e2(:,:) +end type H_apply_buffer_type + +type(H_apply_buffer_type), pointer :: H_apply_buffer(:) + + + BEGIN_PROVIDER [ logical, H_apply_buffer_allocated ] +&BEGIN_PROVIDER [ integer(omp_lock_kind), H_apply_buffer_lock, (64,0:nproc-1) ] + use omp_lib + implicit none + BEGIN_DOC + ! Buffer of determinants/coefficients/perturbative energy for H_apply. + ! Uninitialized. Filled by H_apply subroutines. + END_DOC + integer :: iproc, sze + sze = 10000 + if (.not.associated(H_apply_buffer)) then + allocate(H_apply_buffer(0:nproc-1)) + iproc = 0 + !$OMP PARALLEL PRIVATE(iproc) DEFAULT(NONE) & + !$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock) + !$ iproc = omp_get_thread_num() + H_apply_buffer(iproc)%N_det = 0 + H_apply_buffer(iproc)%sze = sze + allocate ( & + H_apply_buffer(iproc)%det(N_int,2,sze), & + H_apply_buffer(iproc)%coef(sze,N_states), & + H_apply_buffer(iproc)%e2(sze,N_states) & + ) + H_apply_buffer(iproc)%det = 0_bit_kind + H_apply_buffer(iproc)%coef = 0.d0 + H_apply_buffer(iproc)%e2 = 0.d0 + call omp_init_lock(H_apply_buffer_lock(1,iproc)) + !$OMP END PARALLEL + endif + +END_PROVIDER + + +subroutine resize_H_apply_buffer(new_size,iproc) + implicit none + integer, intent(in) :: new_size, iproc + integer(bit_kind), pointer :: buffer_det(:,:,:) + double precision, pointer :: buffer_coef(:,:) + double precision, pointer :: buffer_e2(:,:) + integer :: i,j,k + integer :: Ndet + PROVIDE H_apply_buffer_allocated + + ASSERT (new_size > 0) + ASSERT (iproc >= 0) + ASSERT (iproc < nproc) + + call omp_set_lock(H_apply_buffer_lock(1,iproc)) + allocate ( buffer_det(N_int,2,new_size), & + buffer_coef(new_size,N_states), & + buffer_e2(new_size,N_states) ) + + do i=1,min(new_size,H_apply_buffer(iproc)%N_det) + do k=1,N_int + buffer_det(k,1,i) = H_apply_buffer(iproc)%det(k,1,i) + buffer_det(k,2,i) = H_apply_buffer(iproc)%det(k,2,i) + enddo + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num ) + enddo + deallocate(H_apply_buffer(iproc)%det) + H_apply_buffer(iproc)%det => buffer_det + + do k=1,N_states + do i=1,min(new_size,H_apply_buffer(iproc)%N_det) + buffer_coef(i,k) = H_apply_buffer(iproc)%coef(i,k) + enddo + enddo + deallocate(H_apply_buffer(iproc)%coef) + H_apply_buffer(iproc)%coef => buffer_coef + + do k=1,N_states + do i=1,min(new_size,H_apply_buffer(iproc)%N_det) + buffer_e2(i,k) = H_apply_buffer(iproc)%e2(i,k) + enddo + enddo + deallocate(H_apply_buffer(iproc)%e2) + H_apply_buffer(iproc)%e2 => buffer_e2 + + H_apply_buffer(iproc)%sze = new_size + H_apply_buffer(iproc)%N_det = min(new_size,H_apply_buffer(iproc)%N_det) + call omp_unset_lock(H_apply_buffer_lock(1,iproc)) + +end + +subroutine copy_H_apply_buffer_to_wf + use omp_lib + implicit none + BEGIN_DOC +! Copies the H_apply buffer to psi_coef. You need to touch psi_det, psi_coef and N_det +! after calling this function. +! After calling this subroutine, N_det, psi_det and psi_coef need to be touched + END_DOC + integer(bit_kind), allocatable :: buffer_det(:,:,:) + double precision, allocatable :: buffer_coef(:,:) + integer :: i,j,k + integer :: N_det_old + integer :: iproc + + PROVIDE H_apply_buffer_allocated + + ASSERT (N_int > 0) + ASSERT (N_det > 0) + + allocate ( buffer_det(N_int,2,N_det), buffer_coef(N_det,N_states) ) + + do i=1,N_det + do k=1,N_int + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num) + buffer_det(k,1,i) = psi_det(k,1,i) + buffer_det(k,2,i) = psi_det(k,2,i) + enddo + enddo + do k=1,N_states + do i=1,N_det + buffer_coef(i,k) = psi_coef(i,k) + enddo + enddo + + N_det_old = N_det + do j=0,nproc-1 + N_det = N_det + H_apply_buffer(j)%N_det + enddo + + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i=1,N_det_old + do k=1,N_int + psi_det(k,1,i) = buffer_det(k,1,i) + psi_det(k,2,i) = buffer_det(k,2,i) + enddo + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,N_det_old + psi_coef(i,k) = buffer_coef(i,k) + enddo + enddo + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states) + j=0 + !$ j=omp_get_thread_num() + do k=0,j-1 + N_det_old += H_apply_buffer(k)%N_det + enddo + do i=1,H_apply_buffer(j)%N_det + do k=1,N_int + psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i) + psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i) + enddo + ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,H_apply_buffer(j)%N_det + psi_coef(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) + enddo + enddo + !$OMP BARRIER + H_apply_buffer(j)%N_det = 0 + !$OMP END PARALLEL + call normalize(psi_coef,N_det) + SOFT_TOUCH N_det psi_det psi_coef + +end + + +subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) + use bitmasks + implicit none + BEGIN_DOC + ! Fill the H_apply buffer with determiants for CISD + END_DOC + + integer, intent(in) :: n_selected, Nint, iproc + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k + integer :: new_size + PROVIDE H_apply_buffer_allocated + new_size = H_apply_buffer(iproc)%N_det + n_selected + if (new_size > H_apply_buffer(iproc)%sze) then + call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc) + endif + call omp_set_lock(H_apply_buffer_lock(1,iproc)) + do i=1,H_apply_buffer(iproc)%N_det + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) + enddo + do i=1,n_selected + do j=1,N_int + H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) + H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) + enddo + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) + enddo + do j=1,N_states + do i=1,N_selected + H_apply_buffer(iproc)%coef(i,j) = 0.d0 + enddo + enddo + H_apply_buffer(iproc)%N_det = new_size + do i=1,H_apply_buffer(iproc)%N_det + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) + enddo + call omp_unset_lock(H_apply_buffer_lock(1,iproc)) +end + + diff --git a/src/Determinants/Makefile b/src/Determinants/Makefile new file mode 100644 index 00000000..092d879d --- /dev/null +++ b/src/Determinants/Makefile @@ -0,0 +1,6 @@ +# Define here all new external source files and objects.Don't forget to prefix the +# object files with IRPF90_temp/ +SRC=H_apply_template.f +OBJ= + +include $(QPACKAGE_ROOT)/src/Makefile.common diff --git a/src/Determinants/NEEDED_MODULES b/src/Determinants/NEEDED_MODULES new file mode 100644 index 00000000..824c75ed --- /dev/null +++ b/src/Determinants/NEEDED_MODULES @@ -0,0 +1 @@ +AOs Bielec_integrals Bitmask Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst new file mode 100644 index 00000000..445c8b5e --- /dev/null +++ b/src/Determinants/README.rst @@ -0,0 +1,696 @@ +=========== +Dets Module +=========== + +This module contains the determinants of the CI wave function. + +H is applied on the list of generator determinants. Selected determinants +are added into the *H_apply buffer*. Then the new wave function is +constructred as the concatenation of the odl wave function and +some determinants of the H_apply buffer. Generator determinants are built +as a subset of the determinants of the wave function. + + +Assumptions +=========== + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +* The MOs are orthonormal +* All the determinants have the same number of electrons +* The determinants are orthonormal +* The number of generator determinants <= the number of determinants +* All the determinants in the H_apply buffer are supposed to be different from the + wave function determinants +* All the determinants in the H_apply buffer are supposed to be unique + + +Needed Modules +============== + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +* `AOs `_ +* `Bielec_integrals `_ +* `Bitmask `_ +* `Electrons `_ +* `Ezfio_files `_ +* `MonoInts `_ +* `MOs `_ +* `Nuclei `_ +* `Output `_ +* `Utils `_ + +Documentation +============= + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +`copy_h_apply_buffer_to_wf `_ + Copies the H_apply buffer to psi_coef. You need to touch psi_det, psi_coef and N_det + after calling this function. + After calling this subroutine, N_det, psi_det and psi_coef need to be touched + +`fill_h_apply_buffer_no_selection `_ + Fill the H_apply buffer with determiants for CISD + +`h_apply_buffer_allocated `_ + Buffer of determinants/coefficients/perturbative energy for H_apply. + Uninitialized. Filled by H_apply subroutines. + +`h_apply_buffer_lock `_ + Buffer of determinants/coefficients/perturbative energy for H_apply. + Uninitialized. Filled by H_apply subroutines. + +`resize_h_apply_buffer `_ + Undocumented + +`cisd_sc2 `_ + CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + Initial guess vectors are not necessarily orthonormal + +`connected_to_ref `_ + Undocumented + +`connected_to_ref_by_mono `_ + Undocumented + +`det_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`get_index_in_psi_det_sorted_bit `_ + Returns the index of the determinant in the ``psi_det_sorted_bit`` array + +`is_in_wavefunction `_ + True if the determinant ``det`` is in the wave function + +`occ_pattern_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`do_mono_excitation `_ + Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin + on key_in + ispin = 1 == alpha + ispin = 2 == beta + i_ok = 1 == the excitation is possible + i_ok = -1 == the excitation is not possible + +`davidson_converged `_ + True if the Davidson algorithm is converged + +`davidson_criterion `_ + Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + +`davidson_diag `_ + Davidson diagonalization. + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit number for the I/O + .br + Initial guess vectors are not necessarily orthonormal + +`davidson_diag_hjj `_ + Davidson diagonalization with specific diagonal elements of the H matrix + .br + H_jj : specific diagonal H matrix elements to diagonalize de Davidson + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit for the I/O + .br + Initial guess vectors are not necessarily orthonormal + +`davidson_iter_max `_ + Max number of Davidson iterations + +`davidson_sze_max `_ + Max number of Davidson sizes + +`davidson_threshold `_ + Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + +`one_body_dm_mo `_ + One-body density matrix + +`one_body_dm_mo_alpha `_ + Alpha and beta one-body density matrix for each state + +`one_body_dm_mo_beta `_ + Alpha and beta one-body density matrix for each state + +`one_body_single_double_dm_mo_alpha `_ + Alpha and beta one-body density matrix for each state + +`one_body_single_double_dm_mo_beta `_ + Alpha and beta one-body density matrix for each state + +`one_body_spin_density_mo `_ + rho(alpha) - rho(beta) + +`save_natural_mos `_ + Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + +`set_natural_mos `_ + Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + +`state_average_weight `_ + Weights in the state-average calculation of the density matrix + +`det_svd `_ + Computes the SVD of the Alpha x Beta determinant coefficient matrix + +`filter_3_highest_electrons `_ + Returns a determinant with only the 3 highest electrons + +`int_of_3_highest_electrons `_ + Returns an integer*8 as : + .br + |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| + .br + |0<--- i1 ---><--- i2 ---><--- i3 --->| + .br + It encodes the value of the indices of the 3 highest MOs + in descending order + .br + +`max_degree_exc `_ + Maximum degree of excitation in the wf + +`n_det `_ + Number of determinants in the wave function + +`psi_average_norm_contrib `_ + Contribution of determinants to the state-averaged density + +`psi_average_norm_contrib_sorted `_ + Wave function sorted by determinants contribution to the norm (state-averaged) + +`psi_coef `_ + The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file + is empty + +`psi_coef_sorted `_ + Wave function sorted by determinants contribution to the norm (state-averaged) + +`psi_coef_sorted_ab `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`psi_coef_sorted_bit `_ + Determinants on which we apply for perturbation. + They are sorted by determinants interpreted as integers. Useful + to accelerate the search of a random determinant in the wave + function. + +`psi_det `_ + The wave function determinants. Initialized with Hartree-Fock if the EZFIO file + is empty + +`psi_det_size `_ + Size of the psi_det/psi_coef arrays + +`psi_det_sorted `_ + Wave function sorted by determinants contribution to the norm (state-averaged) + +`psi_det_sorted_ab `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`psi_det_sorted_bit `_ + Determinants on which we apply for perturbation. + They are sorted by determinants interpreted as integers. Useful + to accelerate the search of a random determinant in the wave + function. + +`psi_det_sorted_next_ab `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`read_dets `_ + Reads the determinants from the EZFIO file + +`save_wavefunction `_ + Save the wave function into the EZFIO file + +`save_wavefunction_general `_ + Save the wave function into the EZFIO file + +`save_wavefunction_unsorted `_ + Save the wave function into the EZFIO file + +`sort_dets_by_3_highest_electrons `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`sort_dets_by_det_search_key `_ + Determinants are sorted are sorted according to their det_search_key. + Useful to accelerate the search of a random determinant in the wave + function. + +`double_exc_bitmask `_ + double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 + double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 + double_exc_bitmask(:,3,i) is the bitmask for holes of excitation 2 + double_exc_bitmask(:,4,i) is the bitmask for particles of excitation 2 + for a given couple of hole/particle excitations i. + +`n_double_exc_bitmasks `_ + Number of double excitation bitmasks + +`n_single_exc_bitmasks `_ + Number of single excitation bitmasks + +`single_exc_bitmask `_ + single_exc_bitmask(:,1,i) is the bitmask for holes + single_exc_bitmask(:,2,i) is the bitmask for particles + for a given couple of hole/particle excitations i. + +`ci_eigenvectors `_ + Eigenvectors/values of the CI matrix + +`ci_eigenvectors_s2 `_ + Eigenvectors/values of the CI matrix + +`ci_electronic_energy `_ + Eigenvectors/values of the CI matrix + +`ci_energy `_ + N_states lowest eigenvalues of the CI matrix + +`diag_algorithm `_ + Diagonalization algorithm (Davidson or Lapack) + +`diagonalize_ci `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + +`ci_sc2_eigenvectors `_ + Eigenvectors/values of the CI matrix + +`ci_sc2_electronic_energy `_ + Eigenvectors/values of the CI matrix + +`ci_sc2_energy `_ + N_states_diag lowest eigenvalues of the CI matrix + +`diagonalize_ci_sc2 `_ + Replace the coefficients of the CI states_diag by the coefficients of the + eigenstates of the CI matrix + +`threshold_convergence_sc2 `_ + convergence of the correlation energy of SC2 iterations + +`ci_eigenvectors_mono `_ + Eigenvectors/values of the CI matrix + +`ci_eigenvectors_s2_mono `_ + Eigenvectors/values of the CI matrix + +`ci_electronic_energy_mono `_ + Eigenvectors/values of the CI matrix + +`diagonalize_ci_mono `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + +`apply_mono `_ + Undocumented + +`filter_connected `_ + Filters out the determinants that are not connected by H + .br + returns the array idx which contains the index of the + .br + determinants in the array key1 that interact + .br + via the H operator with key2. + .br + idx(0) is the number of determinants that interact with key1 + +`filter_connected_davidson `_ + Filters out the determinants that are not connected by H + returns the array idx which contains the index of the + determinants in the array key1 that interact + via the H operator with key2. + .br + idx(0) is the number of determinants that interact with key1 + key1 should come from psi_det_sorted_ab. + +`filter_connected_i_h_psi0 `_ + returns the array idx which contains the index of the + .br + determinants in the array key1 that interact + .br + via the H operator with key2. + .br + idx(0) is the number of determinants that interact with key1 + +`filter_connected_i_h_psi0_sc2 `_ + standard filter_connected_i_H_psi but returns in addition + .br + the array of the index of the non connected determinants to key1 + .br + in order to know what double excitation can be repeated on key1 + .br + idx_repeat(0) is the number of determinants that can be used + .br + to repeat the excitations + +`filter_connected_sorted_ab `_ + Filters out the determinants that are not connected by H + returns the array idx which contains the index of the + determinants in the array key1 that interact + via the H operator with key2. + idx(0) is the number of determinants that interact with key1 + .br + Determinants are taken from the psi_det_sorted_ab array + +`put_gess `_ + Undocumented + +`det_to_occ_pattern `_ + Transform a determinant to an occupation pattern + +`make_s2_eigenfunction `_ + Undocumented + +`n_occ_pattern `_ + array of the occ_pattern present in the wf + psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + +`occ_pattern_to_dets `_ + Generate all possible determinants for a give occ_pattern + +`occ_pattern_to_dets_size `_ + Number of possible determinants for a given occ_pattern + +`psi_occ_pattern `_ + array of the occ_pattern present in the wf + psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + +`rec_occ_pattern_to_dets `_ + Undocumented + +`n_states_diag `_ + Number of states to consider for the diagonalization + +`pouet `_ + Undocumented + +`routine `_ + Undocumented + +`idx_cas `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`idx_non_cas `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`n_det_cas `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`n_det_non_cas `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`psi_cas `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`psi_cas_coef `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`psi_cas_coef_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`psi_cas_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`psi_non_cas `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`psi_non_cas_coef `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`psi_non_cas_coef_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`psi_non_cas_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`bi_elec_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`kinetic_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`mono_elec_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`nucl_elec_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`expected_s2 `_ + Expected value of S2 : S*(S+1) + +`get_s2 `_ + Returns + +`get_s2_u0 `_ + Undocumented + +`s2_values `_ + array of the averaged values of the S^2 operator on the various states + +`s_z `_ + z component of the Spin + +`s_z2_sz `_ + z component of the Spin + +`prog_save_casino `_ + Undocumented + +`save_casino `_ + Undocumented + +`save_dets_qmcchem `_ + Undocumented + +`save_for_qmc `_ + Undocumented + +`save_natorb `_ + Undocumented + +`a_operator `_ + Needed for diag_H_mat_elem + +`ac_operator `_ + Needed for diag_H_mat_elem + +`decode_exc `_ + Decodes the exc arrays returned by get_excitation. + h1,h2 : Holes + p1,p2 : Particles + s1,s2 : Spins (1:alpha, 2:beta) + degree : Degree of excitation + +`det_connections `_ + Build connection proxy between determinants + +`diag_h_mat_elem `_ + Computes + +`get_double_excitation `_ + Returns the two excitation operators between two doubly excited determinants and the phase + +`get_excitation `_ + Returns the excitation operators between two determinants and the phase + +`get_excitation_degree `_ + Returns the excitation degree between two determinants + +`get_excitation_degree_vector `_ + Applies get_excitation_degree to an array of determinants + +`get_mono_excitation `_ + Returns the excitation operator between two singly excited determinants and the phase + +`get_occ_from_key `_ + Returns a list of occupation numbers from a bitstring + +`h_u_0 `_ + Computes v_0 = H|u_0> + .br + n : number of determinants + .br + H_jj : array of + +`i_h_j `_ + Returns where i and j are determinants + +`i_h_j_verbose `_ + Returns where i and j are determinants + +`i_h_psi `_ + for the various Nstates + +`i_h_psi_sc2 `_ + for the various Nstate + .br + returns in addition + .br + the array of the index of the non connected determinants to key1 + .br + in order to know what double excitation can be repeated on key1 + .br + idx_repeat(0) is the number of determinants that can be used + .br + to repeat the excitations + +`i_h_psi_sc2_verbose `_ + for the various Nstate + .br + returns in addition + .br + the array of the index of the non connected determinants to key1 + .br + in order to know what double excitation can be repeated on key1 + .br + idx_repeat(0) is the number of determinants that can be used + .br + to repeat the excitations + +`i_h_psi_sec_ord `_ + for the various Nstates + +`n_con_int `_ + Number of integers to represent the connections between determinants + +`create_wf_of_psi_svd_matrix `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`generate_all_alpha_beta_det_products `_ + Create a wave function from all possible alpha x beta determinants + +`get_index_in_psi_det_alpha_unique `_ + Returns the index of the determinant in the ``psi_det_alpha_unique`` array + +`get_index_in_psi_det_beta_unique `_ + Returns the index of the determinant in the ``psi_det_beta_unique`` array + +`n_det_alpha_unique `_ + Unique alpha determinants + +`n_det_beta_unique `_ + Unique beta determinants + +`psi_det_alpha `_ + List of alpha determinants of psi_det + +`psi_det_alpha_unique `_ + Unique alpha determinants + +`psi_det_beta `_ + List of beta determinants of psi_det + +`psi_det_beta_unique `_ + Unique beta determinants + +`psi_svd_alpha `_ + SVD wave function + +`psi_svd_beta `_ + SVD wave function + +`psi_svd_coefs `_ + SVD wave function + +`psi_svd_matrix `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_columns `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_rows `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_values `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`spin_det_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`write_spindeterminants `_ + Undocumented + +`cisd `_ + Undocumented + +`h_matrix_all_dets `_ + H matrix on the basis of the slater determinants defined by psi_det + + + diff --git a/src/Determinants/SC2.irp.f b/src/Determinants/SC2.irp.f new file mode 100644 index 00000000..440b2870 --- /dev/null +++ b/src/Determinants/SC2.irp.f @@ -0,0 +1,215 @@ +subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + double precision, intent(in) :: convergence + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + integer :: iter + integer :: i,j,k,l,m + logical :: converged + double precision :: overlap(N_st,N_st) + double precision :: u_dot_v, u_dot_u + + integer :: degree,N_double,index_hf + double precision :: hij_elec, e_corr_double,e_corr,diag_h_mat_elem,inv_c0 + double precision :: e_corr_double_before,accu,cpu_2,cpu_1 + integer,allocatable :: degree_exc(:), index_double(:) + integer :: i_ok + double precision,allocatable :: e_corr_array(:),H_jj_ref(:),H_jj_dressed(:),hij_double(:) + integer(bit_kind), allocatable :: doubles(:,:,:) + + + allocate (doubles(Nint,2,sze),e_corr_array(sze),H_jj_ref(sze),H_jj_dressed(sze),& + index_double(sze), degree_exc(sze), hij_double(sze)) + call write_time(output_determinants) + write(output_determinants,'(A)') '' + write(output_determinants,'(A)') 'CISD SC2' + write(output_determinants,'(A)') '========' + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze,N_st, & + !$OMP H_jj_ref,Nint,dets_in,u_in) & + !$OMP PRIVATE(i) + + !$OMP DO SCHEDULE(guided) + do i=1,sze + H_jj_ref(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) + enddo + !$OMP END DO NOWAIT + !$OMP END PARALLEL + + N_double = 0 + e_corr = 0.d0 + e_corr_double = 0.d0 + do i = 1, sze + call get_excitation_degree(ref_bitmask,dets_in(1,1,i),degree,Nint) + degree_exc(i) = degree+1 + if(degree==0)then + index_hf=i + else if (degree == 2)then + N_double += 1 + index_double(N_double) = i + doubles(:,:,N_double) = dets_in(:,:,i) + call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) + hij_double(N_double) = hij_elec + e_corr_array(N_double) = u_in(i,1)* hij_elec + e_corr_double += e_corr_array(N_double) + e_corr += e_corr_array(N_double) + else if (degree == 1)then + call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) + e_corr += u_in(i,1)* hij_elec + endif + enddo + inv_c0 = 1.d0/u_in(index_hf,1) + do i = 1, N_double + e_corr_array(i) = e_corr_array(i) * inv_c0 + enddo + e_corr = e_corr * inv_c0 + e_corr_double = e_corr_double * inv_c0 + converged = .False. + e_corr_double_before = e_corr_double + iter = 0 + do while (.not.converged) + if (abort_here) then + exit + endif + iter +=1 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,degree,accu) & + !$OMP SHARED(H_jj_dressed,sze,H_jj_ref,index_hf,N_int,N_double,& + !$OMP dets_in,doubles,degree_exc,e_corr_array,e_corr_double) + !$OMP DO SCHEDULE(STATIC) + do i=1,sze + H_jj_dressed(i) = H_jj_ref(i) + if (i==index_hf)cycle + accu = -e_corr_double + select case (N_int) + case (1) + do j=1,N_double + degree = & + popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & + popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + + if (degree<=ishft(degree_exc(i),1)) then + accu += e_corr_array(j) + endif + enddo + case (2) + do j=1,N_double + degree = & + popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & + popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & + popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & + popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) + + if (degree<=ishft(degree_exc(i),1)) then + accu += e_corr_array(j) + endif + enddo + case (3) + do j=1,N_double + degree = & + popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & + popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & + popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & + popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) + & + popcnt(xor( dets_in(3,1,i),doubles(3,1,j))) + & + popcnt(xor( dets_in(3,2,i),doubles(3,2,j))) + + if (degree<=ishft(degree_exc(i),1)) then + accu += e_corr_array(j) + endif + enddo + case default + do j=1,N_double + call get_excitation_degree(dets_in(1,1,i),doubles(1,1,j),degree,N_int) + if (degree<=degree_exc(i)) then + accu += e_corr_array(j) + endif + enddo + end select + H_jj_dressed(i) -= accu + enddo + !$OMP END DO + !$OMP END PARALLEL + + if(sze<=N_det_max_jacobi)then + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) + allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) + do j=1,sze + do i=1,sze + H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) + enddo + enddo + do i = 1,sze + H_matrix_tmp(i,i) = H_jj_dressed(i) + enddo + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_tmp,size(H_matrix_all_dets,1),sze) + do j=1,min(N_states_diag,sze) + do i=1,sze + u_in(i,j) = eigenvectors(i,j) + enddo + energies(j) = eigenvalues(j) + enddo + deallocate (H_matrix_tmp, eigenvalues, eigenvectors) + else + call davidson_diag_hjj(dets_in,u_in,H_jj_dressed,energies,dim_in,sze,N_st,Nint,output_determinants) + endif + + e_corr_double = 0.d0 + inv_c0 = 1.d0/u_in(index_hf,1) + do i = 1, N_double + e_corr_array(i) = u_in(index_double(i),1)*inv_c0 * hij_double(i) + e_corr_double += e_corr_array(i) + enddo + write(output_determinants,'(A,I3)') 'SC2 Iteration ', iter + write(output_determinants,'(A)') '------------------' + write(output_determinants,'(A)') '' + write(output_determinants,'(A)') '===== ================' + write(output_determinants,'(A)') 'State Energy ' + write(output_determinants,'(A)') '===== ================' + do i=1,N_st + write(output_determinants,'(I5,X,F16.10)') i, energies(i)+nuclear_repulsion + enddo + write(output_determinants,'(A)') '===== ================' + write(output_determinants,'(A)') '' + call write_double(output_determinants,(e_corr_double - e_corr_double_before),& + 'Delta(E_corr)') + converged = dabs(e_corr_double - e_corr_double_before) < convergence + converged = converged .or. abort_here + if (converged) then + exit + endif + e_corr_double_before = e_corr_double + + enddo + + call write_time(output_determinants) + deallocate (doubles,e_corr_array,H_jj_ref,H_jj_dressed, & + index_double, degree_exc, hij_double) + +end + + diff --git a/src/Determinants/connected_to_ref.irp.f b/src/Determinants/connected_to_ref.irp.f new file mode 100644 index 00000000..2d40b621 --- /dev/null +++ b/src/Determinants/connected_to_ref.irp.f @@ -0,0 +1,357 @@ +integer*8 function det_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint,2) + integer :: i + det_search_key = iand(det(1,1),det(1,2)) + do i=2,Nint + det_search_key = ieor(det_search_key,iand(det(i,1),det(i,2))) + enddo +end + + +integer*8 function occ_pattern_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint,2) + integer :: i + occ_pattern_search_key = ieor(det(1,1),det(1,2)) + do i=2,Nint + occ_pattern_search_key = ieor(occ_pattern_search_key,iand(det(i,1),det(i,2))) + enddo +end + + + +logical function is_in_wavefunction(key,Nint,Ndet) + use bitmasks + implicit none + BEGIN_DOC +! True if the determinant ``det`` is in the wave function + END_DOC + integer, intent(in) :: Nint, Ndet + integer(bit_kind), intent(in) :: key(Nint,2) + integer, external :: get_index_in_psi_det_sorted_bit + + !DIR$ FORCEINLINE + is_in_wavefunction = get_index_in_psi_det_sorted_bit(key,Nint) > 0 +end + +integer function get_index_in_psi_det_sorted_bit(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_sorted_bit`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_sorted_bit = 0 + ibegin = 1 + iend = N_det+1 + + !DIR$ FORCEINLINE + det_ref = det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = det_search_key(psi_det_sorted_bit(1,1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = det_search_key(psi_det_sorted_bit(1,1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det) then + return + endif + + !DIR$ FORCEINLINE + do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) + if ( (key(1,1) /= psi_det_sorted_bit(1,1,i)).or. & + (key(1,2) /= psi_det_sorted_bit(1,2,i)) ) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if ( (key(l,1) /= psi_det_sorted_bit(l,1,i)).or. & + (key(l,2) /= psi_det_sorted_bit(l,2,i)) ) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_sorted_bit = i +! exit + return + endif + endif + i += 1 + if (i > N_det) then +! exit + return + endif + + enddo + +! DEBUG is_in_wf +! if (is_in_wavefunction) then +! degree = 1 +! do i=1,N_det +! integer :: degree +! call get_excitation_degree(key,psi_det(1,1,i),degree,N_int) +! if (degree == 0) then +! exit +! endif +! enddo +! if (degree /=0) then +! stop 'pouet 1' +! endif +! else +! do i=1,N_det +! call get_excitation_degree(key,psi_det(1,1,i),degree,N_int) +! if (degree == 0) then +! stop 'pouet 2' +! endif +! enddo +! endif +! END DEBUG is_in_wf +end + +integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) + use bitmasks + implicit none + integer, intent(in) :: Nint, N_past_in, Ndet + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: N_past + integer :: i, l + integer :: degree_x2 + logical :: t + double precision :: hij_elec + + ! output : 0 : not connected + ! i : connected to determinant i of the past + ! -i : is the ith determinant of the refernce wf keys + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + connected_to_ref = 0 + N_past = max(1,N_past_in) + if (Nint == 1) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + return + + + else if (Nint==2) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + return + + else if (Nint==3) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + & + popcnt(xor( key(3,1), keys(3,1,i))) + & + popcnt(xor( key(3,2), keys(3,2,i))) + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + return + + else + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + !DEC$ LOOP COUNT MIN(3) + do l=2,Nint + degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& + popcnt(xor( key(l,2), keys(l,2,i))) + enddo + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + endif + +end + + + +integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) + use bitmasks + implicit none + integer, intent(in) :: Nint, N_past_in, Ndet + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: N_past + integer :: i, l + integer :: degree_x2 + logical :: t + double precision :: hij_elec + + ! output : 0 : not connected + ! i : connected to determinant i of the past + ! -i : is the ith determinant of the refernce wf keys + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + connected_to_ref_by_mono = 0 + N_past = max(1,N_past_in) + if (Nint == 1) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + return + + + else if (Nint==2) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + return + + else if (Nint==3) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + & + popcnt(xor( key(3,1), keys(3,1,i))) + & + popcnt(xor( key(3,2), keys(3,2,i))) + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + return + + else + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + !DEC$ LOOP COUNT MIN(3) + do l=2,Nint + degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& + popcnt(xor( key(l,2), keys(l,2,i))) + enddo + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + endif + +end + + diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f new file mode 100644 index 00000000..a33525c7 --- /dev/null +++ b/src/Determinants/create_excitations.irp.f @@ -0,0 +1,36 @@ +subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) + implicit none + BEGIN_DOC + ! Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin + ! on key_in + ! ispin = 1 == alpha + ! ispin = 2 == beta + ! i_ok = 1 == the excitation is possible + ! i_ok = -1 == the excitation is not possible + END_DOC + integer, intent(in) :: i_hole,i_particle,ispin + integer(bit_kind), intent(inout) :: key_in(N_int,2) + integer, intent(out) :: i_ok + integer :: k,j,i + use bitmasks + ASSERT (i_hole > 0 ) + ASSERT (i_particle <= mo_tot_num) + i_ok = 1 + ! hole + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin) = ibclr(key_in(k,ispin),j) + + ! particle + k = ishft(i_particle-1,-bit_kind_shift)+1 + j = i_particle-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin) = ibset(key_in(k,ispin),j) + integer :: n_elec_tmp + n_elec_tmp = 0 + do i = 1, N_int + n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) + enddo + if(n_elec_tmp .ne. elec_num)then + i_ok = -1 + endif +end diff --git a/src/Determinants/davidson.irp.f b/src/Determinants/davidson.irp.f new file mode 100644 index 00000000..bdc979c4 --- /dev/null +++ b/src/Determinants/davidson.irp.f @@ -0,0 +1,418 @@ +BEGIN_PROVIDER [ integer, davidson_iter_max ] + implicit none + BEGIN_DOC + ! Max number of Davidson iterations + END_DOC + davidson_iter_max = 100 +END_PROVIDER + +BEGIN_PROVIDER [ integer, davidson_sze_max ] + implicit none + BEGIN_DOC + ! Max number of Davidson sizes + END_DOC + ASSERT (davidson_sze_max <= davidson_iter_max) + davidson_sze_max = 8*N_states_diag +END_PROVIDER + +subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization. + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! iunit : Unit number for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint, iunit + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + double precision, allocatable :: H_jj(:) + + double precision :: diag_h_mat_elem + integer :: i + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + PROVIDE mo_bielec_integrals_in_map + allocate(H_jj(sze)) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze,H_jj,dets_in,Nint) & + !$OMP PRIVATE(i) + !$OMP DO SCHEDULE(guided) + do i=1,sze + H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) + enddo + !$OMP END DO + !$OMP END PARALLEL + + call davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) + deallocate (H_jj) +end + +subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: overlap(N_st,N_st) + double precision :: u_dot_v, u_dot_u + + integer, allocatable :: kl_pairs(:,:) + integer :: k_pairs, kl + + integer :: iter2 + double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:) + double precision, allocatable :: y(:,:,:,:), h(:,:,:,:), lambda(:) + double precision :: diag_h_mat_elem + double precision :: residual_norm(N_st) + character*(16384) :: write_buffer + double precision :: to_print(2,N_st) + double precision :: cpu, wall + + PROVIDE det_connections + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,sze,'Number of determinants') + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ================' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy Residual' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ================' + enddo + write(iunit,'(A)') trim(write_buffer) + + allocate( & + kl_pairs(2,N_st*(N_st+1)/2), & + W(sze,N_st,davidson_sze_max), & + U(sze,N_st,davidson_sze_max), & + R(sze,N_st), & + h(N_st,davidson_sze_max,N_st,davidson_sze_max), & + y(N_st,davidson_sze_max,N_st,davidson_sze_max), & + lambda(N_st*davidson_sze_max)) + + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Initialization + ! ============== + + k_pairs=0 + do l=1,N_st + do k=1,l + k_pairs+=1 + kl_pairs(1,k_pairs) = k + kl_pairs(2,k_pairs) = l + enddo + enddo + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & + !$OMP Nint,dets_in,u_in) & + !$OMP PRIVATE(k,l,kl,i) + + + ! Orthonormalize initial guess + ! ============================ + + !$OMP DO + do kl=1,k_pairs + k = kl_pairs(1,kl) + l = kl_pairs(2,kl) + if (k/=l) then + overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze) + overlap(l,k) = overlap(k,l) + else + overlap(k,k) = u_dot_u(U_in(1,k),sze) + endif + enddo + !$OMP END DO + !$OMP END PARALLEL + + call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) + + ! Davidson iterations + ! =================== + + converged = .False. + + do while (.not.converged) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(k,i) SHARED(U,u_in,sze,N_st) + do k=1,N_st + !$OMP DO + do i=1,sze + U(i,k,1) = u_in(i,k) + enddo + !$OMP END DO + enddo + !$OMP END PARALLEL + + do iter=1,davidson_sze_max-1 + + ! Compute W_k = H |u_k> + ! ---------------------- + + do k=1,N_st + call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) + enddo + + ! Compute h_kl = = + ! ------------------------------------------- + + do l=1,N_st + do k=1,N_st + do iter2=1,iter-1 + h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) + h(k,iter,l,iter2) = h(k,iter2,l,iter) + enddo + enddo + do k=1,l + h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) + h(l,iter,k,iter) = h(k,iter,l,iter) + enddo + enddo + + !DEBUG H MATRIX + !do i=1,iter + ! print '(10(x,F16.10))', h(1,i,1,1:i) + !enddo + !print *, '' + !END + + ! Diagonalize h + ! ------------- + call lapack_diag(lambda,y,h,N_st*davidson_sze_max,N_st*iter) + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + do k=1,N_st + do i=1,sze + U(i,k,iter+1) = 0.d0 + W(i,k,iter+1) = 0.d0 + do l=1,N_st + do iter2=1,iter + U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) + W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) + enddo + enddo + enddo + enddo + + ! Compute residual vector + ! ----------------------- + + do k=1,N_st + do i=1,sze + R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) + enddo + residual_norm(k) = u_dot_u(R(1,k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = residual_norm(k) + enddo + + write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))'), iter, to_print(:,1:N_st) + call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + if (converged) then + exit + endif + + + ! Davidson step + ! ------------- + + do k=1,N_st + do i=1,sze + U(i,k,iter+1) = -1.d0/max(H_jj(i) - lambda(k),1.d-2) * R(i,k) + enddo + enddo + + ! Gram-Schmidt + ! ------------ + + double precision :: c + do k=1,N_st + do iter2=1,iter + do l=1,N_st + c = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) + do i=1,sze + U(i,k,iter+1) -= c * U(i,l,iter2) + enddo + enddo + enddo + do l=1,k-1 + c = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) + do i=1,sze + U(i,k,iter+1) -= c * U(i,l,iter+1) + enddo + enddo + call normalize( U(1,k,iter+1), sze ) + enddo + + !DEBUG : CHECK OVERLAP + !print *, '===' + !do k=1,iter+1 + ! do l=1,k + ! c = u_dot_v(U(1,1,k),U(1,1,l),sze) + ! print *, k,l, c + ! enddo + !enddo + !print *, '===' + !pause + !END DEBUG + + + enddo + + if (.not.converged) then + iter = davidson_sze_max-1 + endif + + ! Re-contract to u_in + ! ----------- + + do k=1,N_st + energies(k) = lambda(k) + do i=1,sze + u_in(i,k) = 0.d0 + do iter2=1,iter + do l=1,N_st + u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) + enddo + enddo + enddo + enddo + + enddo + + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ================' + enddo + write(iunit,'(A)') trim(write_buffer) + write(iunit,'(A)') '' + call write_time(iunit) + + deallocate ( & + kl_pairs, & + W, & + U, & + R, & + h, & + y, & + lambda & + ) + abort_here = abort_all +end + + BEGIN_PROVIDER [ character(64), davidson_criterion ] +&BEGIN_PROVIDER [ double precision, davidson_threshold ] + implicit none + BEGIN_DOC + ! Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + END_DOC + davidson_criterion = 'residual' + davidson_threshold = 1.d-6 +END_PROVIDER + +subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged) + implicit none + BEGIN_DOC +! True if the Davidson algorithm is converged + END_DOC + integer, intent(in) :: N_st, iterations + logical, intent(out) :: converged + double precision, intent(in) :: energy(N_st), residual(N_st) + double precision, intent(in) :: wall, cpu + double precision :: E(N_st), time + double precision, allocatable, save :: energy_old(:) + + if (.not.allocated(energy_old)) then + allocate(energy_old(N_st)) + energy_old = 0.d0 + endif + + E = energy - energy_old + energy_old = energy + if (davidson_criterion == 'energy') then + converged = dabs(maxval(E(1:N_st))) < davidson_threshold + else if (davidson_criterion == 'residual') then + converged = dabs(maxval(residual(1:N_st))) < davidson_threshold + else if (davidson_criterion == 'both') then + converged = dabs(maxval(residual(1:N_st))) + dabs(maxval(E(1:N_st)) ) & + < davidson_threshold + else if (davidson_criterion == 'wall_time') then + call wall_time(time) + converged = time - wall > davidson_threshold + else if (davidson_criterion == 'cpu_time') then + call cpu_time(time) + converged = time - cpu > davidson_threshold + else if (davidson_criterion == 'iterations') then + converged = iterations >= int(davidson_threshold) + endif + converged = converged.or.abort_here +end diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f new file mode 100644 index 00000000..f72b337c --- /dev/null +++ b/src/Determinants/density_matrix.irp.f @@ -0,0 +1,214 @@ + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ_alpha + double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + + if(only_single_double_dm)then + print*,'ONLY DOUBLE DM' + one_body_dm_mo_alpha = one_body_single_double_dm_mo_alpha + one_body_dm_mo_beta = one_body_single_double_dm_mo_beta + else + one_body_dm_mo_alpha = 0.d0 + one_body_dm_mo_beta = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ_alpha)& + !$OMP SHARED(psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& + !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& + !$OMP mo_tot_num) + allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det + call bitstring_to_list(psi_det(1,1,k), occ(1,1), n_occ_alpha, N_int) + call bitstring_to_list(psi_det(1,2,k), occ(1,2), n_occ_alpha, N_int) + do m=1,N_states + ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j) += ck + enddo + enddo + do l=1,k-1 + call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) + if (s1==1) then + tmp_a(h1,p1) += ckl + tmp_a(p1,h1) += ckl + else + tmp_b(h1,p1) += ckl + tmp_b(p1,h1) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha = one_body_dm_mo_alpha + tmp_a + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP BARRIER + !$OMP END PARALLEL + + endif +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ_alpha + double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + integer :: degree_respect_to_HF_k + integer :: degree_respect_to_HF_l + + PROVIDE elec_alpha_num elec_beta_num + + one_body_single_double_dm_mo_alpha = 0.d0 + one_body_single_double_dm_mo_beta = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ_alpha,degree_respect_to_HF_k,degree_respect_to_HF_l)& + !$OMP SHARED(ref_bitmask,psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& + !$OMP elec_beta_num,one_body_single_double_dm_mo_alpha,one_body_single_double_dm_mo_beta,N_det,mo_tot_num_align,& + !$OMP mo_tot_num) + allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det + call bitstring_to_list(psi_det(1,1,k), occ(1,1), n_occ_alpha, N_int) + call bitstring_to_list(psi_det(1,2,k), occ(1,2), n_occ_alpha, N_int) + call get_excitation_degree(ref_bitmask,psi_det(1,1,k),degree_respect_to_HF_k,N_int) + + do m=1,N_states + ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) + call get_excitation_degree(ref_bitmask,psi_det(1,1,k),degree_respect_to_HF_l,N_int) + if(degree_respect_to_HF_l.le.0)then + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j) += ck + enddo + endif + enddo + do l=1,k-1 + call get_excitation_degree(ref_bitmask,psi_det(1,1,l),degree_respect_to_HF_l,N_int) + if(degree_respect_to_HF_k.ne.0)cycle + if(degree_respect_to_HF_l.eq.2.and.degree_respect_to_HF_k.ne.2)cycle + call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) + if (s1==1) then + tmp_a(h1,p1) += ckl + tmp_a(p1,h1) += ckl + else + tmp_b(h1,p1) += ckl + tmp_b(p1,h1) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_single_double_dm_mo_alpha = one_body_single_double_dm_mo_alpha + tmp_a + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP BARRIER + !$OMP END PARALLEL +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! One-body density matrix + END_DOC + one_body_dm_mo = one_body_dm_mo_alpha + one_body_dm_mo_beta +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! rho(alpha) - rho(beta) + END_DOC + one_body_spin_density_mo = one_body_dm_mo_alpha - one_body_dm_mo_beta +END_PROVIDER + +subroutine set_natural_mos + implicit none + BEGIN_DOC + ! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + END_DOC + character*(64) :: label + double precision, allocatable :: tmp(:,:) + allocate(tmp(size(one_body_dm_mo,1),size(one_body_dm_mo,2))) + + ! Negation to have the occupied MOs first after the diagonalization + tmp = -one_body_dm_mo + label = "Natural" + call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label) + deallocate(tmp) + +end +subroutine save_natural_mos + implicit none + BEGIN_DOC + ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + END_DOC + call set_natural_mos + call save_mos + +end + + +BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ] + implicit none + BEGIN_DOC + ! Weights in the state-average calculation of the density matrix + END_DOC + state_average_weight = 1.d0/dble(N_states) +END_PROVIDER + diff --git a/src/Determinants/det_svd.irp.f b/src/Determinants/det_svd.irp.f new file mode 100644 index 00000000..0a57acf3 --- /dev/null +++ b/src/Determinants/det_svd.irp.f @@ -0,0 +1,61 @@ +program det_svd + implicit none + BEGIN_DOC +! Computes the SVD of the Alpha x Beta determinant coefficient matrix + END_DOC + integer :: i,j,k + + read_wf = .True. + TOUCH read_wf + + print *, 'SVD matrix before filling' + print *, '=========================' + print *, '' + print *, 'N_det = ', N_det + print *, 'N_det_alpha = ', N_det_alpha_unique + print *, 'N_det_beta = ', N_det_beta_unique + print *, '' + +! do i=1,N_det_alpha_unique +! do j=1,N_det_beta_unique +! print *, i,j,psi_svd_matrix(i,j,:) +! enddo +! enddo + + print *, '' + print *, 'Energy = ', ci_energy + print *, '' + + print *, psi_svd_coefs(1:20,1) + + call generate_all_alpha_beta_det_products + print *, '' + print *, 'Energy = ', ci_energy + print *, '' + + print *, 'SVD matrix after filling' + print *, '========================' + print *, '' + print *, 'N_det = ', N_det + print *, 'N_det_alpha = ', N_det_alpha_unique + print *, 'N_det_beta = ', N_det_beta_unique + print *, '' + print *, '' + call diagonalize_ci + print *, 'Energy = ', ci_energy + + do i=1,N_det_alpha_unique + do j=1,N_det_beta_unique + do k=1,N_states + if (dabs(psi_svd_matrix(i,j,k)) < 1.d-15) then + psi_svd_matrix(i,j,k) = 0.d0 + endif + enddo + enddo + enddo + + print *, '' + print *, psi_svd_coefs(1:20,1) + call save_wavefunction + +end diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 03315836..a70d0fe8 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -68,9 +68,6 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] ! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file ! is empty END_DOC - - PROVIDE ezfio_filename - integer :: i logical :: exists character*64 :: label @@ -237,8 +234,6 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states_diag) ] ! is empty END_DOC - PROVIDE ezfio_filename - integer :: i,k, N_int2 logical :: exists double precision, allocatable :: psi_coef_read(:,:) @@ -602,8 +597,6 @@ subroutine read_dets(det,Nint,Ndet) integer :: i,k equivalence (det_8, det_bk) - PROVIDE ezfio_filename - call ezfio_get_determinants_N_int(N_int2) ASSERT (N_int2 == Nint) call ezfio_get_determinants_bit_kind(k) @@ -672,8 +665,6 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,k PROVIDE progress_bar - PROVIDE ezfio_filename - call start_progress(7,'Saving wfunction',0.d0) progress_bar(1) = 1 diff --git a/src/Determinants/determinants_bitmasks.irp.f b/src/Determinants/determinants_bitmasks.irp.f new file mode 100644 index 00000000..8343fa84 --- /dev/null +++ b/src/Determinants/determinants_bitmasks.irp.f @@ -0,0 +1,57 @@ +use bitmasks + +integer, parameter :: hole_ = 1 +integer, parameter :: particle_ = 2 +integer, parameter :: hole2_ = 3 +integer, parameter :: particle2_= 4 + +BEGIN_PROVIDER [ integer, N_single_exc_bitmasks ] + implicit none + BEGIN_DOC + ! Number of single excitation bitmasks + END_DOC + N_single_exc_bitmasks = 1 + !TODO : Read from input! +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), single_exc_bitmask, (N_int, 2, N_single_exc_bitmasks) ] + implicit none + BEGIN_DOC + ! single_exc_bitmask(:,1,i) is the bitmask for holes + ! single_exc_bitmask(:,2,i) is the bitmask for particles + ! for a given couple of hole/particle excitations i. + END_DOC + + single_exc_bitmask(:,hole_,1) = HF_bitmask(:,1) + single_exc_bitmask(:,particle_,1) = not(HF_bitmask(:,2)) + !TODO : Read from input! +END_PROVIDER + + +BEGIN_PROVIDER [ integer, N_double_exc_bitmasks ] + implicit none + BEGIN_DOC + ! Number of double excitation bitmasks + END_DOC + N_double_exc_bitmasks = 1 + !TODO : Read from input! +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), double_exc_bitmask, (N_int, 4, N_double_exc_bitmasks) ] + implicit none + BEGIN_DOC + ! double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 + ! double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 + ! double_exc_bitmask(:,3,i) is the bitmask for holes of excitation 2 + ! double_exc_bitmask(:,4,i) is the bitmask for particles of excitation 2 + ! for a given couple of hole/particle excitations i. + END_DOC + + double_exc_bitmask(:,hole_,1) = HF_bitmask(:,1) + double_exc_bitmask(:,particle_,1) = not(HF_bitmask(:,2)) + double_exc_bitmask(:,hole2_,1) = HF_bitmask(:,1) + double_exc_bitmask(:,particle2_,1) = not(HF_bitmask(:,2)) + + !TODO : Read from input! +END_PROVIDER + diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f new file mode 100644 index 00000000..0e697ab3 --- /dev/null +++ b/src/Determinants/diagonalize_CI.irp.f @@ -0,0 +1,109 @@ +BEGIN_PROVIDER [ character*(64), diag_algorithm ] + implicit none + BEGIN_DOC + ! Diagonalization algorithm (Davidson or Lapack) + END_DOC + if (N_det > N_det_max_jacobi) then + diag_algorithm = "Davidson" + else + diag_algorithm = "Lapack" + endif + + if (N_det < N_states_diag) then + diag_algorithm = "Lapack" + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] + implicit none + BEGIN_DOC + ! N_states lowest eigenvalues of the CI matrix + END_DOC + + integer :: j + character*(8) :: st + call write_time(output_determinants) + do j=1,N_states_diag + CI_energy(j) = CI_electronic_energy(j) + nuclear_repulsion + write(st,'(I4)') j + call write_double(output_determinants,CI_energy(j),'Energy of state '//trim(st)) + call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] + implicit none + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + integer :: i,j + + do j=1,N_states_diag + do i=1,N_det + CI_eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + + if (diag_algorithm == "Davidson") then + + call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & + size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) + + else if (diag_algorithm == "Lapack") then + + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy(:) = 0.d0 + do i=1,N_det + CI_eigenvectors(i,1) = eigenvectors(i,1) + enddo + integer :: i_state + double precision :: s2 + i_state = 0 + do j=1,N_det + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) + if(dabs(s2-expected_s2).le.0.3d0)then + i_state += 1 + do i=1,N_det + CI_eigenvectors(i,i_state) = eigenvectors(i,j) + enddo + CI_electronic_energy(i_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state) = s2 + endif + if (i_state.ge.N_states_diag) then + exit + endif + enddo +! if(i_state < min(N_states_diag,N_det))then +! print *, 'pb with the number of states' +! print *, 'i_state = ',i_state +! print *, 'N_states_diag ',N_states_diag +! print *,'stopping ...' +! stop +! endif + deallocate(eigenvectors,eigenvalues) + endif + +END_PROVIDER + +subroutine diagonalize_CI + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_eigenvectors_s2 +end diff --git a/src/Determinants/diagonalize_CI_SC2.irp.f b/src/Determinants/diagonalize_CI_SC2.irp.f new file mode 100644 index 00000000..3b0d7904 --- /dev/null +++ b/src/Determinants/diagonalize_CI_SC2.irp.f @@ -0,0 +1,59 @@ +BEGIN_PROVIDER [ double precision, CI_SC2_energy, (N_states_diag) ] + implicit none + BEGIN_DOC + ! N_states_diag lowest eigenvalues of the CI matrix + END_DOC + + integer :: j + character*(8) :: st + call write_time(output_determinants) + do j=1,N_states_diag + CI_SC2_energy(j) = CI_SC2_electronic_energy(j) + nuclear_repulsion + write(st,'(I4)') j + call write_double(output_determinants,CI_SC2_energy(j),'Energy of state '//trim(st)) + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, threshold_convergence_SC2] + implicit none + BEGIN_DOC + ! convergence of the correlation energy of SC2 iterations + END_DOC + threshold_convergence_SC2 = 1.d-10 + + END_PROVIDER + BEGIN_PROVIDER [ double precision, CI_SC2_electronic_energy, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_SC2_eigenvectors, (N_det,N_states_diag) ] + implicit none + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + integer :: i,j + + do j=1,N_states_diag + do i=1,N_det + CI_SC2_eigenvectors(i,j) = psi_coef(i,j) + enddo +! TODO : check comment +! CI_SC2_electronic_energy(j) = CI_electronic_energy(j) + enddo + + call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, & + size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) +END_PROVIDER + +subroutine diagonalize_CI_SC2 + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states_diag by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_SC2_eigenvectors(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors +end diff --git a/src/Determinants/diagonalize_CI_mono.irp.f b/src/Determinants/diagonalize_CI_mono.irp.f new file mode 100644 index 00000000..1c9a4de3 --- /dev/null +++ b/src/Determinants/diagonalize_CI_mono.irp.f @@ -0,0 +1,72 @@ + BEGIN_PROVIDER [ double precision, CI_electronic_energy_mono, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_mono, (N_det,N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_mono, (N_states_diag) ] + implicit none + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + integer :: i,j + + do j=1,N_states_diag + do i=1,N_det + CI_eigenvectors_mono(i,j) = psi_coef(i,j) + enddo + enddo + + if (diag_algorithm == "Davidson") then + + call davidson_diag(psi_det,CI_eigenvectors_mono,CI_electronic_energy, & + size(CI_eigenvectors_mono,1),N_det,N_states_diag,N_int,output_determinants) + + else if (diag_algorithm == "Lapack") then + + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy_mono(:) = 0.d0 + do i=1,N_det + CI_eigenvectors_mono(i,1) = eigenvectors(i,1) + enddo + integer :: i_state + double precision :: s2 + i_state = 0 + do j=1,N_det + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) + if(dabs(s2-expected_s2).le.0.3d0)then + print*,'j = ',j + print*,'e = ',eigenvalues(j) + print*,'c = ',dabs(eigenvectors(1,j)) + if(dabs(eigenvectors(1,j)).gt.0.9d0)then + i_state += 1 + do i=1,N_det + CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) + enddo + CI_electronic_energy_mono(i_state) = eigenvalues(j) + CI_eigenvectors_s2_mono(i_state) = s2 + endif + endif + if (i_state.ge.N_states_diag) then + exit + endif + enddo + deallocate(eigenvectors,eigenvalues) + endif + +END_PROVIDER + +subroutine diagonalize_CI_mono + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors_mono(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_electronic_energy_mono CI_eigenvectors_mono CI_eigenvectors_s2_mono +end diff --git a/src/Determinants/excitations_utils.irp.f b/src/Determinants/excitations_utils.irp.f new file mode 100644 index 00000000..46e38b08 --- /dev/null +++ b/src/Determinants/excitations_utils.irp.f @@ -0,0 +1,16 @@ +subroutine apply_mono(i_hole,i_particle,ispin_excit,key_in,Nint) + implicit none + integer, intent(in) :: i_hole,i_particle,ispin_excit,Nint + integer(bit_kind), intent(inout) :: key_in(Nint,2) + integer :: k,j + use bitmasks + ! hole + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin_excit) = ibclr(key_in(k,ispin_excit),j) + + k = ishft(i_particle-1,-bit_kind_shift)+1 + j = i_particle-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin_excit) = ibset(key_in(k,ispin_excit),j) + +end diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f new file mode 100644 index 00000000..93a6ee7b --- /dev/null +++ b/src/Determinants/filter_connected.irp.f @@ -0,0 +1,611 @@ + +subroutine filter_connected(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Filters out the determinants that are not connected by H + ! + ! returns the array idx which contains the index of the + ! + ! determinants in the array key1 that interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that interact with key1 + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) & + + popcnt( xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do j=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +& + popcnt(xor( key1(j,2,i), key2(j,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + + +subroutine filter_connected_sorted_ab(key1,key2,next,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Filters out the determinants that are not connected by H + ! returns the array idx which contains the index of the + ! determinants in the array key1 that interact + ! via the H operator with key2. + ! idx(0) is the number of determinants that interact with key1 + ! + ! Determinants are taken from the psi_det_sorted_ab array + END_DOC + integer, intent(in) :: Nint, sze + integer, intent(in) :: next(2,N_det) + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + integer(bit_kind) :: det3_1(Nint,2), det3_2(Nint,2) + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + call filter_3_highest_electrons( key2(1,1), det3_2(1,1), Nint) + if (Nint==1) then + + i = 1 + do while ( i<= sze ) + call filter_3_highest_electrons( key1(1,1,i), det3_1(1,1), Nint) + degree_x2 = popcnt( xor( det3_1(1,1), det3_2(1,1))) + if (degree_x2 > 4) then + i = next(1,i) + cycle + else + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1)) ) + if (degree_x2 <= 4) then + degree_x2 += popcnt( xor( key1(1,2,i), key2(1,2)) ) + if (degree_x2 <= 4) then + idx(l) = i + l += 1 + endif + endif + i += 1 + endif + enddo + + else + + print *, 'Not implemented', irp_here + stop 1 + + endif + idx(0) = l-1 +end + + + + +subroutine filter_connected_davidson(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Filters out the determinants that are not connected by H + ! returns the array idx which contains the index of the + ! determinants in the array key1 that interact + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that interact with key1 + ! key1 should come from psi_det_sorted_ab. + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,k,l + integer :: degree_x2 + integer :: j_int, j_start + integer*8 :: itmp + + PROVIDE N_con_int det_connections + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & + popcnt(xor( key1(1,2,j), key2(1,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + else if (Nint==2) then + + + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & + popcnt(xor( key1(2,1,j), key2(2,1))) + & + popcnt(xor( key1(1,2,j), key2(1,2))) + & + popcnt(xor( key1(2,2,j), key2(2,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & + popcnt(xor( key1(1,2,j), key2(1,2))) + & + popcnt(xor( key1(2,1,j), key2(2,1))) + & + popcnt(xor( key1(2,2,j), key2(2,2))) + & + popcnt(xor( key1(3,1,j), key2(3,1))) + & + popcnt(xor( key1(3,2,j), key2(3,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + else + + !DIR$ LOOP COUNT (1000) + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do k=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(k,1,j), key2(k,1))) +& + popcnt(xor( key1(k,2,j), key2(k,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + endif + idx(0) = l-1 +end + +subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) + use bitmasks + BEGIN_DOC + ! returns the array idx which contains the index of the + ! + ! determinants in the array key1 that interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that interact with key1 + END_DOC + implicit none + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,l,m + integer :: degree_x2 + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sze > 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do m=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& + popcnt(xor( key1(m,2,i), key2(m,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + +subroutine filter_connected_i_H_psi0_SC2(key1,key2,Nint,sze,idx,idx_repeat) + use bitmasks + BEGIN_DOC + ! standard filter_connected_i_H_psi but returns in addition + ! + ! the array of the index of the non connected determinants to key1 + ! + ! in order to know what double excitation can be repeated on key1 + ! + ! idx_repeat(0) is the number of determinants that can be used + ! + ! to repeat the excitations + END_DOC + implicit none + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + integer, intent(out) :: idx_repeat(0:sze) + + integer :: i,l,l_repeat,m + integer :: degree_x2 + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sze > 0) + + integer :: degree + degree = popcnt(xor( ref_bitmask(1,1), key2(1,1))) + & + popcnt(xor( ref_bitmask(1,2), key2(1,2))) + !DEC$ NOUNROLL + do m=2,Nint + degree = degree+ popcnt(xor( ref_bitmask(m,1), key2(m,1))) + & + popcnt(xor( ref_bitmask(m,2), key2(m,2))) + enddo + degree = ishft(degree,-1) + + l_repeat=1 + l=1 + if(degree == 2)then + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + elseif(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + elseif(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + else if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do m=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& + popcnt(xor( key1(m,2,i), key2(m,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + elseif(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + endif + elseif(degree==1)then + if (Nint==1) then + + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do m=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& + popcnt(xor( key1(m,2,i), key2(m,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + endif + + else +! print*,'more than a double excitation, can not apply the ' +! print*,'SC2 dressing of the diagonal element .....' +! print*,'stop !!' +! print*,'degree = ',degree +! stop + idx(0) = 0 + idx_repeat(0) = 0 + endif + idx(0) = l-1 + idx_repeat(0) = l_repeat-1 +end + diff --git a/src/Determinants/guess_doublet.irp.f b/src/Determinants/guess_doublet.irp.f new file mode 100644 index 00000000..a44697c1 --- /dev/null +++ b/src/Determinants/guess_doublet.irp.f @@ -0,0 +1,79 @@ +program put_gess + use bitmasks + implicit none + integer :: i,j,N_det_tmp,N_states_tmp + integer :: list(N_int*bit_kind_size,2) + integer(bit_kind) :: string(N_int,2) + integer(bit_kind) :: psi_det_tmp(N_int,2,3) + double precision :: psi_coef_tmp(3,1) + + integer :: iorb,jorb,korb + print*,'which open shells ?' + read(5,*)iorb,jorb,korb + print*,iorb,jorb,korb + N_states= 1 + N_det= 3 + + + list = 0 + list(1,1) = 1 + list(1,2) = 1 + list(2,1) = 2 + list(2,2) = 2 + list(3,1) = iorb + list(4,1) = jorb + list(3,2) = korb + print*,'passed' + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + print*,'passed' + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + print*,'passed' + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,1) = string(i,j) + enddo + enddo + psi_coef(1,1) = 1.d0/dsqrt(3.d0) + + print*,'passed 1' + list = 0 + list(1,1) = 1 + list(1,2) = 1 + list(2,1) = 2 + list(2,2) = 2 + list(3,1) = iorb + list(4,1) = korb + list(3,2) = jorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,2) = string(i,j) + enddo + enddo + psi_coef(2,1) = 1.d0/dsqrt(3.d0) + + print*,'passed 2' + list = 0 + list(1,1) = 1 + list(1,2) = 1 + list(2,1) = 2 + list(2,2) = 2 + list(3,1) = korb + list(4,1) = jorb + list(3,2) = iorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,3) = string(i,j) + enddo + enddo + psi_coef(3,1) = 1.d0/dsqrt(3.d0) + print*,'passed 3' + + call save_wavefunction +end diff --git a/src/Determinants/guess_singlet.irp.f b/src/Determinants/guess_singlet.irp.f new file mode 100644 index 00000000..50f8dc4e --- /dev/null +++ b/src/Determinants/guess_singlet.irp.f @@ -0,0 +1,44 @@ +program put_gess + use bitmasks + implicit none + integer :: i,j,N_det_tmp,N_states_tmp + integer :: list(N_int*bit_kind_size,2) + integer(bit_kind) :: string(N_int,2) + integer(bit_kind) :: psi_det_tmp(N_int,2,2) + double precision :: psi_coef_tmp(2,1) + + integer :: iorb,jorb + print*,'which open shells ?' + read(5,*)iorb,jorb + N_states= 1 + N_det= 2 + + + list = 0 + list(1,1) = iorb + list(1,2) = jorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,1) = string(i,j) + enddo + enddo + psi_coef(1,1) = 1.d0/dsqrt(2.d0) + + list = 0 + list(1,1) = jorb + list(1,2) = iorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,2) = string(i,j) + enddo + enddo + psi_coef(2,1) = 1.d0/dsqrt(2.d0) + + call save_wavefunction +end diff --git a/src/Determinants/guess_triplet.irp.f b/src/Determinants/guess_triplet.irp.f new file mode 100644 index 00000000..77f88c3e --- /dev/null +++ b/src/Determinants/guess_triplet.irp.f @@ -0,0 +1,48 @@ +program put_gess + use bitmasks + implicit none + integer :: i,j,N_det_tmp,N_states_tmp + integer :: list(N_int*bit_kind_size,2) + integer(bit_kind) :: string(N_int,2) + integer(bit_kind) :: psi_det_tmp(N_int,2,2) + double precision :: psi_coef_tmp(2,1) + + integer :: iorb,jorb + print*,'which open shells ?' + read(5,*)iorb,jorb + N_states= 1 + N_det= 2 + print*,'iorb = ',iorb + print*,'jorb = ',jorb + + + list = 0 + list(1,1) = iorb + list(1,2) = jorb + string = 0 + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,1) = string(i,j) + enddo + enddo + psi_coef(1,1) = 1.d0/dsqrt(2.d0) + + list = 0 + list(1,1) = jorb + list(1,2) = iorb + string = 0 + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,2) = string(i,j) + enddo + enddo + psi_coef(2,1) = -1.d0/dsqrt(2.d0) + + call save_wavefunction +end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f new file mode 100644 index 00000000..a0fd4a3c --- /dev/null +++ b/src/Determinants/occ_pattern.irp.f @@ -0,0 +1,339 @@ +use bitmasks +subroutine det_to_occ_pattern(d,o,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Transform a determinant to an occupation pattern + END_DOC + integer ,intent(in) :: Nint + integer(bit_kind),intent(in) :: d(Nint,2) + integer(bit_kind),intent(out) :: o(Nint,2) + + integer :: k + + do k=1,Nint + o(k,1) = ieor(d(k,1),d(k,2)) + o(k,2) = iand(d(k,1),d(k,2)) + enddo +end + +subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Number of possible determinants for a given occ_pattern + END_DOC + integer ,intent(in) :: Nint, n_alpha + integer(bit_kind),intent(in) :: o(Nint,2) + integer, intent(out) :: sze + integer :: amax,bmax,k + double precision, external :: binom_func + + amax = n_alpha + bmax = 0 + do k=1,Nint + bmax += popcnt( o(k,1) ) + amax -= popcnt( o(k,2) ) + enddo + sze = int( min(binom_func(bmax, amax), 1.d8) ) + +end + +subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Generate all possible determinants for a give occ_pattern + END_DOC + integer ,intent(in) :: Nint, n_alpha + integer ,intent(inout) :: sze + integer(bit_kind),intent(in) :: o(Nint,2) + integer(bit_kind),intent(out) :: d(Nint,2,sze) + + integer :: i, k, nt, na, nd, amax + integer :: list_todo(n_alpha) + integer :: list_a(n_alpha) + + amax = n_alpha + do k=1,Nint + amax -= popcnt( o(k,2) ) + enddo + + call bitstring_to_list(o(1,1), list_todo, nt, Nint) + + na = 0 + nd = 0 + d = 0 + call rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) + + sze = nd + + do i=1,nd + ! Doubly occupied orbitals + do k=1,Nint + d(k,1,i) = ior(d(k,1,i),o(k,2)) + d(k,2,i) = ior(d(k,2,i),o(k,2)) + enddo + enddo + +! !TODO DEBUG +! integer :: j,s +! do i=1,nd +! do j=1,i-1 +! na=0 +! do k=1,Nint +! if((d(k,1,j) /= d(k,1,i)).or. & +! (d(k,2,j) /= d(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( j== 0 ) then +! print *, 'det ',i,' and ',j,' equal:' +! call debug_det(d(1,1,j),Nint) +! call debug_det(d(1,1,i),Nint) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG +end + +recursive subroutine rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) + use bitmasks + implicit none + + integer, intent(in) :: nt, sze, amax, Nint,na + integer,intent(inout) :: list_todo(nt) + integer, intent(inout) :: list_a(na+1),nd + integer(bit_kind),intent(inout) :: d(Nint,2,sze) + + if (na == amax) then + nd += 1 + if (na > 0) then + call list_to_bitstring( d(1,1,nd), list_a, na, Nint) + endif + if (nt > 0) then + call list_to_bitstring( d(1,2,nd), list_todo, nt, Nint) + endif + else + integer :: i, j, k + integer :: list_todo_tmp(nt) + do i=1,nt + if (na > 0) then + if (list_todo(i) < list_a(na)) then + cycle + endif + endif + list_a(na+1) = list_todo(i) + k=1 + do j=1,nt + if (i/=j) then + list_todo_tmp(k) = list_todo(j) + k += 1 + endif + enddo + call rec_occ_pattern_to_dets(list_todo_tmp,nt-1,list_a,na+1,d,nd,sze,amax,Nint) + enddo + endif + +end + + BEGIN_PROVIDER [ integer(bit_kind), psi_occ_pattern, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_occ_pattern ] + implicit none + BEGIN_DOC + ! array of the occ_pattern present in the wf + ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + END_DOC + integer :: i,j,k + + ! create + do i = 1, N_det + do k = 1, N_int + psi_occ_pattern(k,1,i) = ieor(psi_det(k,1,i),psi_det(k,2,i)) + psi_occ_pattern(k,2,i) = iand(psi_det(k,1,i),psi_det(k,2,i)) + enddo + enddo + + ! Sort + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8, external :: occ_pattern_search_key + integer(bit_kind), allocatable :: tmp_array(:,:,:) + logical,allocatable :: duplicate(:) + + + allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) + + do i=1,N_det + iorder(i) = i + !$DIR FORCEINLINE + bit_tmp(i) = occ_pattern_search_key(psi_occ_pattern(1,1,i),N_int) + enddo + call i8sort(bit_tmp,iorder,N_det) + !DIR$ IVDEP + do i=1,N_det + do k=1,N_int + tmp_array(k,1,i) = psi_occ_pattern(k,1,iorder(i)) + tmp_array(k,2,i) = psi_occ_pattern(k,2,iorder(i)) + enddo + duplicate(i) = .False. + enddo + + i=1 + integer (bit_kind) :: occ_pattern_tmp + do i=1,N_det + duplicate(i) = .False. + enddo + + do i=1,N_det-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j+=1 + cycle + endif + duplicate(j) = .True. + do k=1,N_int + if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & + .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then + duplicate(j) = .False. + exit + endif + enddo + j+=1 + if (j>N_det) then + exit + endif + enddo + enddo + + N_occ_pattern=0 + do i=1,N_det + if (duplicate(i)) then + cycle + endif + N_occ_pattern += 1 + do k=1,N_int + psi_occ_pattern(k,1,N_occ_pattern) = tmp_array(k,1,i) + psi_occ_pattern(k,2,N_occ_pattern) = tmp_array(k,2,i) + enddo + enddo + + deallocate(iorder,duplicate,bit_tmp,tmp_array) +! !TODO DEBUG +! integer :: s +! do i=1,N_occ_pattern +! do j=i+1,N_occ_pattern +! s = 0 +! do k=1,N_int +! if((psi_occ_pattern(k,1,j) /= psi_occ_pattern(k,1,i)).or. & +! (psi_occ_pattern(k,2,j) /= psi_occ_pattern(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error : occ ', j, 'already in wf' +! call debug_det(psi_occ_pattern(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG +END_PROVIDER + +subroutine make_s2_eigenfunction + implicit none + integer :: i,j,k + integer :: smax, s + integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) + integer :: N_det_new + integer, parameter :: bufsze = 1000 + logical, external :: is_in_wavefunction + +! !TODO DEBUG +! do i=1,N_det +! do j=i+1,N_det +! s = 0 +! do k=1,N_int +! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & +! (psi_det(k,2,j) /= psi_det(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error0: det ', j, 'already in wf' +! call debug_det(psi_det(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG + + allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) + smax = 1 + N_det_new = 0 + + do i=1,N_occ_pattern + call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) + s += 1 + if (s > smax) then + deallocate(d) + allocate ( d(N_int,2,s) ) + smax = s + endif + call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int) + do j=1,s + if (.not. is_in_wavefunction( d(1,1,j), N_int, N_det)) then + N_det_new += 1 + do k=1,N_int + det_buffer(k,1,N_det_new) = d(k,1,j) + det_buffer(k,2,N_det_new) = d(k,2,j) + enddo + if (N_det_new == bufsze) then + call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) + N_det_new = 0 + endif + endif + enddo + enddo + + if (N_det_new > 0) then + call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det + endif + + deallocate(d,det_buffer) + + +! !TODO DEBUG +! do i=1,N_det +! do j=i+1,N_det +! s = 0 +! do k=1,N_int +! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & +! (psi_det(k,2,j) /= psi_det(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error : det ', j, 'already in wf at ', i +! call debug_det(psi_det(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG + call write_int(output_determinants,N_det_new, 'Added deteminants for S^2') + +end + diff --git a/src/Determinants/options.irp.f b/src/Determinants/options.irp.f new file mode 100644 index 00000000..d4283128 --- /dev/null +++ b/src/Determinants/options.irp.f @@ -0,0 +1,22 @@ +BEGIN_PROVIDER [ integer, N_states_diag ] + implicit none + BEGIN_DOC +! Number of states to consider for the diagonalization + END_DOC + + logical :: has + PROVIDE ezfio_filename + call ezfio_has_determinants_n_states_diag(has) + if (has) then + call ezfio_get_determinants_n_states_diag(N_states_diag) + else + N_states_diag = N_states + endif + + call write_time(output_determinants) + call write_int(output_determinants, N_states_diag, & + 'N_states_diag') + + +END_PROVIDER + diff --git a/src/Determinants/program_beginer_determinants.irp.f b/src/Determinants/program_beginer_determinants.irp.f new file mode 100644 index 00000000..6375af22 --- /dev/null +++ b/src/Determinants/program_beginer_determinants.irp.f @@ -0,0 +1,138 @@ +program pouet + implicit none + print*,'HF energy = ',ref_bitmask_energy + nuclear_repulsion + call routine + +end +subroutine routine + use bitmasks + implicit none + integer :: i,j,k,l + double precision :: hij,get_mo_bielec_integral + double precision :: hmono,h_bi_ispin,h_bi_other_spin + integer(bit_kind),allocatable :: key_tmp(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha, n_occ_beta + ! First checks + print*,'N_int = ',N_int + print*,'mo_tot_num = ',mo_tot_num + print*,'mo_tot_num / 64+1= ',mo_tot_num/64+1 + ! We print the HF determinant + do i = 1, N_int + print*,'ref_bitmask(i,1) = ',ref_bitmask(i,1) + print*,'ref_bitmask(i,2) = ',ref_bitmask(i,2) + enddo + print*,'' + print*,'Hartree Fock determinant ...' + call debug_det(ref_bitmask,N_int) + allocate(key_tmp(N_int,2)) + ! We initialize key_tmp to the Hartree Fock one + key_tmp = ref_bitmask + integer :: i_hole,i_particle,ispin,i_ok,other_spin + ! We do a mono excitation on the top of the HF determinant + write(*,*)'Enter the (hole, particle) couple for the mono excitation ...' + read(5,*)i_hole,i_particle +!!i_hole = 4 +!!i_particle = 20 + write(*,*)'Enter the ispin variable ...' + write(*,*)'ispin = 1 ==> alpha ' + write(*,*)'ispin = 2 ==> beta ' + read(5,*)ispin + if(ispin == 1)then + other_spin = 2 + else if(ispin == 2)then + other_spin = 1 + else + print*,'PB !! ' + print*,'ispin must be 1 or 2 !' + stop + endif +!!ispin = 1 + call do_mono_excitation(key_tmp,i_hole,i_particle,ispin,i_ok) + ! We check if it the excitation was possible with "i_ok" + if(i_ok == -1)then + print*,'i_ok = ',i_ok + print*,'You can not do this excitation because of Pauli principle ...' + print*,'check your hole particle couple, there must be something wrong ...' + stop + + endif + print*,'New det = ' + call debug_det(key_tmp,N_int) + call i_H_j(key_tmp,ref_bitmask,N_int,hij) + ! We calculate the H matrix element between the new determinant and HF + print*,' = ',hij + print*,'' + print*,'' + print*,'Recalculating it old school style ....' + print*,'' + print*,'' + ! We recalculate this old school style !!! + ! Mono electronic part + hmono = mo_mono_elec_integral(i_hole,i_particle) + print*,'' + print*,'Mono electronic part ' + print*,'' + print*,' = ',hmono + h_bi_ispin = 0.d0 + h_bi_other_spin = 0.d0 + print*,'' + print*,'Getting all the info for the calculation of the bi electronic part ...' + print*,'' + allocate (occ(N_int*bit_kind_size,2)) + ! We get the occupation of the alpha electrons in occ(:,1) + call bitstring_to_list(key_tmp(1,1), occ(1,1), n_occ_alpha, N_int) + print*,'n_occ_alpha = ',n_occ_alpha + print*,'elec_alpha_num = ',elec_alpha_num + ! We get the occupation of the beta electrons in occ(:,2) + call bitstring_to_list(key_tmp(1,2), occ(1,2), n_occ_beta, N_int) + print*,'n_occ_beta = ',n_occ_beta + print*,'elec_beta_num = ',elec_beta_num + ! We print the occupation of the alpha electrons + print*,'Alpha electrons !' + do i = 1, n_occ_alpha + print*,'i = ',i + print*,'occ(i,1) = ',occ(i,1) + enddo + ! We print the occupation of the beta electrons + print*,'Alpha electrons !' + do i = 1, n_occ_beta + print*,'i = ',i + print*,'occ(i,2) = ',occ(i,2) + enddo + integer :: exc(0:2,2,2),degree,h1,p1,h2,p2,s1,s2 + double precision :: phase + + call get_excitation_degree(key_tmp,ref_bitmask,degree,N_int) + print*,'degree = ',degree + call get_mono_excitation(ref_bitmask,key_tmp,exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + print*,'h1 = ',h1 + print*,'p1 = ',p1 + print*,'s1 = ',s1 + print*,'phase = ',phase + do i = 1, elec_num_tab(ispin) + integer :: orb_occupied + orb_occupied = occ(i,ispin) + h_bi_ispin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) & + -get_mo_bielec_integral(i_hole,i_particle,orb_occupied,orb_occupied,mo_integrals_map) + enddo + print*,'h_bi_ispin = ',h_bi_ispin + + do i = 1, elec_num_tab(other_spin) + orb_occupied = occ(i,other_spin) + h_bi_other_spin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) + enddo + print*,'h_bi_other_spin = ',h_bi_other_spin + print*,'h_bi_ispin + h_bi_other_spin = ',h_bi_ispin + h_bi_other_spin + + print*,'Total matrix element = ',phase*(h_bi_ispin + h_bi_other_spin + hmono) +!i = 1 +!j = 1 +!k = 1 +!l = 1 +!hij = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) +!print*,' = ',hij + + +end diff --git a/src/Determinants/psi_cas.irp.f b/src/Determinants/psi_cas.irp.f new file mode 100644 index 00000000..8ca081d6 --- /dev/null +++ b/src/Determinants/psi_cas.irp.f @@ -0,0 +1,114 @@ +use bitmasks + + BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_cas, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_cas ] + implicit none + BEGIN_DOC + ! CAS wave function, defined from the application of the CAS bitmask on the + ! determinants. idx_cas gives the indice of the CAS determinant in psi_det. + END_DOC + integer :: i, k, l + logical :: good + N_det_cas = 0 + do i=1,N_det + do l=1,n_cas_bitmask + good = .True. + do k=1,N_int + good = good .and. ( & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,1)) ) .and. ( & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,1)) ) + enddo + if (good) then + exit + endif + enddo + if (good) then + N_det_cas = N_det_cas+1 + do k=1,N_int + psi_cas(k,1,N_det_cas) = psi_det(k,1,i) + psi_cas(k,2,N_det_cas) = psi_det(k,2,i) + enddo + idx_cas(N_det_cas) = i + do k=1,N_states + psi_cas_coef(N_det_cas,k) = psi_coef(i,k) + enddo + endif + enddo + call write_int(output_determinants,N_det_cas, 'Number of determinants in the CAS') + +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! CAS determinants sorted to accelerate the search of a random determinant in the wave + ! function. + END_DOC + call sort_dets_by_det_search_key(N_det_cas, psi_cas, psi_cas_coef, & + psi_cas_sorted_bit, psi_cas_coef_sorted_bit) + +END_PROVIDER + + + + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_non_cas, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_non_cas ] + implicit none + BEGIN_DOC + ! Set of determinants which are not part of the CAS, defined from the application + ! of the CAS bitmask on the determinants. + ! idx_non_cas gives the indice of the determinant in psi_det. + END_DOC + integer :: i_non_cas,j,k + integer :: degree + logical :: in_cas + i_non_cas =0 + do k=1,N_det + in_cas = .False. + do j=1,N_det_cas + call get_excitation_degree(psi_cas(1,1,j), psi_det(1,1,k), degree, N_int) + if (degree == 0) then + in_cas = .True. + exit + endif + enddo + if (.not.in_cas) then + double precision :: hij + i_non_cas += 1 + do j=1,N_int + psi_non_cas(j,1,i_non_cas) = psi_det(j,1,k) + psi_non_cas(j,2,i_non_cas) = psi_det(j,2,k) + enddo + do j=1,N_states + psi_non_cas_coef(i_non_cas,j) = psi_coef(k,j) + enddo + idx_non_cas(i_non_cas) = k + endif + enddo + N_det_non_cas = i_non_cas +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! CAS determinants sorted to accelerate the search of a random determinant in the wave + ! function. + END_DOC + call sort_dets_by_det_search_key(N_det_cas, psi_non_cas, psi_non_cas_coef, & + psi_non_cas_sorted_bit, psi_non_cas_coef_sorted_bit) + +END_PROVIDER + + + + + diff --git a/src/Determinants/ref_bitmask.irp.f b/src/Determinants/ref_bitmask.irp.f new file mode 100644 index 00000000..7f760562 --- /dev/null +++ b/src/Determinants/ref_bitmask.irp.f @@ -0,0 +1,57 @@ + BEGIN_PROVIDER [ double precision, ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, mono_elec_ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, kinetic_ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, nucl_elec_ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, bi_elec_ref_bitmask_energy ] + use bitmasks + implicit none + BEGIN_DOC + ! Energy of the reference bitmask used in Slater rules + END_DOC + + integer :: occ(N_int*bit_kind_size,2) + integer :: i,j + + call bitstring_to_list(ref_bitmask(1,1), occ(1,1), i, N_int) + call bitstring_to_list(ref_bitmask(1,2), occ(1,2), i, N_int) + + + ref_bitmask_energy = 0.d0 + mono_elec_ref_bitmask_energy = 0.d0 + kinetic_ref_bitmask_energy = 0.d0 + nucl_elec_ref_bitmask_energy = 0.d0 + bi_elec_ref_bitmask_energy = 0.d0 + + do i = 1, elec_beta_num + ref_bitmask_energy += mo_mono_elec_integral(occ(i,1),occ(i,1)) + mo_mono_elec_integral(occ(i,2),occ(i,2)) + kinetic_ref_bitmask_energy += mo_kinetic_integral(occ(i,1),occ(i,1)) + mo_kinetic_integral(occ(i,2),occ(i,2)) + nucl_elec_ref_bitmask_energy += mo_nucl_elec_integral(occ(i,1),occ(i,1)) + mo_nucl_elec_integral(occ(i,2),occ(i,2)) + enddo + + do i = elec_beta_num+1,elec_alpha_num + ref_bitmask_energy += mo_mono_elec_integral(occ(i,1),occ(i,1)) + kinetic_ref_bitmask_energy += mo_kinetic_integral(occ(i,1),occ(i,1)) + nucl_elec_ref_bitmask_energy += mo_nucl_elec_integral(occ(i,1),occ(i,1)) + enddo + + do j= 1, elec_alpha_num + do i = j+1, elec_alpha_num + bi_elec_ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,1),occ(j,1)) + ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,1),occ(j,1)) + enddo + enddo + + do j= 1, elec_beta_num + do i = j+1, elec_beta_num + bi_elec_ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,2),occ(j,2)) + ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,2),occ(j,2)) + enddo + do i= 1, elec_alpha_num + bi_elec_ref_bitmask_energy += mo_bielec_integral_jj(occ(i,1),occ(j,2)) + ref_bitmask_energy += mo_bielec_integral_jj(occ(i,1),occ(j,2)) + enddo + enddo + mono_elec_ref_bitmask_energy = kinetic_ref_bitmask_energy + nucl_elec_ref_bitmask_energy + +END_PROVIDER + diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f new file mode 100644 index 00000000..cd1d9fda --- /dev/null +++ b/src/Determinants/s2.irp.f @@ -0,0 +1,106 @@ +subroutine get_s2(key_i,key_j,phase,Nint) + implicit none + use bitmasks + BEGIN_DOC +! Returns + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer(bit_kind), intent(in) :: key_j(Nint,2) + double precision, intent(out) :: phase + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase_spsm + integer :: nup, i + + phase = 0.d0 + !$FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case(2) + call get_double_excitation(key_i,key_j,exc,phase_spsm,Nint) + if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta + if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then + phase = -phase_spsm + endif + endif + case(0) + nup = 0 + do i=1,Nint + nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) + enddo + phase = dble(nup) + end select +end + +BEGIN_PROVIDER [ double precision, S_z ] +&BEGIN_PROVIDER [ double precision, S_z2_Sz ] + implicit none + BEGIN_DOC +! z component of the Spin + END_DOC + + S_z = 0.5d0*dble(elec_alpha_num-elec_beta_num) + S_z2_Sz = S_z*(S_z-1.d0) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, expected_s2] + implicit none + BEGIN_DOC +! Expected value of S2 : S*(S+1) + END_DOC + logical :: has_expected_s2 + + call ezfio_has_determinants_expected_s2(has_expected_s2) + if (has_expected_s2) then + call ezfio_get_determinants_expected_s2(expected_s2) + else + double precision :: S + S = (elec_alpha_num-elec_beta_num)*0.5d0 + expected_s2 = S * (S+1.d0) +! expected_s2 = elec_alpha_num - elec_beta_num + 0.5d0 * ((elec_alpha_num - elec_beta_num)**2*0.5d0 - (elec_alpha_num-elec_beta_num)) + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] + implicit none + BEGIN_DOC +! array of the averaged values of the S^2 operator on the various states + END_DOC + integer :: i + double precision :: s2 + do i = 1, N_states + call get_s2_u0(psi_det,psi_coef(1,i),n_det,psi_det_size,s2) + s2_values(i) = s2 + enddo + +END_PROVIDER + + +subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) + integer, intent(in) :: n,nmax + double precision, intent(in) :: psi_coefs_tmp(nmax) + double precision, intent(out) :: s2 + integer :: i,j,l + double precision :: s2_tmp + s2 = S_z2_Sz + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP PRIVATE(i,j,s2_tmp) SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int) & + !$OMP REDUCTION(+:s2) SCHEDULE(dynamic) + do i = 1, n + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) +! print*,'s2_tmp = ',s2_tmp + do j = 1, n + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),s2_tmp,N_int) + if (s2_tmp == 0.d0) cycle + s2 += psi_coefs_tmp(i)*psi_coefs_tmp(j)*s2_tmp + enddo + enddo + !$OMP END PARALLEL DO +end + diff --git a/src/Determinants/save_for_casino.irp.f b/src/Determinants/save_for_casino.irp.f new file mode 100644 index 00000000..631f79bd --- /dev/null +++ b/src/Determinants/save_for_casino.irp.f @@ -0,0 +1,268 @@ +subroutine save_casino + use bitmasks + implicit none + character*(128) :: message + integer :: getUnitAndOpen, iunit + integer, allocatable :: itmp(:) + integer :: n_ao_new + real, allocatable :: rtmp(:) + PROVIDE ezfio_filename + + iunit = getUnitAndOpen('gwfn.data','w') + print *, 'Title?' + read(*,*) message + write(iunit,'(A)') trim(message) + write(iunit,'(A)') '' + write(iunit,'(A)') 'BASIC_INFO' + write(iunit,'(A)') '----------' + write(iunit,'(A)') 'Generated by:' + write(iunit,'(A)') 'Quantum package' + write(iunit,'(A)') 'Method:' + print *, 'Method?' + read(*,*) message + write(iunit,'(A)') trim(message) + write(iunit,'(A)') 'DFT Functional:' + write(iunit,'(A)') 'none' + write(iunit,'(A)') 'Periodicity:' + write(iunit,'(A)') '0' + write(iunit,'(A)') 'Spin unrestricted:' + write(iunit,'(A)') '.false.' + write(iunit,'(A)') 'nuclear-nuclear repulsion energy (au/atom):' + write(iunit,*) nuclear_repulsion + write(iunit,'(A)') 'Number of electrons per primitive cell:' + write(iunit,*) elec_num + write(iunit,*) '' + + + write(iunit,*) 'GEOMETRY' + write(iunit,'(A)') '--------' + write(iunit,'(A)') 'Number of atoms:' + write(iunit,*) nucl_num + write(iunit,'(A)') 'Atomic positions (au):' + integer :: i + do i=1,nucl_num + write(iunit,'(3(1PE20.13))') nucl_coord(i,1:3) + enddo + write(iunit,'(A)') 'Atomic numbers for each atom:' + ! Add 200 if pseudopotential + allocate(itmp(nucl_num)) + do i=1,nucl_num + itmp(i) = int(nucl_charge(i)) + enddo + write(iunit,'(8(I10))') itmp(1:nucl_num) + deallocate(itmp) + write(iunit,'(A)') 'Valence charges for each atom:' + write(iunit,'(4(1PE20.13))') nucl_charge(1:nucl_num) + write(iunit,'(A)') '' + + + write(iunit,'(A)') 'BASIS SET' + write(iunit,'(A)') '---------' + write(iunit,'(A)') 'Number of Gaussian centres' + write(iunit,*) nucl_num + write(iunit,'(A)') 'Number of shells per primitive cell' + integer :: icount + icount = 0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + icount += 1 + endif + enddo + write(iunit,*) icount + write(iunit,'(A)') 'Number of basis functions (''AO'') per primitive cell' + icount = 0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + icount += 2*ao_l(i)+1 + endif + enddo + n_ao_new = icount + write(iunit,*) n_ao_new + write(iunit,'(A)') 'Number of Gaussian primitives per primitive cell' + allocate(itmp(ao_num)) + integer :: l + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l += 1 + itmp(l) = ao_prim_num(i) + endif + enddo + write(iunit,'(8(I10))') sum(itmp(1:l)) + write(iunit,'(A)') 'Highest shell angular momentum (s/p/d/f... 1/2/3/4...)' + write(iunit,*) maxval(ao_l(1:ao_num))+1 + write(iunit,'(A)') 'Code for shell types (s/sp/p/d/f... 1/2/3/4/5...)' + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l += 1 + if (ao_l(i) > 0) then + itmp(l) = ao_l(i)+2 + else + itmp(l) = ao_l(i)+1 + endif + endif + enddo + write(iunit,'(8(I10))') itmp(1:l) + write(iunit,'(A)') 'Number of primitive Gaussians in each shell' + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l += 1 + itmp(l) = ao_prim_num(i) + endif + enddo + write(iunit,'(8(I10))') itmp(1:l) + deallocate(itmp) + write(iunit,'(A)') 'Sequence number of first shell on each centre' + allocate(itmp(nucl_num)) + l=0 + icount = 1 + itmp(icount) = 1 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l = l+1 + if (ao_nucl(i) == icount) then + continue + else if (ao_nucl(i) == icount+1) then + icount += 1 + itmp(icount) = l + else + print *, 'Problem in order of centers of basis functions' + stop 1 + endif + endif + enddo + ! Check + if (icount /= nucl_num) then + print *, 'Error :' + print *, ' icount :', icount + print *, ' nucl_num:', nucl_num + stop 2 + endif + write(iunit,'(8(I10))') itmp(1:nucl_num) + deallocate(itmp) + write(iunit,'(A)') 'Exponents of Gaussian primitives' + allocate(rtmp(ao_num)) + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + do j=1,ao_prim_num(i) + l+=1 + rtmp(l) = ao_expo(i,ao_prim_num(i)-j+1) + enddo + endif + enddo + write(iunit,'(4(1PE20.13))') rtmp(1:l) + write(iunit,'(A)') 'Normalized contraction coefficients' + l=0 + integer :: j + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + do j=1,ao_prim_num(i) + l+=1 + rtmp(l) = ao_coef(i,ao_prim_num(i)-j+1) + enddo + endif + enddo + write(iunit,'(4(1PE20.13))') rtmp(1:l) + deallocate(rtmp) + write(iunit,'(A)') 'Position of each shell (au)' + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + write(iunit,'(3(1PE20.13))') nucl_coord( ao_nucl(i), 1:3 ) + endif + enddo + write(iunit,'(A)') + + + write(iunit,'(A)') 'MULTIDETERMINANT INFORMATION' + write(iunit,'(A)') '----------------------------' + write(iunit,'(A)') 'GS' + write(iunit,'(A)') 'ORBITAL COEFFICIENTS' + write(iunit,'(A)') '------------------------' + + ! Transformation cartesian -> spherical + double precision :: tf2(6,5), tf3(10,7), tf4(15,9) + integer :: check2(3,6), check3(3,10), check4(3,15) + check2(:,1) = (/ 2, 0, 0 /) + check2(:,2) = (/ 1, 1, 0 /) + check2(:,3) = (/ 1, 0, 1 /) + check2(:,4) = (/ 0, 2, 0 /) + check2(:,5) = (/ 0, 1, 1 /) + check2(:,6) = (/ 0, 0, 2 /) + + check3(:,1) = (/ 3, 0, 0 /) + check3(:,2) = (/ 2, 1, 0 /) + check3(:,3) = (/ 2, 0, 1 /) + check3(:,4) = (/ 1, 2, 0 /) + check3(:,5) = (/ 1, 1, 1 /) + check3(:,6) = (/ 1, 0, 2 /) + check3(:,7) = (/ 0, 3, 0 /) + check3(:,8) = (/ 0, 2, 1 /) + check3(:,9) = (/ 0, 1, 2 /) + check3(:,10) = (/ 0, 0, 3 /) + + check4(:,1) = (/ 4, 0, 0 /) + check4(:,2) = (/ 3, 1, 0 /) + check4(:,3) = (/ 3, 0, 1 /) + check4(:,4) = (/ 2, 2, 0 /) + check4(:,5) = (/ 2, 1, 1 /) + check4(:,6) = (/ 2, 0, 2 /) + check4(:,7) = (/ 1, 3, 0 /) + check4(:,8) = (/ 1, 2, 1 /) + check4(:,9) = (/ 1, 1, 2 /) + check4(:,10) = (/ 1, 0, 3 /) + check4(:,11) = (/ 0, 4, 0 /) + check4(:,12) = (/ 0, 3, 1 /) + check4(:,13) = (/ 0, 2, 2 /) + check4(:,14) = (/ 0, 1, 3 /) + check4(:,15) = (/ 0, 0, 4 /) + +! tf2 = (/ +! -0.5, 0, 0, -0.5, 0, 1.0, & +! 0, 0, 1.0, 0, 0, 0, & +! 0, 0, 0, 0, 1.0, 0, & +! 0.86602540378443864676, 0, 0, -0.86602540378443864676, 0, 0, & +! 0, 1.0, 0, 0, 0, 0, & +! /) +! tf3 = (/ +! 0, 0, -0.67082039324993690892, 0, 0, 0, 0, -0.67082039324993690892, 0, 1.0, & +! -0.61237243569579452455, 0, 0, -0.27386127875258305673, 0, 1.0954451150103322269, 0, 0, 0, 0, & +! 0, -0.27386127875258305673, 0, 0, 0, 0, -0.61237243569579452455, 0, 1.0954451150103322269, 0, & +! 0, 0, 0.86602540378443864676, 0, 0, 0, 0, -0.86602540378443864676, 0, 0, & +! 0, 0, 0, 0, 1.0, 0, 0, 0, 0, 0, & +! 0.790569415042094833, 0, 0, -1.0606601717798212866, 0, 0, 0, 0, 0, 0, & +! 0, 1.0606601717798212866, 0, 0, 0, 0, -0.790569415042094833, 0, 0, 0, & +! /) +! tf4 = (/ +! 0.375, 0, 0, 0.21957751641341996535, 0, -0.87831006565367986142, 0, 0, 0, 0, 0.375, 0, -0.87831006565367986142, 0, 1.0, & +! 0, 0, -0.89642145700079522998, 0, 0, 0, 0, -0.40089186286863657703, 0, 1.19522860933439364, 0, 0, 0, 0, 0, & +! 0, 0, 0, 0, -0.40089186286863657703, 0, 0, 0, 0, 0, 0, -0.89642145700079522998, 0, 1.19522860933439364, 0, & +! -0.5590169943749474241, 0, 0, 0, 0, 0.9819805060619657157, 0, 0, 0, 0, 0.5590169943749474241, 0, -0.9819805060619657157, 0, 0, & +! 0, -0.42257712736425828875, 0, 0, 0, 0, -0.42257712736425828875, 0, 1.1338934190276816816, 0, 0, 0, 0, 0, 0, & +! 0, 0, 0.790569415042094833, 0, 0, 0, 0, -1.0606601717798212866, 0, 0, 0, 0, 0, 0, 0, & +! 0, 0, 0, 0, 1.0606601717798212866, 0, 0, 0, 0, 0, 0, -0.790569415042094833, 0, 0, 0, & +! 0.73950997288745200532, 0, 0, -1.2990381056766579701, 0, 0, 0, 0, 0, 0, 0.73950997288745200532, 0, 0, 0, 0, & +! 0, 1.1180339887498948482, 0, 0, 0, 0, -1.1180339887498948482, 0, 0, 0, 0, 0, 0, 0, 0, & +! /) +! + + + allocate(rtmp(ao_num*mo_tot_num)) + l=0 + do i=1,mo_tot_num + do j=1,ao_num + l += 1 + rtmp(l) = mo_coef(j,i) + enddo + enddo + write(iunit,'(4(1PE20.13))') rtmp(1:l) + deallocate(rtmp) + close(iunit) +end + +program prog_save_casino + call save_casino +end diff --git a/src/Determinants/save_for_qmcchem.irp.f b/src/Determinants/save_for_qmcchem.irp.f new file mode 100644 index 00000000..b707ff7c --- /dev/null +++ b/src/Determinants/save_for_qmcchem.irp.f @@ -0,0 +1,51 @@ +subroutine save_dets_qmcchem + use bitmasks + implicit none + character :: c(mo_tot_num) + integer :: i,k + + integer, allocatable :: occ(:,:,:), occ_tmp(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: occ, occ_tmp + + read_wf = .True. + TOUCH read_wf + call ezfio_set_determinants_det_num(N_det) + call ezfio_set_determinants_det_coef(psi_coef_sorted(1,1)) + + allocate (occ(elec_alpha_num,N_det,2)) + ! OMP PARALLEL DEFAULT(NONE) & + ! OMP PRIVATE(occ_tmp,i,k)& + ! OMP SHARED(N_det,psi_det_sorted,elec_alpha_num, & + ! OMP occ,elec_beta_num,N_int) + allocate (occ_tmp(N_int*bit_kind_size,2)) + occ_tmp = 0 + ! OMP DO + do i=1,N_det + call bitstring_to_list(psi_det_sorted(1,1,i), occ_tmp(1,1), elec_alpha_num, N_int ) + call bitstring_to_list(psi_det_sorted(1,2,i), occ_tmp(1,2), elec_beta_num, N_int ) + do k=1,elec_alpha_num + occ(k,i,1) = occ_tmp(k,1) + occ(k,i,2) = occ_tmp(k,2) + enddo + enddo + ! OMP END DO + deallocate(occ_tmp) + ! OMP END PARALLEL + call ezfio_set_determinants_det_occ(occ) + call write_int(output_determinants,N_det,'Determinants saved for QMC') + deallocate(occ) + open(unit=31,file=trim(ezfio_filename)//'/mo_basis/mo_classif') + write(31,'(I1)') 1 + write(31,*) mo_tot_num + do i=1,mo_tot_num + write(31,'(A)') 'a' + enddo + close(31) + call system('gzip -f '//trim(ezfio_filename)//'/mo_basis/mo_classif') + +end + +program save_for_qmc + call save_dets_qmcchem + call write_spindeterminants +end diff --git a/src/Determinants/save_natorb.irp.f b/src/Determinants/save_natorb.irp.f new file mode 100644 index 00000000..e56f9821 --- /dev/null +++ b/src/Determinants/save_natorb.irp.f @@ -0,0 +1,6 @@ +program save_natorb + read_wf = .True. + touch read_wf + call save_natural_mos +end + diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f new file mode 100644 index 00000000..7d431879 --- /dev/null +++ b/src/Determinants/slater_rules.irp.f @@ -0,0 +1,1301 @@ +subroutine get_excitation_degree(key1,key2,degree,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation degree between two determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key1(Nint,2) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree + + integer :: l + + ASSERT (Nint > 0) + + degree = popcnt(xor( key1(1,1), key2(1,1))) + & + popcnt(xor( key1(1,2), key2(1,2))) + !DEC$ NOUNROLL + do l=2,Nint + degree = degree+ popcnt(xor( key1(l,1), key2(l,1))) + & + popcnt(xor( key1(l,2), key2(l,2))) + enddo + ASSERT (degree >= 0) + degree = ishft(degree,-1) + +end + + + +subroutine get_excitation(det1,det2,exc,degree,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operators between two determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(out) :: exc(0:2,2,2) + integer, intent(out) :: degree + double precision, intent(out) :: phase + ! exc(number,hole/particle,spin) + ! ex : + ! exc(0,1,1) = number of holes alpha + ! exc(0,2,1) = number of particle alpha + ! exc(0,2,2) = number of particle beta + ! exc(1,2,1) = first particle alpha + ! exc(1,1,1) = first hole alpha + ! exc(1,2,2) = first particle beta + ! exc(1,1,2) = first hole beta + + ASSERT (Nint > 0) + + !DIR$ FORCEINLINE + call get_excitation_degree(det1,det2,degree,Nint) + select case (degree) + + case (3:) + degree = -1 + return + + case (2) + call get_double_excitation(det1,det2,exc,phase,Nint) + return + + case (1) + call get_mono_excitation(det1,det2,exc,phase,Nint) + return + + case(0) + return + + end select +end + +subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + use bitmasks + implicit none + BEGIN_DOC + ! Decodes the exc arrays returned by get_excitation. + ! h1,h2 : Holes + ! p1,p2 : Particles + ! s1,s2 : Spins (1:alpha, 2:beta) + ! degree : Degree of excitation + END_DOC + integer, intent(in) :: exc(0:2,2,2),degree + integer, intent(out) :: h1,h2,p1,p2,s1,s2 + ASSERT (degree > 0) + ASSERT (degree < 3) + + select case(degree) + case(2) + if (exc(0,1,1) == 2) then + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + s1 = 1 + s2 = 1 + else if (exc(0,1,2) == 2) then + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + s1 = 2 + s2 = 2 + else + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + s1 = 1 + s2 = 2 + endif + case(1) + if (exc(0,1,1) == 1) then + h1 = exc(1,1,1) + h2 = 0 + p1 = exc(1,2,1) + p2 = 0 + s1 = 1 + s2 = 0 + else + h1 = exc(1,1,2) + h2 = 0 + p1 = exc(1,2,2) + p2 = 0 + s1 = 2 + s2 = 0 + endif + case(0) + h1 = 0 + p1 = 0 + h2 = 0 + p2 = 0 + s1 = 0 + s2 = 0 + end select +end + +subroutine get_double_excitation(det1,det2,exc,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the two excitation operators between two doubly excited determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(out) :: exc(0:2,2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ispin = 1,2 + idx_particle = 0 + idx_hole = 0 + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (det1(l,ispin) == det2(l,ispin)) then + cycle + endif + tmp = xor( det1(l,ispin), det2(l,ispin) ) + particle = iand(tmp, det2(l,ispin)) + hole = iand(tmp, det1(l,ispin)) + do while (particle /= 0_bit_kind) + tz = trailz(particle) + idx_particle = idx_particle + 1 + exc(0,2,ispin) = exc(0,2,ispin) + 1 + exc(idx_particle,2,ispin) = tz+ishift + particle = iand(particle,particle-1_bit_kind) + enddo + if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)==2 + exit + endif + do while (hole /= 0_bit_kind) + tz = trailz(hole) + idx_hole = idx_hole + 1 + exc(0,1,ispin) = exc(0,1,ispin) + 1 + exc(idx_hole,1,ispin) = tz+ishift + hole = iand(hole,hole-1_bit_kind) + enddo + if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin) + exit + endif + enddo + + ! TODO : Voir si il faut sortir i,n,k,m du case. + + select case (exc(0,1,ispin)) + case(0) + cycle + + case(1) + low = min(exc(1,1,ispin), exc(1,2,ispin)) + high = max(exc(1,1,ispin), exc(1,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + & + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i,ispin)) + end do + endif + + case (2) + + do i=1,2 + low = min(exc(i,1,ispin), exc(i,2,ispin)) + high = max(exc(i,1,ispin), exc(i,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + & + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + do l=j+1,k-1 + nperm = nperm + popcnt(det1(l,ispin)) + end do + endif + + enddo + + a = min(exc(1,1,ispin), exc(1,2,ispin)) + b = max(exc(1,1,ispin), exc(1,2,ispin)) + c = min(exc(2,1,ispin), exc(2,2,ispin)) + d = max(exc(2,1,ispin), exc(2,2,ispin)) + if (c>a .and. cb) then + nperm = nperm + 1 + endif + exit + end select + + enddo + phase = phase_dble(iand(nperm,1)) + +end + +subroutine get_mono_excitation(det1,det2,exc,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operator between two singly excited determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(out) :: exc(0:2,2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ispin = 1,2 + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (det1(l,ispin) == det2(l,ispin)) then + cycle + endif + tmp = xor( det1(l,ispin), det2(l,ispin) ) + particle = iand(tmp, det2(l,ispin)) + hole = iand(tmp, det1(l,ispin)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ispin) = 1 + exc(1,2,ispin) = tz+ishift + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ispin) = 1 + exc(1,1,ispin) = tz+ishift + endif + + if ( iand(exc(0,1,ispin),exc(0,2,ispin)) /= 1) then ! exc(0,1,ispin)/=1 and exc(0,2,ispin) /= 1 + cycle + endif + + low = min(exc(1,1,ispin),exc(1,2,ispin)) + high = max(exc(1,1,ispin),exc(1,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + if (j==k) then + nperm = popcnt(iand(det1(j,ispin), & + iand(ibset(0_bit_kind,m-1)-1_bit_kind,ibclr(-1_bit_kind,n)+1_bit_kind))) + else + nperm = nperm + popcnt(iand(det1(k,ispin),ibset(0_bit_kind,m-1)-1_bit_kind)) +& + popcnt(iand(det1(j,ispin),ibclr(-1_bit_kind,n)+1_bit_kind)) + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i,ispin)) + end do + endif + phase = phase_dble(iand(nperm,1)) + return + + enddo + enddo +end + + + + + +subroutine i_H_j(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_alpha, n_occ_beta + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + !DEC$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) + call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) + enddo + do k = 1, elec_beta_num + hij = hij + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, elec_beta_num + hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p)) + + case (0) + hij = diag_H_mat_elem(key_i,Nint) + end select +end + + + + +subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij,hmono,hdouble + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_alpha, n_occ_beta + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + hmono = 0.d0 + hdouble = 0.d0 + !DEC$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) + call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1)) + enddo + do k = 1, elec_beta_num + hdouble = hdouble + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hdouble = hdouble + mipi(occ(k,1)) + enddo + do k = 1, elec_beta_num + hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2)) + enddo + + endif + hmono = mo_mono_elec_integral(m,p) + hij = phase*(hdouble + hmono) + + case (0) + hij = diag_H_mat_elem(key_i,Nint) + end select +end + + + +subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + BEGIN_DOC + ! for the various Nstates + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) + do ii=1,idx(0) + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo +end + +subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + double precision, intent(out) :: interactions(Ndet) + integer,intent(out) :: idx_interaction(0:Ndet) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet),n_interact + BEGIN_DOC + ! for the various Nstates + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) + n_interact = 0 + do ii=1,idx(0) + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + if(dabs(hij).ge.1.d-8)then + if(i.ne.1)then + n_interact += 1 + interactions(n_interact) = hij + idx_interaction(n_interact) = i + endif + endif + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo + idx_interaction(0) = n_interact +end + + +subroutine i_H_psi_SC2(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_repeat) + use bitmasks + BEGIN_DOC + ! for the various Nstate + ! + ! returns in addition + ! + ! the array of the index of the non connected determinants to key1 + ! + ! in order to know what double excitation can be repeated on key1 + ! + ! idx_repeat(0) is the number of determinants that can be used + ! + ! to repeat the excitations + END_DOC + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + integer , intent(out) :: idx_repeat(0:Ndet) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) + do ii=1,idx(0) + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo +end + + +subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_repeat) + use bitmasks + BEGIN_DOC + ! for the various Nstate + ! + ! returns in addition + ! + ! the array of the index of the non connected determinants to key1 + ! + ! in order to know what double excitation can be repeated on key1 + ! + ! idx_repeat(0) is the number of determinants that can be used + ! + ! to repeat the excitations + END_DOC + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + integer , intent(out) :: idx_repeat(0:Ndet) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) + print*,'--------' + do ii=1,idx(0) + print*,'--' + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + if (i==1)then + print*,'i==1 !!' + endif + print*,coef(i,1) * hij,coef(i,1),hij + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + print*,i_H_psi_array(1) + enddo + print*,'------' +end + + + +subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Applies get_excitation_degree to an array of determinants + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree(sze) + integer, intent(out) :: idx(0:sze) + + integer :: i,l + + ASSERT (Nint > 0) + ASSERT (sze > 0) + + l=1 + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = ishft( popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = 0 + !DEC$ LOOP COUNT MIN(4) + do l=1,Nint + degree(l) = degree(l)+ popcnt(xor( key1(l,1,i), key2(l,1))) +& + popcnt(xor( key1(l,2,i), key2(l,2))) + enddo + degree(l) = ishft(degree(l),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + + + + +double precision function diag_H_mat_elem(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer(bit_kind) :: hole(Nint,2) + integer(bit_kind) :: particle(Nint,2) + integer :: i, nexc(2), ispin + integer :: occ_particle(Nint*bit_kind_size,2) + integer :: occ_hole(Nint*bit_kind_size,2) + integer(bit_kind) :: det_tmp(Nint,2) + integer :: na, nb + + ASSERT (Nint > 0) + ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num) + + nexc(1) = 0 + nexc(2) = 0 + do i=1,Nint + hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) + particle(i,1) = iand(hole(i,1),det_in(i,1)) + particle(i,2) = iand(hole(i,2),det_in(i,2)) + hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) + hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) + nexc(1) += popcnt(hole(i,1)) + nexc(2) += popcnt(hole(i,2)) + enddo + + diag_H_mat_elem = ref_bitmask_energy + if (nexc(1)+nexc(2) == 0) then + return + endif + + !call debug_det(det_in,Nint) + integer :: tmp + call bitstring_to_list(particle(1,1), occ_particle(1,1), tmp, Nint) + ASSERT (tmp == nexc(1)) + call bitstring_to_list(particle(1,2), occ_particle(1,2), tmp, Nint) + ASSERT (tmp == nexc(2)) + call bitstring_to_list(hole(1,1), occ_hole(1,1), tmp, Nint) + ASSERT (tmp == nexc(1)) + call bitstring_to_list(hole(1,2), occ_hole(1,2), tmp, Nint) + ASSERT (tmp == nexc(2)) + + det_tmp = ref_bitmask + do ispin=1,2 + na = elec_num_tab(ispin) + nb = elec_num_tab(iand(ispin,1)+1) + do i=1,nexc(ispin) + !DIR$ FORCEINLINE + call ac_operator( occ_particle(i,ispin), ispin, det_tmp, diag_H_mat_elem, Nint,na,nb) + !DIR$ FORCEINLINE + call a_operator ( occ_hole (i,ispin), ispin, det_tmp, diag_H_mat_elem, Nint,na,nb) + enddo + enddo +end + +subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Needed for diag_H_mat_elem + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hjj + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + k = ishft(iorb-1,-bit_kind_shift)+1 + ASSERT (k > 0) + l = iorb - ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibclr(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + !DIR$ FORCEINLINE + call get_occ_from_key(key,occ,Nint) + na -= 1 + + hjj -= mo_mono_elec_integral(iorb,iorb) + + ! Same spin + do i=1,na + hjj -= mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + hjj -= mo_bielec_integral_jj(occ(i,other_spin),iorb) + enddo + +end + + +subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Needed for diag_H_mat_elem + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hjj + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + integer :: tmp + !DIR$ FORCEINLINE + call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) + ASSERT (tmp == elec_alpha_num) + !DIR$ FORCEINLINE + call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) + ASSERT (tmp == elec_beta_num) + + k = ishft(iorb-1,-bit_kind_shift)+1 + ASSERT (k > 0) + l = iorb - ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + hjj += mo_mono_elec_integral(iorb,iorb) + + ! Same spin + do i=1,na + hjj += mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + hjj += mo_bielec_integral_jj(occ(i,other_spin),iorb) + enddo + na += 1 +end + +subroutine get_occ_from_key(key,occ,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns a list of occupation numbers from a bitstring + END_DOC + integer(bit_kind), intent(in) :: key(Nint,2) + integer , intent(in) :: Nint + integer , intent(out) :: occ(Nint*bit_kind_size,2) + integer :: tmp + + call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) + call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) + +end + +subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + END_DOC + integer, intent(in) :: n,Nint + double precision, intent(out) :: v_0(n) + double precision, intent(in) :: u_0(n) + double precision, intent(in) :: H_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + integer, allocatable :: idx(:) + double precision :: hij + double precision, allocatable :: vt(:) + integer :: i,j,k,l, jj + integer :: i0, j0 + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + integer, parameter :: block_size = 157 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,j,k,idx,jj,vt) & + !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0) + !$OMP DO SCHEDULE(static) + do i=1,n + v_0(i) = H_jj(i) * u_0(i) + enddo + !$OMP END DO + allocate(idx(0:n), vt(n)) + Vt = 0.d0 + !$OMP DO SCHEDULE(guided) + do i=1,n + idx(0) = i + call filter_connected_davidson(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) + do jj=1,idx(0) + j = idx(jj) + if ( (dabs(u_0(j)) > 1.d-7).or.((dabs(u_0(i)) > 1.d-7)) ) then + call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) + vt (i) = vt (i) + hij*u_0(j) + vt (j) = vt (j) + hij*u_0(i) + endif + enddo + enddo + !$OMP END DO + !$OMP CRITICAL + do i=1,n + v_0(i) = v_0(i) + vt(i) + enddo + !$OMP END CRITICAL + deallocate(idx,vt) + !$OMP END PARALLEL +end + + + +BEGIN_PROVIDER [ integer, N_con_int ] + implicit none + BEGIN_DOC + ! Number of integers to represent the connections between determinants + END_DOC + N_con_int = 1 + ishft(N_det-1,-11) +END_PROVIDER + +BEGIN_PROVIDER [ integer*8, det_connections, (N_con_int,N_det) ] + implicit none + BEGIN_DOC + ! Build connection proxy between determinants + END_DOC + integer :: i,j + integer :: degree + integer :: j_int, j_k, j_l + integer, allocatable :: idx(:) + integer :: thread_num + integer :: omp_get_thread_num + + PROVIDE progress_bar + call start_progress(N_det,'Det connections',0.d0) + + select case(N_int) + + case(1) + + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections, & + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & + popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + if (degree < 5) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + case(2) + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & + popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & + popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & + popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) + if (degree < 5) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + case(3) + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & + popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & + popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & + popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) + & + popcnt(xor( psi_det(3,1,i),psi_det(3,1,j))) + & + popcnt(xor( psi_det(3,2,i),psi_det(3,2,j))) + if (degree < 5) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + case default + + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + !DIR$ FORCEINLINE + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if (degree < 3) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + end select + call stop_progress + +END_PROVIDER + diff --git a/src/Determinants/spindeterminants.ezfio_config b/src/Determinants/spindeterminants.ezfio_config new file mode 100644 index 00000000..39ccb82b --- /dev/null +++ b/src/Determinants/spindeterminants.ezfio_config @@ -0,0 +1,17 @@ +spindeterminants + n_det_alpha integer + n_det_beta integer + n_det integer + n_int integer + bit_kind integer + n_states integer + psi_det_alpha integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_alpha) + psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta) + psi_coef_matrix_rows integer (spindeterminants_n_det) + psi_coef_matrix_columns integer (spindeterminants_n_det) + psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) + n_svd_coefs integer + psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states) + psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states) + psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states) + diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f new file mode 100644 index 00000000..ffd28f85 --- /dev/null +++ b/src/Determinants/spindeterminants.irp.f @@ -0,0 +1,615 @@ +!==============================================================================! +! ! +! Independent alpha/beta parts ! +! ! +!==============================================================================! + +use bitmasks + +integer*8 function spin_det_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint) + integer :: i + spin_det_search_key = det(1) + do i=2,Nint + spin_det_search_key = ieor(spin_det_search_key,det(i)) + enddo +end + + +BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] + implicit none + BEGIN_DOC +! List of alpha determinants of psi_det + END_DOC + integer :: i,k + + do i=1,N_det + do k=1,N_int + psi_det_alpha(k,i) = psi_det(k,1,i) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] + implicit none + BEGIN_DOC +! List of beta determinants of psi_det + END_DOC + integer :: i,k + + do i=1,N_det + do k=1,N_int + psi_det_beta(k,i) = psi_det(k,2,i) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha_unique, (N_int,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_alpha_unique ] + implicit none + BEGIN_DOC + ! Unique alpha determinants + END_DOC + + integer :: i,k + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key + + allocate ( iorder(N_det), bit_tmp(N_det)) + + do i=1,N_det + iorder(i) = i + bit_tmp(i) = spin_det_search_key(psi_det_alpha(1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,N_det) + + N_det_alpha_unique = 0 + last_key = 0_8 + do i=1,N_det + if (bit_tmp(i) /= last_key) then + last_key = bit_tmp(i) + N_det_alpha_unique += 1 + do k=1,N_int + psi_det_alpha_unique(k,N_det_alpha_unique) = psi_det_alpha(k,iorder(i)) + enddo + endif + enddo + + deallocate (iorder, bit_tmp) +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta_unique, (N_int,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_beta_unique ] + implicit none + BEGIN_DOC + ! Unique beta determinants + END_DOC + + integer :: i,k + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key + + allocate ( iorder(N_det), bit_tmp(N_det)) + + do i=1,N_det + iorder(i) = i + bit_tmp(i) = spin_det_search_key(psi_det_beta(1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,N_det) + + N_det_beta_unique = 0 + last_key = 0_8 + do i=1,N_det + if (bit_tmp(i) /= last_key) then + last_key = bit_tmp(i) + N_det_beta_unique += 1 + do k=1,N_int + psi_det_beta_unique(k,N_det_beta_unique) = psi_det_beta(k,iorder(i)) + enddo + endif + enddo + + deallocate (iorder, bit_tmp) +END_PROVIDER + + + + + +integer function get_index_in_psi_det_alpha_unique(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_alpha_unique`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: spin_det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_alpha_unique = 0 + ibegin = 1 + iend = N_det_alpha_unique + 1 + + !DIR$ FORCEINLINE + det_ref = spin_det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_alpha_unique(1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_alpha_unique(1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det_alpha_unique) then + return + endif + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) + if (key(1) /= psi_det_alpha_unique(1,i)) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if (key(l) /= psi_det_alpha_unique(l,i)) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_alpha_unique = i + return + endif + endif + i += 1 + if (i > N_det_alpha_unique) then + return + endif + + enddo + +end + +integer function get_index_in_psi_det_beta_unique(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_beta_unique`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: spin_det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_beta_unique = 0 + ibegin = 1 + iend = N_det_beta_unique + 1 + + !DIR$ FORCEINLINE + det_ref = spin_det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_beta_unique(1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_beta_unique(1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det_beta_unique) then + return + endif + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) + if (key(1) /= psi_det_beta_unique(1,i)) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if (key(l) /= psi_det_beta_unique(l,i)) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_beta_unique = i + return + endif + endif + i += 1 + if (i > N_det_beta_unique) then + return + endif + + enddo + +end + + +subroutine write_spindeterminants + use bitmasks + implicit none + integer*8, allocatable :: tmpdet(:,:) + integer :: N_int2 + integer :: i,j,k + integer*8 :: det_8(100) + integer(bit_kind) :: det_bk((100*8)/bit_kind) + equivalence (det_8, det_bk) + + N_int2 = (N_int*bit_kind)/8 + call ezfio_set_spindeterminants_n_det_alpha(N_det_alpha_unique) + call ezfio_set_spindeterminants_n_det_beta(N_det_beta_unique) + call ezfio_set_spindeterminants_n_det(N_det) + call ezfio_set_spindeterminants_n_int(N_int) + call ezfio_set_spindeterminants_bit_kind(bit_kind) + call ezfio_set_spindeterminants_n_states(N_states) + + allocate(tmpdet(N_int2,N_det_alpha_unique)) + do i=1,N_det_alpha_unique + do k=1,N_int + det_bk(k) = psi_det_alpha_unique(k,i) + enddo + do k=1,N_int2 + tmpdet(k,i) = det_8(k) + enddo + enddo + call ezfio_set_spindeterminants_psi_det_alpha(psi_det_alpha_unique) + deallocate(tmpdet) + + allocate(tmpdet(N_int2,N_det_beta_unique)) + do i=1,N_det_beta_unique + do k=1,N_int + det_bk(k) = psi_det_beta_unique(k,i) + enddo + do k=1,N_int2 + tmpdet(k,i) = det_8(k) + enddo + enddo + call ezfio_set_spindeterminants_psi_det_beta(psi_det_beta_unique) + deallocate(tmpdet) + + call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_svd_matrix_values) + call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_svd_matrix_rows) + call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_svd_matrix_columns) + + integer :: n_svd_coefs + double precision :: norm, f + f = 1.d0/dble(N_states) + norm = 1.d0 + do n_svd_coefs=1,N_det_alpha_unique + do k=1,N_states + norm -= psi_svd_coefs(n_svd_coefs,k)*psi_svd_coefs(n_svd_coefs,k) + enddo + if (norm < 1.d-4) then + exit + endif + enddo + n_svd_coefs -= 1 + call ezfio_set_spindeterminants_n_svd_coefs(n_svd_coefs) + + double precision, allocatable :: dtmp(:,:,:) + allocate(dtmp(N_det_alpha_unique,n_svd_coefs,N_states)) + do k=1,N_states + do j=1,n_svd_coefs + do i=1,N_det_alpha_unique + dtmp(i,j,k) = psi_svd_alpha(i,j,k) + enddo + enddo + enddo + call ezfio_set_spindeterminants_psi_svd_alpha(dtmp) + deallocate(dtmp) + + allocate(dtmp(N_det_beta_unique,n_svd_coefs,N_states)) + do k=1,N_states + do j=1,n_svd_coefs + do i=1,N_det_beta_unique + dtmp(i,j,k) = psi_svd_beta(i,j,k) + enddo + enddo + enddo + call ezfio_set_spindeterminants_psi_svd_beta(dtmp) + deallocate(dtmp) + + allocate(dtmp(n_svd_coefs,N_states,1)) + do k=1,N_states + do j=1,n_svd_coefs + dtmp(j,k,1) = psi_svd_coefs(j,k) + enddo + enddo + call ezfio_set_spindeterminants_psi_svd_coefs(dtmp) + deallocate(dtmp) + +end + + +!==============================================================================! +! ! +! Alpha x Beta Matrix ! +! ! +!==============================================================================! + +BEGIN_PROVIDER [ double precision, psi_svd_matrix_values, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer, psi_svd_matrix_rows, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_svd_matrix_columns, (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k, l + integer(bit_kind) :: tmp_det(N_int,2) + integer :: idx + integer, external :: get_index_in_psi_det_sorted_bit + logical, external :: is_in_wavefunction + + + PROVIDE psi_coef_sorted_bit + +! l=0 +! do j=1,N_det_beta_unique +! do k=1,N_int +! tmp_det(k,2) = psi_det_beta_unique(k,j) +! enddo +! do i=1,N_det_alpha_unique +! do k=1,N_int +! tmp_det(k,1) = psi_det_alpha_unique(k,i) +! enddo +! idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) +! if (idx > 0) then +! l += 1 +! psi_svd_matrix_rows(l) = i +! psi_svd_matrix_columns(l) = j +! do k=1,N_states +! psi_svd_matrix_values(l,k) = psi_coef_sorted_bit(idx,k) +! enddo +! endif +! enddo +! enddo +! ASSERT (l == N_det) + + integer, allocatable :: iorder(:), to_sort(:) + integer, external :: get_index_in_psi_det_alpha_unique + integer, external :: get_index_in_psi_det_beta_unique + allocate(iorder(N_det), to_sort(N_det)) + do k=1,N_det + i = get_index_in_psi_det_alpha_unique(psi_det(1,1,k),N_int) + j = get_index_in_psi_det_beta_unique (psi_det(1,2,k),N_int) + do l=1,N_states + psi_svd_matrix_values(k,l) = psi_coef(k,l) + enddo + psi_svd_matrix_rows(k) = i + psi_svd_matrix_columns(k) = j + to_sort(k) = N_det_alpha_unique * (j-1) + i + iorder(k) = k + enddo + call isort(to_sort, iorder, N_det) + call iset_order(psi_svd_matrix_rows,iorder,N_det) + call iset_order(psi_svd_matrix_columns,iorder,N_det) + call dset_order(psi_svd_matrix_values,iorder,N_det) + deallocate(iorder,to_sort) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_svd_matrix, (N_det_alpha_unique,N_det_beta_unique,N_states) ] + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k,istate + psi_svd_matrix = 0.d0 + do k=1,N_det + i = psi_svd_matrix_rows(k) + j = psi_svd_matrix_columns(k) + do istate=1,N_states + psi_svd_matrix(i,j,istate) = psi_svd_matrix_values(k,istate) + enddo + enddo +END_PROVIDER + +subroutine create_wf_of_psi_svd_matrix + use bitmasks + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k + integer(bit_kind) :: tmp_det(N_int,2) + integer :: idx + integer, external :: get_index_in_psi_det_sorted_bit + logical, external :: is_in_wavefunction + double precision :: norm(N_states) + + call generate_all_alpha_beta_det_products + norm = 0.d0 + do j=1,N_det_beta_unique + do k=1,N_int + tmp_det(k,2) = psi_det_beta_unique(k,j) + enddo + do i=1,N_det_alpha_unique + do k=1,N_int + tmp_det(k,1) = psi_det_alpha_unique(k,i) + enddo + idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) + if (idx > 0) then + do k=1,N_states + psi_coef_sorted_bit(idx,k) = psi_svd_matrix(i,j,k) + norm(k) += psi_svd_matrix(i,j,k) + enddo + endif + enddo + enddo + do k=1,N_states + norm(k) = 1.d0/dsqrt(norm(k)) + do i=1,N_det + psi_coef_sorted_bit(i,k) = psi_coef_sorted_bit(i,k)*norm(k) + enddo + enddo + psi_det = psi_det_sorted_bit + psi_coef = psi_coef_sorted_bit + TOUCH psi_det psi_coef + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + norm(1) = 0.d0 + do i=1,N_det + norm(1) += psi_average_norm_contrib_sorted(i) + if (norm(1) >= 0.999999d0) then + exit + endif + enddo + N_det = min(i,N_det) + SOFT_TOUCH psi_det psi_coef N_det + +end + +subroutine generate_all_alpha_beta_det_products + implicit none + BEGIN_DOC +! Create a wave function from all possible alpha x beta determinants + END_DOC + integer :: i,j,k,l + integer :: idx, iproc + integer, external :: get_index_in_psi_det_sorted_bit + integer(bit_kind), allocatable :: tmp_det(:,:,:) + logical, external :: is_in_wavefunction + integer, external :: omp_get_thread_num + + !$OMP PARALLEL DEFAULT(NONE) SHARED(psi_coef_sorted_bit,N_det_beta_unique,& + !$OMP N_det_alpha_unique, N_int, psi_det_alpha_unique, psi_det_beta_unique,& + !$OMP N_det) & + !$OMP PRIVATE(i,j,k,l,tmp_det,idx,iproc) + !$ iproc = omp_get_thread_num() + allocate (tmp_det(N_int,2,N_det_alpha_unique)) + !$OMP DO + do j=1,N_det_beta_unique + l = 1 + do i=1,N_det_alpha_unique + do k=1,N_int + tmp_det(k,1,l) = psi_det_alpha_unique(k,i) + tmp_det(k,2,l) = psi_det_beta_unique (k,j) + enddo + if (.not.is_in_wavefunction(tmp_det(1,1,l),N_int,N_det)) then + l = l+1 + endif + enddo + call fill_H_apply_buffer_no_selection(l-1, tmp_det, N_int, iproc) + enddo + !$OMP END DO NOWAIT + deallocate(tmp_det) + !$OMP END PARALLEL + deallocate (tmp_det) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH psi_det psi_coef N_det +end + + BEGIN_PROVIDER [ double precision, psi_svd_alpha, (N_det_alpha_unique,N_det_alpha_unique,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_svd_beta , (N_det_beta_unique,N_det_beta_unique,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_svd_coefs, (N_det_beta_unique,N_states) ] + implicit none + BEGIN_DOC + ! SVD wave function + END_DOC + + integer :: lwork, info, istate + double precision, allocatable :: work(:), tmp(:,:), copy(:,:) + allocate (work(1),tmp(N_det_beta_unique,N_det_beta_unique), & + copy(size(psi_svd_matrix,1),size(psi_svd_matrix,2))) + + do istate = 1,N_states + copy(:,:) = psi_svd_matrix(:,:,istate) + lwork=-1 + call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & + copy, size(copy,1), & + psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & + size(psi_svd_alpha,1), & + tmp, size(psi_svd_beta,2), & + work, lwork, info) + lwork = work(1) + deallocate(work) + allocate(work(lwork)) + call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & + copy, size(copy,1), & + psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & + size(psi_svd_alpha,1), & + tmp, size(psi_svd_beta,2), & + work, lwork, info) + deallocate(work) + if (info /= 0) then + print *, irp_here//': error in det SVD' + stop 1 + endif + integer :: i,j + do j=1,N_det_beta_unique + do i=1,N_det_beta_unique + psi_svd_beta(i,j,istate) = tmp(j,i) + enddo + enddo + deallocate(tmp,copy) + enddo + +END_PROVIDER + + diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f new file mode 100644 index 00000000..f867ad7e --- /dev/null +++ b/src/Determinants/truncate_wf.irp.f @@ -0,0 +1,18 @@ +program cisd + implicit none + integer :: i,k + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + N_det=10000 + do i=1,N_det + do k=1,N_int + psi_det(k,1,i) = psi_det_sorted(k,1,i) + psi_det(k,2,i) = psi_det_sorted(k,2,i) + enddo + psi_coef(k,:) = psi_coef_sorted(k,:) + enddo + TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det + call save_wavefunction +end diff --git a/src/Determinants/utils.irp.f b/src/Determinants/utils.irp.f new file mode 100644 index 00000000..22faee83 --- /dev/null +++ b/src/Determinants/utils.irp.f @@ -0,0 +1,20 @@ +BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] + implicit none + BEGIN_DOC + ! H matrix on the basis of the slater determinants defined by psi_det + END_DOC + integer :: i,j + double precision :: hij + call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) + !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij) & + !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) + do i =1,N_det + do j =i,N_det + call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) + H_matrix_all_dets(i,j) = hij + H_matrix_all_dets(j,i) = hij + enddo + enddo + !$OMP END PARALLEL DO +END_PROVIDER + diff --git a/src/Properties/EZFIO.cfg b/src/Properties/EZFIO.cfg new file mode 100644 index 00000000..d230011d --- /dev/null +++ b/src/Properties/EZFIO.cfg @@ -0,0 +1,5 @@ +[z_one_point] +type: double precision +doc: z point on which the integrated delta rho is calculated +interface: input +default: 3.9 \ No newline at end of file From d44ccfa2743db18b92eddaa4bef2361b16b639fc Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 18:20:26 +0200 Subject: [PATCH 35/70] mend --- src/Determinants/EZFIO.cfg | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 32b4d5f7..5f63404b 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -5,16 +5,11 @@ interface: input default: 1 [N_det_max_jacobi] -type: integer +type: Strictly_positive_int doc: Maximum number of determinants diagonalized by Jacobi interface: input default: 1000 -[n_states_diag] -type: integer -doc: n_states_diag -interface: Ocaml - [read_wf] type: logical doc: If true, read the wave function from the EZFIO file @@ -45,6 +40,14 @@ doc: Thresholds on selectors (fraction of the norm) interface: input default: 0.999 + +# Only create the ezfio_config, (no Input_* and no PROVIDER) + +[n_states_diag] +type: integer +doc: n_states_diag +interface: Ocaml + [n_int] interface: OCaml doc: n_int From b35f836af1ca979f4d5fff80059ab6332d3c5277 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 18:20:44 +0200 Subject: [PATCH 36/70] mend --- ocaml/Input_determinants.ml | 249 ------------------------------------ 1 file changed, 249 deletions(-) delete mode 100644 ocaml/Input_determinants.ml diff --git a/ocaml/Input_determinants.ml b/ocaml/Input_determinants.ml deleted file mode 100644 index fa08e72b..00000000 --- a/ocaml/Input_determinants.ml +++ /dev/null @@ -1,249 +0,0 @@ -(* =~=~ *) -(* Init *) -(* =~=~ *) - -open Qptypes;; -open Qputils;; -open Core.Std;; - -module Determinants : sig -(* Generate type *) - type t = - { - n_det_max_jacobi : int; - threshold_generators : Threshold.t; - threshold_selectors : Threshold.t; - n_states : States_number.t; - s2_eig : bool; - read_wf : bool; - only_single_double_dm : bool; - } with sexp - ;; - val read : unit -> t option - val write : t-> unit - val to_string : t -> string - val to_rst : t -> Rst_string.t - val of_rst : Rst_string.t -> t option -end = struct -(* Generate type *) - type t = - { - n_det_max_jacobi : int; - threshold_generators : Threshold.t; - threshold_selectors : Threshold.t; - n_states : States_number.t; - s2_eig : bool; - read_wf : bool; - only_single_double_dm : bool; - } with sexp - ;; - - let get_default = Qpackage.get_ezfio_default "determinants";; - -(* =~=~=~=~=~=~==~=~=~=~=~=~ *) -(* Generate Special Function *) -(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) - -(* Read snippet for n_det_max_jacobi *) - let read_n_det_max_jacobi () = - if not (Ezfio.has_determinants_n_det_max_jacobi ()) then - get_default "n_det_max_jacobi" - |> Int.of_string - |> Ezfio.set_determinants_n_det_max_jacobi - ; - Ezfio.get_determinants_n_det_max_jacobi () - ;; -(* Write snippet for n_det_max_jacobi *) - let write_n_det_max_jacobi = - Ezfio.set_determinants_n_det_max_jacobi - ;; - -(* Read snippet for n_states *) - let read_n_states () = - if not (Ezfio.has_determinants_n_states ()) then - get_default "n_states" - |> Int.of_string - |> Ezfio.set_determinants_n_states - ; - Ezfio.get_determinants_n_states () - |> States_number.of_int - ;; -(* Write snippet for n_states *) - let write_n_states var = - States_number.to_int var - |> Ezfio.set_determinants_n_states - ;; - -(* Read snippet for only_single_double_dm *) - let read_only_single_double_dm () = - if not (Ezfio.has_determinants_only_single_double_dm ()) then - get_default "only_single_double_dm" - |> Bool.of_string - |> Ezfio.set_determinants_only_single_double_dm - ; - Ezfio.get_determinants_only_single_double_dm () - ;; -(* Write snippet for only_single_double_dm *) - let write_only_single_double_dm = - Ezfio.set_determinants_only_single_double_dm - ;; - -(* Read snippet for read_wf *) - let read_read_wf () = - if not (Ezfio.has_determinants_read_wf ()) then - get_default "read_wf" - |> Bool.of_string - |> Ezfio.set_determinants_read_wf - ; - Ezfio.get_determinants_read_wf () - ;; -(* Write snippet for read_wf *) - let write_read_wf = - Ezfio.set_determinants_read_wf - ;; - -(* Read snippet for s2_eig *) - let read_s2_eig () = - if not (Ezfio.has_determinants_s2_eig ()) then - get_default "s2_eig" - |> Bool.of_string - |> Ezfio.set_determinants_s2_eig - ; - Ezfio.get_determinants_s2_eig () - ;; -(* Write snippet for s2_eig *) - let write_s2_eig = - Ezfio.set_determinants_s2_eig - ;; - -(* Read snippet for threshold_generators *) - let read_threshold_generators () = - if not (Ezfio.has_determinants_threshold_generators ()) then - get_default "threshold_generators" - |> Float.of_string - |> Ezfio.set_determinants_threshold_generators - ; - Ezfio.get_determinants_threshold_generators () - |> Threshold.of_float - ;; -(* Write snippet for threshold_generators *) - let write_threshold_generators var = - Threshold.to_float var - |> Ezfio.set_determinants_threshold_generators - ;; - -(* Read snippet for threshold_selectors *) - let read_threshold_selectors () = - if not (Ezfio.has_determinants_threshold_selectors ()) then - get_default "threshold_selectors" - |> Float.of_string - |> Ezfio.set_determinants_threshold_selectors - ; - Ezfio.get_determinants_threshold_selectors () - |> Threshold.of_float - ;; -(* Write snippet for threshold_selectors *) - let write_threshold_selectors var = - Threshold.to_float var - |> Ezfio.set_determinants_threshold_selectors - ;; - -(* =~=~=~=~=~=~=~=~=~=~=~=~ *) -(* Generate Global Function *) -(* =~=~=~=~=~=~=~=~=~=~=~=~ *) - -(* Read all *) - let read() = - Some - { - n_det_max_jacobi = read_n_det_max_jacobi (); - threshold_generators = read_threshold_generators (); - threshold_selectors = read_threshold_selectors (); - n_states = read_n_states (); - s2_eig = read_s2_eig (); - read_wf = read_read_wf (); - only_single_double_dm = read_only_single_double_dm (); - } - ;; -(* Write all *) - let write{ - n_det_max_jacobi; - threshold_generators; - threshold_selectors; - n_states; - s2_eig; - read_wf; - only_single_double_dm; - } = - write_n_det_max_jacobi n_det_max_jacobi; - write_threshold_generators threshold_generators; - write_threshold_selectors threshold_selectors; - write_n_states n_states; - write_s2_eig s2_eig; - write_read_wf read_wf; - write_only_single_double_dm only_single_double_dm; - ;; -(* to_string*) - let to_string b = - Printf.sprintf " - n_det_max_jacobi = %s - threshold_generators = %s - threshold_selectors = %s - n_states = %s - s2_eig = %s - read_wf = %s - only_single_double_dm = %s - " - (Int.to_string b.n_det_max_jacobi) - (Threshold.to_string b.threshold_generators) - (Threshold.to_string b.threshold_selectors) - (States_number.to_string b.n_states) - (Bool.to_string b.s2_eig) - (Bool.to_string b.read_wf) - (Bool.to_string b.only_single_double_dm) - ;; -(* to_rst*) - let to_rst b = - Printf.sprintf " - Maximum number of determinants diagonalized by Jacobi :: - - n_det_max_jacobi = %s - - Thresholds on generators (fraction of the norm) :: - - threshold_generators = %s - - Thresholds on selectors (fraction of the norm) :: - - threshold_selectors = %s - - Number of states to consider :: - - n_states = %s - - Force the wave function to be an eigenfunction of S^2 :: - - s2_eig = %s - - If true, read the wave function from the EZFIO file :: - - read_wf = %s - - If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements :: - - only_single_double_dm = %s - - " - (Int.to_string b.n_det_max_jacobi) - (Threshold.to_string b.threshold_generators) - (Threshold.to_string b.threshold_selectors) - (States_number.to_string b.n_states) - (Bool.to_string b.s2_eig) - (Bool.to_string b.read_wf) - (Bool.to_string b.only_single_double_dm) - |> Rst_string.of_string - ;; - include Generic_input_of_rst;; - let of_rst = of_rst t_of_sexp;; - -end \ No newline at end of file From bf997c558372b02ae1b87fd78c3f628675060697 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 16:45:06 +0200 Subject: [PATCH 37/70] Add all the mising file... --- ocaml/Input_determinants.ml | 251 ---- scripts/ezfio_interface/ei_handler.py | 1 - src/Determinants/ASSUMPTIONS.rst | 7 + src/Determinants/EZFIO.cfg | 103 ++ src/Determinants/H_apply.irp.f | 229 +++ src/Determinants/H_apply_template.f | 542 +++++++ src/Determinants/Makefile | 6 + src/Determinants/NEEDED_MODULES | 1 + src/Determinants/README.rst | 696 +++++++++ src/Determinants/SC2.irp.f | 215 +++ src/Determinants/connected_to_ref.irp.f | 357 +++++ src/Determinants/create_excitations.irp.f | 36 + src/Determinants/davidson.irp.f | 418 ++++++ src/Determinants/density_matrix.irp.f | 214 +++ src/Determinants/det_svd.irp.f | 61 + src/Determinants/determinants.irp.f | 9 - src/Determinants/determinants_bitmasks.irp.f | 57 + src/Determinants/diagonalize_CI.irp.f | 109 ++ src/Determinants/diagonalize_CI_SC2.irp.f | 59 + src/Determinants/diagonalize_CI_mono.irp.f | 72 + src/Determinants/excitations_utils.irp.f | 16 + src/Determinants/filter_connected.irp.f | 611 ++++++++ src/Determinants/guess_doublet.irp.f | 79 + src/Determinants/guess_singlet.irp.f | 44 + src/Determinants/guess_triplet.irp.f | 48 + src/Determinants/occ_pattern.irp.f | 339 +++++ src/Determinants/options.irp.f | 22 + .../program_beginer_determinants.irp.f | 138 ++ src/Determinants/psi_cas.irp.f | 114 ++ src/Determinants/ref_bitmask.irp.f | 57 + src/Determinants/s2.irp.f | 106 ++ src/Determinants/save_for_casino.irp.f | 268 ++++ src/Determinants/save_for_qmcchem.irp.f | 51 + src/Determinants/save_natorb.irp.f | 6 + src/Determinants/slater_rules.irp.f | 1301 +++++++++++++++++ .../spindeterminants.ezfio_config | 17 + src/Determinants/spindeterminants.irp.f | 615 ++++++++ src/Determinants/truncate_wf.irp.f | 18 + src/Determinants/utils.irp.f | 20 + src/Output/README.rst | 1 + src/Properties/EZFIO.cfg | 5 + 41 files changed, 7058 insertions(+), 261 deletions(-) delete mode 100644 ocaml/Input_determinants.ml create mode 100644 src/Determinants/ASSUMPTIONS.rst create mode 100644 src/Determinants/EZFIO.cfg create mode 100644 src/Determinants/H_apply.irp.f create mode 100644 src/Determinants/H_apply_template.f create mode 100644 src/Determinants/Makefile create mode 100644 src/Determinants/NEEDED_MODULES create mode 100644 src/Determinants/README.rst create mode 100644 src/Determinants/SC2.irp.f create mode 100644 src/Determinants/connected_to_ref.irp.f create mode 100644 src/Determinants/create_excitations.irp.f create mode 100644 src/Determinants/davidson.irp.f create mode 100644 src/Determinants/density_matrix.irp.f create mode 100644 src/Determinants/det_svd.irp.f create mode 100644 src/Determinants/determinants_bitmasks.irp.f create mode 100644 src/Determinants/diagonalize_CI.irp.f create mode 100644 src/Determinants/diagonalize_CI_SC2.irp.f create mode 100644 src/Determinants/diagonalize_CI_mono.irp.f create mode 100644 src/Determinants/excitations_utils.irp.f create mode 100644 src/Determinants/filter_connected.irp.f create mode 100644 src/Determinants/guess_doublet.irp.f create mode 100644 src/Determinants/guess_singlet.irp.f create mode 100644 src/Determinants/guess_triplet.irp.f create mode 100644 src/Determinants/occ_pattern.irp.f create mode 100644 src/Determinants/options.irp.f create mode 100644 src/Determinants/program_beginer_determinants.irp.f create mode 100644 src/Determinants/psi_cas.irp.f create mode 100644 src/Determinants/ref_bitmask.irp.f create mode 100644 src/Determinants/s2.irp.f create mode 100644 src/Determinants/save_for_casino.irp.f create mode 100644 src/Determinants/save_for_qmcchem.irp.f create mode 100644 src/Determinants/save_natorb.irp.f create mode 100644 src/Determinants/slater_rules.irp.f create mode 100644 src/Determinants/spindeterminants.ezfio_config create mode 100644 src/Determinants/spindeterminants.irp.f create mode 100644 src/Determinants/truncate_wf.irp.f create mode 100644 src/Determinants/utils.irp.f create mode 100644 src/Properties/EZFIO.cfg diff --git a/ocaml/Input_determinants.ml b/ocaml/Input_determinants.ml deleted file mode 100644 index df046231..00000000 --- a/ocaml/Input_determinants.ml +++ /dev/null @@ -1,251 +0,0 @@ -(* =~=~ *) -(* Init *) -(* =~=~ *) - -open Qptypes;; -open Qputils;; -open Core.Std;; - -module Determinants : sig -(* Generate type *) - type t = - { - n_det_max_jacobi : Strictly_positive_int.t; - threshold_generators : Threshold.t; - threshold_selectors : Threshold.t; - n_states : Strictly_positive_int.t; - s2_eig : bool; - read_wf : bool; - only_single_double_dm : bool; - } with sexp - ;; - val read : unit -> t option - val write : t-> unit - val to_string : t -> string - val to_rst : t -> Rst_string.t - val of_rst : Rst_string.t -> t option -end = struct -(* Generate type *) - type t = - { - n_det_max_jacobi : Strictly_positive_int.t; - threshold_generators : Threshold.t; - threshold_selectors : Threshold.t; - n_states : Strictly_positive_int.t; - s2_eig : bool; - read_wf : bool; - only_single_double_dm : bool; - } with sexp - ;; - - let get_default = Qpackage.get_ezfio_default "determinants";; - -(* =~=~=~=~=~=~==~=~=~=~=~=~ *) -(* Generate Special Function *) -(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) - -(* Read snippet for n_det_max_jacobi *) - let read_n_det_max_jacobi () = - if not (Ezfio.has_determinants_n_det_max_jacobi ()) then - get_default "n_det_max_jacobi" - |> Int.of_string - |> Ezfio.set_determinants_n_det_max_jacobi - ; - Ezfio.get_determinants_n_det_max_jacobi () - |> Strictly_positive_int.of_int - ;; -(* Write snippet for n_det_max_jacobi *) - let write_n_det_max_jacobi var = - Strictly_positive_int.to_int var - |> Ezfio.set_determinants_n_det_max_jacobi - ;; - -(* Read snippet for n_states *) - let read_n_states () = - if not (Ezfio.has_determinants_n_states ()) then - get_default "n_states" - |> Int.of_string - |> Ezfio.set_determinants_n_states - ; - Ezfio.get_determinants_n_states () - |> Strictly_positive_int.of_int - ;; -(* Write snippet for n_states *) - let write_n_states var = - Strictly_positive_int.to_int var - |> Ezfio.set_determinants_n_states - ;; - -(* Read snippet for only_single_double_dm *) - let read_only_single_double_dm () = - if not (Ezfio.has_determinants_only_single_double_dm ()) then - get_default "only_single_double_dm" - |> Bool.of_string - |> Ezfio.set_determinants_only_single_double_dm - ; - Ezfio.get_determinants_only_single_double_dm () - ;; -(* Write snippet for only_single_double_dm *) - let write_only_single_double_dm = - Ezfio.set_determinants_only_single_double_dm - ;; - -(* Read snippet for read_wf *) - let read_read_wf () = - if not (Ezfio.has_determinants_read_wf ()) then - get_default "read_wf" - |> Bool.of_string - |> Ezfio.set_determinants_read_wf - ; - Ezfio.get_determinants_read_wf () - ;; -(* Write snippet for read_wf *) - let write_read_wf = - Ezfio.set_determinants_read_wf - ;; - -(* Read snippet for s2_eig *) - let read_s2_eig () = - if not (Ezfio.has_determinants_s2_eig ()) then - get_default "s2_eig" - |> Bool.of_string - |> Ezfio.set_determinants_s2_eig - ; - Ezfio.get_determinants_s2_eig () - ;; -(* Write snippet for s2_eig *) - let write_s2_eig = - Ezfio.set_determinants_s2_eig - ;; - -(* Read snippet for threshold_generators *) - let read_threshold_generators () = - if not (Ezfio.has_determinants_threshold_generators ()) then - get_default "threshold_generators" - |> Float.of_string - |> Ezfio.set_determinants_threshold_generators - ; - Ezfio.get_determinants_threshold_generators () - |> Threshold.of_float - ;; -(* Write snippet for threshold_generators *) - let write_threshold_generators var = - Threshold.to_float var - |> Ezfio.set_determinants_threshold_generators - ;; - -(* Read snippet for threshold_selectors *) - let read_threshold_selectors () = - if not (Ezfio.has_determinants_threshold_selectors ()) then - get_default "threshold_selectors" - |> Float.of_string - |> Ezfio.set_determinants_threshold_selectors - ; - Ezfio.get_determinants_threshold_selectors () - |> Threshold.of_float - ;; -(* Write snippet for threshold_selectors *) - let write_threshold_selectors var = - Threshold.to_float var - |> Ezfio.set_determinants_threshold_selectors - ;; - -(* =~=~=~=~=~=~=~=~=~=~=~=~ *) -(* Generate Global Function *) -(* =~=~=~=~=~=~=~=~=~=~=~=~ *) - -(* Read all *) - let read() = - Some - { - n_det_max_jacobi = read_n_det_max_jacobi (); - threshold_generators = read_threshold_generators (); - threshold_selectors = read_threshold_selectors (); - n_states = read_n_states (); - s2_eig = read_s2_eig (); - read_wf = read_read_wf (); - only_single_double_dm = read_only_single_double_dm (); - } - ;; -(* Write all *) - let write{ - n_det_max_jacobi; - threshold_generators; - threshold_selectors; - n_states; - s2_eig; - read_wf; - only_single_double_dm; - } = - write_n_det_max_jacobi n_det_max_jacobi; - write_threshold_generators threshold_generators; - write_threshold_selectors threshold_selectors; - write_n_states n_states; - write_s2_eig s2_eig; - write_read_wf read_wf; - write_only_single_double_dm only_single_double_dm; - ;; -(* to_string*) - let to_string b = - Printf.sprintf " - n_det_max_jacobi = %s - threshold_generators = %s - threshold_selectors = %s - n_states = %s - s2_eig = %s - read_wf = %s - only_single_double_dm = %s - " - (Strictly_positive_int.to_string b.n_det_max_jacobi) - (Threshold.to_string b.threshold_generators) - (Threshold.to_string b.threshold_selectors) - (Strictly_positive_int.to_string b.n_states) - (Bool.to_string b.s2_eig) - (Bool.to_string b.read_wf) - (Bool.to_string b.only_single_double_dm) - ;; -(* to_rst*) - let to_rst b = - Printf.sprintf " - Maximum number of determinants diagonalized by Jacobi :: - - n_det_max_jacobi = %s - - Percentage of the norm of the state-averaged wave function to consider for the generators :: - - threshold_generators = %s - - Percentage of the norm of the state-averaged wave function to consider for the selectors :: - - threshold_selectors = %s - - Number of states to consider :: - - n_states = %s - - Force the wave function to be an eigenfunction of S^2 :: - - s2_eig = %s - - If true, read the wave function from the EZFIO file :: - - read_wf = %s - - If true, The One body DM is calculated with ignoing the Double <-> Doubles extra diag elements :: - - only_single_double_dm = %s - - " - (Strictly_positive_int.to_string b.n_det_max_jacobi) - (Threshold.to_string b.threshold_generators) - (Threshold.to_string b.threshold_selectors) - (Strictly_positive_int.to_string b.n_states) - (Bool.to_string b.s2_eig) - (Bool.to_string b.read_wf) - (Bool.to_string b.only_single_double_dm) - |> Rst_string.of_string - ;; - include Generic_input_of_rst;; - let of_rst = of_rst t_of_sexp;; - -end \ No newline at end of file diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index e5c08895..6d18d071 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -278,7 +278,6 @@ def get_dict_config_file(config_file_path, module_lower): try: d[pvd]["default"] = is_bool(default_raw) - print is_bool(default_raw) except TypeError: d[pvd]["default"] = Type(None, default_raw, default_raw) diff --git a/src/Determinants/ASSUMPTIONS.rst b/src/Determinants/ASSUMPTIONS.rst new file mode 100644 index 00000000..e9e24d09 --- /dev/null +++ b/src/Determinants/ASSUMPTIONS.rst @@ -0,0 +1,7 @@ +* The MOs are orthonormal +* All the determinants have the same number of electrons +* The determinants are orthonormal +* The number of generator determinants <= the number of determinants +* All the determinants in the H_apply buffer are supposed to be different from the + wave function determinants +* All the determinants in the H_apply buffer are supposed to be unique diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg new file mode 100644 index 00000000..5f63404b --- /dev/null +++ b/src/Determinants/EZFIO.cfg @@ -0,0 +1,103 @@ +[N_states] +type: States_number +doc: Number of states to consider +interface: input +default: 1 + +[N_det_max_jacobi] +type: Strictly_positive_int +doc: Maximum number of determinants diagonalized by Jacobi +interface: input +default: 1000 + +[read_wf] +type: logical +doc: If true, read the wave function from the EZFIO file +interface: input +default: False + +[only_single_double_dm] +type: logical +doc: If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements +interface: input +default: False + +[s2_eig] +type: logical +doc: Force the wave function to be an eigenfunction of S^2 +interface: input +default: False + +[threshold_generators] +type: Threshold +doc: Thresholds on generators (fraction of the norm) +interface: input +default: 0.99 + +[threshold_selectors] +type: Threshold +doc: Thresholds on selectors (fraction of the norm) +interface: input +default: 0.999 + + +# Only create the ezfio_config, (no Input_* and no PROVIDER) + +[n_states_diag] +type: integer +doc: n_states_diag +interface: Ocaml + +[n_int] +interface: OCaml +doc: n_int +type: N_int_number + +[bit_kind] +interface: OCaml +doc: bit_kind +type: Bit_kind + +[mo_label] +interface: OCaml +doc: o_label +type: character*(64) + +[n_det] +interface: OCaml +doc: n_det +type: integer + +[psi_coef] +interface: OCaml +doc: psi_coef +type: double precision +size: (determinants_n_det,determinants_n_states) + +[psi_det] +interface: OCaml +doc: psi_det +type: integer*8 +size: (determinants_n_int*determinants_bit_kind/8,2,determinants_n_det) + +[det_num] +interface: OCaml +doc: det_num +type: integer + +[det_occ] +interface: OCaml +doc: det_occ +type: integer +size: (electrons_elec_alpha_num,determinants_det_num,2) + +[det_coef] +interface: OCaml +doc: det_coef +type: double precision +size: (determinants_det_num) + +[expected_s2] +interface: OCaml +doc: expcted_s2 +type: double precision \ No newline at end of file diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f new file mode 100644 index 00000000..801d00a5 --- /dev/null +++ b/src/Determinants/H_apply.irp.f @@ -0,0 +1,229 @@ +use bitmasks +use omp_lib + +type H_apply_buffer_type +integer :: N_det +integer :: sze +integer(bit_kind), pointer :: det(:,:,:) +double precision , pointer :: coef(:,:) +double precision , pointer :: e2(:,:) +end type H_apply_buffer_type + +type(H_apply_buffer_type), pointer :: H_apply_buffer(:) + + + BEGIN_PROVIDER [ logical, H_apply_buffer_allocated ] +&BEGIN_PROVIDER [ integer(omp_lock_kind), H_apply_buffer_lock, (64,0:nproc-1) ] + use omp_lib + implicit none + BEGIN_DOC + ! Buffer of determinants/coefficients/perturbative energy for H_apply. + ! Uninitialized. Filled by H_apply subroutines. + END_DOC + integer :: iproc, sze + sze = 10000 + if (.not.associated(H_apply_buffer)) then + allocate(H_apply_buffer(0:nproc-1)) + iproc = 0 + !$OMP PARALLEL PRIVATE(iproc) DEFAULT(NONE) & + !$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock) + !$ iproc = omp_get_thread_num() + H_apply_buffer(iproc)%N_det = 0 + H_apply_buffer(iproc)%sze = sze + allocate ( & + H_apply_buffer(iproc)%det(N_int,2,sze), & + H_apply_buffer(iproc)%coef(sze,N_states), & + H_apply_buffer(iproc)%e2(sze,N_states) & + ) + H_apply_buffer(iproc)%det = 0_bit_kind + H_apply_buffer(iproc)%coef = 0.d0 + H_apply_buffer(iproc)%e2 = 0.d0 + call omp_init_lock(H_apply_buffer_lock(1,iproc)) + !$OMP END PARALLEL + endif + +END_PROVIDER + + +subroutine resize_H_apply_buffer(new_size,iproc) + implicit none + integer, intent(in) :: new_size, iproc + integer(bit_kind), pointer :: buffer_det(:,:,:) + double precision, pointer :: buffer_coef(:,:) + double precision, pointer :: buffer_e2(:,:) + integer :: i,j,k + integer :: Ndet + PROVIDE H_apply_buffer_allocated + + ASSERT (new_size > 0) + ASSERT (iproc >= 0) + ASSERT (iproc < nproc) + + call omp_set_lock(H_apply_buffer_lock(1,iproc)) + allocate ( buffer_det(N_int,2,new_size), & + buffer_coef(new_size,N_states), & + buffer_e2(new_size,N_states) ) + + do i=1,min(new_size,H_apply_buffer(iproc)%N_det) + do k=1,N_int + buffer_det(k,1,i) = H_apply_buffer(iproc)%det(k,1,i) + buffer_det(k,2,i) = H_apply_buffer(iproc)%det(k,2,i) + enddo + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num ) + enddo + deallocate(H_apply_buffer(iproc)%det) + H_apply_buffer(iproc)%det => buffer_det + + do k=1,N_states + do i=1,min(new_size,H_apply_buffer(iproc)%N_det) + buffer_coef(i,k) = H_apply_buffer(iproc)%coef(i,k) + enddo + enddo + deallocate(H_apply_buffer(iproc)%coef) + H_apply_buffer(iproc)%coef => buffer_coef + + do k=1,N_states + do i=1,min(new_size,H_apply_buffer(iproc)%N_det) + buffer_e2(i,k) = H_apply_buffer(iproc)%e2(i,k) + enddo + enddo + deallocate(H_apply_buffer(iproc)%e2) + H_apply_buffer(iproc)%e2 => buffer_e2 + + H_apply_buffer(iproc)%sze = new_size + H_apply_buffer(iproc)%N_det = min(new_size,H_apply_buffer(iproc)%N_det) + call omp_unset_lock(H_apply_buffer_lock(1,iproc)) + +end + +subroutine copy_H_apply_buffer_to_wf + use omp_lib + implicit none + BEGIN_DOC +! Copies the H_apply buffer to psi_coef. You need to touch psi_det, psi_coef and N_det +! after calling this function. +! After calling this subroutine, N_det, psi_det and psi_coef need to be touched + END_DOC + integer(bit_kind), allocatable :: buffer_det(:,:,:) + double precision, allocatable :: buffer_coef(:,:) + integer :: i,j,k + integer :: N_det_old + integer :: iproc + + PROVIDE H_apply_buffer_allocated + + ASSERT (N_int > 0) + ASSERT (N_det > 0) + + allocate ( buffer_det(N_int,2,N_det), buffer_coef(N_det,N_states) ) + + do i=1,N_det + do k=1,N_int + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num) + buffer_det(k,1,i) = psi_det(k,1,i) + buffer_det(k,2,i) = psi_det(k,2,i) + enddo + enddo + do k=1,N_states + do i=1,N_det + buffer_coef(i,k) = psi_coef(i,k) + enddo + enddo + + N_det_old = N_det + do j=0,nproc-1 + N_det = N_det + H_apply_buffer(j)%N_det + enddo + + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i=1,N_det_old + do k=1,N_int + psi_det(k,1,i) = buffer_det(k,1,i) + psi_det(k,2,i) = buffer_det(k,2,i) + enddo + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,N_det_old + psi_coef(i,k) = buffer_coef(i,k) + enddo + enddo + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states) + j=0 + !$ j=omp_get_thread_num() + do k=0,j-1 + N_det_old += H_apply_buffer(k)%N_det + enddo + do i=1,H_apply_buffer(j)%N_det + do k=1,N_int + psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i) + psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i) + enddo + ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,H_apply_buffer(j)%N_det + psi_coef(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) + enddo + enddo + !$OMP BARRIER + H_apply_buffer(j)%N_det = 0 + !$OMP END PARALLEL + call normalize(psi_coef,N_det) + SOFT_TOUCH N_det psi_det psi_coef + +end + + +subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) + use bitmasks + implicit none + BEGIN_DOC + ! Fill the H_apply buffer with determiants for CISD + END_DOC + + integer, intent(in) :: n_selected, Nint, iproc + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k + integer :: new_size + PROVIDE H_apply_buffer_allocated + new_size = H_apply_buffer(iproc)%N_det + n_selected + if (new_size > H_apply_buffer(iproc)%sze) then + call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc) + endif + call omp_set_lock(H_apply_buffer_lock(1,iproc)) + do i=1,H_apply_buffer(iproc)%N_det + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) + enddo + do i=1,n_selected + do j=1,N_int + H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) + H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) + enddo + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) + enddo + do j=1,N_states + do i=1,N_selected + H_apply_buffer(iproc)%coef(i,j) = 0.d0 + enddo + enddo + H_apply_buffer(iproc)%N_det = new_size + do i=1,H_apply_buffer(iproc)%N_det + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) + enddo + call omp_unset_lock(H_apply_buffer_lock(1,iproc)) +end + + diff --git a/src/Determinants/H_apply_template.f b/src/Determinants/H_apply_template.f new file mode 100644 index 00000000..a9a282ae --- /dev/null +++ b/src/Determinants/H_apply_template.f @@ -0,0 +1,542 @@ +subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_generator, iproc_in $parameters ) + use omp_lib + use bitmasks + implicit none + BEGIN_DOC + ! Generate all double excitations of key_in using the bit masks of holes and + ! particles. + ! Assume N_int is already provided. + END_DOC + integer,parameter :: size_max = $size_max + $declarations + integer ,intent(in) :: i_generator + integer(bit_kind),intent(in) :: key_in(N_int,2) + integer(bit_kind),allocatable :: keys_out(:,:,:) + integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2) + integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2) + integer, intent(in) :: iproc_in + integer(bit_kind), allocatable :: hole_save(:,:) + integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:) + integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:) + integer :: ii,i,jj,j,k,ispin,l + integer, allocatable :: occ_particle(:,:), occ_hole(:,:) + integer, allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer :: kk,pp,other_spin,key_idx + integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) + integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) + + double precision :: mo_bielec_integral + logical :: is_a_two_holes_two_particles + integer, allocatable :: ia_ja_pairs(:,:,:) + integer, allocatable :: ib_jb_pairs(:,:) + double precision :: diag_H_mat_elem + integer :: iproc + integer(omp_lock_kind), save :: lck, ifirst=0 + if (ifirst == 0) then +!$ call omp_init_lock(lck) + ifirst=1 + endif + + logical :: check_double_excitation + check_double_excitation = .True. + iproc = iproc_in + + + $initialization + + $omp_parallel +!$ iproc = omp_get_thread_num() + allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & + key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& + particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & + occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& + occ_hole_tmp(N_int*bit_kind_size,2)) + $init_thread + + + + !!!! First couple hole particle + do j = 1, N_int + hole(j,1) = iand(hole_1(j,1),key_in(j,1)) + hole(j,2) = iand(hole_1(j,2),key_in(j,2)) + particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) + particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) + enddo + call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) + call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) + call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int) + call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), & + ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num)) + + do ispin=1,2 + i=0 + do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole + i_a = occ_hole(ii,ispin) + ASSERT (i_a > 0) + ASSERT (i_a <= mo_tot_num) + + do jj=1,N_elec_in_key_part_1(ispin) !particle + j_a = occ_particle(jj,ispin) + ASSERT (j_a > 0) + ASSERT (j_a <= mo_tot_num) + i += 1 + ia_ja_pairs(1,i,ispin) = i_a + ia_ja_pairs(2,i,ispin) = j_a + enddo + enddo + ia_ja_pairs(1,0,ispin) = i + enddo + + key_idx = 0 + + integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b + integer(bit_kind) :: test(N_int,2) + double precision :: accu + logical, allocatable :: array_pairs(:,:) + allocate(array_pairs(mo_tot_num,mo_tot_num)) + accu = 0.d0 + do ispin=1,2 + other_spin = iand(ispin,1)+1 + if (abort_here) then + exit + endif + $omp_do + do ii=1,ia_ja_pairs(1,0,ispin) + if (abort_here) then + cycle + endif + i_a = ia_ja_pairs(1,ii,ispin) + ASSERT (i_a > 0) + ASSERT (i_a <= mo_tot_num) + j_a = ia_ja_pairs(2,ii,ispin) + ASSERT (j_a > 0) + ASSERT (j_a <= mo_tot_num) + hole = key_in + k = ishft(i_a-1,-bit_kind_shift)+1 + j = i_a-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + k_a = ishft(j_a-1,-bit_kind_shift)+1 + l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 + hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + + !!!! Second couple hole particle + do j = 1, N_int + hole_tmp(j,1) = iand(hole_2(j,1),hole(j,1)) + hole_tmp(j,2) = iand(hole_2(j,2),hole(j,2)) + particle_tmp(j,1) = iand(xor(particl_2(j,1),hole(j,1)),particl_2(j,1)) + particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2)) + enddo + + call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int) + call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int) + call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int) + call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int) + + ! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin) + hole_save = hole + + ! Build array of the non-zero integrals of second excitation + $filter_integrals + if (ispin == 1) then + integer :: jjj + + i=0 + do kk = 1,N_elec_in_key_hole_2(other_spin) + i_b = occ_hole_tmp(kk,other_spin) + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(other_spin) ! particule + j_b = occ_particle_tmp(jjj,other_spin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (array_pairs(i_b,j_b)) then + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + endif + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,other_spin) = ibclr(hole(k,other_spin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,other_spin) = ibset(key(k,other_spin),l) + $filter2h2p + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + if (abort_here) then + exit + endif + enddo + endif + + ! does all the mono excitations of the same spin + i=0 + do kk = 1,N_elec_in_key_hole_2(ispin) + i_b = occ_hole_tmp(kk,ispin) + if (i_b <= i_a.or.i_b == j_a) cycle + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(ispin) ! particule + j_b = occ_particle_tmp(jjj,ispin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (j_b <= j_a) cycle + if (array_pairs(i_b,j_b)) then + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + endif + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + $filter2h2p + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + if (abort_here) then + exit + endif + enddo ! kk + + enddo ! ii + $omp_enddo + enddo ! ispin + $keys_work + $deinit_thread + deallocate (ia_ja_pairs, ib_jb_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp,& + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp,& + occ_hole_tmp,array_pairs) + $omp_end_parallel + $finalization +end + +subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $parameters ) + use omp_lib + use bitmasks + implicit none + BEGIN_DOC + ! Generate all single excitations of key_in using the bit masks of holes and + ! particles. + ! Assume N_int is already provided. + END_DOC + integer,parameter :: size_max = $size_max + $declarations + integer ,intent(in) :: i_generator + integer(bit_kind),intent(in) :: key_in(N_int,2) + integer(bit_kind),intent(in) :: hole_1(N_int,2), particl_1(N_int,2) + integer, intent(in) :: iproc_in + integer(bit_kind),allocatable :: keys_out(:,:,:) + integer(bit_kind),allocatable :: hole_save(:,:) + integer(bit_kind),allocatable :: key(:,:),hole(:,:), particle(:,:) + integer(bit_kind),allocatable :: hole_tmp(:,:), particle_tmp(:,:) + integer(bit_kind),allocatable :: hole_2(:,:), particl_2(:,:) + integer :: ii,i,jj,j,k,ispin,l + integer,allocatable :: occ_particle(:,:), occ_hole(:,:) + integer,allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer,allocatable :: ib_jb_pairs(:,:) + integer :: kk,pp,other_spin,key_idx + integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) + integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) + logical :: is_a_two_holes_two_particles + + integer, allocatable :: ia_ja_pairs(:,:,:) + logical, allocatable :: array_pairs(:,:) + double precision :: diag_H_mat_elem + integer(omp_lock_kind), save :: lck, ifirst=0 + integer :: iproc + + logical :: check_double_excitation + iproc = iproc_in + + check_double_excitation = .True. + $check_double_excitation + + + if (ifirst == 0) then + ifirst=1 +!$ call omp_init_lock(lck) + endif + + $initialization + + $omp_parallel +!$ iproc = omp_get_thread_num() + allocate (keys_out(N_int,2,size_max), hole_save(N_int,2), & + key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),& + particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & + occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& + occ_hole_tmp(N_int*bit_kind_size,2)) + $init_thread + !!!! First couple hole particle + do j = 1, N_int + hole(j,1) = iand(hole_1(j,1),key_in(j,1)) + hole(j,2) = iand(hole_1(j,2),key_in(j,2)) + particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) + particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) + enddo + + call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) + call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) + call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int) + call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2)) + + do ispin=1,2 + i=0 + do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole + i_a = occ_hole(ii,ispin) + do jj=1,N_elec_in_key_part_1(ispin) !particule + j_a = occ_particle(jj,ispin) + i += 1 + ia_ja_pairs(1,i,ispin) = i_a + ia_ja_pairs(2,i,ispin) = j_a + enddo + enddo + ia_ja_pairs(1,0,ispin) = i + enddo + + key_idx = 0 + + integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b + integer(bit_kind) :: test(N_int,2) + double precision :: accu + accu = 0.d0 + do ispin=1,2 + other_spin = iand(ispin,1)+1 + $omp_do + do ii=1,ia_ja_pairs(1,0,ispin) + i_a = ia_ja_pairs(1,ii,ispin) + j_a = ia_ja_pairs(2,ii,ispin) + hole = key_in + k = ishft(i_a-1,-bit_kind_shift)+1 + j = i_a-ishft(k-1,bit_kind_shift)-1 + $filterhole + hole(k,ispin) = ibclr(hole(k,ispin),j) + k_a = ishft(j_a-1,-bit_kind_shift)+1 + l_a = j_a-ishft(k_a-1,bit_kind_shift)-1 + $filterparticle + hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) + $filter2h2p + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = hole(k,1) + keys_out(k,2,key_idx) = hole(k,2) + enddo + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + enddo ! ii + $omp_enddo + enddo ! ispin + $keys_work + $deinit_thread + deallocate (ia_ja_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp,& + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp,& + occ_hole_tmp) + $omp_end_parallel + $finalization + +end + + +subroutine $subroutine($params_main) + implicit none + use omp_lib + use bitmasks + BEGIN_DOC + ! Calls H_apply on the HF determinant and selects all connected single and double + ! excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + END_DOC + + $decls_main + + integer :: i_generator, nmax + double precision :: wall_0, wall_1 + integer(omp_lock_kind) :: lck + integer(bit_kind), allocatable :: mask(:,:,:) + integer :: ispin, k + integer :: iproc + + $initialization + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + + + nmax = mod( N_det_generators,nproc ) + + + !$ call omp_init_lock(lck) + call start_progress(N_det_generators,'Selection (norm)',0.d0) + + call wall_time(wall_0) + + iproc = 0 + allocate( mask(N_int,2,6) ) + do i_generator=1,nmax + + progress_bar(1) = i_generator + + if (abort_here) then + exit + endif + $skip + + ! Create bit masks for holes and particles + do ispin=1,2 + do k=1,N_int + mask(k,ispin,s_hole) = & + iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + enddo + enddo + if($do_double_excitations)then + call $subroutine_diexc(psi_det_generators(1,1,i_generator), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + i_generator, iproc $params_post) + endif + if($do_mono_excitations)then + call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + i_generator, iproc $params_post) + endif + call wall_time(wall_1) + $printout_always + if (wall_1 - wall_0 > 2.d0) then + $printout_now + wall_0 = wall_1 + endif + enddo + + deallocate( mask ) + + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc) + call wall_time(wall_0) + !$ iproc = omp_get_thread_num() + allocate( mask(N_int,2,6) ) + !$OMP DO SCHEDULE(dynamic,1) + do i_generator=nmax+1,N_det_generators + if (iproc == 0) then + progress_bar(1) = i_generator + endif + if (abort_here) then + cycle + endif + $skip + + ! Create bit masks for holes and particles + do ispin=1,2 + do k=1,N_int + mask(k,ispin,s_hole) = & + iand(generators_bitmask(k,ispin,s_hole,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,s_part) = & + iand(generators_bitmask(k,ispin,s_part,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole1) = & + iand(generators_bitmask(k,ispin,d_hole1,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part1) = & + iand(generators_bitmask(k,ispin,d_part1,i_bitmask_gen), & + not(psi_det_generators(k,ispin,i_generator)) ) + mask(k,ispin,d_hole2) = & + iand(generators_bitmask(k,ispin,d_hole2,i_bitmask_gen), & + psi_det_generators(k,ispin,i_generator) ) + mask(k,ispin,d_part2) = & + iand(generators_bitmask(k,ispin,d_part2,i_bitmask_gen), & + not (psi_det_generators(k,ispin,i_generator)) ) + enddo + enddo + + if($do_double_excitations)then + call $subroutine_diexc(psi_det_generators(1,1,i_generator), & + mask(1,1,d_hole1), mask(1,1,d_part1), & + mask(1,1,d_hole2), mask(1,1,d_part2), & + i_generator, iproc $params_post) + endif + if($do_mono_excitations)then + call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & + mask(1,1,s_hole ), mask(1,1,s_part ), & + i_generator, iproc $params_post) + endif + !$ call omp_set_lock(lck) + call wall_time(wall_1) + $printout_always + if (wall_1 - wall_0 > 2.d0) then + $printout_now + wall_0 = wall_1 + endif + !$ call omp_unset_lock(lck) + enddo + !$OMP END DO + deallocate( mask ) + !$OMP END PARALLEL + !$ call omp_destroy_lock(lck) + + abort_here = abort_all + call stop_progress + + $copy_buffer + $generate_psi_guess + +end + diff --git a/src/Determinants/Makefile b/src/Determinants/Makefile new file mode 100644 index 00000000..092d879d --- /dev/null +++ b/src/Determinants/Makefile @@ -0,0 +1,6 @@ +# Define here all new external source files and objects.Don't forget to prefix the +# object files with IRPF90_temp/ +SRC=H_apply_template.f +OBJ= + +include $(QPACKAGE_ROOT)/src/Makefile.common diff --git a/src/Determinants/NEEDED_MODULES b/src/Determinants/NEEDED_MODULES new file mode 100644 index 00000000..824c75ed --- /dev/null +++ b/src/Determinants/NEEDED_MODULES @@ -0,0 +1 @@ +AOs Bielec_integrals Bitmask Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst new file mode 100644 index 00000000..445c8b5e --- /dev/null +++ b/src/Determinants/README.rst @@ -0,0 +1,696 @@ +=========== +Dets Module +=========== + +This module contains the determinants of the CI wave function. + +H is applied on the list of generator determinants. Selected determinants +are added into the *H_apply buffer*. Then the new wave function is +constructred as the concatenation of the odl wave function and +some determinants of the H_apply buffer. Generator determinants are built +as a subset of the determinants of the wave function. + + +Assumptions +=========== + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +* The MOs are orthonormal +* All the determinants have the same number of electrons +* The determinants are orthonormal +* The number of generator determinants <= the number of determinants +* All the determinants in the H_apply buffer are supposed to be different from the + wave function determinants +* All the determinants in the H_apply buffer are supposed to be unique + + +Needed Modules +============== + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +* `AOs `_ +* `Bielec_integrals `_ +* `Bitmask `_ +* `Electrons `_ +* `Ezfio_files `_ +* `MonoInts `_ +* `MOs `_ +* `Nuclei `_ +* `Output `_ +* `Utils `_ + +Documentation +============= + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +`copy_h_apply_buffer_to_wf `_ + Copies the H_apply buffer to psi_coef. You need to touch psi_det, psi_coef and N_det + after calling this function. + After calling this subroutine, N_det, psi_det and psi_coef need to be touched + +`fill_h_apply_buffer_no_selection `_ + Fill the H_apply buffer with determiants for CISD + +`h_apply_buffer_allocated `_ + Buffer of determinants/coefficients/perturbative energy for H_apply. + Uninitialized. Filled by H_apply subroutines. + +`h_apply_buffer_lock `_ + Buffer of determinants/coefficients/perturbative energy for H_apply. + Uninitialized. Filled by H_apply subroutines. + +`resize_h_apply_buffer `_ + Undocumented + +`cisd_sc2 `_ + CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + Initial guess vectors are not necessarily orthonormal + +`connected_to_ref `_ + Undocumented + +`connected_to_ref_by_mono `_ + Undocumented + +`det_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`get_index_in_psi_det_sorted_bit `_ + Returns the index of the determinant in the ``psi_det_sorted_bit`` array + +`is_in_wavefunction `_ + True if the determinant ``det`` is in the wave function + +`occ_pattern_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`do_mono_excitation `_ + Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin + on key_in + ispin = 1 == alpha + ispin = 2 == beta + i_ok = 1 == the excitation is possible + i_ok = -1 == the excitation is not possible + +`davidson_converged `_ + True if the Davidson algorithm is converged + +`davidson_criterion `_ + Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + +`davidson_diag `_ + Davidson diagonalization. + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit number for the I/O + .br + Initial guess vectors are not necessarily orthonormal + +`davidson_diag_hjj `_ + Davidson diagonalization with specific diagonal elements of the H matrix + .br + H_jj : specific diagonal H matrix elements to diagonalize de Davidson + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit for the I/O + .br + Initial guess vectors are not necessarily orthonormal + +`davidson_iter_max `_ + Max number of Davidson iterations + +`davidson_sze_max `_ + Max number of Davidson sizes + +`davidson_threshold `_ + Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + +`one_body_dm_mo `_ + One-body density matrix + +`one_body_dm_mo_alpha `_ + Alpha and beta one-body density matrix for each state + +`one_body_dm_mo_beta `_ + Alpha and beta one-body density matrix for each state + +`one_body_single_double_dm_mo_alpha `_ + Alpha and beta one-body density matrix for each state + +`one_body_single_double_dm_mo_beta `_ + Alpha and beta one-body density matrix for each state + +`one_body_spin_density_mo `_ + rho(alpha) - rho(beta) + +`save_natural_mos `_ + Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + +`set_natural_mos `_ + Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + +`state_average_weight `_ + Weights in the state-average calculation of the density matrix + +`det_svd `_ + Computes the SVD of the Alpha x Beta determinant coefficient matrix + +`filter_3_highest_electrons `_ + Returns a determinant with only the 3 highest electrons + +`int_of_3_highest_electrons `_ + Returns an integer*8 as : + .br + |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| + .br + |0<--- i1 ---><--- i2 ---><--- i3 --->| + .br + It encodes the value of the indices of the 3 highest MOs + in descending order + .br + +`max_degree_exc `_ + Maximum degree of excitation in the wf + +`n_det `_ + Number of determinants in the wave function + +`psi_average_norm_contrib `_ + Contribution of determinants to the state-averaged density + +`psi_average_norm_contrib_sorted `_ + Wave function sorted by determinants contribution to the norm (state-averaged) + +`psi_coef `_ + The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file + is empty + +`psi_coef_sorted `_ + Wave function sorted by determinants contribution to the norm (state-averaged) + +`psi_coef_sorted_ab `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`psi_coef_sorted_bit `_ + Determinants on which we apply for perturbation. + They are sorted by determinants interpreted as integers. Useful + to accelerate the search of a random determinant in the wave + function. + +`psi_det `_ + The wave function determinants. Initialized with Hartree-Fock if the EZFIO file + is empty + +`psi_det_size `_ + Size of the psi_det/psi_coef arrays + +`psi_det_sorted `_ + Wave function sorted by determinants contribution to the norm (state-averaged) + +`psi_det_sorted_ab `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`psi_det_sorted_bit `_ + Determinants on which we apply for perturbation. + They are sorted by determinants interpreted as integers. Useful + to accelerate the search of a random determinant in the wave + function. + +`psi_det_sorted_next_ab `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`read_dets `_ + Reads the determinants from the EZFIO file + +`save_wavefunction `_ + Save the wave function into the EZFIO file + +`save_wavefunction_general `_ + Save the wave function into the EZFIO file + +`save_wavefunction_unsorted `_ + Save the wave function into the EZFIO file + +`sort_dets_by_3_highest_electrons `_ + Determinants on which we apply . + They are sorted by the 3 highest electrons in the alpha part, + then by the 3 highest electrons in the beta part to accelerate + the research of connected determinants. + +`sort_dets_by_det_search_key `_ + Determinants are sorted are sorted according to their det_search_key. + Useful to accelerate the search of a random determinant in the wave + function. + +`double_exc_bitmask `_ + double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 + double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 + double_exc_bitmask(:,3,i) is the bitmask for holes of excitation 2 + double_exc_bitmask(:,4,i) is the bitmask for particles of excitation 2 + for a given couple of hole/particle excitations i. + +`n_double_exc_bitmasks `_ + Number of double excitation bitmasks + +`n_single_exc_bitmasks `_ + Number of single excitation bitmasks + +`single_exc_bitmask `_ + single_exc_bitmask(:,1,i) is the bitmask for holes + single_exc_bitmask(:,2,i) is the bitmask for particles + for a given couple of hole/particle excitations i. + +`ci_eigenvectors `_ + Eigenvectors/values of the CI matrix + +`ci_eigenvectors_s2 `_ + Eigenvectors/values of the CI matrix + +`ci_electronic_energy `_ + Eigenvectors/values of the CI matrix + +`ci_energy `_ + N_states lowest eigenvalues of the CI matrix + +`diag_algorithm `_ + Diagonalization algorithm (Davidson or Lapack) + +`diagonalize_ci `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + +`ci_sc2_eigenvectors `_ + Eigenvectors/values of the CI matrix + +`ci_sc2_electronic_energy `_ + Eigenvectors/values of the CI matrix + +`ci_sc2_energy `_ + N_states_diag lowest eigenvalues of the CI matrix + +`diagonalize_ci_sc2 `_ + Replace the coefficients of the CI states_diag by the coefficients of the + eigenstates of the CI matrix + +`threshold_convergence_sc2 `_ + convergence of the correlation energy of SC2 iterations + +`ci_eigenvectors_mono `_ + Eigenvectors/values of the CI matrix + +`ci_eigenvectors_s2_mono `_ + Eigenvectors/values of the CI matrix + +`ci_electronic_energy_mono `_ + Eigenvectors/values of the CI matrix + +`diagonalize_ci_mono `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + +`apply_mono `_ + Undocumented + +`filter_connected `_ + Filters out the determinants that are not connected by H + .br + returns the array idx which contains the index of the + .br + determinants in the array key1 that interact + .br + via the H operator with key2. + .br + idx(0) is the number of determinants that interact with key1 + +`filter_connected_davidson `_ + Filters out the determinants that are not connected by H + returns the array idx which contains the index of the + determinants in the array key1 that interact + via the H operator with key2. + .br + idx(0) is the number of determinants that interact with key1 + key1 should come from psi_det_sorted_ab. + +`filter_connected_i_h_psi0 `_ + returns the array idx which contains the index of the + .br + determinants in the array key1 that interact + .br + via the H operator with key2. + .br + idx(0) is the number of determinants that interact with key1 + +`filter_connected_i_h_psi0_sc2 `_ + standard filter_connected_i_H_psi but returns in addition + .br + the array of the index of the non connected determinants to key1 + .br + in order to know what double excitation can be repeated on key1 + .br + idx_repeat(0) is the number of determinants that can be used + .br + to repeat the excitations + +`filter_connected_sorted_ab `_ + Filters out the determinants that are not connected by H + returns the array idx which contains the index of the + determinants in the array key1 that interact + via the H operator with key2. + idx(0) is the number of determinants that interact with key1 + .br + Determinants are taken from the psi_det_sorted_ab array + +`put_gess `_ + Undocumented + +`det_to_occ_pattern `_ + Transform a determinant to an occupation pattern + +`make_s2_eigenfunction `_ + Undocumented + +`n_occ_pattern `_ + array of the occ_pattern present in the wf + psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + +`occ_pattern_to_dets `_ + Generate all possible determinants for a give occ_pattern + +`occ_pattern_to_dets_size `_ + Number of possible determinants for a given occ_pattern + +`psi_occ_pattern `_ + array of the occ_pattern present in the wf + psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + +`rec_occ_pattern_to_dets `_ + Undocumented + +`n_states_diag `_ + Number of states to consider for the diagonalization + +`pouet `_ + Undocumented + +`routine `_ + Undocumented + +`idx_cas `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`idx_non_cas `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`n_det_cas `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`n_det_non_cas `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`psi_cas `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`psi_cas_coef `_ + CAS wave function, defined from the application of the CAS bitmask on the + determinants. idx_cas gives the indice of the CAS determinant in psi_det. + +`psi_cas_coef_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`psi_cas_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`psi_non_cas `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`psi_non_cas_coef `_ + Set of determinants which are not part of the CAS, defined from the application + of the CAS bitmask on the determinants. + idx_non_cas gives the indice of the determinant in psi_det. + +`psi_non_cas_coef_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`psi_non_cas_sorted_bit `_ + CAS determinants sorted to accelerate the search of a random determinant in the wave + function. + +`bi_elec_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`kinetic_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`mono_elec_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`nucl_elec_ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`ref_bitmask_energy `_ + Energy of the reference bitmask used in Slater rules + +`expected_s2 `_ + Expected value of S2 : S*(S+1) + +`get_s2 `_ + Returns + +`get_s2_u0 `_ + Undocumented + +`s2_values `_ + array of the averaged values of the S^2 operator on the various states + +`s_z `_ + z component of the Spin + +`s_z2_sz `_ + z component of the Spin + +`prog_save_casino `_ + Undocumented + +`save_casino `_ + Undocumented + +`save_dets_qmcchem `_ + Undocumented + +`save_for_qmc `_ + Undocumented + +`save_natorb `_ + Undocumented + +`a_operator `_ + Needed for diag_H_mat_elem + +`ac_operator `_ + Needed for diag_H_mat_elem + +`decode_exc `_ + Decodes the exc arrays returned by get_excitation. + h1,h2 : Holes + p1,p2 : Particles + s1,s2 : Spins (1:alpha, 2:beta) + degree : Degree of excitation + +`det_connections `_ + Build connection proxy between determinants + +`diag_h_mat_elem `_ + Computes + +`get_double_excitation `_ + Returns the two excitation operators between two doubly excited determinants and the phase + +`get_excitation `_ + Returns the excitation operators between two determinants and the phase + +`get_excitation_degree `_ + Returns the excitation degree between two determinants + +`get_excitation_degree_vector `_ + Applies get_excitation_degree to an array of determinants + +`get_mono_excitation `_ + Returns the excitation operator between two singly excited determinants and the phase + +`get_occ_from_key `_ + Returns a list of occupation numbers from a bitstring + +`h_u_0 `_ + Computes v_0 = H|u_0> + .br + n : number of determinants + .br + H_jj : array of + +`i_h_j `_ + Returns where i and j are determinants + +`i_h_j_verbose `_ + Returns where i and j are determinants + +`i_h_psi `_ + for the various Nstates + +`i_h_psi_sc2 `_ + for the various Nstate + .br + returns in addition + .br + the array of the index of the non connected determinants to key1 + .br + in order to know what double excitation can be repeated on key1 + .br + idx_repeat(0) is the number of determinants that can be used + .br + to repeat the excitations + +`i_h_psi_sc2_verbose `_ + for the various Nstate + .br + returns in addition + .br + the array of the index of the non connected determinants to key1 + .br + in order to know what double excitation can be repeated on key1 + .br + idx_repeat(0) is the number of determinants that can be used + .br + to repeat the excitations + +`i_h_psi_sec_ord `_ + for the various Nstates + +`n_con_int `_ + Number of integers to represent the connections between determinants + +`create_wf_of_psi_svd_matrix `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`generate_all_alpha_beta_det_products `_ + Create a wave function from all possible alpha x beta determinants + +`get_index_in_psi_det_alpha_unique `_ + Returns the index of the determinant in the ``psi_det_alpha_unique`` array + +`get_index_in_psi_det_beta_unique `_ + Returns the index of the determinant in the ``psi_det_beta_unique`` array + +`n_det_alpha_unique `_ + Unique alpha determinants + +`n_det_beta_unique `_ + Unique beta determinants + +`psi_det_alpha `_ + List of alpha determinants of psi_det + +`psi_det_alpha_unique `_ + Unique alpha determinants + +`psi_det_beta `_ + List of beta determinants of psi_det + +`psi_det_beta_unique `_ + Unique beta determinants + +`psi_svd_alpha `_ + SVD wave function + +`psi_svd_beta `_ + SVD wave function + +`psi_svd_coefs `_ + SVD wave function + +`psi_svd_matrix `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_columns `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_rows `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`psi_svd_matrix_values `_ + Matrix of wf coefficients. Outer product of alpha and beta determinants + +`spin_det_search_key `_ + Return an integer*8 corresponding to a determinant index for searching + +`write_spindeterminants `_ + Undocumented + +`cisd `_ + Undocumented + +`h_matrix_all_dets `_ + H matrix on the basis of the slater determinants defined by psi_det + + + diff --git a/src/Determinants/SC2.irp.f b/src/Determinants/SC2.irp.f new file mode 100644 index 00000000..440b2870 --- /dev/null +++ b/src/Determinants/SC2.irp.f @@ -0,0 +1,215 @@ +subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + double precision, intent(in) :: convergence + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + integer :: iter + integer :: i,j,k,l,m + logical :: converged + double precision :: overlap(N_st,N_st) + double precision :: u_dot_v, u_dot_u + + integer :: degree,N_double,index_hf + double precision :: hij_elec, e_corr_double,e_corr,diag_h_mat_elem,inv_c0 + double precision :: e_corr_double_before,accu,cpu_2,cpu_1 + integer,allocatable :: degree_exc(:), index_double(:) + integer :: i_ok + double precision,allocatable :: e_corr_array(:),H_jj_ref(:),H_jj_dressed(:),hij_double(:) + integer(bit_kind), allocatable :: doubles(:,:,:) + + + allocate (doubles(Nint,2,sze),e_corr_array(sze),H_jj_ref(sze),H_jj_dressed(sze),& + index_double(sze), degree_exc(sze), hij_double(sze)) + call write_time(output_determinants) + write(output_determinants,'(A)') '' + write(output_determinants,'(A)') 'CISD SC2' + write(output_determinants,'(A)') '========' + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze,N_st, & + !$OMP H_jj_ref,Nint,dets_in,u_in) & + !$OMP PRIVATE(i) + + !$OMP DO SCHEDULE(guided) + do i=1,sze + H_jj_ref(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) + enddo + !$OMP END DO NOWAIT + !$OMP END PARALLEL + + N_double = 0 + e_corr = 0.d0 + e_corr_double = 0.d0 + do i = 1, sze + call get_excitation_degree(ref_bitmask,dets_in(1,1,i),degree,Nint) + degree_exc(i) = degree+1 + if(degree==0)then + index_hf=i + else if (degree == 2)then + N_double += 1 + index_double(N_double) = i + doubles(:,:,N_double) = dets_in(:,:,i) + call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) + hij_double(N_double) = hij_elec + e_corr_array(N_double) = u_in(i,1)* hij_elec + e_corr_double += e_corr_array(N_double) + e_corr += e_corr_array(N_double) + else if (degree == 1)then + call i_H_j(ref_bitmask,dets_in(1,1,i),Nint,hij_elec) + e_corr += u_in(i,1)* hij_elec + endif + enddo + inv_c0 = 1.d0/u_in(index_hf,1) + do i = 1, N_double + e_corr_array(i) = e_corr_array(i) * inv_c0 + enddo + e_corr = e_corr * inv_c0 + e_corr_double = e_corr_double * inv_c0 + converged = .False. + e_corr_double_before = e_corr_double + iter = 0 + do while (.not.converged) + if (abort_here) then + exit + endif + iter +=1 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,degree,accu) & + !$OMP SHARED(H_jj_dressed,sze,H_jj_ref,index_hf,N_int,N_double,& + !$OMP dets_in,doubles,degree_exc,e_corr_array,e_corr_double) + !$OMP DO SCHEDULE(STATIC) + do i=1,sze + H_jj_dressed(i) = H_jj_ref(i) + if (i==index_hf)cycle + accu = -e_corr_double + select case (N_int) + case (1) + do j=1,N_double + degree = & + popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & + popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + + if (degree<=ishft(degree_exc(i),1)) then + accu += e_corr_array(j) + endif + enddo + case (2) + do j=1,N_double + degree = & + popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & + popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & + popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & + popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) + + if (degree<=ishft(degree_exc(i),1)) then + accu += e_corr_array(j) + endif + enddo + case (3) + do j=1,N_double + degree = & + popcnt(xor( dets_in(1,1,i),doubles(1,1,j))) + & + popcnt(xor( dets_in(1,2,i),doubles(1,2,j))) + & + popcnt(xor( dets_in(2,1,i),doubles(2,1,j))) + & + popcnt(xor( dets_in(2,2,i),doubles(2,2,j))) + & + popcnt(xor( dets_in(3,1,i),doubles(3,1,j))) + & + popcnt(xor( dets_in(3,2,i),doubles(3,2,j))) + + if (degree<=ishft(degree_exc(i),1)) then + accu += e_corr_array(j) + endif + enddo + case default + do j=1,N_double + call get_excitation_degree(dets_in(1,1,i),doubles(1,1,j),degree,N_int) + if (degree<=degree_exc(i)) then + accu += e_corr_array(j) + endif + enddo + end select + H_jj_dressed(i) -= accu + enddo + !$OMP END DO + !$OMP END PARALLEL + + if(sze<=N_det_max_jacobi)then + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) + allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) + do j=1,sze + do i=1,sze + H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) + enddo + enddo + do i = 1,sze + H_matrix_tmp(i,i) = H_jj_dressed(i) + enddo + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_tmp,size(H_matrix_all_dets,1),sze) + do j=1,min(N_states_diag,sze) + do i=1,sze + u_in(i,j) = eigenvectors(i,j) + enddo + energies(j) = eigenvalues(j) + enddo + deallocate (H_matrix_tmp, eigenvalues, eigenvectors) + else + call davidson_diag_hjj(dets_in,u_in,H_jj_dressed,energies,dim_in,sze,N_st,Nint,output_determinants) + endif + + e_corr_double = 0.d0 + inv_c0 = 1.d0/u_in(index_hf,1) + do i = 1, N_double + e_corr_array(i) = u_in(index_double(i),1)*inv_c0 * hij_double(i) + e_corr_double += e_corr_array(i) + enddo + write(output_determinants,'(A,I3)') 'SC2 Iteration ', iter + write(output_determinants,'(A)') '------------------' + write(output_determinants,'(A)') '' + write(output_determinants,'(A)') '===== ================' + write(output_determinants,'(A)') 'State Energy ' + write(output_determinants,'(A)') '===== ================' + do i=1,N_st + write(output_determinants,'(I5,X,F16.10)') i, energies(i)+nuclear_repulsion + enddo + write(output_determinants,'(A)') '===== ================' + write(output_determinants,'(A)') '' + call write_double(output_determinants,(e_corr_double - e_corr_double_before),& + 'Delta(E_corr)') + converged = dabs(e_corr_double - e_corr_double_before) < convergence + converged = converged .or. abort_here + if (converged) then + exit + endif + e_corr_double_before = e_corr_double + + enddo + + call write_time(output_determinants) + deallocate (doubles,e_corr_array,H_jj_ref,H_jj_dressed, & + index_double, degree_exc, hij_double) + +end + + diff --git a/src/Determinants/connected_to_ref.irp.f b/src/Determinants/connected_to_ref.irp.f new file mode 100644 index 00000000..2d40b621 --- /dev/null +++ b/src/Determinants/connected_to_ref.irp.f @@ -0,0 +1,357 @@ +integer*8 function det_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint,2) + integer :: i + det_search_key = iand(det(1,1),det(1,2)) + do i=2,Nint + det_search_key = ieor(det_search_key,iand(det(i,1),det(i,2))) + enddo +end + + +integer*8 function occ_pattern_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint,2) + integer :: i + occ_pattern_search_key = ieor(det(1,1),det(1,2)) + do i=2,Nint + occ_pattern_search_key = ieor(occ_pattern_search_key,iand(det(i,1),det(i,2))) + enddo +end + + + +logical function is_in_wavefunction(key,Nint,Ndet) + use bitmasks + implicit none + BEGIN_DOC +! True if the determinant ``det`` is in the wave function + END_DOC + integer, intent(in) :: Nint, Ndet + integer(bit_kind), intent(in) :: key(Nint,2) + integer, external :: get_index_in_psi_det_sorted_bit + + !DIR$ FORCEINLINE + is_in_wavefunction = get_index_in_psi_det_sorted_bit(key,Nint) > 0 +end + +integer function get_index_in_psi_det_sorted_bit(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_sorted_bit`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_sorted_bit = 0 + ibegin = 1 + iend = N_det+1 + + !DIR$ FORCEINLINE + det_ref = det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = det_search_key(psi_det_sorted_bit(1,1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = det_search_key(psi_det_sorted_bit(1,1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det) then + return + endif + + !DIR$ FORCEINLINE + do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) + if ( (key(1,1) /= psi_det_sorted_bit(1,1,i)).or. & + (key(1,2) /= psi_det_sorted_bit(1,2,i)) ) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if ( (key(l,1) /= psi_det_sorted_bit(l,1,i)).or. & + (key(l,2) /= psi_det_sorted_bit(l,2,i)) ) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_sorted_bit = i +! exit + return + endif + endif + i += 1 + if (i > N_det) then +! exit + return + endif + + enddo + +! DEBUG is_in_wf +! if (is_in_wavefunction) then +! degree = 1 +! do i=1,N_det +! integer :: degree +! call get_excitation_degree(key,psi_det(1,1,i),degree,N_int) +! if (degree == 0) then +! exit +! endif +! enddo +! if (degree /=0) then +! stop 'pouet 1' +! endif +! else +! do i=1,N_det +! call get_excitation_degree(key,psi_det(1,1,i),degree,N_int) +! if (degree == 0) then +! stop 'pouet 2' +! endif +! enddo +! endif +! END DEBUG is_in_wf +end + +integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) + use bitmasks + implicit none + integer, intent(in) :: Nint, N_past_in, Ndet + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: N_past + integer :: i, l + integer :: degree_x2 + logical :: t + double precision :: hij_elec + + ! output : 0 : not connected + ! i : connected to determinant i of the past + ! -i : is the ith determinant of the refernce wf keys + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + connected_to_ref = 0 + N_past = max(1,N_past_in) + if (Nint == 1) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + return + + + else if (Nint==2) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + return + + else if (Nint==3) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + & + popcnt(xor( key(3,1), keys(3,1,i))) + & + popcnt(xor( key(3,2), keys(3,2,i))) + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + return + + else + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + !DEC$ LOOP COUNT MIN(3) + do l=2,Nint + degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& + popcnt(xor( key(l,2), keys(l,2,i))) + enddo + if (degree_x2 > 4) then + cycle + else + connected_to_ref = i + return + endif + enddo + + endif + +end + + + +integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) + use bitmasks + implicit none + integer, intent(in) :: Nint, N_past_in, Ndet + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: N_past + integer :: i, l + integer :: degree_x2 + logical :: t + double precision :: hij_elec + + ! output : 0 : not connected + ! i : connected to determinant i of the past + ! -i : is the ith determinant of the refernce wf keys + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + connected_to_ref_by_mono = 0 + N_past = max(1,N_past_in) + if (Nint == 1) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + return + + + else if (Nint==2) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + return + + else if (Nint==3) then + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + & + popcnt(xor( key(2,1), keys(2,1,i))) + & + popcnt(xor( key(2,2), keys(2,2,i))) + & + popcnt(xor( key(3,1), keys(3,1,i))) + & + popcnt(xor( key(3,2), keys(3,2,i))) + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + return + + else + + do i=N_past-1,1,-1 + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + !DEC$ LOOP COUNT MIN(3) + do l=2,Nint + degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& + popcnt(xor( key(l,2), keys(l,2,i))) + enddo + if (degree_x2 > 3.and. degree_x2 <5) then + cycle + else if (degree_x2 == 4)then + cycle + else if(degree_x2 == 2)then + connected_to_ref_by_mono = i + return + endif + enddo + + endif + +end + + diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f new file mode 100644 index 00000000..a33525c7 --- /dev/null +++ b/src/Determinants/create_excitations.irp.f @@ -0,0 +1,36 @@ +subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) + implicit none + BEGIN_DOC + ! Apply the mono excitation operator : a^{dager}_(i_particle) a_(i_hole) of spin = ispin + ! on key_in + ! ispin = 1 == alpha + ! ispin = 2 == beta + ! i_ok = 1 == the excitation is possible + ! i_ok = -1 == the excitation is not possible + END_DOC + integer, intent(in) :: i_hole,i_particle,ispin + integer(bit_kind), intent(inout) :: key_in(N_int,2) + integer, intent(out) :: i_ok + integer :: k,j,i + use bitmasks + ASSERT (i_hole > 0 ) + ASSERT (i_particle <= mo_tot_num) + i_ok = 1 + ! hole + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin) = ibclr(key_in(k,ispin),j) + + ! particle + k = ishft(i_particle-1,-bit_kind_shift)+1 + j = i_particle-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin) = ibset(key_in(k,ispin),j) + integer :: n_elec_tmp + n_elec_tmp = 0 + do i = 1, N_int + n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) + enddo + if(n_elec_tmp .ne. elec_num)then + i_ok = -1 + endif +end diff --git a/src/Determinants/davidson.irp.f b/src/Determinants/davidson.irp.f new file mode 100644 index 00000000..bdc979c4 --- /dev/null +++ b/src/Determinants/davidson.irp.f @@ -0,0 +1,418 @@ +BEGIN_PROVIDER [ integer, davidson_iter_max ] + implicit none + BEGIN_DOC + ! Max number of Davidson iterations + END_DOC + davidson_iter_max = 100 +END_PROVIDER + +BEGIN_PROVIDER [ integer, davidson_sze_max ] + implicit none + BEGIN_DOC + ! Max number of Davidson sizes + END_DOC + ASSERT (davidson_sze_max <= davidson_iter_max) + davidson_sze_max = 8*N_states_diag +END_PROVIDER + +subroutine davidson_diag(dets_in,u_in,energies,dim_in,sze,N_st,Nint,iunit) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization. + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! iunit : Unit number for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint, iunit + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + double precision, allocatable :: H_jj(:) + + double precision :: diag_h_mat_elem + integer :: i + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + PROVIDE mo_bielec_integrals_in_map + allocate(H_jj(sze)) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze,H_jj,dets_in,Nint) & + !$OMP PRIVATE(i) + !$OMP DO SCHEDULE(guided) + do i=1,sze + H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) + enddo + !$OMP END DO + !$OMP END PARALLEL + + call davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) + deallocate (H_jj) +end + +subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iunit) + use bitmasks + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: overlap(N_st,N_st) + double precision :: u_dot_v, u_dot_u + + integer, allocatable :: kl_pairs(:,:) + integer :: k_pairs, kl + + integer :: iter2 + double precision, allocatable :: W(:,:,:), U(:,:,:), R(:,:) + double precision, allocatable :: y(:,:,:,:), h(:,:,:,:), lambda(:) + double precision :: diag_h_mat_elem + double precision :: residual_norm(N_st) + character*(16384) :: write_buffer + double precision :: to_print(2,N_st) + double precision :: cpu, wall + + PROVIDE det_connections + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,sze,'Number of determinants') + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ================' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy Residual' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ================' + enddo + write(iunit,'(A)') trim(write_buffer) + + allocate( & + kl_pairs(2,N_st*(N_st+1)/2), & + W(sze,N_st,davidson_sze_max), & + U(sze,N_st,davidson_sze_max), & + R(sze,N_st), & + h(N_st,davidson_sze_max,N_st,davidson_sze_max), & + y(N_st,davidson_sze_max,N_st,davidson_sze_max), & + lambda(N_st*davidson_sze_max)) + + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Initialization + ! ============== + + k_pairs=0 + do l=1,N_st + do k=1,l + k_pairs+=1 + kl_pairs(1,k_pairs) = k + kl_pairs(2,k_pairs) = l + enddo + enddo + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & + !$OMP Nint,dets_in,u_in) & + !$OMP PRIVATE(k,l,kl,i) + + + ! Orthonormalize initial guess + ! ============================ + + !$OMP DO + do kl=1,k_pairs + k = kl_pairs(1,kl) + l = kl_pairs(2,kl) + if (k/=l) then + overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze) + overlap(l,k) = overlap(k,l) + else + overlap(k,k) = u_dot_u(U_in(1,k),sze) + endif + enddo + !$OMP END DO + !$OMP END PARALLEL + + call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) + + ! Davidson iterations + ! =================== + + converged = .False. + + do while (.not.converged) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(k,i) SHARED(U,u_in,sze,N_st) + do k=1,N_st + !$OMP DO + do i=1,sze + U(i,k,1) = u_in(i,k) + enddo + !$OMP END DO + enddo + !$OMP END PARALLEL + + do iter=1,davidson_sze_max-1 + + ! Compute W_k = H |u_k> + ! ---------------------- + + do k=1,N_st + call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) + enddo + + ! Compute h_kl = = + ! ------------------------------------------- + + do l=1,N_st + do k=1,N_st + do iter2=1,iter-1 + h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) + h(k,iter,l,iter2) = h(k,iter2,l,iter) + enddo + enddo + do k=1,l + h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) + h(l,iter,k,iter) = h(k,iter,l,iter) + enddo + enddo + + !DEBUG H MATRIX + !do i=1,iter + ! print '(10(x,F16.10))', h(1,i,1,1:i) + !enddo + !print *, '' + !END + + ! Diagonalize h + ! ------------- + call lapack_diag(lambda,y,h,N_st*davidson_sze_max,N_st*iter) + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + do k=1,N_st + do i=1,sze + U(i,k,iter+1) = 0.d0 + W(i,k,iter+1) = 0.d0 + do l=1,N_st + do iter2=1,iter + U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) + W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) + enddo + enddo + enddo + enddo + + ! Compute residual vector + ! ----------------------- + + do k=1,N_st + do i=1,sze + R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) + enddo + residual_norm(k) = u_dot_u(R(1,k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = residual_norm(k) + enddo + + write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))'), iter, to_print(:,1:N_st) + call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + if (converged) then + exit + endif + + + ! Davidson step + ! ------------- + + do k=1,N_st + do i=1,sze + U(i,k,iter+1) = -1.d0/max(H_jj(i) - lambda(k),1.d-2) * R(i,k) + enddo + enddo + + ! Gram-Schmidt + ! ------------ + + double precision :: c + do k=1,N_st + do iter2=1,iter + do l=1,N_st + c = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) + do i=1,sze + U(i,k,iter+1) -= c * U(i,l,iter2) + enddo + enddo + enddo + do l=1,k-1 + c = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) + do i=1,sze + U(i,k,iter+1) -= c * U(i,l,iter+1) + enddo + enddo + call normalize( U(1,k,iter+1), sze ) + enddo + + !DEBUG : CHECK OVERLAP + !print *, '===' + !do k=1,iter+1 + ! do l=1,k + ! c = u_dot_v(U(1,1,k),U(1,1,l),sze) + ! print *, k,l, c + ! enddo + !enddo + !print *, '===' + !pause + !END DEBUG + + + enddo + + if (.not.converged) then + iter = davidson_sze_max-1 + endif + + ! Re-contract to u_in + ! ----------- + + do k=1,N_st + energies(k) = lambda(k) + do i=1,sze + u_in(i,k) = 0.d0 + do iter2=1,iter + do l=1,N_st + u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) + enddo + enddo + enddo + enddo + + enddo + + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ================' + enddo + write(iunit,'(A)') trim(write_buffer) + write(iunit,'(A)') '' + call write_time(iunit) + + deallocate ( & + kl_pairs, & + W, & + U, & + R, & + h, & + y, & + lambda & + ) + abort_here = abort_all +end + + BEGIN_PROVIDER [ character(64), davidson_criterion ] +&BEGIN_PROVIDER [ double precision, davidson_threshold ] + implicit none + BEGIN_DOC + ! Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + END_DOC + davidson_criterion = 'residual' + davidson_threshold = 1.d-6 +END_PROVIDER + +subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged) + implicit none + BEGIN_DOC +! True if the Davidson algorithm is converged + END_DOC + integer, intent(in) :: N_st, iterations + logical, intent(out) :: converged + double precision, intent(in) :: energy(N_st), residual(N_st) + double precision, intent(in) :: wall, cpu + double precision :: E(N_st), time + double precision, allocatable, save :: energy_old(:) + + if (.not.allocated(energy_old)) then + allocate(energy_old(N_st)) + energy_old = 0.d0 + endif + + E = energy - energy_old + energy_old = energy + if (davidson_criterion == 'energy') then + converged = dabs(maxval(E(1:N_st))) < davidson_threshold + else if (davidson_criterion == 'residual') then + converged = dabs(maxval(residual(1:N_st))) < davidson_threshold + else if (davidson_criterion == 'both') then + converged = dabs(maxval(residual(1:N_st))) + dabs(maxval(E(1:N_st)) ) & + < davidson_threshold + else if (davidson_criterion == 'wall_time') then + call wall_time(time) + converged = time - wall > davidson_threshold + else if (davidson_criterion == 'cpu_time') then + call cpu_time(time) + converged = time - cpu > davidson_threshold + else if (davidson_criterion == 'iterations') then + converged = iterations >= int(davidson_threshold) + endif + converged = converged.or.abort_here +end diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f new file mode 100644 index 00000000..f72b337c --- /dev/null +++ b/src/Determinants/density_matrix.irp.f @@ -0,0 +1,214 @@ + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ_alpha + double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + + if(only_single_double_dm)then + print*,'ONLY DOUBLE DM' + one_body_dm_mo_alpha = one_body_single_double_dm_mo_alpha + one_body_dm_mo_beta = one_body_single_double_dm_mo_beta + else + one_body_dm_mo_alpha = 0.d0 + one_body_dm_mo_beta = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ_alpha)& + !$OMP SHARED(psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& + !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& + !$OMP mo_tot_num) + allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det + call bitstring_to_list(psi_det(1,1,k), occ(1,1), n_occ_alpha, N_int) + call bitstring_to_list(psi_det(1,2,k), occ(1,2), n_occ_alpha, N_int) + do m=1,N_states + ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j) += ck + enddo + enddo + do l=1,k-1 + call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) + if (s1==1) then + tmp_a(h1,p1) += ckl + tmp_a(p1,h1) += ckl + else + tmp_b(h1,p1) += ckl + tmp_b(p1,h1) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha = one_body_dm_mo_alpha + tmp_a + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP BARRIER + !$OMP END PARALLEL + + endif +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ_alpha + double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + integer :: degree_respect_to_HF_k + integer :: degree_respect_to_HF_l + + PROVIDE elec_alpha_num elec_beta_num + + one_body_single_double_dm_mo_alpha = 0.d0 + one_body_single_double_dm_mo_beta = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ_alpha,degree_respect_to_HF_k,degree_respect_to_HF_l)& + !$OMP SHARED(ref_bitmask,psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& + !$OMP elec_beta_num,one_body_single_double_dm_mo_alpha,one_body_single_double_dm_mo_beta,N_det,mo_tot_num_align,& + !$OMP mo_tot_num) + allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det + call bitstring_to_list(psi_det(1,1,k), occ(1,1), n_occ_alpha, N_int) + call bitstring_to_list(psi_det(1,2,k), occ(1,2), n_occ_alpha, N_int) + call get_excitation_degree(ref_bitmask,psi_det(1,1,k),degree_respect_to_HF_k,N_int) + + do m=1,N_states + ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) + call get_excitation_degree(ref_bitmask,psi_det(1,1,k),degree_respect_to_HF_l,N_int) + if(degree_respect_to_HF_l.le.0)then + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j) += ck + enddo + endif + enddo + do l=1,k-1 + call get_excitation_degree(ref_bitmask,psi_det(1,1,l),degree_respect_to_HF_l,N_int) + if(degree_respect_to_HF_k.ne.0)cycle + if(degree_respect_to_HF_l.eq.2.and.degree_respect_to_HF_k.ne.2)cycle + call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) + if (s1==1) then + tmp_a(h1,p1) += ckl + tmp_a(p1,h1) += ckl + else + tmp_b(h1,p1) += ckl + tmp_b(p1,h1) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_single_double_dm_mo_alpha = one_body_single_double_dm_mo_alpha + tmp_a + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP BARRIER + !$OMP END PARALLEL +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! One-body density matrix + END_DOC + one_body_dm_mo = one_body_dm_mo_alpha + one_body_dm_mo_beta +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! rho(alpha) - rho(beta) + END_DOC + one_body_spin_density_mo = one_body_dm_mo_alpha - one_body_dm_mo_beta +END_PROVIDER + +subroutine set_natural_mos + implicit none + BEGIN_DOC + ! Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + END_DOC + character*(64) :: label + double precision, allocatable :: tmp(:,:) + allocate(tmp(size(one_body_dm_mo,1),size(one_body_dm_mo,2))) + + ! Negation to have the occupied MOs first after the diagonalization + tmp = -one_body_dm_mo + label = "Natural" + call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label) + deallocate(tmp) + +end +subroutine save_natural_mos + implicit none + BEGIN_DOC + ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis + END_DOC + call set_natural_mos + call save_mos + +end + + +BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ] + implicit none + BEGIN_DOC + ! Weights in the state-average calculation of the density matrix + END_DOC + state_average_weight = 1.d0/dble(N_states) +END_PROVIDER + diff --git a/src/Determinants/det_svd.irp.f b/src/Determinants/det_svd.irp.f new file mode 100644 index 00000000..0a57acf3 --- /dev/null +++ b/src/Determinants/det_svd.irp.f @@ -0,0 +1,61 @@ +program det_svd + implicit none + BEGIN_DOC +! Computes the SVD of the Alpha x Beta determinant coefficient matrix + END_DOC + integer :: i,j,k + + read_wf = .True. + TOUCH read_wf + + print *, 'SVD matrix before filling' + print *, '=========================' + print *, '' + print *, 'N_det = ', N_det + print *, 'N_det_alpha = ', N_det_alpha_unique + print *, 'N_det_beta = ', N_det_beta_unique + print *, '' + +! do i=1,N_det_alpha_unique +! do j=1,N_det_beta_unique +! print *, i,j,psi_svd_matrix(i,j,:) +! enddo +! enddo + + print *, '' + print *, 'Energy = ', ci_energy + print *, '' + + print *, psi_svd_coefs(1:20,1) + + call generate_all_alpha_beta_det_products + print *, '' + print *, 'Energy = ', ci_energy + print *, '' + + print *, 'SVD matrix after filling' + print *, '========================' + print *, '' + print *, 'N_det = ', N_det + print *, 'N_det_alpha = ', N_det_alpha_unique + print *, 'N_det_beta = ', N_det_beta_unique + print *, '' + print *, '' + call diagonalize_ci + print *, 'Energy = ', ci_energy + + do i=1,N_det_alpha_unique + do j=1,N_det_beta_unique + do k=1,N_states + if (dabs(psi_svd_matrix(i,j,k)) < 1.d-15) then + psi_svd_matrix(i,j,k) = 0.d0 + endif + enddo + enddo + enddo + + print *, '' + print *, psi_svd_coefs(1:20,1) + call save_wavefunction + +end diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 03315836..a70d0fe8 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -68,9 +68,6 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] ! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file ! is empty END_DOC - - PROVIDE ezfio_filename - integer :: i logical :: exists character*64 :: label @@ -237,8 +234,6 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states_diag) ] ! is empty END_DOC - PROVIDE ezfio_filename - integer :: i,k, N_int2 logical :: exists double precision, allocatable :: psi_coef_read(:,:) @@ -602,8 +597,6 @@ subroutine read_dets(det,Nint,Ndet) integer :: i,k equivalence (det_8, det_bk) - PROVIDE ezfio_filename - call ezfio_get_determinants_N_int(N_int2) ASSERT (N_int2 == Nint) call ezfio_get_determinants_bit_kind(k) @@ -672,8 +665,6 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,k PROVIDE progress_bar - PROVIDE ezfio_filename - call start_progress(7,'Saving wfunction',0.d0) progress_bar(1) = 1 diff --git a/src/Determinants/determinants_bitmasks.irp.f b/src/Determinants/determinants_bitmasks.irp.f new file mode 100644 index 00000000..8343fa84 --- /dev/null +++ b/src/Determinants/determinants_bitmasks.irp.f @@ -0,0 +1,57 @@ +use bitmasks + +integer, parameter :: hole_ = 1 +integer, parameter :: particle_ = 2 +integer, parameter :: hole2_ = 3 +integer, parameter :: particle2_= 4 + +BEGIN_PROVIDER [ integer, N_single_exc_bitmasks ] + implicit none + BEGIN_DOC + ! Number of single excitation bitmasks + END_DOC + N_single_exc_bitmasks = 1 + !TODO : Read from input! +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), single_exc_bitmask, (N_int, 2, N_single_exc_bitmasks) ] + implicit none + BEGIN_DOC + ! single_exc_bitmask(:,1,i) is the bitmask for holes + ! single_exc_bitmask(:,2,i) is the bitmask for particles + ! for a given couple of hole/particle excitations i. + END_DOC + + single_exc_bitmask(:,hole_,1) = HF_bitmask(:,1) + single_exc_bitmask(:,particle_,1) = not(HF_bitmask(:,2)) + !TODO : Read from input! +END_PROVIDER + + +BEGIN_PROVIDER [ integer, N_double_exc_bitmasks ] + implicit none + BEGIN_DOC + ! Number of double excitation bitmasks + END_DOC + N_double_exc_bitmasks = 1 + !TODO : Read from input! +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), double_exc_bitmask, (N_int, 4, N_double_exc_bitmasks) ] + implicit none + BEGIN_DOC + ! double_exc_bitmask(:,1,i) is the bitmask for holes of excitation 1 + ! double_exc_bitmask(:,2,i) is the bitmask for particles of excitation 1 + ! double_exc_bitmask(:,3,i) is the bitmask for holes of excitation 2 + ! double_exc_bitmask(:,4,i) is the bitmask for particles of excitation 2 + ! for a given couple of hole/particle excitations i. + END_DOC + + double_exc_bitmask(:,hole_,1) = HF_bitmask(:,1) + double_exc_bitmask(:,particle_,1) = not(HF_bitmask(:,2)) + double_exc_bitmask(:,hole2_,1) = HF_bitmask(:,1) + double_exc_bitmask(:,particle2_,1) = not(HF_bitmask(:,2)) + + !TODO : Read from input! +END_PROVIDER + diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f new file mode 100644 index 00000000..0e697ab3 --- /dev/null +++ b/src/Determinants/diagonalize_CI.irp.f @@ -0,0 +1,109 @@ +BEGIN_PROVIDER [ character*(64), diag_algorithm ] + implicit none + BEGIN_DOC + ! Diagonalization algorithm (Davidson or Lapack) + END_DOC + if (N_det > N_det_max_jacobi) then + diag_algorithm = "Davidson" + else + diag_algorithm = "Lapack" + endif + + if (N_det < N_states_diag) then + diag_algorithm = "Lapack" + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] + implicit none + BEGIN_DOC + ! N_states lowest eigenvalues of the CI matrix + END_DOC + + integer :: j + character*(8) :: st + call write_time(output_determinants) + do j=1,N_states_diag + CI_energy(j) = CI_electronic_energy(j) + nuclear_repulsion + write(st,'(I4)') j + call write_double(output_determinants,CI_energy(j),'Energy of state '//trim(st)) + call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] + implicit none + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + integer :: i,j + + do j=1,N_states_diag + do i=1,N_det + CI_eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + + if (diag_algorithm == "Davidson") then + + call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & + size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) + + else if (diag_algorithm == "Lapack") then + + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy(:) = 0.d0 + do i=1,N_det + CI_eigenvectors(i,1) = eigenvectors(i,1) + enddo + integer :: i_state + double precision :: s2 + i_state = 0 + do j=1,N_det + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) + if(dabs(s2-expected_s2).le.0.3d0)then + i_state += 1 + do i=1,N_det + CI_eigenvectors(i,i_state) = eigenvectors(i,j) + enddo + CI_electronic_energy(i_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state) = s2 + endif + if (i_state.ge.N_states_diag) then + exit + endif + enddo +! if(i_state < min(N_states_diag,N_det))then +! print *, 'pb with the number of states' +! print *, 'i_state = ',i_state +! print *, 'N_states_diag ',N_states_diag +! print *,'stopping ...' +! stop +! endif + deallocate(eigenvectors,eigenvalues) + endif + +END_PROVIDER + +subroutine diagonalize_CI + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_eigenvectors_s2 +end diff --git a/src/Determinants/diagonalize_CI_SC2.irp.f b/src/Determinants/diagonalize_CI_SC2.irp.f new file mode 100644 index 00000000..3b0d7904 --- /dev/null +++ b/src/Determinants/diagonalize_CI_SC2.irp.f @@ -0,0 +1,59 @@ +BEGIN_PROVIDER [ double precision, CI_SC2_energy, (N_states_diag) ] + implicit none + BEGIN_DOC + ! N_states_diag lowest eigenvalues of the CI matrix + END_DOC + + integer :: j + character*(8) :: st + call write_time(output_determinants) + do j=1,N_states_diag + CI_SC2_energy(j) = CI_SC2_electronic_energy(j) + nuclear_repulsion + write(st,'(I4)') j + call write_double(output_determinants,CI_SC2_energy(j),'Energy of state '//trim(st)) + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, threshold_convergence_SC2] + implicit none + BEGIN_DOC + ! convergence of the correlation energy of SC2 iterations + END_DOC + threshold_convergence_SC2 = 1.d-10 + + END_PROVIDER + BEGIN_PROVIDER [ double precision, CI_SC2_electronic_energy, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_SC2_eigenvectors, (N_det,N_states_diag) ] + implicit none + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + integer :: i,j + + do j=1,N_states_diag + do i=1,N_det + CI_SC2_eigenvectors(i,j) = psi_coef(i,j) + enddo +! TODO : check comment +! CI_SC2_electronic_energy(j) = CI_electronic_energy(j) + enddo + + call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, & + size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) +END_PROVIDER + +subroutine diagonalize_CI_SC2 + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states_diag by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_SC2_eigenvectors(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors +end diff --git a/src/Determinants/diagonalize_CI_mono.irp.f b/src/Determinants/diagonalize_CI_mono.irp.f new file mode 100644 index 00000000..1c9a4de3 --- /dev/null +++ b/src/Determinants/diagonalize_CI_mono.irp.f @@ -0,0 +1,72 @@ + BEGIN_PROVIDER [ double precision, CI_electronic_energy_mono, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_mono, (N_det,N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_mono, (N_states_diag) ] + implicit none + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + integer :: i,j + + do j=1,N_states_diag + do i=1,N_det + CI_eigenvectors_mono(i,j) = psi_coef(i,j) + enddo + enddo + + if (diag_algorithm == "Davidson") then + + call davidson_diag(psi_det,CI_eigenvectors_mono,CI_electronic_energy, & + size(CI_eigenvectors_mono,1),N_det,N_states_diag,N_int,output_determinants) + + else if (diag_algorithm == "Lapack") then + + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy_mono(:) = 0.d0 + do i=1,N_det + CI_eigenvectors_mono(i,1) = eigenvectors(i,1) + enddo + integer :: i_state + double precision :: s2 + i_state = 0 + do j=1,N_det + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) + if(dabs(s2-expected_s2).le.0.3d0)then + print*,'j = ',j + print*,'e = ',eigenvalues(j) + print*,'c = ',dabs(eigenvectors(1,j)) + if(dabs(eigenvectors(1,j)).gt.0.9d0)then + i_state += 1 + do i=1,N_det + CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) + enddo + CI_electronic_energy_mono(i_state) = eigenvalues(j) + CI_eigenvectors_s2_mono(i_state) = s2 + endif + endif + if (i_state.ge.N_states_diag) then + exit + endif + enddo + deallocate(eigenvectors,eigenvalues) + endif + +END_PROVIDER + +subroutine diagonalize_CI_mono + implicit none + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors_mono(i,j) + enddo + enddo + SOFT_TOUCH psi_coef CI_electronic_energy_mono CI_eigenvectors_mono CI_eigenvectors_s2_mono +end diff --git a/src/Determinants/excitations_utils.irp.f b/src/Determinants/excitations_utils.irp.f new file mode 100644 index 00000000..46e38b08 --- /dev/null +++ b/src/Determinants/excitations_utils.irp.f @@ -0,0 +1,16 @@ +subroutine apply_mono(i_hole,i_particle,ispin_excit,key_in,Nint) + implicit none + integer, intent(in) :: i_hole,i_particle,ispin_excit,Nint + integer(bit_kind), intent(inout) :: key_in(Nint,2) + integer :: k,j + use bitmasks + ! hole + k = ishft(i_hole-1,-bit_kind_shift)+1 + j = i_hole-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin_excit) = ibclr(key_in(k,ispin_excit),j) + + k = ishft(i_particle-1,-bit_kind_shift)+1 + j = i_particle-ishft(k-1,bit_kind_shift)-1 + key_in(k,ispin_excit) = ibset(key_in(k,ispin_excit),j) + +end diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f new file mode 100644 index 00000000..93a6ee7b --- /dev/null +++ b/src/Determinants/filter_connected.irp.f @@ -0,0 +1,611 @@ + +subroutine filter_connected(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Filters out the determinants that are not connected by H + ! + ! returns the array idx which contains the index of the + ! + ! determinants in the array key1 that interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that interact with key1 + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) & + + popcnt( xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do j=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +& + popcnt(xor( key1(j,2,i), key2(j,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + + +subroutine filter_connected_sorted_ab(key1,key2,next,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Filters out the determinants that are not connected by H + ! returns the array idx which contains the index of the + ! determinants in the array key1 that interact + ! via the H operator with key2. + ! idx(0) is the number of determinants that interact with key1 + ! + ! Determinants are taken from the psi_det_sorted_ab array + END_DOC + integer, intent(in) :: Nint, sze + integer, intent(in) :: next(2,N_det) + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + integer(bit_kind) :: det3_1(Nint,2), det3_2(Nint,2) + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + call filter_3_highest_electrons( key2(1,1), det3_2(1,1), Nint) + if (Nint==1) then + + i = 1 + do while ( i<= sze ) + call filter_3_highest_electrons( key1(1,1,i), det3_1(1,1), Nint) + degree_x2 = popcnt( xor( det3_1(1,1), det3_2(1,1))) + if (degree_x2 > 4) then + i = next(1,i) + cycle + else + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1)) ) + if (degree_x2 <= 4) then + degree_x2 += popcnt( xor( key1(1,2,i), key2(1,2)) ) + if (degree_x2 <= 4) then + idx(l) = i + l += 1 + endif + endif + i += 1 + endif + enddo + + else + + print *, 'Not implemented', irp_here + stop 1 + + endif + idx(0) = l-1 +end + + + + +subroutine filter_connected_davidson(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Filters out the determinants that are not connected by H + ! returns the array idx which contains the index of the + ! determinants in the array key1 that interact + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that interact with key1 + ! key1 should come from psi_det_sorted_ab. + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,k,l + integer :: degree_x2 + integer :: j_int, j_start + integer*8 :: itmp + + PROVIDE N_con_int det_connections + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & + popcnt(xor( key1(1,2,j), key2(1,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + else if (Nint==2) then + + + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & + popcnt(xor( key1(2,1,j), key2(2,1))) + & + popcnt(xor( key1(1,2,j), key2(1,2))) + & + popcnt(xor( key1(2,2,j), key2(2,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & + popcnt(xor( key1(1,2,j), key2(1,2))) + & + popcnt(xor( key1(2,1,j), key2(2,1))) + & + popcnt(xor( key1(2,2,j), key2(2,2))) + & + popcnt(xor( key1(3,1,j), key2(3,1))) + & + popcnt(xor( key1(3,2,j), key2(3,2))) + if (degree_x2 > 4) then + cycle + else + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + else + + !DIR$ LOOP COUNT (1000) + i = idx(0) + do j_int=1,N_con_int + itmp = det_connections(j_int,i) + do while (itmp /= 0_8) + j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) + do j = j_start+1, min(j_start+32,i-1) + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do k=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(k,1,j), key2(k,1))) +& + popcnt(xor( key1(k,2,j), key2(k,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + idx(l) = j + l = l+1 + endif + enddo + itmp = iand(itmp-1_8,itmp) + enddo + enddo + + endif + idx(0) = l-1 +end + +subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) + use bitmasks + BEGIN_DOC + ! returns the array idx which contains the index of the + ! + ! determinants in the array key1 that interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that interact with key1 + END_DOC + implicit none + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,l,m + integer :: degree_x2 + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sze > 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do m=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& + popcnt(xor( key1(m,2,i), key2(m,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 > 4) then + cycle + else if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + +subroutine filter_connected_i_H_psi0_SC2(key1,key2,Nint,sze,idx,idx_repeat) + use bitmasks + BEGIN_DOC + ! standard filter_connected_i_H_psi but returns in addition + ! + ! the array of the index of the non connected determinants to key1 + ! + ! in order to know what double excitation can be repeated on key1 + ! + ! idx_repeat(0) is the number of determinants that can be used + ! + ! to repeat the excitations + END_DOC + implicit none + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + integer, intent(out) :: idx_repeat(0:sze) + + integer :: i,l,l_repeat,m + integer :: degree_x2 + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sze > 0) + + integer :: degree + degree = popcnt(xor( ref_bitmask(1,1), key2(1,1))) + & + popcnt(xor( ref_bitmask(1,2), key2(1,2))) + !DEC$ NOUNROLL + do m=2,Nint + degree = degree+ popcnt(xor( ref_bitmask(m,1), key2(m,1))) + & + popcnt(xor( ref_bitmask(m,2), key2(m,2))) + enddo + degree = ishft(degree,-1) + + l_repeat=1 + l=1 + if(degree == 2)then + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + elseif(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + elseif(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + else if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do m=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& + popcnt(xor( key1(m,2,i), key2(m,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + elseif(degree_x2>6)then + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + endif + elseif(degree==1)then + if (Nint==1) then + + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 < 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do m=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& + popcnt(xor( key1(m,2,i), key2(m,2))) + if (degree_x2 > 4) then + exit + endif + enddo + if (degree_x2 <= 5) then + if(degree_x2 .ne. 0)then + idx(l) = i + l = l+1 + endif + else + idx_repeat(l_repeat) = i + l_repeat = l_repeat + 1 + endif + enddo + + endif + + else +! print*,'more than a double excitation, can not apply the ' +! print*,'SC2 dressing of the diagonal element .....' +! print*,'stop !!' +! print*,'degree = ',degree +! stop + idx(0) = 0 + idx_repeat(0) = 0 + endif + idx(0) = l-1 + idx_repeat(0) = l_repeat-1 +end + diff --git a/src/Determinants/guess_doublet.irp.f b/src/Determinants/guess_doublet.irp.f new file mode 100644 index 00000000..a44697c1 --- /dev/null +++ b/src/Determinants/guess_doublet.irp.f @@ -0,0 +1,79 @@ +program put_gess + use bitmasks + implicit none + integer :: i,j,N_det_tmp,N_states_tmp + integer :: list(N_int*bit_kind_size,2) + integer(bit_kind) :: string(N_int,2) + integer(bit_kind) :: psi_det_tmp(N_int,2,3) + double precision :: psi_coef_tmp(3,1) + + integer :: iorb,jorb,korb + print*,'which open shells ?' + read(5,*)iorb,jorb,korb + print*,iorb,jorb,korb + N_states= 1 + N_det= 3 + + + list = 0 + list(1,1) = 1 + list(1,2) = 1 + list(2,1) = 2 + list(2,2) = 2 + list(3,1) = iorb + list(4,1) = jorb + list(3,2) = korb + print*,'passed' + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + print*,'passed' + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + print*,'passed' + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,1) = string(i,j) + enddo + enddo + psi_coef(1,1) = 1.d0/dsqrt(3.d0) + + print*,'passed 1' + list = 0 + list(1,1) = 1 + list(1,2) = 1 + list(2,1) = 2 + list(2,2) = 2 + list(3,1) = iorb + list(4,1) = korb + list(3,2) = jorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,2) = string(i,j) + enddo + enddo + psi_coef(2,1) = 1.d0/dsqrt(3.d0) + + print*,'passed 2' + list = 0 + list(1,1) = 1 + list(1,2) = 1 + list(2,1) = 2 + list(2,2) = 2 + list(3,1) = korb + list(4,1) = jorb + list(3,2) = iorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,3) = string(i,j) + enddo + enddo + psi_coef(3,1) = 1.d0/dsqrt(3.d0) + print*,'passed 3' + + call save_wavefunction +end diff --git a/src/Determinants/guess_singlet.irp.f b/src/Determinants/guess_singlet.irp.f new file mode 100644 index 00000000..50f8dc4e --- /dev/null +++ b/src/Determinants/guess_singlet.irp.f @@ -0,0 +1,44 @@ +program put_gess + use bitmasks + implicit none + integer :: i,j,N_det_tmp,N_states_tmp + integer :: list(N_int*bit_kind_size,2) + integer(bit_kind) :: string(N_int,2) + integer(bit_kind) :: psi_det_tmp(N_int,2,2) + double precision :: psi_coef_tmp(2,1) + + integer :: iorb,jorb + print*,'which open shells ?' + read(5,*)iorb,jorb + N_states= 1 + N_det= 2 + + + list = 0 + list(1,1) = iorb + list(1,2) = jorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,1) = string(i,j) + enddo + enddo + psi_coef(1,1) = 1.d0/dsqrt(2.d0) + + list = 0 + list(1,1) = jorb + list(1,2) = iorb + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,2) = string(i,j) + enddo + enddo + psi_coef(2,1) = 1.d0/dsqrt(2.d0) + + call save_wavefunction +end diff --git a/src/Determinants/guess_triplet.irp.f b/src/Determinants/guess_triplet.irp.f new file mode 100644 index 00000000..77f88c3e --- /dev/null +++ b/src/Determinants/guess_triplet.irp.f @@ -0,0 +1,48 @@ +program put_gess + use bitmasks + implicit none + integer :: i,j,N_det_tmp,N_states_tmp + integer :: list(N_int*bit_kind_size,2) + integer(bit_kind) :: string(N_int,2) + integer(bit_kind) :: psi_det_tmp(N_int,2,2) + double precision :: psi_coef_tmp(2,1) + + integer :: iorb,jorb + print*,'which open shells ?' + read(5,*)iorb,jorb + N_states= 1 + N_det= 2 + print*,'iorb = ',iorb + print*,'jorb = ',jorb + + + list = 0 + list(1,1) = iorb + list(1,2) = jorb + string = 0 + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,1) = string(i,j) + enddo + enddo + psi_coef(1,1) = 1.d0/dsqrt(2.d0) + + list = 0 + list(1,1) = jorb + list(1,2) = iorb + string = 0 + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + call print_det(string,N_int) + do j = 1,2 + do i = 1, N_int + psi_det(i,j,2) = string(i,j) + enddo + enddo + psi_coef(2,1) = -1.d0/dsqrt(2.d0) + + call save_wavefunction +end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f new file mode 100644 index 00000000..a0fd4a3c --- /dev/null +++ b/src/Determinants/occ_pattern.irp.f @@ -0,0 +1,339 @@ +use bitmasks +subroutine det_to_occ_pattern(d,o,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Transform a determinant to an occupation pattern + END_DOC + integer ,intent(in) :: Nint + integer(bit_kind),intent(in) :: d(Nint,2) + integer(bit_kind),intent(out) :: o(Nint,2) + + integer :: k + + do k=1,Nint + o(k,1) = ieor(d(k,1),d(k,2)) + o(k,2) = iand(d(k,1),d(k,2)) + enddo +end + +subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Number of possible determinants for a given occ_pattern + END_DOC + integer ,intent(in) :: Nint, n_alpha + integer(bit_kind),intent(in) :: o(Nint,2) + integer, intent(out) :: sze + integer :: amax,bmax,k + double precision, external :: binom_func + + amax = n_alpha + bmax = 0 + do k=1,Nint + bmax += popcnt( o(k,1) ) + amax -= popcnt( o(k,2) ) + enddo + sze = int( min(binom_func(bmax, amax), 1.d8) ) + +end + +subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Generate all possible determinants for a give occ_pattern + END_DOC + integer ,intent(in) :: Nint, n_alpha + integer ,intent(inout) :: sze + integer(bit_kind),intent(in) :: o(Nint,2) + integer(bit_kind),intent(out) :: d(Nint,2,sze) + + integer :: i, k, nt, na, nd, amax + integer :: list_todo(n_alpha) + integer :: list_a(n_alpha) + + amax = n_alpha + do k=1,Nint + amax -= popcnt( o(k,2) ) + enddo + + call bitstring_to_list(o(1,1), list_todo, nt, Nint) + + na = 0 + nd = 0 + d = 0 + call rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) + + sze = nd + + do i=1,nd + ! Doubly occupied orbitals + do k=1,Nint + d(k,1,i) = ior(d(k,1,i),o(k,2)) + d(k,2,i) = ior(d(k,2,i),o(k,2)) + enddo + enddo + +! !TODO DEBUG +! integer :: j,s +! do i=1,nd +! do j=1,i-1 +! na=0 +! do k=1,Nint +! if((d(k,1,j) /= d(k,1,i)).or. & +! (d(k,2,j) /= d(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( j== 0 ) then +! print *, 'det ',i,' and ',j,' equal:' +! call debug_det(d(1,1,j),Nint) +! call debug_det(d(1,1,i),Nint) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG +end + +recursive subroutine rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) + use bitmasks + implicit none + + integer, intent(in) :: nt, sze, amax, Nint,na + integer,intent(inout) :: list_todo(nt) + integer, intent(inout) :: list_a(na+1),nd + integer(bit_kind),intent(inout) :: d(Nint,2,sze) + + if (na == amax) then + nd += 1 + if (na > 0) then + call list_to_bitstring( d(1,1,nd), list_a, na, Nint) + endif + if (nt > 0) then + call list_to_bitstring( d(1,2,nd), list_todo, nt, Nint) + endif + else + integer :: i, j, k + integer :: list_todo_tmp(nt) + do i=1,nt + if (na > 0) then + if (list_todo(i) < list_a(na)) then + cycle + endif + endif + list_a(na+1) = list_todo(i) + k=1 + do j=1,nt + if (i/=j) then + list_todo_tmp(k) = list_todo(j) + k += 1 + endif + enddo + call rec_occ_pattern_to_dets(list_todo_tmp,nt-1,list_a,na+1,d,nd,sze,amax,Nint) + enddo + endif + +end + + BEGIN_PROVIDER [ integer(bit_kind), psi_occ_pattern, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_occ_pattern ] + implicit none + BEGIN_DOC + ! array of the occ_pattern present in the wf + ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + END_DOC + integer :: i,j,k + + ! create + do i = 1, N_det + do k = 1, N_int + psi_occ_pattern(k,1,i) = ieor(psi_det(k,1,i),psi_det(k,2,i)) + psi_occ_pattern(k,2,i) = iand(psi_det(k,1,i),psi_det(k,2,i)) + enddo + enddo + + ! Sort + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8, external :: occ_pattern_search_key + integer(bit_kind), allocatable :: tmp_array(:,:,:) + logical,allocatable :: duplicate(:) + + + allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) + + do i=1,N_det + iorder(i) = i + !$DIR FORCEINLINE + bit_tmp(i) = occ_pattern_search_key(psi_occ_pattern(1,1,i),N_int) + enddo + call i8sort(bit_tmp,iorder,N_det) + !DIR$ IVDEP + do i=1,N_det + do k=1,N_int + tmp_array(k,1,i) = psi_occ_pattern(k,1,iorder(i)) + tmp_array(k,2,i) = psi_occ_pattern(k,2,iorder(i)) + enddo + duplicate(i) = .False. + enddo + + i=1 + integer (bit_kind) :: occ_pattern_tmp + do i=1,N_det + duplicate(i) = .False. + enddo + + do i=1,N_det-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j+=1 + cycle + endif + duplicate(j) = .True. + do k=1,N_int + if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & + .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then + duplicate(j) = .False. + exit + endif + enddo + j+=1 + if (j>N_det) then + exit + endif + enddo + enddo + + N_occ_pattern=0 + do i=1,N_det + if (duplicate(i)) then + cycle + endif + N_occ_pattern += 1 + do k=1,N_int + psi_occ_pattern(k,1,N_occ_pattern) = tmp_array(k,1,i) + psi_occ_pattern(k,2,N_occ_pattern) = tmp_array(k,2,i) + enddo + enddo + + deallocate(iorder,duplicate,bit_tmp,tmp_array) +! !TODO DEBUG +! integer :: s +! do i=1,N_occ_pattern +! do j=i+1,N_occ_pattern +! s = 0 +! do k=1,N_int +! if((psi_occ_pattern(k,1,j) /= psi_occ_pattern(k,1,i)).or. & +! (psi_occ_pattern(k,2,j) /= psi_occ_pattern(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error : occ ', j, 'already in wf' +! call debug_det(psi_occ_pattern(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG +END_PROVIDER + +subroutine make_s2_eigenfunction + implicit none + integer :: i,j,k + integer :: smax, s + integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) + integer :: N_det_new + integer, parameter :: bufsze = 1000 + logical, external :: is_in_wavefunction + +! !TODO DEBUG +! do i=1,N_det +! do j=i+1,N_det +! s = 0 +! do k=1,N_int +! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & +! (psi_det(k,2,j) /= psi_det(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error0: det ', j, 'already in wf' +! call debug_det(psi_det(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG + + allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) + smax = 1 + N_det_new = 0 + + do i=1,N_occ_pattern + call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) + s += 1 + if (s > smax) then + deallocate(d) + allocate ( d(N_int,2,s) ) + smax = s + endif + call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int) + do j=1,s + if (.not. is_in_wavefunction( d(1,1,j), N_int, N_det)) then + N_det_new += 1 + do k=1,N_int + det_buffer(k,1,N_det_new) = d(k,1,j) + det_buffer(k,2,N_det_new) = d(k,2,j) + enddo + if (N_det_new == bufsze) then + call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) + N_det_new = 0 + endif + endif + enddo + enddo + + if (N_det_new > 0) then + call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det + endif + + deallocate(d,det_buffer) + + +! !TODO DEBUG +! do i=1,N_det +! do j=i+1,N_det +! s = 0 +! do k=1,N_int +! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & +! (psi_det(k,2,j) /= psi_det(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error : det ', j, 'already in wf at ', i +! call debug_det(psi_det(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG + call write_int(output_determinants,N_det_new, 'Added deteminants for S^2') + +end + diff --git a/src/Determinants/options.irp.f b/src/Determinants/options.irp.f new file mode 100644 index 00000000..d4283128 --- /dev/null +++ b/src/Determinants/options.irp.f @@ -0,0 +1,22 @@ +BEGIN_PROVIDER [ integer, N_states_diag ] + implicit none + BEGIN_DOC +! Number of states to consider for the diagonalization + END_DOC + + logical :: has + PROVIDE ezfio_filename + call ezfio_has_determinants_n_states_diag(has) + if (has) then + call ezfio_get_determinants_n_states_diag(N_states_diag) + else + N_states_diag = N_states + endif + + call write_time(output_determinants) + call write_int(output_determinants, N_states_diag, & + 'N_states_diag') + + +END_PROVIDER + diff --git a/src/Determinants/program_beginer_determinants.irp.f b/src/Determinants/program_beginer_determinants.irp.f new file mode 100644 index 00000000..6375af22 --- /dev/null +++ b/src/Determinants/program_beginer_determinants.irp.f @@ -0,0 +1,138 @@ +program pouet + implicit none + print*,'HF energy = ',ref_bitmask_energy + nuclear_repulsion + call routine + +end +subroutine routine + use bitmasks + implicit none + integer :: i,j,k,l + double precision :: hij,get_mo_bielec_integral + double precision :: hmono,h_bi_ispin,h_bi_other_spin + integer(bit_kind),allocatable :: key_tmp(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha, n_occ_beta + ! First checks + print*,'N_int = ',N_int + print*,'mo_tot_num = ',mo_tot_num + print*,'mo_tot_num / 64+1= ',mo_tot_num/64+1 + ! We print the HF determinant + do i = 1, N_int + print*,'ref_bitmask(i,1) = ',ref_bitmask(i,1) + print*,'ref_bitmask(i,2) = ',ref_bitmask(i,2) + enddo + print*,'' + print*,'Hartree Fock determinant ...' + call debug_det(ref_bitmask,N_int) + allocate(key_tmp(N_int,2)) + ! We initialize key_tmp to the Hartree Fock one + key_tmp = ref_bitmask + integer :: i_hole,i_particle,ispin,i_ok,other_spin + ! We do a mono excitation on the top of the HF determinant + write(*,*)'Enter the (hole, particle) couple for the mono excitation ...' + read(5,*)i_hole,i_particle +!!i_hole = 4 +!!i_particle = 20 + write(*,*)'Enter the ispin variable ...' + write(*,*)'ispin = 1 ==> alpha ' + write(*,*)'ispin = 2 ==> beta ' + read(5,*)ispin + if(ispin == 1)then + other_spin = 2 + else if(ispin == 2)then + other_spin = 1 + else + print*,'PB !! ' + print*,'ispin must be 1 or 2 !' + stop + endif +!!ispin = 1 + call do_mono_excitation(key_tmp,i_hole,i_particle,ispin,i_ok) + ! We check if it the excitation was possible with "i_ok" + if(i_ok == -1)then + print*,'i_ok = ',i_ok + print*,'You can not do this excitation because of Pauli principle ...' + print*,'check your hole particle couple, there must be something wrong ...' + stop + + endif + print*,'New det = ' + call debug_det(key_tmp,N_int) + call i_H_j(key_tmp,ref_bitmask,N_int,hij) + ! We calculate the H matrix element between the new determinant and HF + print*,' = ',hij + print*,'' + print*,'' + print*,'Recalculating it old school style ....' + print*,'' + print*,'' + ! We recalculate this old school style !!! + ! Mono electronic part + hmono = mo_mono_elec_integral(i_hole,i_particle) + print*,'' + print*,'Mono electronic part ' + print*,'' + print*,' = ',hmono + h_bi_ispin = 0.d0 + h_bi_other_spin = 0.d0 + print*,'' + print*,'Getting all the info for the calculation of the bi electronic part ...' + print*,'' + allocate (occ(N_int*bit_kind_size,2)) + ! We get the occupation of the alpha electrons in occ(:,1) + call bitstring_to_list(key_tmp(1,1), occ(1,1), n_occ_alpha, N_int) + print*,'n_occ_alpha = ',n_occ_alpha + print*,'elec_alpha_num = ',elec_alpha_num + ! We get the occupation of the beta electrons in occ(:,2) + call bitstring_to_list(key_tmp(1,2), occ(1,2), n_occ_beta, N_int) + print*,'n_occ_beta = ',n_occ_beta + print*,'elec_beta_num = ',elec_beta_num + ! We print the occupation of the alpha electrons + print*,'Alpha electrons !' + do i = 1, n_occ_alpha + print*,'i = ',i + print*,'occ(i,1) = ',occ(i,1) + enddo + ! We print the occupation of the beta electrons + print*,'Alpha electrons !' + do i = 1, n_occ_beta + print*,'i = ',i + print*,'occ(i,2) = ',occ(i,2) + enddo + integer :: exc(0:2,2,2),degree,h1,p1,h2,p2,s1,s2 + double precision :: phase + + call get_excitation_degree(key_tmp,ref_bitmask,degree,N_int) + print*,'degree = ',degree + call get_mono_excitation(ref_bitmask,key_tmp,exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + print*,'h1 = ',h1 + print*,'p1 = ',p1 + print*,'s1 = ',s1 + print*,'phase = ',phase + do i = 1, elec_num_tab(ispin) + integer :: orb_occupied + orb_occupied = occ(i,ispin) + h_bi_ispin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) & + -get_mo_bielec_integral(i_hole,i_particle,orb_occupied,orb_occupied,mo_integrals_map) + enddo + print*,'h_bi_ispin = ',h_bi_ispin + + do i = 1, elec_num_tab(other_spin) + orb_occupied = occ(i,other_spin) + h_bi_other_spin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) + enddo + print*,'h_bi_other_spin = ',h_bi_other_spin + print*,'h_bi_ispin + h_bi_other_spin = ',h_bi_ispin + h_bi_other_spin + + print*,'Total matrix element = ',phase*(h_bi_ispin + h_bi_other_spin + hmono) +!i = 1 +!j = 1 +!k = 1 +!l = 1 +!hij = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) +!print*,' = ',hij + + +end diff --git a/src/Determinants/psi_cas.irp.f b/src/Determinants/psi_cas.irp.f new file mode 100644 index 00000000..8ca081d6 --- /dev/null +++ b/src/Determinants/psi_cas.irp.f @@ -0,0 +1,114 @@ +use bitmasks + + BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_cas, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_cas ] + implicit none + BEGIN_DOC + ! CAS wave function, defined from the application of the CAS bitmask on the + ! determinants. idx_cas gives the indice of the CAS determinant in psi_det. + END_DOC + integer :: i, k, l + logical :: good + N_det_cas = 0 + do i=1,N_det + do l=1,n_cas_bitmask + good = .True. + do k=1,N_int + good = good .and. ( & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,1)) ) .and. ( & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,1)) ) + enddo + if (good) then + exit + endif + enddo + if (good) then + N_det_cas = N_det_cas+1 + do k=1,N_int + psi_cas(k,1,N_det_cas) = psi_det(k,1,i) + psi_cas(k,2,N_det_cas) = psi_det(k,2,i) + enddo + idx_cas(N_det_cas) = i + do k=1,N_states + psi_cas_coef(N_det_cas,k) = psi_coef(i,k) + enddo + endif + enddo + call write_int(output_determinants,N_det_cas, 'Number of determinants in the CAS') + +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! CAS determinants sorted to accelerate the search of a random determinant in the wave + ! function. + END_DOC + call sort_dets_by_det_search_key(N_det_cas, psi_cas, psi_cas_coef, & + psi_cas_sorted_bit, psi_cas_coef_sorted_bit) + +END_PROVIDER + + + + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_non_cas, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_non_cas ] + implicit none + BEGIN_DOC + ! Set of determinants which are not part of the CAS, defined from the application + ! of the CAS bitmask on the determinants. + ! idx_non_cas gives the indice of the determinant in psi_det. + END_DOC + integer :: i_non_cas,j,k + integer :: degree + logical :: in_cas + i_non_cas =0 + do k=1,N_det + in_cas = .False. + do j=1,N_det_cas + call get_excitation_degree(psi_cas(1,1,j), psi_det(1,1,k), degree, N_int) + if (degree == 0) then + in_cas = .True. + exit + endif + enddo + if (.not.in_cas) then + double precision :: hij + i_non_cas += 1 + do j=1,N_int + psi_non_cas(j,1,i_non_cas) = psi_det(j,1,k) + psi_non_cas(j,2,i_non_cas) = psi_det(j,2,k) + enddo + do j=1,N_states + psi_non_cas_coef(i_non_cas,j) = psi_coef(k,j) + enddo + idx_non_cas(i_non_cas) = k + endif + enddo + N_det_non_cas = i_non_cas +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! CAS determinants sorted to accelerate the search of a random determinant in the wave + ! function. + END_DOC + call sort_dets_by_det_search_key(N_det_cas, psi_non_cas, psi_non_cas_coef, & + psi_non_cas_sorted_bit, psi_non_cas_coef_sorted_bit) + +END_PROVIDER + + + + + diff --git a/src/Determinants/ref_bitmask.irp.f b/src/Determinants/ref_bitmask.irp.f new file mode 100644 index 00000000..7f760562 --- /dev/null +++ b/src/Determinants/ref_bitmask.irp.f @@ -0,0 +1,57 @@ + BEGIN_PROVIDER [ double precision, ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, mono_elec_ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, kinetic_ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, nucl_elec_ref_bitmask_energy ] +&BEGIN_PROVIDER [ double precision, bi_elec_ref_bitmask_energy ] + use bitmasks + implicit none + BEGIN_DOC + ! Energy of the reference bitmask used in Slater rules + END_DOC + + integer :: occ(N_int*bit_kind_size,2) + integer :: i,j + + call bitstring_to_list(ref_bitmask(1,1), occ(1,1), i, N_int) + call bitstring_to_list(ref_bitmask(1,2), occ(1,2), i, N_int) + + + ref_bitmask_energy = 0.d0 + mono_elec_ref_bitmask_energy = 0.d0 + kinetic_ref_bitmask_energy = 0.d0 + nucl_elec_ref_bitmask_energy = 0.d0 + bi_elec_ref_bitmask_energy = 0.d0 + + do i = 1, elec_beta_num + ref_bitmask_energy += mo_mono_elec_integral(occ(i,1),occ(i,1)) + mo_mono_elec_integral(occ(i,2),occ(i,2)) + kinetic_ref_bitmask_energy += mo_kinetic_integral(occ(i,1),occ(i,1)) + mo_kinetic_integral(occ(i,2),occ(i,2)) + nucl_elec_ref_bitmask_energy += mo_nucl_elec_integral(occ(i,1),occ(i,1)) + mo_nucl_elec_integral(occ(i,2),occ(i,2)) + enddo + + do i = elec_beta_num+1,elec_alpha_num + ref_bitmask_energy += mo_mono_elec_integral(occ(i,1),occ(i,1)) + kinetic_ref_bitmask_energy += mo_kinetic_integral(occ(i,1),occ(i,1)) + nucl_elec_ref_bitmask_energy += mo_nucl_elec_integral(occ(i,1),occ(i,1)) + enddo + + do j= 1, elec_alpha_num + do i = j+1, elec_alpha_num + bi_elec_ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,1),occ(j,1)) + ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,1),occ(j,1)) + enddo + enddo + + do j= 1, elec_beta_num + do i = j+1, elec_beta_num + bi_elec_ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,2),occ(j,2)) + ref_bitmask_energy += mo_bielec_integral_jj_anti(occ(i,2),occ(j,2)) + enddo + do i= 1, elec_alpha_num + bi_elec_ref_bitmask_energy += mo_bielec_integral_jj(occ(i,1),occ(j,2)) + ref_bitmask_energy += mo_bielec_integral_jj(occ(i,1),occ(j,2)) + enddo + enddo + mono_elec_ref_bitmask_energy = kinetic_ref_bitmask_energy + nucl_elec_ref_bitmask_energy + +END_PROVIDER + diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f new file mode 100644 index 00000000..cd1d9fda --- /dev/null +++ b/src/Determinants/s2.irp.f @@ -0,0 +1,106 @@ +subroutine get_s2(key_i,key_j,phase,Nint) + implicit none + use bitmasks + BEGIN_DOC +! Returns + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer(bit_kind), intent(in) :: key_j(Nint,2) + double precision, intent(out) :: phase + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase_spsm + integer :: nup, i + + phase = 0.d0 + !$FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case(2) + call get_double_excitation(key_i,key_j,exc,phase_spsm,Nint) + if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta + if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then + phase = -phase_spsm + endif + endif + case(0) + nup = 0 + do i=1,Nint + nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) + enddo + phase = dble(nup) + end select +end + +BEGIN_PROVIDER [ double precision, S_z ] +&BEGIN_PROVIDER [ double precision, S_z2_Sz ] + implicit none + BEGIN_DOC +! z component of the Spin + END_DOC + + S_z = 0.5d0*dble(elec_alpha_num-elec_beta_num) + S_z2_Sz = S_z*(S_z-1.d0) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, expected_s2] + implicit none + BEGIN_DOC +! Expected value of S2 : S*(S+1) + END_DOC + logical :: has_expected_s2 + + call ezfio_has_determinants_expected_s2(has_expected_s2) + if (has_expected_s2) then + call ezfio_get_determinants_expected_s2(expected_s2) + else + double precision :: S + S = (elec_alpha_num-elec_beta_num)*0.5d0 + expected_s2 = S * (S+1.d0) +! expected_s2 = elec_alpha_num - elec_beta_num + 0.5d0 * ((elec_alpha_num - elec_beta_num)**2*0.5d0 - (elec_alpha_num-elec_beta_num)) + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] + implicit none + BEGIN_DOC +! array of the averaged values of the S^2 operator on the various states + END_DOC + integer :: i + double precision :: s2 + do i = 1, N_states + call get_s2_u0(psi_det,psi_coef(1,i),n_det,psi_det_size,s2) + s2_values(i) = s2 + enddo + +END_PROVIDER + + +subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) + implicit none + use bitmasks + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) + integer, intent(in) :: n,nmax + double precision, intent(in) :: psi_coefs_tmp(nmax) + double precision, intent(out) :: s2 + integer :: i,j,l + double precision :: s2_tmp + s2 = S_z2_Sz + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP PRIVATE(i,j,s2_tmp) SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int) & + !$OMP REDUCTION(+:s2) SCHEDULE(dynamic) + do i = 1, n + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) +! print*,'s2_tmp = ',s2_tmp + do j = 1, n + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),s2_tmp,N_int) + if (s2_tmp == 0.d0) cycle + s2 += psi_coefs_tmp(i)*psi_coefs_tmp(j)*s2_tmp + enddo + enddo + !$OMP END PARALLEL DO +end + diff --git a/src/Determinants/save_for_casino.irp.f b/src/Determinants/save_for_casino.irp.f new file mode 100644 index 00000000..631f79bd --- /dev/null +++ b/src/Determinants/save_for_casino.irp.f @@ -0,0 +1,268 @@ +subroutine save_casino + use bitmasks + implicit none + character*(128) :: message + integer :: getUnitAndOpen, iunit + integer, allocatable :: itmp(:) + integer :: n_ao_new + real, allocatable :: rtmp(:) + PROVIDE ezfio_filename + + iunit = getUnitAndOpen('gwfn.data','w') + print *, 'Title?' + read(*,*) message + write(iunit,'(A)') trim(message) + write(iunit,'(A)') '' + write(iunit,'(A)') 'BASIC_INFO' + write(iunit,'(A)') '----------' + write(iunit,'(A)') 'Generated by:' + write(iunit,'(A)') 'Quantum package' + write(iunit,'(A)') 'Method:' + print *, 'Method?' + read(*,*) message + write(iunit,'(A)') trim(message) + write(iunit,'(A)') 'DFT Functional:' + write(iunit,'(A)') 'none' + write(iunit,'(A)') 'Periodicity:' + write(iunit,'(A)') '0' + write(iunit,'(A)') 'Spin unrestricted:' + write(iunit,'(A)') '.false.' + write(iunit,'(A)') 'nuclear-nuclear repulsion energy (au/atom):' + write(iunit,*) nuclear_repulsion + write(iunit,'(A)') 'Number of electrons per primitive cell:' + write(iunit,*) elec_num + write(iunit,*) '' + + + write(iunit,*) 'GEOMETRY' + write(iunit,'(A)') '--------' + write(iunit,'(A)') 'Number of atoms:' + write(iunit,*) nucl_num + write(iunit,'(A)') 'Atomic positions (au):' + integer :: i + do i=1,nucl_num + write(iunit,'(3(1PE20.13))') nucl_coord(i,1:3) + enddo + write(iunit,'(A)') 'Atomic numbers for each atom:' + ! Add 200 if pseudopotential + allocate(itmp(nucl_num)) + do i=1,nucl_num + itmp(i) = int(nucl_charge(i)) + enddo + write(iunit,'(8(I10))') itmp(1:nucl_num) + deallocate(itmp) + write(iunit,'(A)') 'Valence charges for each atom:' + write(iunit,'(4(1PE20.13))') nucl_charge(1:nucl_num) + write(iunit,'(A)') '' + + + write(iunit,'(A)') 'BASIS SET' + write(iunit,'(A)') '---------' + write(iunit,'(A)') 'Number of Gaussian centres' + write(iunit,*) nucl_num + write(iunit,'(A)') 'Number of shells per primitive cell' + integer :: icount + icount = 0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + icount += 1 + endif + enddo + write(iunit,*) icount + write(iunit,'(A)') 'Number of basis functions (''AO'') per primitive cell' + icount = 0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + icount += 2*ao_l(i)+1 + endif + enddo + n_ao_new = icount + write(iunit,*) n_ao_new + write(iunit,'(A)') 'Number of Gaussian primitives per primitive cell' + allocate(itmp(ao_num)) + integer :: l + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l += 1 + itmp(l) = ao_prim_num(i) + endif + enddo + write(iunit,'(8(I10))') sum(itmp(1:l)) + write(iunit,'(A)') 'Highest shell angular momentum (s/p/d/f... 1/2/3/4...)' + write(iunit,*) maxval(ao_l(1:ao_num))+1 + write(iunit,'(A)') 'Code for shell types (s/sp/p/d/f... 1/2/3/4/5...)' + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l += 1 + if (ao_l(i) > 0) then + itmp(l) = ao_l(i)+2 + else + itmp(l) = ao_l(i)+1 + endif + endif + enddo + write(iunit,'(8(I10))') itmp(1:l) + write(iunit,'(A)') 'Number of primitive Gaussians in each shell' + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l += 1 + itmp(l) = ao_prim_num(i) + endif + enddo + write(iunit,'(8(I10))') itmp(1:l) + deallocate(itmp) + write(iunit,'(A)') 'Sequence number of first shell on each centre' + allocate(itmp(nucl_num)) + l=0 + icount = 1 + itmp(icount) = 1 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + l = l+1 + if (ao_nucl(i) == icount) then + continue + else if (ao_nucl(i) == icount+1) then + icount += 1 + itmp(icount) = l + else + print *, 'Problem in order of centers of basis functions' + stop 1 + endif + endif + enddo + ! Check + if (icount /= nucl_num) then + print *, 'Error :' + print *, ' icount :', icount + print *, ' nucl_num:', nucl_num + stop 2 + endif + write(iunit,'(8(I10))') itmp(1:nucl_num) + deallocate(itmp) + write(iunit,'(A)') 'Exponents of Gaussian primitives' + allocate(rtmp(ao_num)) + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + do j=1,ao_prim_num(i) + l+=1 + rtmp(l) = ao_expo(i,ao_prim_num(i)-j+1) + enddo + endif + enddo + write(iunit,'(4(1PE20.13))') rtmp(1:l) + write(iunit,'(A)') 'Normalized contraction coefficients' + l=0 + integer :: j + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + do j=1,ao_prim_num(i) + l+=1 + rtmp(l) = ao_coef(i,ao_prim_num(i)-j+1) + enddo + endif + enddo + write(iunit,'(4(1PE20.13))') rtmp(1:l) + deallocate(rtmp) + write(iunit,'(A)') 'Position of each shell (au)' + l=0 + do i=1,ao_num + if (ao_l(i) == ao_power(i,1)) then + write(iunit,'(3(1PE20.13))') nucl_coord( ao_nucl(i), 1:3 ) + endif + enddo + write(iunit,'(A)') + + + write(iunit,'(A)') 'MULTIDETERMINANT INFORMATION' + write(iunit,'(A)') '----------------------------' + write(iunit,'(A)') 'GS' + write(iunit,'(A)') 'ORBITAL COEFFICIENTS' + write(iunit,'(A)') '------------------------' + + ! Transformation cartesian -> spherical + double precision :: tf2(6,5), tf3(10,7), tf4(15,9) + integer :: check2(3,6), check3(3,10), check4(3,15) + check2(:,1) = (/ 2, 0, 0 /) + check2(:,2) = (/ 1, 1, 0 /) + check2(:,3) = (/ 1, 0, 1 /) + check2(:,4) = (/ 0, 2, 0 /) + check2(:,5) = (/ 0, 1, 1 /) + check2(:,6) = (/ 0, 0, 2 /) + + check3(:,1) = (/ 3, 0, 0 /) + check3(:,2) = (/ 2, 1, 0 /) + check3(:,3) = (/ 2, 0, 1 /) + check3(:,4) = (/ 1, 2, 0 /) + check3(:,5) = (/ 1, 1, 1 /) + check3(:,6) = (/ 1, 0, 2 /) + check3(:,7) = (/ 0, 3, 0 /) + check3(:,8) = (/ 0, 2, 1 /) + check3(:,9) = (/ 0, 1, 2 /) + check3(:,10) = (/ 0, 0, 3 /) + + check4(:,1) = (/ 4, 0, 0 /) + check4(:,2) = (/ 3, 1, 0 /) + check4(:,3) = (/ 3, 0, 1 /) + check4(:,4) = (/ 2, 2, 0 /) + check4(:,5) = (/ 2, 1, 1 /) + check4(:,6) = (/ 2, 0, 2 /) + check4(:,7) = (/ 1, 3, 0 /) + check4(:,8) = (/ 1, 2, 1 /) + check4(:,9) = (/ 1, 1, 2 /) + check4(:,10) = (/ 1, 0, 3 /) + check4(:,11) = (/ 0, 4, 0 /) + check4(:,12) = (/ 0, 3, 1 /) + check4(:,13) = (/ 0, 2, 2 /) + check4(:,14) = (/ 0, 1, 3 /) + check4(:,15) = (/ 0, 0, 4 /) + +! tf2 = (/ +! -0.5, 0, 0, -0.5, 0, 1.0, & +! 0, 0, 1.0, 0, 0, 0, & +! 0, 0, 0, 0, 1.0, 0, & +! 0.86602540378443864676, 0, 0, -0.86602540378443864676, 0, 0, & +! 0, 1.0, 0, 0, 0, 0, & +! /) +! tf3 = (/ +! 0, 0, -0.67082039324993690892, 0, 0, 0, 0, -0.67082039324993690892, 0, 1.0, & +! -0.61237243569579452455, 0, 0, -0.27386127875258305673, 0, 1.0954451150103322269, 0, 0, 0, 0, & +! 0, -0.27386127875258305673, 0, 0, 0, 0, -0.61237243569579452455, 0, 1.0954451150103322269, 0, & +! 0, 0, 0.86602540378443864676, 0, 0, 0, 0, -0.86602540378443864676, 0, 0, & +! 0, 0, 0, 0, 1.0, 0, 0, 0, 0, 0, & +! 0.790569415042094833, 0, 0, -1.0606601717798212866, 0, 0, 0, 0, 0, 0, & +! 0, 1.0606601717798212866, 0, 0, 0, 0, -0.790569415042094833, 0, 0, 0, & +! /) +! tf4 = (/ +! 0.375, 0, 0, 0.21957751641341996535, 0, -0.87831006565367986142, 0, 0, 0, 0, 0.375, 0, -0.87831006565367986142, 0, 1.0, & +! 0, 0, -0.89642145700079522998, 0, 0, 0, 0, -0.40089186286863657703, 0, 1.19522860933439364, 0, 0, 0, 0, 0, & +! 0, 0, 0, 0, -0.40089186286863657703, 0, 0, 0, 0, 0, 0, -0.89642145700079522998, 0, 1.19522860933439364, 0, & +! -0.5590169943749474241, 0, 0, 0, 0, 0.9819805060619657157, 0, 0, 0, 0, 0.5590169943749474241, 0, -0.9819805060619657157, 0, 0, & +! 0, -0.42257712736425828875, 0, 0, 0, 0, -0.42257712736425828875, 0, 1.1338934190276816816, 0, 0, 0, 0, 0, 0, & +! 0, 0, 0.790569415042094833, 0, 0, 0, 0, -1.0606601717798212866, 0, 0, 0, 0, 0, 0, 0, & +! 0, 0, 0, 0, 1.0606601717798212866, 0, 0, 0, 0, 0, 0, -0.790569415042094833, 0, 0, 0, & +! 0.73950997288745200532, 0, 0, -1.2990381056766579701, 0, 0, 0, 0, 0, 0, 0.73950997288745200532, 0, 0, 0, 0, & +! 0, 1.1180339887498948482, 0, 0, 0, 0, -1.1180339887498948482, 0, 0, 0, 0, 0, 0, 0, 0, & +! /) +! + + + allocate(rtmp(ao_num*mo_tot_num)) + l=0 + do i=1,mo_tot_num + do j=1,ao_num + l += 1 + rtmp(l) = mo_coef(j,i) + enddo + enddo + write(iunit,'(4(1PE20.13))') rtmp(1:l) + deallocate(rtmp) + close(iunit) +end + +program prog_save_casino + call save_casino +end diff --git a/src/Determinants/save_for_qmcchem.irp.f b/src/Determinants/save_for_qmcchem.irp.f new file mode 100644 index 00000000..b707ff7c --- /dev/null +++ b/src/Determinants/save_for_qmcchem.irp.f @@ -0,0 +1,51 @@ +subroutine save_dets_qmcchem + use bitmasks + implicit none + character :: c(mo_tot_num) + integer :: i,k + + integer, allocatable :: occ(:,:,:), occ_tmp(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: occ, occ_tmp + + read_wf = .True. + TOUCH read_wf + call ezfio_set_determinants_det_num(N_det) + call ezfio_set_determinants_det_coef(psi_coef_sorted(1,1)) + + allocate (occ(elec_alpha_num,N_det,2)) + ! OMP PARALLEL DEFAULT(NONE) & + ! OMP PRIVATE(occ_tmp,i,k)& + ! OMP SHARED(N_det,psi_det_sorted,elec_alpha_num, & + ! OMP occ,elec_beta_num,N_int) + allocate (occ_tmp(N_int*bit_kind_size,2)) + occ_tmp = 0 + ! OMP DO + do i=1,N_det + call bitstring_to_list(psi_det_sorted(1,1,i), occ_tmp(1,1), elec_alpha_num, N_int ) + call bitstring_to_list(psi_det_sorted(1,2,i), occ_tmp(1,2), elec_beta_num, N_int ) + do k=1,elec_alpha_num + occ(k,i,1) = occ_tmp(k,1) + occ(k,i,2) = occ_tmp(k,2) + enddo + enddo + ! OMP END DO + deallocate(occ_tmp) + ! OMP END PARALLEL + call ezfio_set_determinants_det_occ(occ) + call write_int(output_determinants,N_det,'Determinants saved for QMC') + deallocate(occ) + open(unit=31,file=trim(ezfio_filename)//'/mo_basis/mo_classif') + write(31,'(I1)') 1 + write(31,*) mo_tot_num + do i=1,mo_tot_num + write(31,'(A)') 'a' + enddo + close(31) + call system('gzip -f '//trim(ezfio_filename)//'/mo_basis/mo_classif') + +end + +program save_for_qmc + call save_dets_qmcchem + call write_spindeterminants +end diff --git a/src/Determinants/save_natorb.irp.f b/src/Determinants/save_natorb.irp.f new file mode 100644 index 00000000..e56f9821 --- /dev/null +++ b/src/Determinants/save_natorb.irp.f @@ -0,0 +1,6 @@ +program save_natorb + read_wf = .True. + touch read_wf + call save_natural_mos +end + diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f new file mode 100644 index 00000000..7d431879 --- /dev/null +++ b/src/Determinants/slater_rules.irp.f @@ -0,0 +1,1301 @@ +subroutine get_excitation_degree(key1,key2,degree,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation degree between two determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key1(Nint,2) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree + + integer :: l + + ASSERT (Nint > 0) + + degree = popcnt(xor( key1(1,1), key2(1,1))) + & + popcnt(xor( key1(1,2), key2(1,2))) + !DEC$ NOUNROLL + do l=2,Nint + degree = degree+ popcnt(xor( key1(l,1), key2(l,1))) + & + popcnt(xor( key1(l,2), key2(l,2))) + enddo + ASSERT (degree >= 0) + degree = ishft(degree,-1) + +end + + + +subroutine get_excitation(det1,det2,exc,degree,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operators between two determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(out) :: exc(0:2,2,2) + integer, intent(out) :: degree + double precision, intent(out) :: phase + ! exc(number,hole/particle,spin) + ! ex : + ! exc(0,1,1) = number of holes alpha + ! exc(0,2,1) = number of particle alpha + ! exc(0,2,2) = number of particle beta + ! exc(1,2,1) = first particle alpha + ! exc(1,1,1) = first hole alpha + ! exc(1,2,2) = first particle beta + ! exc(1,1,2) = first hole beta + + ASSERT (Nint > 0) + + !DIR$ FORCEINLINE + call get_excitation_degree(det1,det2,degree,Nint) + select case (degree) + + case (3:) + degree = -1 + return + + case (2) + call get_double_excitation(det1,det2,exc,phase,Nint) + return + + case (1) + call get_mono_excitation(det1,det2,exc,phase,Nint) + return + + case(0) + return + + end select +end + +subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + use bitmasks + implicit none + BEGIN_DOC + ! Decodes the exc arrays returned by get_excitation. + ! h1,h2 : Holes + ! p1,p2 : Particles + ! s1,s2 : Spins (1:alpha, 2:beta) + ! degree : Degree of excitation + END_DOC + integer, intent(in) :: exc(0:2,2,2),degree + integer, intent(out) :: h1,h2,p1,p2,s1,s2 + ASSERT (degree > 0) + ASSERT (degree < 3) + + select case(degree) + case(2) + if (exc(0,1,1) == 2) then + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + s1 = 1 + s2 = 1 + else if (exc(0,1,2) == 2) then + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + s1 = 2 + s2 = 2 + else + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + s1 = 1 + s2 = 2 + endif + case(1) + if (exc(0,1,1) == 1) then + h1 = exc(1,1,1) + h2 = 0 + p1 = exc(1,2,1) + p2 = 0 + s1 = 1 + s2 = 0 + else + h1 = exc(1,1,2) + h2 = 0 + p1 = exc(1,2,2) + p2 = 0 + s1 = 2 + s2 = 0 + endif + case(0) + h1 = 0 + p1 = 0 + h2 = 0 + p2 = 0 + s1 = 0 + s2 = 0 + end select +end + +subroutine get_double_excitation(det1,det2,exc,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the two excitation operators between two doubly excited determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(out) :: exc(0:2,2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ispin = 1,2 + idx_particle = 0 + idx_hole = 0 + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (det1(l,ispin) == det2(l,ispin)) then + cycle + endif + tmp = xor( det1(l,ispin), det2(l,ispin) ) + particle = iand(tmp, det2(l,ispin)) + hole = iand(tmp, det1(l,ispin)) + do while (particle /= 0_bit_kind) + tz = trailz(particle) + idx_particle = idx_particle + 1 + exc(0,2,ispin) = exc(0,2,ispin) + 1 + exc(idx_particle,2,ispin) = tz+ishift + particle = iand(particle,particle-1_bit_kind) + enddo + if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)==2 + exit + endif + do while (hole /= 0_bit_kind) + tz = trailz(hole) + idx_hole = idx_hole + 1 + exc(0,1,ispin) = exc(0,1,ispin) + 1 + exc(idx_hole,1,ispin) = tz+ishift + hole = iand(hole,hole-1_bit_kind) + enddo + if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin) + exit + endif + enddo + + ! TODO : Voir si il faut sortir i,n,k,m du case. + + select case (exc(0,1,ispin)) + case(0) + cycle + + case(1) + low = min(exc(1,1,ispin), exc(1,2,ispin)) + high = max(exc(1,1,ispin), exc(1,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + & + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i,ispin)) + end do + endif + + case (2) + + do i=1,2 + low = min(exc(i,1,ispin), exc(i,2,ispin)) + high = max(exc(i,1,ispin), exc(i,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j,ispin), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k,ispin), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + & + popcnt(iand(det1(j,ispin), ibclr(-1_bit_kind,n) +1_bit_kind)) + do l=j+1,k-1 + nperm = nperm + popcnt(det1(l,ispin)) + end do + endif + + enddo + + a = min(exc(1,1,ispin), exc(1,2,ispin)) + b = max(exc(1,1,ispin), exc(1,2,ispin)) + c = min(exc(2,1,ispin), exc(2,2,ispin)) + d = max(exc(2,1,ispin), exc(2,2,ispin)) + if (c>a .and. cb) then + nperm = nperm + 1 + endif + exit + end select + + enddo + phase = phase_dble(iand(nperm,1)) + +end + +subroutine get_mono_excitation(det1,det2,exc,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operator between two singly excited determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint,2) + integer(bit_kind), intent(in) :: det2(Nint,2) + integer, intent(out) :: exc(0:2,2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ispin = 1,2 + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (det1(l,ispin) == det2(l,ispin)) then + cycle + endif + tmp = xor( det1(l,ispin), det2(l,ispin) ) + particle = iand(tmp, det2(l,ispin)) + hole = iand(tmp, det1(l,ispin)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ispin) = 1 + exc(1,2,ispin) = tz+ishift + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ispin) = 1 + exc(1,1,ispin) = tz+ishift + endif + + if ( iand(exc(0,1,ispin),exc(0,2,ispin)) /= 1) then ! exc(0,1,ispin)/=1 and exc(0,2,ispin) /= 1 + cycle + endif + + low = min(exc(1,1,ispin),exc(1,2,ispin)) + high = max(exc(1,1,ispin),exc(1,2,ispin)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low,bit_kind_size-1) ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + if (j==k) then + nperm = popcnt(iand(det1(j,ispin), & + iand(ibset(0_bit_kind,m-1)-1_bit_kind,ibclr(-1_bit_kind,n)+1_bit_kind))) + else + nperm = nperm + popcnt(iand(det1(k,ispin),ibset(0_bit_kind,m-1)-1_bit_kind)) +& + popcnt(iand(det1(j,ispin),ibclr(-1_bit_kind,n)+1_bit_kind)) + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i,ispin)) + end do + endif + phase = phase_dble(iand(nperm,1)) + return + + enddo + enddo +end + + + + + +subroutine i_H_j(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_alpha, n_occ_beta + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + !DEC$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) + call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) + enddo + do k = 1, elec_beta_num + hij = hij + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, elec_beta_num + hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p)) + + case (0) + hij = diag_H_mat_elem(key_i,Nint) + end select +end + + + + +subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij,hmono,hdouble + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_alpha, n_occ_beta + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + hmono = 0.d0 + hdouble = 0.d0 + !DEC$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) + call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1)) + enddo + do k = 1, elec_beta_num + hdouble = hdouble + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, elec_beta_num + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, elec_alpha_num + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, elec_alpha_num + hdouble = hdouble + mipi(occ(k,1)) + enddo + do k = 1, elec_beta_num + hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2)) + enddo + + endif + hmono = mo_mono_elec_integral(m,p) + hij = phase*(hdouble + hmono) + + case (0) + hij = diag_H_mat_elem(key_i,Nint) + end select +end + + + +subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + BEGIN_DOC + ! for the various Nstates + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) + do ii=1,idx(0) + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo +end + +subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + double precision, intent(out) :: interactions(Ndet) + integer,intent(out) :: idx_interaction(0:Ndet) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet),n_interact + BEGIN_DOC + ! for the various Nstates + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) + n_interact = 0 + do ii=1,idx(0) + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + if(dabs(hij).ge.1.d-8)then + if(i.ne.1)then + n_interact += 1 + interactions(n_interact) = hij + idx_interaction(n_interact) = i + endif + endif + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo + idx_interaction(0) = n_interact +end + + +subroutine i_H_psi_SC2(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_repeat) + use bitmasks + BEGIN_DOC + ! for the various Nstate + ! + ! returns in addition + ! + ! the array of the index of the non connected determinants to key1 + ! + ! in order to know what double excitation can be repeated on key1 + ! + ! idx_repeat(0) is the number of determinants that can be used + ! + ! to repeat the excitations + END_DOC + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + integer , intent(out) :: idx_repeat(0:Ndet) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) + do ii=1,idx(0) + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + enddo +end + + +subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_repeat) + use bitmasks + BEGIN_DOC + ! for the various Nstate + ! + ! returns in addition + ! + ! the array of the index of the non connected determinants to key1 + ! + ! in order to know what double excitation can be repeated on key1 + ! + ! idx_repeat(0) is the number of determinants that can be used + ! + ! to repeat the excitations + END_DOC + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + integer , intent(out) :: idx_repeat(0:Ndet) + + integer :: i, ii,j + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) + print*,'--------' + do ii=1,idx(0) + print*,'--' + i = idx(ii) + !DEC$ FORCEINLINE + call i_H_j(keys(1,1,i),key,Nint,hij) + if (i==1)then + print*,'i==1 !!' + endif + print*,coef(i,1) * hij,coef(i,1),hij + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij + enddo + print*,i_H_psi_array(1) + enddo + print*,'------' +end + + + +subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Applies get_excitation_degree to an array of determinants + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree(sze) + integer, intent(out) :: idx(0:sze) + + integer :: i,l + + ASSERT (Nint > 0) + ASSERT (sze > 0) + + l=1 + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = ishft( popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree(l) = 0 + !DEC$ LOOP COUNT MIN(4) + do l=1,Nint + degree(l) = degree(l)+ popcnt(xor( key1(l,1,i), key2(l,1))) +& + popcnt(xor( key1(l,2,i), key2(l,2))) + enddo + degree(l) = ishft(degree(l),-1) + if (degree(l) < 3) then + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + + + + +double precision function diag_H_mat_elem(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer(bit_kind) :: hole(Nint,2) + integer(bit_kind) :: particle(Nint,2) + integer :: i, nexc(2), ispin + integer :: occ_particle(Nint*bit_kind_size,2) + integer :: occ_hole(Nint*bit_kind_size,2) + integer(bit_kind) :: det_tmp(Nint,2) + integer :: na, nb + + ASSERT (Nint > 0) + ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num) + + nexc(1) = 0 + nexc(2) = 0 + do i=1,Nint + hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) + particle(i,1) = iand(hole(i,1),det_in(i,1)) + particle(i,2) = iand(hole(i,2),det_in(i,2)) + hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) + hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) + nexc(1) += popcnt(hole(i,1)) + nexc(2) += popcnt(hole(i,2)) + enddo + + diag_H_mat_elem = ref_bitmask_energy + if (nexc(1)+nexc(2) == 0) then + return + endif + + !call debug_det(det_in,Nint) + integer :: tmp + call bitstring_to_list(particle(1,1), occ_particle(1,1), tmp, Nint) + ASSERT (tmp == nexc(1)) + call bitstring_to_list(particle(1,2), occ_particle(1,2), tmp, Nint) + ASSERT (tmp == nexc(2)) + call bitstring_to_list(hole(1,1), occ_hole(1,1), tmp, Nint) + ASSERT (tmp == nexc(1)) + call bitstring_to_list(hole(1,2), occ_hole(1,2), tmp, Nint) + ASSERT (tmp == nexc(2)) + + det_tmp = ref_bitmask + do ispin=1,2 + na = elec_num_tab(ispin) + nb = elec_num_tab(iand(ispin,1)+1) + do i=1,nexc(ispin) + !DIR$ FORCEINLINE + call ac_operator( occ_particle(i,ispin), ispin, det_tmp, diag_H_mat_elem, Nint,na,nb) + !DIR$ FORCEINLINE + call a_operator ( occ_hole (i,ispin), ispin, det_tmp, diag_H_mat_elem, Nint,na,nb) + enddo + enddo +end + +subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Needed for diag_H_mat_elem + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hjj + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + k = ishft(iorb-1,-bit_kind_shift)+1 + ASSERT (k > 0) + l = iorb - ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibclr(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + !DIR$ FORCEINLINE + call get_occ_from_key(key,occ,Nint) + na -= 1 + + hjj -= mo_mono_elec_integral(iorb,iorb) + + ! Same spin + do i=1,na + hjj -= mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + hjj -= mo_bielec_integral_jj(occ(i,other_spin),iorb) + enddo + +end + + +subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Needed for diag_H_mat_elem + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hjj + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + integer :: tmp + !DIR$ FORCEINLINE + call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) + ASSERT (tmp == elec_alpha_num) + !DIR$ FORCEINLINE + call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) + ASSERT (tmp == elec_beta_num) + + k = ishft(iorb-1,-bit_kind_shift)+1 + ASSERT (k > 0) + l = iorb - ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + hjj += mo_mono_elec_integral(iorb,iorb) + + ! Same spin + do i=1,na + hjj += mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + hjj += mo_bielec_integral_jj(occ(i,other_spin),iorb) + enddo + na += 1 +end + +subroutine get_occ_from_key(key,occ,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns a list of occupation numbers from a bitstring + END_DOC + integer(bit_kind), intent(in) :: key(Nint,2) + integer , intent(in) :: Nint + integer , intent(out) :: occ(Nint*bit_kind_size,2) + integer :: tmp + + call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) + call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) + +end + +subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + END_DOC + integer, intent(in) :: n,Nint + double precision, intent(out) :: v_0(n) + double precision, intent(in) :: u_0(n) + double precision, intent(in) :: H_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + integer, allocatable :: idx(:) + double precision :: hij + double precision, allocatable :: vt(:) + integer :: i,j,k,l, jj + integer :: i0, j0 + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + integer, parameter :: block_size = 157 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,j,k,idx,jj,vt) & + !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0) + !$OMP DO SCHEDULE(static) + do i=1,n + v_0(i) = H_jj(i) * u_0(i) + enddo + !$OMP END DO + allocate(idx(0:n), vt(n)) + Vt = 0.d0 + !$OMP DO SCHEDULE(guided) + do i=1,n + idx(0) = i + call filter_connected_davidson(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) + do jj=1,idx(0) + j = idx(jj) + if ( (dabs(u_0(j)) > 1.d-7).or.((dabs(u_0(i)) > 1.d-7)) ) then + call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) + vt (i) = vt (i) + hij*u_0(j) + vt (j) = vt (j) + hij*u_0(i) + endif + enddo + enddo + !$OMP END DO + !$OMP CRITICAL + do i=1,n + v_0(i) = v_0(i) + vt(i) + enddo + !$OMP END CRITICAL + deallocate(idx,vt) + !$OMP END PARALLEL +end + + + +BEGIN_PROVIDER [ integer, N_con_int ] + implicit none + BEGIN_DOC + ! Number of integers to represent the connections between determinants + END_DOC + N_con_int = 1 + ishft(N_det-1,-11) +END_PROVIDER + +BEGIN_PROVIDER [ integer*8, det_connections, (N_con_int,N_det) ] + implicit none + BEGIN_DOC + ! Build connection proxy between determinants + END_DOC + integer :: i,j + integer :: degree + integer :: j_int, j_k, j_l + integer, allocatable :: idx(:) + integer :: thread_num + integer :: omp_get_thread_num + + PROVIDE progress_bar + call start_progress(N_det,'Det connections',0.d0) + + select case(N_int) + + case(1) + + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections, & + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & + popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + if (degree < 5) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + case(2) + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & + popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & + popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & + popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) + if (degree < 5) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + case(3) + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & + popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & + popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & + popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) + & + popcnt(xor( psi_det(3,1,i),psi_det(3,1,j))) + & + popcnt(xor( psi_det(3,2,i),psi_det(3,2,j))) + if (degree < 5) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + case default + + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& + !$OMP progress_bar,progress_value)& + !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) + !$ thread_num = omp_get_thread_num() + allocate (idx(0:N_det)) + !$OMP DO SCHEDULE(guided) + do i=1,N_det + if (thread_num == 0) then + progress_bar(1) = i + progress_value = dble(i) + endif + do j_int=1,N_con_int + det_connections(j_int,i) = 0_8 + j_k = ishft(j_int-1,11) + do j_l = j_k,min(j_k+2047,N_det), 32 + do j = j_l+1,min(j_l+32,i) + !DIR$ FORCEINLINE + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if (degree < 3) then + det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) + exit + endif + enddo + enddo + enddo + enddo + !$OMP ENDDO + deallocate(idx) + !$OMP END PARALLEL + + end select + call stop_progress + +END_PROVIDER + diff --git a/src/Determinants/spindeterminants.ezfio_config b/src/Determinants/spindeterminants.ezfio_config new file mode 100644 index 00000000..39ccb82b --- /dev/null +++ b/src/Determinants/spindeterminants.ezfio_config @@ -0,0 +1,17 @@ +spindeterminants + n_det_alpha integer + n_det_beta integer + n_det integer + n_int integer + bit_kind integer + n_states integer + psi_det_alpha integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_alpha) + psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta) + psi_coef_matrix_rows integer (spindeterminants_n_det) + psi_coef_matrix_columns integer (spindeterminants_n_det) + psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) + n_svd_coefs integer + psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states) + psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states) + psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states) + diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f new file mode 100644 index 00000000..ffd28f85 --- /dev/null +++ b/src/Determinants/spindeterminants.irp.f @@ -0,0 +1,615 @@ +!==============================================================================! +! ! +! Independent alpha/beta parts ! +! ! +!==============================================================================! + +use bitmasks + +integer*8 function spin_det_search_key(det,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Return an integer*8 corresponding to a determinant index for searching + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det(Nint) + integer :: i + spin_det_search_key = det(1) + do i=2,Nint + spin_det_search_key = ieor(spin_det_search_key,det(i)) + enddo +end + + +BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] + implicit none + BEGIN_DOC +! List of alpha determinants of psi_det + END_DOC + integer :: i,k + + do i=1,N_det + do k=1,N_int + psi_det_alpha(k,i) = psi_det(k,1,i) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] + implicit none + BEGIN_DOC +! List of beta determinants of psi_det + END_DOC + integer :: i,k + + do i=1,N_det + do k=1,N_int + psi_det_beta(k,i) = psi_det(k,2,i) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha_unique, (N_int,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_alpha_unique ] + implicit none + BEGIN_DOC + ! Unique alpha determinants + END_DOC + + integer :: i,k + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key + + allocate ( iorder(N_det), bit_tmp(N_det)) + + do i=1,N_det + iorder(i) = i + bit_tmp(i) = spin_det_search_key(psi_det_alpha(1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,N_det) + + N_det_alpha_unique = 0 + last_key = 0_8 + do i=1,N_det + if (bit_tmp(i) /= last_key) then + last_key = bit_tmp(i) + N_det_alpha_unique += 1 + do k=1,N_int + psi_det_alpha_unique(k,N_det_alpha_unique) = psi_det_alpha(k,iorder(i)) + enddo + endif + enddo + + deallocate (iorder, bit_tmp) +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta_unique, (N_int,psi_det_size) ] +&BEGIN_PROVIDER [ integer, N_det_beta_unique ] + implicit none + BEGIN_DOC + ! Unique beta determinants + END_DOC + + integer :: i,k + integer, allocatable :: iorder(:) + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key + + allocate ( iorder(N_det), bit_tmp(N_det)) + + do i=1,N_det + iorder(i) = i + bit_tmp(i) = spin_det_search_key(psi_det_beta(1,i),N_int) + enddo + + call i8sort(bit_tmp,iorder,N_det) + + N_det_beta_unique = 0 + last_key = 0_8 + do i=1,N_det + if (bit_tmp(i) /= last_key) then + last_key = bit_tmp(i) + N_det_beta_unique += 1 + do k=1,N_int + psi_det_beta_unique(k,N_det_beta_unique) = psi_det_beta(k,iorder(i)) + enddo + endif + enddo + + deallocate (iorder, bit_tmp) +END_PROVIDER + + + + + +integer function get_index_in_psi_det_alpha_unique(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_alpha_unique`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: spin_det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_alpha_unique = 0 + ibegin = 1 + iend = N_det_alpha_unique + 1 + + !DIR$ FORCEINLINE + det_ref = spin_det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_alpha_unique(1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_alpha_unique(1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det_alpha_unique) then + return + endif + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_alpha_unique(1,i),Nint) == det_ref) + if (key(1) /= psi_det_alpha_unique(1,i)) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if (key(l) /= psi_det_alpha_unique(l,i)) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_alpha_unique = i + return + endif + endif + i += 1 + if (i > N_det_alpha_unique) then + return + endif + + enddo + +end + +integer function get_index_in_psi_det_beta_unique(key,Nint) + use bitmasks + BEGIN_DOC +! Returns the index of the determinant in the ``psi_det_beta_unique`` array + END_DOC + implicit none + + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key(Nint) + + integer :: i, ibegin, iend, istep, l + integer*8 :: det_ref, det_search + integer*8, external :: spin_det_search_key + logical :: is_in_wavefunction + + is_in_wavefunction = .False. + get_index_in_psi_det_beta_unique = 0 + ibegin = 1 + iend = N_det_beta_unique + 1 + + !DIR$ FORCEINLINE + det_ref = spin_det_search_key(key,Nint) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_beta_unique(1,1),Nint) + + istep = ishft(iend-ibegin,-1) + i=ibegin+istep + do while (istep > 0) + !DIR$ FORCEINLINE + det_search = spin_det_search_key(psi_det_beta_unique(1,i),Nint) + if ( det_search > det_ref ) then + iend = i + else if ( det_search == det_ref ) then + exit + else + ibegin = i + endif + istep = ishft(iend-ibegin,-1) + i = ibegin + istep + end do + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) + i = i-1 + if (i == 0) then + exit + endif + enddo + i += 1 + + if (i > N_det_beta_unique) then + return + endif + + !DIR$ FORCEINLINE + do while (spin_det_search_key(psi_det_beta_unique(1,i),Nint) == det_ref) + if (key(1) /= psi_det_beta_unique(1,i)) then + continue + else + is_in_wavefunction = .True. + !DIR$ IVDEP + !DIR$ LOOP COUNT MIN(3) + do l=2,Nint + if (key(l) /= psi_det_beta_unique(l,i)) then + is_in_wavefunction = .False. + endif + enddo + if (is_in_wavefunction) then + get_index_in_psi_det_beta_unique = i + return + endif + endif + i += 1 + if (i > N_det_beta_unique) then + return + endif + + enddo + +end + + +subroutine write_spindeterminants + use bitmasks + implicit none + integer*8, allocatable :: tmpdet(:,:) + integer :: N_int2 + integer :: i,j,k + integer*8 :: det_8(100) + integer(bit_kind) :: det_bk((100*8)/bit_kind) + equivalence (det_8, det_bk) + + N_int2 = (N_int*bit_kind)/8 + call ezfio_set_spindeterminants_n_det_alpha(N_det_alpha_unique) + call ezfio_set_spindeterminants_n_det_beta(N_det_beta_unique) + call ezfio_set_spindeterminants_n_det(N_det) + call ezfio_set_spindeterminants_n_int(N_int) + call ezfio_set_spindeterminants_bit_kind(bit_kind) + call ezfio_set_spindeterminants_n_states(N_states) + + allocate(tmpdet(N_int2,N_det_alpha_unique)) + do i=1,N_det_alpha_unique + do k=1,N_int + det_bk(k) = psi_det_alpha_unique(k,i) + enddo + do k=1,N_int2 + tmpdet(k,i) = det_8(k) + enddo + enddo + call ezfio_set_spindeterminants_psi_det_alpha(psi_det_alpha_unique) + deallocate(tmpdet) + + allocate(tmpdet(N_int2,N_det_beta_unique)) + do i=1,N_det_beta_unique + do k=1,N_int + det_bk(k) = psi_det_beta_unique(k,i) + enddo + do k=1,N_int2 + tmpdet(k,i) = det_8(k) + enddo + enddo + call ezfio_set_spindeterminants_psi_det_beta(psi_det_beta_unique) + deallocate(tmpdet) + + call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_svd_matrix_values) + call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_svd_matrix_rows) + call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_svd_matrix_columns) + + integer :: n_svd_coefs + double precision :: norm, f + f = 1.d0/dble(N_states) + norm = 1.d0 + do n_svd_coefs=1,N_det_alpha_unique + do k=1,N_states + norm -= psi_svd_coefs(n_svd_coefs,k)*psi_svd_coefs(n_svd_coefs,k) + enddo + if (norm < 1.d-4) then + exit + endif + enddo + n_svd_coefs -= 1 + call ezfio_set_spindeterminants_n_svd_coefs(n_svd_coefs) + + double precision, allocatable :: dtmp(:,:,:) + allocate(dtmp(N_det_alpha_unique,n_svd_coefs,N_states)) + do k=1,N_states + do j=1,n_svd_coefs + do i=1,N_det_alpha_unique + dtmp(i,j,k) = psi_svd_alpha(i,j,k) + enddo + enddo + enddo + call ezfio_set_spindeterminants_psi_svd_alpha(dtmp) + deallocate(dtmp) + + allocate(dtmp(N_det_beta_unique,n_svd_coefs,N_states)) + do k=1,N_states + do j=1,n_svd_coefs + do i=1,N_det_beta_unique + dtmp(i,j,k) = psi_svd_beta(i,j,k) + enddo + enddo + enddo + call ezfio_set_spindeterminants_psi_svd_beta(dtmp) + deallocate(dtmp) + + allocate(dtmp(n_svd_coefs,N_states,1)) + do k=1,N_states + do j=1,n_svd_coefs + dtmp(j,k,1) = psi_svd_coefs(j,k) + enddo + enddo + call ezfio_set_spindeterminants_psi_svd_coefs(dtmp) + deallocate(dtmp) + +end + + +!==============================================================================! +! ! +! Alpha x Beta Matrix ! +! ! +!==============================================================================! + +BEGIN_PROVIDER [ double precision, psi_svd_matrix_values, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer, psi_svd_matrix_rows, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_svd_matrix_columns, (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k, l + integer(bit_kind) :: tmp_det(N_int,2) + integer :: idx + integer, external :: get_index_in_psi_det_sorted_bit + logical, external :: is_in_wavefunction + + + PROVIDE psi_coef_sorted_bit + +! l=0 +! do j=1,N_det_beta_unique +! do k=1,N_int +! tmp_det(k,2) = psi_det_beta_unique(k,j) +! enddo +! do i=1,N_det_alpha_unique +! do k=1,N_int +! tmp_det(k,1) = psi_det_alpha_unique(k,i) +! enddo +! idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) +! if (idx > 0) then +! l += 1 +! psi_svd_matrix_rows(l) = i +! psi_svd_matrix_columns(l) = j +! do k=1,N_states +! psi_svd_matrix_values(l,k) = psi_coef_sorted_bit(idx,k) +! enddo +! endif +! enddo +! enddo +! ASSERT (l == N_det) + + integer, allocatable :: iorder(:), to_sort(:) + integer, external :: get_index_in_psi_det_alpha_unique + integer, external :: get_index_in_psi_det_beta_unique + allocate(iorder(N_det), to_sort(N_det)) + do k=1,N_det + i = get_index_in_psi_det_alpha_unique(psi_det(1,1,k),N_int) + j = get_index_in_psi_det_beta_unique (psi_det(1,2,k),N_int) + do l=1,N_states + psi_svd_matrix_values(k,l) = psi_coef(k,l) + enddo + psi_svd_matrix_rows(k) = i + psi_svd_matrix_columns(k) = j + to_sort(k) = N_det_alpha_unique * (j-1) + i + iorder(k) = k + enddo + call isort(to_sort, iorder, N_det) + call iset_order(psi_svd_matrix_rows,iorder,N_det) + call iset_order(psi_svd_matrix_columns,iorder,N_det) + call dset_order(psi_svd_matrix_values,iorder,N_det) + deallocate(iorder,to_sort) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_svd_matrix, (N_det_alpha_unique,N_det_beta_unique,N_states) ] + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k,istate + psi_svd_matrix = 0.d0 + do k=1,N_det + i = psi_svd_matrix_rows(k) + j = psi_svd_matrix_columns(k) + do istate=1,N_states + psi_svd_matrix(i,j,istate) = psi_svd_matrix_values(k,istate) + enddo + enddo +END_PROVIDER + +subroutine create_wf_of_psi_svd_matrix + use bitmasks + implicit none + BEGIN_DOC +! Matrix of wf coefficients. Outer product of alpha and beta determinants + END_DOC + integer :: i,j,k + integer(bit_kind) :: tmp_det(N_int,2) + integer :: idx + integer, external :: get_index_in_psi_det_sorted_bit + logical, external :: is_in_wavefunction + double precision :: norm(N_states) + + call generate_all_alpha_beta_det_products + norm = 0.d0 + do j=1,N_det_beta_unique + do k=1,N_int + tmp_det(k,2) = psi_det_beta_unique(k,j) + enddo + do i=1,N_det_alpha_unique + do k=1,N_int + tmp_det(k,1) = psi_det_alpha_unique(k,i) + enddo + idx = get_index_in_psi_det_sorted_bit(tmp_det,N_int) + if (idx > 0) then + do k=1,N_states + psi_coef_sorted_bit(idx,k) = psi_svd_matrix(i,j,k) + norm(k) += psi_svd_matrix(i,j,k) + enddo + endif + enddo + enddo + do k=1,N_states + norm(k) = 1.d0/dsqrt(norm(k)) + do i=1,N_det + psi_coef_sorted_bit(i,k) = psi_coef_sorted_bit(i,k)*norm(k) + enddo + enddo + psi_det = psi_det_sorted_bit + psi_coef = psi_coef_sorted_bit + TOUCH psi_det psi_coef + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + norm(1) = 0.d0 + do i=1,N_det + norm(1) += psi_average_norm_contrib_sorted(i) + if (norm(1) >= 0.999999d0) then + exit + endif + enddo + N_det = min(i,N_det) + SOFT_TOUCH psi_det psi_coef N_det + +end + +subroutine generate_all_alpha_beta_det_products + implicit none + BEGIN_DOC +! Create a wave function from all possible alpha x beta determinants + END_DOC + integer :: i,j,k,l + integer :: idx, iproc + integer, external :: get_index_in_psi_det_sorted_bit + integer(bit_kind), allocatable :: tmp_det(:,:,:) + logical, external :: is_in_wavefunction + integer, external :: omp_get_thread_num + + !$OMP PARALLEL DEFAULT(NONE) SHARED(psi_coef_sorted_bit,N_det_beta_unique,& + !$OMP N_det_alpha_unique, N_int, psi_det_alpha_unique, psi_det_beta_unique,& + !$OMP N_det) & + !$OMP PRIVATE(i,j,k,l,tmp_det,idx,iproc) + !$ iproc = omp_get_thread_num() + allocate (tmp_det(N_int,2,N_det_alpha_unique)) + !$OMP DO + do j=1,N_det_beta_unique + l = 1 + do i=1,N_det_alpha_unique + do k=1,N_int + tmp_det(k,1,l) = psi_det_alpha_unique(k,i) + tmp_det(k,2,l) = psi_det_beta_unique (k,j) + enddo + if (.not.is_in_wavefunction(tmp_det(1,1,l),N_int,N_det)) then + l = l+1 + endif + enddo + call fill_H_apply_buffer_no_selection(l-1, tmp_det, N_int, iproc) + enddo + !$OMP END DO NOWAIT + deallocate(tmp_det) + !$OMP END PARALLEL + deallocate (tmp_det) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH psi_det psi_coef N_det +end + + BEGIN_PROVIDER [ double precision, psi_svd_alpha, (N_det_alpha_unique,N_det_alpha_unique,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_svd_beta , (N_det_beta_unique,N_det_beta_unique,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_svd_coefs, (N_det_beta_unique,N_states) ] + implicit none + BEGIN_DOC + ! SVD wave function + END_DOC + + integer :: lwork, info, istate + double precision, allocatable :: work(:), tmp(:,:), copy(:,:) + allocate (work(1),tmp(N_det_beta_unique,N_det_beta_unique), & + copy(size(psi_svd_matrix,1),size(psi_svd_matrix,2))) + + do istate = 1,N_states + copy(:,:) = psi_svd_matrix(:,:,istate) + lwork=-1 + call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & + copy, size(copy,1), & + psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & + size(psi_svd_alpha,1), & + tmp, size(psi_svd_beta,2), & + work, lwork, info) + lwork = work(1) + deallocate(work) + allocate(work(lwork)) + call dgesvd('A','A', N_det_alpha_unique, N_det_beta_unique, & + copy, size(copy,1), & + psi_svd_coefs(1,istate), psi_svd_alpha(1,1,istate), & + size(psi_svd_alpha,1), & + tmp, size(psi_svd_beta,2), & + work, lwork, info) + deallocate(work) + if (info /= 0) then + print *, irp_here//': error in det SVD' + stop 1 + endif + integer :: i,j + do j=1,N_det_beta_unique + do i=1,N_det_beta_unique + psi_svd_beta(i,j,istate) = tmp(j,i) + enddo + enddo + deallocate(tmp,copy) + enddo + +END_PROVIDER + + diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f new file mode 100644 index 00000000..f867ad7e --- /dev/null +++ b/src/Determinants/truncate_wf.irp.f @@ -0,0 +1,18 @@ +program cisd + implicit none + integer :: i,k + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + N_det=10000 + do i=1,N_det + do k=1,N_int + psi_det(k,1,i) = psi_det_sorted(k,1,i) + psi_det(k,2,i) = psi_det_sorted(k,2,i) + enddo + psi_coef(k,:) = psi_coef_sorted(k,:) + enddo + TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det + call save_wavefunction +end diff --git a/src/Determinants/utils.irp.f b/src/Determinants/utils.irp.f new file mode 100644 index 00000000..22faee83 --- /dev/null +++ b/src/Determinants/utils.irp.f @@ -0,0 +1,20 @@ +BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] + implicit none + BEGIN_DOC + ! H matrix on the basis of the slater determinants defined by psi_det + END_DOC + integer :: i,j + double precision :: hij + call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) + !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij) & + !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) + do i =1,N_det + do j =i,N_det + call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) + H_matrix_all_dets(i,j) = hij + H_matrix_all_dets(j,i) = hij + enddo + enddo + !$OMP END PARALLEL DO +END_PROVIDER + diff --git a/src/Output/README.rst b/src/Output/README.rst index adcae302..7b510fc1 100644 --- a/src/Output/README.rst +++ b/src/Output/README.rst @@ -32,6 +32,7 @@ Needed Modules .. NEEDED_MODULES file. * `Utils `_ +* `Ezfio_files `_ Documentation ============= diff --git a/src/Properties/EZFIO.cfg b/src/Properties/EZFIO.cfg new file mode 100644 index 00000000..d230011d --- /dev/null +++ b/src/Properties/EZFIO.cfg @@ -0,0 +1,5 @@ +[z_one_point] +type: double precision +doc: z point on which the integrated delta rho is calculated +interface: input +default: 3.9 \ No newline at end of file From fbab2d613eee25e6f611072b4fa4c978673f3ff1 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 20 Apr 2015 17:17:36 +0200 Subject: [PATCH 38/70] New version of int.f90 for big alpha but not to much --- src/MonoInts/int.f90 | 77 ++++++++++++++++++++++++++++------ src/MonoInts/pot_ao_ints.irp.f | 8 ++-- 2 files changed, 70 insertions(+), 15 deletions(-) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index c7d2ac84..750dbaa7 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -140,7 +140,7 @@ end ! __ __ _ __ ___ ___ _ _ __| | ___ ! \ \ / / | '_ \/ __|/ _ \ | | |/ _` |/ _ \ ! \ V / | |_) \__ \ __/ |_| | (_| | (_) | -! \_/ | .__/|___/\___|\__,_|\__,_|\___/ +! \_/ | .__/|___/\___|\__,_|\____|\___/ ! | | ! |_| @@ -200,7 +200,7 @@ double precision, intent(in) :: v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_ double precision :: fourpi,f,prod,prodp,binom,accu,bigR,bigI,ylm double precision :: theta_AC0,phi_AC0,theta_BC0,phi_BC0,ac,bc,big -double precision :: areal,freal,breal,t1,t2,int_prod_bessel +double precision :: areal,freal,breal,t1,t2,int_prod_bessel, int_prod_bessel_num_soph_p double precision :: arg integer :: ntot,ntotA,m,mu,mup,k1,k2,k3,ntotB,k1p,k2p,k3p,lambda,lambdap,ktot @@ -237,7 +237,7 @@ fourpi=4.d0*dacos(-1.d0) ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) bc=dsqrt((b(1)-c(1))**2+(b(2)-c(2))**2+(b(3)-c(3))**2) arg=g_a*ac**2+g_b*bc**2 -if(arg.gt.-dlog(10.d-20))then +if(arg.gt.-dlog(1.d-20))then Vpseudo=0.d0 return endif @@ -270,7 +270,9 @@ if(ac.eq.0.d0.and.bc.eq.0.d0)then do m=-l,l prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) - accu=accu+prod*prodp*v_kl(k,l)*freal*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal) + + accu=accu+prod*prodp*v_kl(k,l)*int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal,arg) + enddo enddo enddo @@ -302,8 +304,7 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then do lambdap=0,lmax+ntotB do k=1,kmax do l=0,lmax - array_R(ktot,k,l,lambda,lambdap)= freal & - *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal) + array_R(ktot,k,l,lambda,lambdap)= int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal,arg) enddo enddo enddo @@ -425,9 +426,8 @@ else if(ac.eq.0.d0.and.bc.ne.0.d0)then do k=1,kmax do l=0,lmax - array_R(ktot,k,l,0,lambdap)= freal & - *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal) - enddo + array_R(ktot,k,l,0,lambdap)= int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal,arg) + enddo enddo enddo enddo @@ -512,9 +512,7 @@ else if(ac.ne.0.d0.and.bc.eq.0.d0)then do k=1,kmax do l=0,lmax - array_R(ktot,k,l,lambda,0)= freal & - *int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal) - + array_R(ktot,k,l,lambda,0)= int_prod_bessel_num_soph_p(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal,arg) enddo enddo enddo @@ -1974,6 +1972,61 @@ end stop 'pb in int_prod_bessel!!' end + +double precision function int_prod_bessel_num_soph_p(l,gam,n,m,a,b,arg) + implicit none + integer :: n,m,l + double precision :: gam,a,b,arg,arg_new + double precision :: bessel_mod,factor + logical :: not_done + double precision :: bigA,xold,x,dx,accu,intnew,intold,intold2,u,v,freal + integer :: iter, i, nI, n0 + double precision :: eps + + u=(a+b)/(2.d0*dsqrt(gam)) + arg_new=u**2-arg + freal=dexp(arg_new) + v=u/dsqrt(gam) + + bigA=v+dsqrt(-dlog(1.d-15)/gam) + n0=5 + accu=0.d0 + dx=bigA/(float(n0)-1.d0) + iter=0 + do i=1,n0 + x=(float(i)-1.d0)*dx + accu=accu+x**l*dexp(-gam*(x-v)**2)*bessel_mod(a*x,n)*bessel_mod(b*x,m)*dexp(-(a+b)*x) + enddo + +accu=accu*freal +intold=accu*dx + +eps=1.d-08 +nI=n0-1 +dx=dx/2.d0 +not_done=.true. + +do while(not_done) + iter=iter+1 + accu=0.d0 + do i=1,nI + x=dx+(float(i)-1.d0)*2.d0*dx + accu=accu+dx*x**l*dexp(-gam*(x-v)**2)*bessel_mod(a*x,n)*bessel_mod(b*x,m)*dexp(-(a+b)*x) + enddo + accu=accu*freal + intnew=intold/2.d0+accu + if(iter.gt.1.and.dabs(intnew-intold).lt.eps.and.dabs(intnew-intold2).lt.eps)then + not_done=.false. + else + intold2=intold + intold=intnew + dx=dx/2.d0 + nI=2*nI + endif +enddo +int_prod_bessel_num_soph_p=intold +end + !! Calculation of !! !! I= \int dx x**l *exp(-gam*x**2) M_n(ax) diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index ef2e8c8f..badf4afd 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -156,7 +156,7 @@ c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) +! c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) n_kl_dump = n_kl(k,1:kmax,0:lmax) @@ -167,7 +167,7 @@ ! print*, "kmax",kmax ! print*, "v_kl",v_kl_dump ! print*, "n_kl",n_kl_dump -! print*, n_kl_dump(1,0) +! print*, n_kl_ump(1,0) ! print*, n_kl_dump(1,1) ! print*, "dz_kl",dz_kl_dump ! print*, dz_kl_dump(1,0) @@ -180,7 +180,9 @@ ! print*, "beta", beta ! print*, "C_center",C_center - ! c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + dump = Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + print*, dump ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) ! print*, "#################" From cda3a5ee9c969e5d735ce0f3a6123543a47107f7 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 21 Apr 2015 15:05:39 +0200 Subject: [PATCH 39/70] Working ! --- scripts/get_basis.sh | 2 +- scripts/pseudo/put_pseudo_in_ezfio.py | 1 - src/MonoInts/README.rst | 22 +- src/MonoInts/int.f90 | 4 +- src/MonoInts/pot_ao_ints.irp.f | 303 +++++++++++++++----------- src/MonoInts/pseudo.ezfio_config | 3 +- 6 files changed, 188 insertions(+), 147 deletions(-) diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index 9f959110..7cfe8305 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -47,4 +47,4 @@ fi #${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" -${EMSL_API_ROOT}/EMSL_api.py get_basis_data --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" +${EMSL_API_ROOT}/EMSL_api.py get_basis_data --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" \ No newline at end of file diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 53170271..0ba71b0c 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -253,7 +253,6 @@ if __name__ == "__main__": alpha_tot += alpha beta_tot += beta l_zeff.append(zeff) - # _ # /\ _| _| _|_ _ _ _ _|_ o _ # /--\ (_| (_| |_ (_) (/_ /_ | | (_) diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index ec92eada..69da98ed 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -102,38 +102,38 @@ Documentation `ao_nucl_elec_integral `_ interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented `mo_nucl_elec_integral `_ diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index 750dbaa7..31b51c51 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -188,9 +188,9 @@ double precision, intent(in) :: a(3),g_a,b(3),g_b,c(3) integer kmax_max,lmax_max,ntot_max,nkl_max parameter (kmax_max=2,lmax_max=2,nkl_max=4) parameter (ntot_max=10) -integer, intent(in) :: lmax,kmax,n_kl(kmax_max,0:lmax_max) +integer, intent(in) :: lmax,kmax,n_kl(kmax,0:lmax) integer, intent(in) :: n_a(3),n_b(3) -double precision, intent(in) :: v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) +double precision, intent(in) :: v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) ! diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index badf4afd..065785c2 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -4,21 +4,93 @@ END_DOC implicit none double precision :: alpha, beta, gama, delta - integer :: i_c,num_A,num_B - double precision :: A_center(3),B_center(3),C_center(3) - integer :: power_A(3),power_B(3) - integer :: i,j,k,l,n_pt_in,m - double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult, Vloc, Vpseudo, Vpseudo_num - double precision :: dump - integer :: nucl_numC - ! Important for OpenMP + integer :: num_A,num_B + double precision :: A_center(3),B_center(3),C_center(3) + integer :: power_A(3),power_B(3) + integer :: i,j,k,l,n_pt_in,m + double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult - ao_nucl_elec_integral = 0.d0 + ao_nucl_elec_integral = ao_nucl_elec_integral_pseudo ! 0.d0 + + ! _ + ! /| / |_) + ! | / | \ + ! + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & + !$OMP num_A,num_B,Z,c,n_pt_in) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & + !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) + + n_pt_in = n_pt_max_integrals + + !$OMP DO SCHEDULE (guided) + + do j = 1, ao_num + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_transp(l,j) + + do m=1,ao_prim_num(i) + beta = ao_expo_transp(m,i) + + double precision :: c + c = 0.d0 + + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) + + enddo + ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) + & + ao_coef_transp(l,j)*ao_coef_transp(m,i)*c + enddo + enddo + enddo + enddo + + !$OMP END DO + !$OMP END PARALLEL + + END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral_pseudo, (ao_num_align,ao_num)] + BEGIN_DOC +! interaction nuclear electron + END_DOC + implicit none + double precision :: alpha, beta, gama, delta + integer :: num_A,num_B + double precision :: A_center(3),B_center(3),C_center(3) + integer :: power_A(3),power_B(3) + integer :: i,j,k,l,n_pt_in,m + double precision :: Vloc, Vpseudo + + double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 + integer :: thread_num + + ao_nucl_elec_integral_pseudo = 0.d0 ! ! | _ _ _. | ! |_ (_) (_ (_| | ! + !! Parameters of the local part of pseudo: integer klocmax integer, allocatable :: n_k(:,:) @@ -32,43 +104,22 @@ call ezfio_get_pseudo_n_k(n_k) call ezfio_get_pseudo_dz_k(dz_k) -! klocmax = 3 -! -! integer :: n_k(3) -! double precision :: v_k(3), dz_k(3) -! -! v_k(1) = 1.00000000d0 -! v_k(2) = 5.35838717 -! v_k(3) = -2.07764789 -! -! n_k(1) = -1 -! n_k(2) = 1 -! n_k(3) = 0 -! -! dz_k(1) = 5.35838717 -! dz_k(2) = 3.67918975 -! dz_k(3) = 1.60507673 - print*, "=======================" - print*, "=======================" - print*, "=======================" + !! Dump array + integer, allocatable :: n_k_dump(:) + double precision, allocatable :: v_k_dump(:), dz_k_dump(:) + + allocate(n_k_dump(1:klocmax), v_k_dump(1:klocmax), dz_k_dump(1:klocmax)) - print*, "nucl_num", nucl_num - print*, "klocmax", klocmax - - print*, "n_k_ezfio", n_k - print*, "v_k_ezfio",v_k - print*, "dz_k_ezfio", dz_k ! ! |\ | _ ._ | _ _ _. | ! | \| (_) | | | (_) (_ (_| | ! - !! Parameters of non local part of pseudo: - integer :: kmax,lmax - integer, allocatable :: n_kl(:,:,:) - double precision, allocatable :: v_kl(:,:,:), dz_kl(:,:,:) + integer :: kmax,lmax + integer, allocatable :: n_kl(:,:,:) + double precision, allocatable :: v_kl(:,:,:), dz_kl(:,:,:) call ezfio_get_pseudo_lmaxpo(lmax) call ezfio_get_pseudo_kmax(kmax) @@ -81,55 +132,43 @@ call ezfio_get_pseudo_v_kl(v_kl) call ezfio_get_pseudo_dz_kl(dz_kl) - print*, "kmax", kmax - print*, "lmax",lmax - - print*,"n_kl_ezfio", n_kl - print*,"v_kl_ezfio", v_kl - print*,"dz_kl_ezfio", dz_kl - - print*, "=======================" - print*, "=======================" - print*, "=======================" - - -! lmax = 1 -! kmax = 1 - -! integer :: n_kl(1,0:1) -! double precision :: v_kl(1,0:1), dz_kl(1,0:1) - -! v_kl(1,0) =10.69640234 -! n_kl(1,0) = 0 -! dz_kl(1,0) = 1.32389367 -! -! v_kl(1,1) = 10.11238853 -! n_kl(1,1) = 0 -! dz_kl(1,1) = 1.14052020 -! -! print*, "kmax", kmax -! print*, "lmax",lmax -! -! print*,"n_kl_ezfio", n_kl -! print*,"v_kl_ezfio", v_kl -! print*,"dz_kl_ezfio", dz_kl - + !! Dump array integer, allocatable :: n_kl_dump(:,:) double precision, allocatable :: v_kl_dump(:,:), dz_kl_dump(:,:) allocate(n_kl_dump(kmax,0:lmax), v_kl_dump(kmax,0:lmax), dz_kl_dump(kmax,0:lmax)) + ! _ + ! / _. | _ | + ! \_ (_| | (_ |_| | + ! - n_pt_in = n_pt_max_integrals - do j = 1, ao_num + write(output_monoints,*) 'Providing the nuclear electron pseudo integrals ' - num_A = ao_nucl(j) - power_A(1:3)= ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) + call wall_time(wall_1) + call cpu_time(cpu_1) - print*, "J", j, "/", ao_num - print*,"===================" + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & + !$OMP num_A,num_B,Z,c,n_pt_in, & + !$OMP v_k_dump,n_k_dump, dz_k_dump, n_kl_dump, v_kl_dump, dz_kl_dump, & + !$OMP wall_0,wall_2,thread_num, output_monoints) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & + !$OMP n_pt_max_integrals,ao_nucl_elec_integral_pseudo,nucl_num,nucl_charge, & + !$OMP klocmax,lmax,kmax,v_k,n_k, dz_k, n_kl, v_kl, dz_kl, & + !$OMP wall_1) + + n_pt_in = n_pt_max_integrals + + !$OMP DO SCHEDULE (guided) + + do j = 1, ao_num + + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) do i = 1, ao_num @@ -137,63 +176,66 @@ power_B(1:3)= ao_power(i,1:3) B_center(1:3) = nucl_coord(num_B,1:3) - - print*, "i", i, "/", ao_num - - do l=1,ao_prim_num(j) - alpha = ao_expo_transp(l,j) - + do l=1,ao_prim_num(j) + alpha = ao_expo_transp(l,j) + do m=1,ao_prim_num(i) - beta = ao_expo_transp(m,i) + beta = ao_expo_transp(m,i) + double precision :: c + c = 0.d0 + + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + v_k_dump = v_k(k,1:klocmax) + n_k_dump = n_k(k,1:klocmax) + dz_k_dump = dz_k(k,1:klocmax) - double precision :: c - c = 0.d0 - do k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) + c = c + Vloc(klocmax, v_k_dump,n_k_dump, dz_k_dump, & + A_center,power_A,alpha,B_center,power_B,beta,C_center) + - C_center(1:3) = nucl_coord(k,1:3) - - c = c - Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) - -! c = c + Vloc( klocmax ,v_k(k,:) ,n_k(k,:) ,dz_k(k,:), A_center,power_A,alpha,B_center,power_B,beta,C_center) - - - n_kl_dump = n_kl(k,1:kmax,0:lmax) - v_kl_dump = v_kl(k,1:kmax,0:lmax) - dz_kl_dump = dz_kl(k,1:kmax,0:lmax) - -! print*, "lmax",lmax -! print*, "kmax",kmax -! print*, "v_kl",v_kl_dump -! print*, "n_kl",n_kl_dump -! print*, n_kl_ump(1,0) -! print*, n_kl_dump(1,1) -! print*, "dz_kl",dz_kl_dump -! print*, dz_kl_dump(1,0) -! print*, dz_kl_dump(1,1) -! print*, "A_center", A_center -! print*, "power_A",power_A -! print*, "alpha", alpha -! print*, "B_center", B_center -! print*, "power_B", power_B -! print*, "beta", beta -! print*, "C_center",C_center - - c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) - dump = Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) - print*, dump - ! c = c - Vps(A_center,power_A,alpha,B_center,power_B,beta,C_center,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) - -! print*, "#################" -! print*, "#################" + n_kl_dump = n_kl(k,1:kmax,0:lmax) + v_kl_dump = v_kl(k,1:kmax,0:lmax) + dz_kl_dump = dz_kl(k,1:kmax,0:lmax) + + c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + + enddo + ao_nucl_elec_integral_pseudo(i,j) = ao_nucl_elec_integral_pseudo(i,j) + & + ao_coef_transp(l,j)*ao_coef_transp(m,i)*c + enddo enddo - ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) + & - ao_coef_transp(l,j)*ao_coef_transp(m,i)*c - enddo - enddo enddo - enddo + + call wall_time(wall_2) + if (thread_num == 0) then + if (wall_2 - wall_0 > 1.d0) then + wall_0 = wall_2 + write(output_monoints,*) 100.*float(j)/float(ao_num), '% in ', & + wall_2-wall_1, 's' + endif + endif + enddo + + !$OMP END DO + !$OMP END PARALLEL + + +! _ +! | \ _ _. | | _ _ _. _|_ _ +! |_/ (/_ (_| | | (_) (_ (_| |_ (/_ +! + + deallocate(n_k,v_k, dz_k) + deallocate(n_k_dump,v_k_dump, dz_k_dump) + + deallocate(n_kl,v_kl, dz_kl) + deallocate(n_kl_dump,v_kl_dump, dz_kl_dump) + END_PROVIDER @@ -210,7 +252,6 @@ END_PROVIDER integer :: power_A(3),power_B(3) integer :: i,j,k,l,n_pt_in,m double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult - integer :: nucl_numC ! Important for OpenMP ao_nucl_elec_integral_per_atom = 0.d0 diff --git a/src/MonoInts/pseudo.ezfio_config b/src/MonoInts/pseudo.ezfio_config index 97f9e1be..db0da938 100644 --- a/src/MonoInts/pseudo.ezfio_config +++ b/src/MonoInts/pseudo.ezfio_config @@ -1,4 +1,5 @@ pseudo + do_pseudo logical klocmax integer v_k double precision (nuclei_nucl_num,pseudo_klocmax) n_k integer (nuclei_nucl_num,pseudo_klocmax) @@ -7,4 +8,4 @@ pseudo kmax integer v_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) n_kl integer (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) - dz_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) \ No newline at end of file + dz_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) From 14d59648af826ab7ec2c938cd3e52efcaf0a823a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 24 Apr 2015 21:45:18 +0200 Subject: [PATCH 40/70] Changed ao_coef to ao_coef_normalized_ordered --- ocaml/.merlin | 4 + src/AOs/ASSUMPTIONS.rst | 7 - src/AOs/README.rst | 90 +++---- src/AOs/ao_overlap.irp.f | 20 +- src/AOs/aos.irp.f | 299 +++++++++++---------- src/Bielec_integrals/ao_bi_integrals.irp.f | 58 ++-- src/Dets/H_apply.irp.f | 35 +++ src/Dets/README.rst | 5 +- src/Dets/diagonalize_CI_SC2.irp.f | 3 +- src/Dets/filter_connected.irp.f | 4 +- src/Dets/save_for_casino.irp.f | 2 +- src/MOs/ASSUMPTIONS.rst | 4 + src/MOs/README.rst | 2 + src/Molden/print_mo.irp.f | 4 +- src/MonoInts/kin_ao_ints.irp.f | 10 +- src/MonoInts/pot_ao_ints.irp.f | 16 +- src/MonoInts/spread_dipole_ao.irp.f | 30 +-- src/Properties/delta_rho.irp.f | 16 +- 18 files changed, 323 insertions(+), 286 deletions(-) create mode 100644 ocaml/.merlin diff --git a/ocaml/.merlin b/ocaml/.merlin new file mode 100644 index 00000000..3683fed6 --- /dev/null +++ b/ocaml/.merlin @@ -0,0 +1,4 @@ +PKG core ZMQ cryptokit +B _build/ + + diff --git a/src/AOs/ASSUMPTIONS.rst b/src/AOs/ASSUMPTIONS.rst index 0c8e0ccc..cede1de9 100644 --- a/src/AOs/ASSUMPTIONS.rst +++ b/src/AOs/ASSUMPTIONS.rst @@ -1,8 +1 @@ -* The atomic orbitals are normalized: - - .. math:: - - \int \left(\chi_i({\bf r}) \right)^2 dr = 1 - * The AO coefficients in the EZFIO files are not necessarily normalized and are normalized after reading -* The AO coefficients and exponents are ordered in increasing order of exponents diff --git a/src/AOs/README.rst b/src/AOs/README.rst index f9f81f5f..5978e16f 100644 --- a/src/AOs/README.rst +++ b/src/AOs/README.rst @@ -17,21 +17,19 @@ The AO coefficients are normalized as: {\tilde c}_{ki} = \frac{c_{ki}}{ \int \left( (x-X_A)^a (y-Y_A)^b (z-Z_A)^c e^{-\gamma_{ki} |{\bf r} - {\bf R}_A|^2} \right)^2} dr +Warning: ``ao_coef`` contains the AO coefficients given in input. These do not +include the normalization constant of the AO. The ``ao_coef_normalized`` includes +this normalization factor. + +The AOs are also sorted by increasing exponent to accelerate the calculation of +the two electron integrals. + Assumptions =========== .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* The atomic orbitals are normalized: - - .. math:: - - \int \left(\chi_i({\bf r}) \right)^2 dr = 1 - -* The AO coefficients in the EZFIO files are not necessarily normalized and are normalized after reading -* The AO coefficients and exponents are ordered in increasing order of exponents - Needed Modules ============== @@ -70,45 +68,41 @@ Documentation Overlap between atomic basis functions: :math:`\int \chi_i(r) \chi_j(r) dr)` -`ao_coef `_ - Coefficients, exponents and powers of x,y and z +`ao_coef `_ + AO Coefficients, read from input. Those should not be used directly, as + the MOs are expressed on the basis of **normalized** AOs. -`ao_coef_transp `_ - Transposed ao_coef and ao_expo +`ao_coef_normalized `_ + Coefficients including the AO normalization -`ao_coef_unnormalized `_ - Coefficients, exponents and powers of x,y and z as in the EZFIO file - ao_coef(i,j) = coefficient of the jth primitive on the ith ao +`ao_coef_normalized_ordered `_ + Sorted primitives to accelerate 4 index MO transformation + +`ao_coef_normalized_ordered_transp `_ + Transposed ao_coef_normalized_ordered + +`ao_expo `_ + AO Exponents read from input + +`ao_expo_ordered `_ + Sorted primitives to accelerate 4 index MO transformation + +`ao_expo_ordered_transp `_ + Transposed ao_expo_ordered + +`ao_l `_ ao_l = l value of the AO: a+b+c in x^a y^b z^c -`ao_expo `_ - Coefficients, exponents and powers of x,y and z - -`ao_expo_transp `_ - Transposed ao_coef and ao_expo - -`ao_expo_unsorted `_ - Coefficients, exponents and powers of x,y and z as in the EZFIO file - ao_coef(i,j) = coefficient of the jth primitive on the ith ao +`ao_l_char `_ ao_l = l value of the AO: a+b+c in x^a y^b z^c -`ao_l `_ - Coefficients, exponents and powers of x,y and z as in the EZFIO file - ao_coef(i,j) = coefficient of the jth primitive on the ith ao - ao_l = l value of the AO: a+b+c in x^a y^b z^c - -`ao_l_char `_ - Coefficients, exponents and powers of x,y and z as in the EZFIO file - ao_coef(i,j) = coefficient of the jth primitive on the ith ao - ao_l = l value of the AO: a+b+c in x^a y^b z^c - -`ao_l_char_space `_ +`ao_l_char_space `_ Undocumented -`ao_md5 `_ +`ao_md5 `_ MD5 key characteristic of the AO basis -`ao_nucl `_ +`ao_nucl `_ Index of the nuclei on which the ao is centered `ao_num `_ @@ -118,35 +112,35 @@ Documentation Number of atomic orbitals `ao_power `_ - Coefficients, exponents and powers of x,y and z + Powers of x,y and z read from input -`ao_prim_num `_ +`ao_prim_num `_ Number of primitives per atomic orbital -`ao_prim_num_max `_ +`ao_prim_num_max `_ Undocumented -`ao_prim_num_max_align `_ +`ao_prim_num_max_align `_ Undocumented -`l_to_charater `_ +`l_to_charater `_ character corresponding to the "L" value of an AO orbital -`n_aos_max `_ +`n_aos_max `_ Number of AOs per atom -`nucl_aos `_ +`nucl_aos `_ List of AOs attached on each atom -`nucl_list_shell_aos `_ +`nucl_list_shell_aos `_ Index of the shell type Aos and of the corresponding Aos Per convention, for P,D,F and G AOs, we take the index of the AO with the the corresponding power in the "X" axis -`nucl_n_aos `_ +`nucl_n_aos `_ Number of AOs per atom -`nucl_num_shell_aos `_ +`nucl_num_shell_aos `_ Index of the shell type Aos and of the corresponding Aos Per convention, for P,D,F and G AOs, we take the index of the AO with the the corresponding power in the "X" axis diff --git a/src/AOs/ao_overlap.irp.f b/src/AOs/ao_overlap.irp.f index f77924d3..737f03f7 100644 --- a/src/AOs/ao_overlap.irp.f +++ b/src/AOs/ao_overlap.irp.f @@ -21,8 +21,8 @@ !$OMP overlap_x,overlap_y, overlap_z, overlap, & !$OMP alpha, beta,i,j,c) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_transp,ao_nucl, & - !$OMP ao_expo_transp,dim1) + !$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) A_center(2) = nucl_coord( ao_nucl(j), 2 ) @@ -44,12 +44,12 @@ power_B(2) = ao_power( i, 2 ) power_B(3) = ao_power( i, 3 ) do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) !DEC$ VECTOR ALIGNED do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) - c = ao_coef_transp(n,j) * ao_coef_transp(l,i) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) ao_overlap(i,j) += c * overlap ao_overlap_x(i,j) += c * overlap_x ao_overlap_y(i,j) += c * overlap_y @@ -84,8 +84,8 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num_align,ao_num) ] !$OMP overlap_x,overlap_y, overlap_z, overlap, & !$OMP alpha, beta,i,j,dx) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_overlap_abs,ao_num,ao_coef_transp,ao_nucl, & - !$OMP ao_expo_transp,dim1,lower_exp_val) + !$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1,lower_exp_val) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) A_center(2) = nucl_coord( ao_nucl(j), 2 ) @@ -104,14 +104,14 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num_align,ao_num) ] power_B(2) = ao_power( i, 2 ) power_B(3) = ao_power( i, 3 ) do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) !DEC$ VECTOR ALIGNED do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_x_abs(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),overlap_x,lower_exp_val,dx,dim1) call overlap_x_abs(A_center(2),B_center(2),alpha,beta,power_A(2),power_B(2),overlap_y,lower_exp_val,dx,dim1) call overlap_x_abs(A_center(3),B_center(3),alpha,beta,power_A(3),power_B(3),overlap_z,lower_exp_val,dx,dim1) - ao_overlap_abs(i,j) += abs(ao_coef_transp(n,j) * ao_coef_transp(l,i)) * overlap_x * overlap_y * overlap_z + ao_overlap_abs(i,j) += abs(ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)) * overlap_x * overlap_y * overlap_z enddo enddo enddo diff --git a/src/AOs/aos.irp.f b/src/AOs/aos.irp.f index c75694fb..b9c82327 100644 --- a/src/AOs/aos.irp.f +++ b/src/AOs/aos.irp.f @@ -1,152 +1,171 @@ BEGIN_PROVIDER [ integer, ao_num ] &BEGIN_PROVIDER [ integer, ao_num_align ] - implicit none - - BEGIN_DOC -! Number of atomic orbitals - END_DOC - - ao_num = -1 - PROVIDE ezfio_filename - call ezfio_get_ao_basis_ao_num(ao_num) - if (ao_num <= 0) then - stop 'Number of contracted gaussians should be > 0' - endif - integer :: align_double - ao_num_align = align_double(ao_num) + implicit none + + BEGIN_DOC + ! Number of atomic orbitals + END_DOC + + ao_num = -1 + PROVIDE ezfio_filename + call ezfio_get_ao_basis_ao_num(ao_num) + if (ao_num <= 0) then + stop 'Number of contracted gaussians should be > 0' + endif + integer :: align_double + ao_num_align = align_double(ao_num) +END_PROVIDER + +BEGIN_PROVIDER [ integer, ao_power, (ao_num_align,3) ] + implicit none + BEGIN_DOC + ! Powers of x,y and z read from input + END_DOC + PROVIDE ezfio_filename + + integer :: i,j,k + integer, allocatable :: ibuffer(:,:) + allocate ( ibuffer(ao_num,3) ) + ibuffer = 0 + call ezfio_get_ao_basis_ao_power(ibuffer) + ao_power = 0 + do j = 1, 3 + do i = 1, ao_num + ao_power(i,j) = ibuffer(i,j) + enddo + enddo + deallocate(ibuffer) + END_PROVIDER - BEGIN_PROVIDER [ integer, ao_power, (ao_num_align,3) ] -&BEGIN_PROVIDER [ double precision, ao_expo, (ao_num_align,ao_prim_num_max) ] -&BEGIN_PROVIDER [ double precision, ao_coef, (ao_num_align,ao_prim_num_max) ] - implicit none - - BEGIN_DOC -! Coefficients, exponents and powers of x,y and z - END_DOC - PROVIDE ezfio_filename - - double precision, allocatable :: buffer(:,:) - allocate ( buffer(ao_num,ao_prim_num_max) ) - integer :: ibuffer(ao_num,3) - integer :: i,j,k - character*(128) :: give_ao_character_space - ibuffer = 0 - call ezfio_get_ao_basis_ao_power(ibuffer) - ao_power = 0 - do j = 1, 3 - do i = 1, ao_num - ao_power(i,j) = ibuffer(i,j) +BEGIN_PROVIDER [ double precision, ao_expo, (ao_num_align,ao_prim_num_max) ] + implicit none + BEGIN_DOC + ! AO Exponents read from input + END_DOC + PROVIDE ezfio_filename + + double precision, allocatable :: buffer(:,:) + allocate ( buffer(ao_num,ao_prim_num_max) ) + integer :: i,j,k + ao_expo = 0.d0 + buffer = 0.d0 + call ezfio_get_ao_basis_ao_expo(buffer) + do j = 1, ao_prim_num_max + do i = 1, ao_num + ao_expo(i,j) = buffer(i,j) + enddo enddo - enddo - ao_expo = 0.d0 - buffer = 0.d0 - call ezfio_get_ao_basis_ao_expo(buffer) - do j = 1, ao_prim_num_max - do i = 1, ao_num - ao_expo(i,j) = buffer(i,j) - enddo - enddo + deallocate(buffer) +END_PROVIDER - ao_coef = 0.d0 - buffer = 0.d0 - call ezfio_get_ao_basis_ao_coef(buffer) - do j = 1, ao_prim_num_max - do i = 1, ao_num - ao_coef(i,j) = buffer(i,j) +BEGIN_PROVIDER [ double precision, ao_coef, (ao_num_align,ao_prim_num_max) ] + implicit none + BEGIN_DOC + ! AO Coefficients, read from input. Those should not be used directly, as + ! the MOs are expressed on the basis of **normalized** AOs. + END_DOC + PROVIDE ezfio_filename + + double precision, allocatable :: buffer(:,:) + allocate ( buffer(ao_num,ao_prim_num_max) ) + integer :: i,j,k + ao_coef = 0.d0 + buffer = 0.d0 + call ezfio_get_ao_basis_ao_coef(buffer) + do j = 1, ao_prim_num_max + do i = 1, ao_num + ao_coef(i,j) = buffer(i,j) + enddo enddo - enddo + deallocate(buffer) +END_PROVIDER - deallocate(buffer) +BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num_align,ao_prim_num_max) ] + implicit none + BEGIN_DOC + ! Coefficients including the AO normalization + END_DOC + double precision :: norm, norm2,overlap_x,overlap_y,overlap_z,C_A(3) + integer :: l, powA(3), nz + integer :: i,j + nz=100 + C_A(1) = 0.d0 + C_A(2) = 0.d0 + C_A(3) = 0.d0 + do i=1,ao_num + powA(1) = ao_power(i,1) + powA(2) = ao_power(i,2) + powA(3) = ao_power(i,3) + do j=1,ao_prim_num(i) + call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j),powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) + ao_coef_normalized(i,j) = ao_coef(i,j)/sqrt(norm) + enddo + enddo +END_PROVIDER -! Normalization of the AO coefficients -! ------------------------------------ - double precision :: norm, norm2,overlap_x,overlap_y,overlap_z,C_A(3) - integer :: l, powA(3), nz - nz=100 - C_A(1) = 0.d0 - C_A(2) = 0.d0 - C_A(3) = 0.d0 - do i=1,ao_num - powA(1) = ao_power(i,1) - powA(2) = ao_power(i,2) - powA(3) = ao_power(i,3) - do j=1,ao_prim_num(i) - call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j),powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) - ao_coef(i,j) = ao_coef(i,j)/sqrt(norm) - enddo - enddo - - ! Sorting of the exponents for efficient integral calculations - integer :: iorder(ao_prim_num_max) - double precision :: d(ao_prim_num_max,2) - do i=1,ao_num - do j=1,ao_prim_num(i) - iorder(j) = j - d(j,1) = ao_expo(i,j) - d(j,2) = ao_coef(i,j) - enddo - call dsort(d(1,1),iorder,ao_prim_num(i)) - call dset_order(d(1,2),iorder,ao_prim_num(i)) - do j=1,ao_prim_num(i) - ao_expo(i,j) = d(j,1) - ao_coef(i,j) = d(j,2) - enddo - enddo + BEGIN_PROVIDER [ double precision, ao_coef_normalized_ordered, (ao_num_align,ao_prim_num_max) ] +&BEGIN_PROVIDER [ double precision, ao_expo_ordered, (ao_num_align,ao_prim_num_max) ] + implicit none + BEGIN_DOC + ! Sorted primitives to accelerate 4 index MO transformation + END_DOC + + integer :: iorder(ao_prim_num_max) + double precision :: d(ao_prim_num_max,2) + integer :: i,j + do i=1,ao_num + do j=1,ao_prim_num(i) + iorder(j) = j + d(j,1) = ao_expo(i,j) + d(j,2) = ao_coef_normalized(i,j) + enddo + call dsort(d(1,1),iorder,ao_prim_num(i)) + call dset_order(d(1,2),iorder,ao_prim_num(i)) + do j=1,ao_prim_num(i) + ao_expo_ordered(i,j) = d(j,1) + ao_coef_normalized_ordered(i,j) = d(j,2) + enddo + enddo END_PROVIDER - BEGIN_PROVIDER [ double precision, ao_coef_transp, (ao_prim_num_max_align,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_expo_transp, (ao_prim_num_max_align,ao_num) ] - implicit none - BEGIN_DOC -! Transposed ao_coef and ao_expo - END_DOC - integer :: i,j - do j=1, ao_num - do i=1, ao_prim_num_max - ao_coef_transp(i,j) = ao_coef(j,i) - ao_expo_transp(i,j) = ao_expo(j,i) +BEGIN_PROVIDER [ double precision, ao_coef_normalized_ordered_transp, (ao_prim_num_max_align,ao_num) ] + implicit none + BEGIN_DOC + ! Transposed ao_coef_normalized_ordered + END_DOC + integer :: i,j + do j=1, ao_num + do i=1, ao_prim_num_max + ao_coef_normalized_ordered_transp(i,j) = ao_coef_normalized_ordered(j,i) + enddo enddo - enddo - - + END_PROVIDER - BEGIN_PROVIDER [ double precision, ao_coef_unnormalized, (ao_num_align,ao_prim_num_max) ] -&BEGIN_PROVIDER [ double precision, ao_expo_unsorted, (ao_num_align,ao_prim_num_max) ] -&BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] +BEGIN_PROVIDER [ double precision, ao_expo_ordered_transp, (ao_prim_num_max_align,ao_num) ] + implicit none + BEGIN_DOC + ! Transposed ao_expo_ordered + END_DOC + integer :: i,j + do j=1, ao_num + do i=1, ao_prim_num_max + ao_expo_ordered_transp(i,j) = ao_expo_ordered(j,i) + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] &BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ] implicit none - BEGIN_DOC -! Coefficients, exponents and powers of x,y and z as in the EZFIO file -! ao_coef(i,j) = coefficient of the jth primitive on the ith ao ! ao_l = l value of the AO: a+b+c in x^a y^b z^c END_DOC - PROVIDE ezfio_filename - - double precision, allocatable :: buffer(:,:) - allocate ( buffer(ao_num,ao_prim_num_max) ) - integer :: i,j,k - character*(128) :: give_ao_character_space - buffer = 0.d0 - call ezfio_get_ao_basis_ao_expo(buffer) - do j = 1, ao_prim_num_max - do i = 1, ao_num - ao_expo_unsorted(i,j) = buffer(i,j) - enddo - enddo - - buffer = 0.d0 - call ezfio_get_ao_basis_ao_coef(buffer) - do j = 1, ao_prim_num_max - do i = 1, ao_num - ao_coef_unnormalized(i,j) = buffer(i,j) - enddo - enddo - deallocate(buffer) - + integer :: i do i=1,ao_num ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) ao_l_char(i) = l_to_charater(ao_l(i)) @@ -154,23 +173,6 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ double precision, ao_coef_transp, (ao_prim_num_max_align,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_expo_transp, (ao_prim_num_max_align,ao_num) ] - implicit none - BEGIN_DOC -! Transposed ao_coef and ao_expo - END_DOC - integer :: i,j - do j=1, ao_num - do i=1, ao_prim_num_max - ao_coef_transp(i,j) = ao_coef(j,i) - ao_expo_transp(i,j) = ao_expo(j,i) - enddo - enddo - - -END_PROVIDER - BEGIN_PROVIDER [ integer, ao_prim_num, (ao_num_align) ] implicit none @@ -303,10 +305,10 @@ END_PROVIDER enddo enddo - END_PROVIDER +END_PROVIDER - BEGIN_PROVIDER [ character*(4), ao_l_char_space, (ao_num) ] +BEGIN_PROVIDER [ character*(4), ao_l_char_space, (ao_num) ] implicit none integer :: i character*(4) :: give_ao_character_space @@ -397,6 +399,7 @@ END_PROVIDER ao_l_char_space(i) = give_ao_character_space enddo END_PROVIDER + BEGIN_PROVIDER [ character*(32), ao_md5 ] BEGIN_DOC ! MD5 key characteristic of the AO basis diff --git a/src/Bielec_integrals/ao_bi_integrals.irp.f b/src/Bielec_integrals/ao_bi_integrals.irp.f index 0da76021..17cf4afc 100644 --- a/src/Bielec_integrals/ao_bi_integrals.irp.f +++ b/src/Bielec_integrals/ao_bi_integrals.irp.f @@ -42,24 +42,24 @@ double precision function ao_bielec_integral(i,j,k,l) do p = 1, ao_prim_num(i) double precision :: coef1 - coef1 = ao_coef_transp(p,i) + coef1 = ao_coef_normalized_ordered_transp(p,i) do q = 1, ao_prim_num(j) double precision :: coef2 - coef2 = coef1*ao_coef_transp(q,j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) double precision :: p_inv,q_inv call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_transp(p,i),ao_expo_transp(q,j), & + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & I_power,J_power,I_center,J_center,dim1) p_inv = 1.d0/pp do r = 1, ao_prim_num(k) double precision :: coef3 - coef3 = coef2*ao_coef_transp(r,k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) do s = 1, ao_prim_num(l) double precision :: coef4 - coef4 = coef3*ao_coef_transp(s,l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) double precision :: general_primitive_integral call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_transp(r,k),ao_expo_transp(s,l), & + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & K_power,L_power,K_center,L_center,dim1) q_inv = 1.d0/qq integral = general_primitive_integral(dim1, & @@ -82,15 +82,15 @@ double precision function ao_bielec_integral(i,j,k,l) double precision :: ERI do p = 1, ao_prim_num(i) - coef1 = ao_coef_transp(p,i) + coef1 = ao_coef_normalized_ordered_transp(p,i) do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_transp(q,j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_transp(r,k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_transp(s,l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) integral = ERI( & - ao_expo_transp(p,i),ao_expo_transp(q,j),ao_expo_transp(r,k),ao_expo_transp(s,l),& + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& I_power(1),J_power(1),K_power(1),L_power(1), & I_power(2),J_power(2),K_power(2),L_power(2), & I_power(3),J_power(3),K_power(3),L_power(3)) @@ -149,12 +149,12 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) schwartz_kl(0,0) = 0.d0 do r = 1, ao_prim_num(k) - coef1 = ao_coef_transp(r,k)*ao_coef_transp(r,k) + coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) schwartz_kl(0,r) = 0.d0 do s = 1, ao_prim_num(l) - coef2 = coef1 * ao_coef_transp(s,l) * ao_coef_transp(s,l) + coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l) call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_transp(r,k),ao_expo_transp(s,l), & + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & K_power,L_power,K_center,L_center,dim1) q_inv = 1.d0/qq schwartz_kl(s,r) = general_primitive_integral(dim1, & @@ -168,13 +168,13 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) do p = 1, ao_prim_num(i) double precision :: coef1 - coef1 = ao_coef_transp(p,i) + coef1 = ao_coef_normalized_ordered_transp(p,i) do q = 1, ao_prim_num(j) double precision :: coef2 - coef2 = coef1*ao_coef_transp(q,j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) double precision :: p_inv,q_inv call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_transp(p,i),ao_expo_transp(q,j), & + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & I_power,J_power,I_center,J_center,dim1) p_inv = 1.d0/pp schwartz_ij = general_primitive_integral(dim1, & @@ -189,16 +189,16 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) cycle endif double precision :: coef3 - coef3 = coef2*ao_coef_transp(r,k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) do s = 1, ao_prim_num(l) double precision :: coef4 if (schwartz_kl(s,r)*schwartz_ij < thresh) then cycle endif - coef4 = coef3*ao_coef_transp(s,l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) double precision :: general_primitive_integral call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_transp(r,k),ao_expo_transp(s,l), & + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & K_power,L_power,K_center,L_center,dim1) q_inv = 1.d0/qq integral = general_primitive_integral(dim1, & @@ -222,12 +222,12 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) schwartz_kl(0,0) = 0.d0 do r = 1, ao_prim_num(k) - coef1 = ao_coef_transp(r,k)*ao_coef_transp(r,k) + coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) schwartz_kl(0,r) = 0.d0 do s = 1, ao_prim_num(l) - coef2 = coef1*ao_coef_transp(s,l)*ao_coef_transp(s,l) + coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l) schwartz_kl(s,r) = ERI( & - ao_expo_transp(r,k),ao_expo_transp(s,l),ao_expo_transp(r,k),ao_expo_transp(s,l),& + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& K_power(1),L_power(1),K_power(1),L_power(1), & K_power(2),L_power(2),K_power(2),L_power(2), & K_power(3),L_power(3),K_power(3),L_power(3)) * & @@ -238,11 +238,11 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) enddo do p = 1, ao_prim_num(i) - coef1 = ao_coef_transp(p,i) + coef1 = ao_coef_normalized_ordered_transp(p,i) do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_transp(q,j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) schwartz_ij = ERI( & - ao_expo_transp(p,i),ao_expo_transp(q,j),ao_expo_transp(p,i),ao_expo_transp(q,j),& + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),& I_power(1),J_power(1),I_power(1),J_power(1), & I_power(2),J_power(2),I_power(2),J_power(2), & I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2 @@ -253,14 +253,14 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) if (schwartz_kl(0,r)*schwartz_ij < thresh) then cycle endif - coef3 = coef2*ao_coef_transp(r,k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) do s = 1, ao_prim_num(l) if (schwartz_kl(s,r)*schwartz_ij < thresh) then cycle endif - coef4 = coef3*ao_coef_transp(s,l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) integral = ERI( & - ao_expo_transp(p,i),ao_expo_transp(q,j),ao_expo_transp(r,k),ao_expo_transp(s,l),& + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& I_power(1),J_power(1),K_power(1),L_power(1), & I_power(2),J_power(2),K_power(2),L_power(2), & I_power(3),J_power(3),K_power(3),L_power(3)) diff --git a/src/Dets/H_apply.irp.f b/src/Dets/H_apply.irp.f index 801d00a5..d230c765 100644 --- a/src/Dets/H_apply.irp.f +++ b/src/Dets/H_apply.irp.f @@ -181,8 +181,43 @@ subroutine copy_H_apply_buffer_to_wf call normalize(psi_coef,N_det) SOFT_TOUCH N_det psi_det psi_coef + call debug_unicity_of_determinants end +subroutine debug_unicity_of_determinants + implicit none + BEGIN_DOC +! This subroutine checks that there are no repetitions in the wave function + END_DOC + logical :: same, failed + integer :: i,k + print *, "======= DEBUG UNICITY =========" + failed = .False. + do i=2,N_det + same = .True. + do k=1,N_int + if ( psi_det_sorted_bit(k,1,i) /= psi_det_sorted_bit(k,1,i-1) ) then + same = .False. + exit + endif + if ( psi_det_sorted_bit(k,2,i) /= psi_det_sorted_bit(k,2,i-1) ) then + same = .False. + exit + endif + enddo + if (same) then + failed = .True. + call debug_det(psi_det_sorted_bit(1,1,i)) + endif + enddo + + if (failed) then + print *, '======= Determinants not unique : Failed ! =========' + stop + else + print *, '======= Determinants are unique : OK ! =========' + endif +end subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) use bitmasks diff --git a/src/Dets/README.rst b/src/Dets/README.rst index e9077510..cbc1c352 100644 --- a/src/Dets/README.rst +++ b/src/Dets/README.rst @@ -54,7 +54,10 @@ Documentation after calling this function. After calling this subroutine, N_det, psi_det and psi_coef need to be touched -`fill_h_apply_buffer_no_selection `_ +`debug_unicity_of_determinants `_ + This subroutine checks that there are no repetitions in the wave function + +`fill_h_apply_buffer_no_selection `_ Fill the H_apply buffer with determiants for CISD `h_apply_buffer_allocated `_ diff --git a/src/Dets/diagonalize_CI_SC2.irp.f b/src/Dets/diagonalize_CI_SC2.irp.f index 86ba72b9..81931a62 100644 --- a/src/Dets/diagonalize_CI_SC2.irp.f +++ b/src/Dets/diagonalize_CI_SC2.irp.f @@ -35,8 +35,7 @@ END_PROVIDER do i=1,N_det CI_SC2_eigenvectors(i,j) = psi_coef(i,j) enddo -! TODO : check comment -! CI_SC2_electronic_energy(j) = CI_electronic_energy(j) + CI_SC2_electronic_energy(j) = CI_electronic_energy(j) enddo call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, & diff --git a/src/Dets/filter_connected.irp.f b/src/Dets/filter_connected.irp.f index 93a6ee7b..c3d333ad 100644 --- a/src/Dets/filter_connected.irp.f +++ b/src/Dets/filter_connected.irp.f @@ -235,8 +235,8 @@ subroutine filter_connected_davidson(key1,key2,Nint,sze,idx) else if (Nint==3) then - !DIR$ LOOP COUNT (1000) i = idx(0) + !DIR$ LOOP COUNT (1000) do j_int=1,N_con_int itmp = det_connections(j_int,i) do while (itmp /= 0_8) @@ -261,8 +261,8 @@ subroutine filter_connected_davidson(key1,key2,Nint,sze,idx) else - !DIR$ LOOP COUNT (1000) i = idx(0) + !DIR$ LOOP COUNT (1000) do j_int=1,N_con_int itmp = det_connections(j_int,i) do while (itmp /= 0_8) diff --git a/src/Dets/save_for_casino.irp.f b/src/Dets/save_for_casino.irp.f index 631f79bd..35c0c3a7 100644 --- a/src/Dets/save_for_casino.irp.f +++ b/src/Dets/save_for_casino.irp.f @@ -161,7 +161,7 @@ subroutine save_casino if (ao_l(i) == ao_power(i,1)) then do j=1,ao_prim_num(i) l+=1 - rtmp(l) = ao_coef(i,ao_prim_num(i)-j+1) + rtmp(l) = ao_coef_normalized(i,ao_prim_num(i)) enddo endif enddo diff --git a/src/MOs/ASSUMPTIONS.rst b/src/MOs/ASSUMPTIONS.rst index e69de29b..8514ef73 100644 --- a/src/MOs/ASSUMPTIONS.rst +++ b/src/MOs/ASSUMPTIONS.rst @@ -0,0 +1,4 @@ +ASSUMPTONS +========== + +* The AO basis functions are normalized. diff --git a/src/MOs/README.rst b/src/MOs/README.rst index d7a15219..d7a869b4 100644 --- a/src/MOs/README.rst +++ b/src/MOs/README.rst @@ -8,6 +8,8 @@ Molecular orbitals are expressed as \phi_k({\bf r}) = \sum_i C_{ik} \chi_k({\bf r}) +where :math:`\chi_k` are *normalized* atomic basis set. + The current set of molecular orbitals has a label ``mo_label``. When the orbitals are modified, the label should also be updated to keep everything consistent. diff --git a/src/Molden/print_mo.irp.f b/src/Molden/print_mo.irp.f index 9cec8fbd..b147fe50 100644 --- a/src/Molden/print_mo.irp.f +++ b/src/Molden/print_mo.irp.f @@ -92,9 +92,9 @@ subroutine write_Ao_basis(i_unit_output) do k = 1, ao_prim_num(i_ao) i_prim +=1 if(i_prim.lt.100)then - write(i_unit_output,'(4X,I3,3X,A1,6X,I2,6X,F16.7,2X,F16.12)')i_shell,character_shell,i_prim,ao_expo_unsorted(i_ao,k),ao_coef_unnormalized(i_ao,k) + write(i_unit_output,'(4X,I3,3X,A1,6X,I2,6X,F16.7,2X,F16.12)')i_shell,character_shell,i_prim,ao_expo(i_ao,k),ao_coef(i_ao,k) else - write(i_unit_output,'(4X,I3,3X,A1,5X,I3,6X,F16.7,2X,F16.12)')i_shell,character_shell,i_prim,ao_expo_unsorted(i_ao,k),ao_coef_unnormalized(i_ao,k) + write(i_unit_output,'(4X,I3,3X,A1,5X,I3,6X,F16.7,2X,F16.12)')i_shell,character_shell,i_prim,ao_expo(i_ao,k),ao_coef(i_ao,k) endif enddo write(i_unit_output,*)'' diff --git a/src/MonoInts/kin_ao_ints.irp.f b/src/MonoInts/kin_ao_ints.irp.f index 444c3880..10b065b4 100644 --- a/src/MonoInts/kin_ao_ints.irp.f +++ b/src/MonoInts/kin_ao_ints.irp.f @@ -36,8 +36,8 @@ !$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, & !$OMP overlap_x0,overlap_y0,overlap_z0) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_transp,ao_nucl, & - !$OMP ao_expo_transp,dim1) + !$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) A_center(2) = nucl_coord( ao_nucl(j), 2 ) @@ -58,12 +58,12 @@ power_B(2) = ao_power( i, 2 ) power_B(3) = ao_power( i, 3 ) do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) !DEC$ VECTOR ALIGNED do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1) - c = ao_coef_transp(n,j) * ao_coef_transp(l,i) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) ! if (abs(c) < 1.d-8) then ! cycle ! endif diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index f430ace9..32e98a2c 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -19,7 +19,7 @@ !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & !$OMP num_A,num_B,Z,c,n_pt_in) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp, & !$OMP n_pt_max_integrals,ao_nucl_elec_integral,nucl_num,nucl_charge) n_pt_in = n_pt_max_integrals !$OMP DO SCHEDULE (guided) @@ -40,9 +40,9 @@ B_center(2) = nucl_coord(num_B,2) B_center(3) = nucl_coord(num_B,3) do l=1,ao_prim_num(j) - alpha = ao_expo_transp(l,j) + alpha = ao_expo_ordered_transp(l,j) do m=1,ao_prim_num(i) - beta = ao_expo_transp(m,i) + beta = ao_expo_ordered_transp(m,i) c = 0.d0 do k = 1, nucl_num double precision :: Z,c @@ -53,7 +53,7 @@ c = c+Z*NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) enddo ao_nucl_elec_integral(i,j) = ao_nucl_elec_integral(i,j) - & - ao_coef_transp(l,j)*ao_coef_transp(m,i)*c + ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c enddo enddo enddo @@ -90,7 +90,7 @@ END_PROVIDER !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,j,l,m,alpha,beta,A_center,B_center,power_A,power_B, & !$OMP num_A,num_B,c,n_pt_in) & - !$OMP SHARED (k,ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & + !$OMP SHARED (k,ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp, & !$OMP n_pt_max_integrals,ao_nucl_elec_integral_per_atom,nucl_num,C_center) n_pt_in = n_pt_max_integrals !$OMP DO SCHEDULE (guided) @@ -114,11 +114,11 @@ END_PROVIDER B_center(3) = nucl_coord(num_B,3) c = 0.d0 do l=1,ao_prim_num(j) - alpha = ao_expo_transp(l,j) + alpha = ao_expo_ordered_transp(l,j) do m=1,ao_prim_num(i) - beta = ao_expo_transp(m,i) + beta = ao_expo_ordered_transp(m,i) c = c + NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in) & - * ao_coef_transp(l,j)*ao_coef_transp(m,i) + * ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i) enddo enddo ao_nucl_elec_integral_per_atom(i,j,k) = -c diff --git a/src/MonoInts/spread_dipole_ao.irp.f b/src/MonoInts/spread_dipole_ao.irp.f index c0d7c88e..d7aa738a 100644 --- a/src/MonoInts/spread_dipole_ao.irp.f +++ b/src/MonoInts/spread_dipole_ao.irp.f @@ -26,8 +26,8 @@ !$OMP overlap_x,overlap_y, overlap_z, overlap, & !$OMP alpha, beta,i,j,dx,tmp,c,accu_x,accu_y,accu_z) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_spread_x,ao_spread_y,ao_spread_z,ao_num,ao_coef_transp,ao_nucl, & - !$OMP ao_expo_transp,dim1,lower_exp_val) + !$OMP ao_spread_x,ao_spread_y,ao_spread_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1,lower_exp_val) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) A_center(2) = nucl_coord( ao_nucl(j), 2 ) @@ -48,11 +48,11 @@ accu_y = 0.d0 accu_z = 0.d0 do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) !DEC$ VECTOR ALIGNED do l = 1, ao_prim_num(i) - c = ao_coef_transp(n,j)*ao_coef_transp(l,i) - beta = ao_expo_transp(l,i) + c = ao_coef_normalized_ordered_transp(n,j)*ao_coef_normalized_ordered_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) call overlap_bourrin_spread(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),tmp,lower_exp_val,dx,dim1) accu_x += c*(tmp*overlap_y*overlap_z) @@ -100,8 +100,8 @@ !$OMP overlap_x,overlap_y, overlap_z, overlap, & !$OMP alpha, beta,i,j,dx,tmp,c,accu_x,accu_y,accu_z) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_dipole_x,ao_dipole_y,ao_dipole_z,ao_num,ao_coef_transp,ao_nucl, & - !$OMP ao_expo_transp,dim1,lower_exp_val) + !$OMP ao_dipole_x,ao_dipole_y,ao_dipole_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1,lower_exp_val) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) A_center(2) = nucl_coord( ao_nucl(j), 2 ) @@ -122,11 +122,11 @@ accu_y = 0.d0 accu_z = 0.d0 do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) !DEC$ VECTOR ALIGNED do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) - c = ao_coef_transp(l,i)*ao_coef_transp(n,j) + beta = ao_expo_ordered_transp(l,i) + c = ao_coef_normalized_ordered_transp(l,i)*ao_coef_normalized_ordered_transp(n,j) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) call overlap_bourrin_dipole(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),tmp,lower_exp_val,dx,dim1) @@ -174,8 +174,8 @@ !$OMP overlap_x,overlap_y, overlap_z, overlap, & !$OMP alpha, beta,i,j,dx,tmp,c,i_component,accu_x,accu_y,accu_z) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_deriv_1_x,ao_deriv_1_y,ao_deriv_1_z,ao_num,ao_coef_transp,ao_nucl, & - !$OMP ao_expo_transp,dim1,lower_exp_val) + !$OMP ao_deriv_1_x,ao_deriv_1_y,ao_deriv_1_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1,lower_exp_val) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) A_center(2) = nucl_coord( ao_nucl(j), 2 ) @@ -196,12 +196,12 @@ accu_y = 0.d0 accu_z = 0.d0 do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) !DEC$ VECTOR ALIGNED do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) - c = ao_coef_transp(l,i) * ao_coef_transp(n,j) + c = ao_coef_normalized_ordered_transp(l,i) * ao_coef_normalized_ordered_transp(n,j) i_component = 1 call overlap_bourrin_deriv_x(i_component,A_center,B_center,alpha,beta,power_A,power_B,dx,lower_exp_val,tmp,dim1) accu_x += c*(tmp*overlap_y*overlap_z) diff --git a/src/Properties/delta_rho.irp.f b/src/Properties/delta_rho.irp.f index 3cfe136c..69894c38 100644 --- a/src/Properties/delta_rho.irp.f +++ b/src/Properties/delta_rho.irp.f @@ -79,7 +79,7 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_all_points, (ao_num_a !$OMP PARALLEL DO DEFAULT(none) & !$OMP PRIVATE(i,j,n,l,A_center,power_A,B_center,power_B,accu_z, & !$OMP overlap_x,overlap_y,overlap_z,overlap,c,alpha,beta) & - !$OMP SHARED(ao_num,nucl_coord,ao_nucl,ao_power,ao_prim_num,ao_expo_transp,ao_coef_transp, & + !$OMP SHARED(ao_num,nucl_coord,ao_nucl,ao_power,ao_prim_num,ao_expo_ordered_transp,ao_coef_normalized_ordered_transp, & !$OMP ao_integrated_delta_rho_all_points,N_z_pts,dim1,i_z,z,delta_z) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) @@ -98,12 +98,12 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_all_points, (ao_num_a accu_z = 0.d0 do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) - c = ao_coef_transp(n,j) * ao_coef_transp(l,i) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) accu_z += c* overlap_x * overlap_y * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta) enddo enddo @@ -147,7 +147,7 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num_al !$OMP PARALLEL DO DEFAULT(none) & !$OMP PRIVATE(i,j,n,l,A_center,power_A,B_center,power_B,accu_z, & !$OMP overlap_x,overlap_y,overlap_z,overlap,c,alpha,beta) & - !$OMP SHARED(ao_num,nucl_coord,ao_nucl,ao_power,ao_prim_num,ao_expo_transp,ao_coef_transp, & + !$OMP SHARED(ao_num,nucl_coord,ao_nucl,ao_power,ao_prim_num,ao_expo_ordered_transp,ao_coef_normalized_ordered_transp, & !$OMP ao_integrated_delta_rho_one_point,dim1,z,delta_z) do j=1,ao_num A_center(1) = nucl_coord( ao_nucl(j), 1 ) @@ -166,12 +166,12 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num_al accu_z = 0.d0 do n = 1,ao_prim_num(j) - alpha = ao_expo_transp(n,j) + alpha = ao_expo_ordered_transp(n,j) do l = 1, ao_prim_num(i) - beta = ao_expo_transp(l,i) + beta = ao_expo_ordered_transp(l,i) call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) - c = ao_coef_transp(n,j) * ao_coef_transp(l,i) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) accu_z += c* overlap_x * overlap_y * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta) enddo enddo From 14b50bf1eb1d20523889ddc3a27bdd0edf352cab Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 27 Apr 2015 16:55:19 +0200 Subject: [PATCH 41/70] Add docopt installation --- scripts/docopt.py | 590 -------------------------------------- scripts/install_docopt.sh | 21 ++ setup_environment.sh | 3 + 3 files changed, 24 insertions(+), 590 deletions(-) delete mode 100755 scripts/docopt.py create mode 100755 scripts/install_docopt.sh diff --git a/scripts/docopt.py b/scripts/docopt.py deleted file mode 100755 index 59830d53..00000000 --- a/scripts/docopt.py +++ /dev/null @@ -1,590 +0,0 @@ -"""Pythonic command-line interface parser that will make you smile. - - * http://docopt.org - * Repository and issue-tracker: https://github.com/docopt/docopt - * Licensed under terms of MIT license (see LICENSE-MIT) - * Copyright (c) 2013 Vladimir Keleshev, vladimir@keleshev.com - -""" -import sys -import re - - -__all__ = ['docopt'] -__version__ = '0.6.1' - - -class DocoptLanguageError(Exception): - - """Error in construction of usage-message by developer.""" - - -class DocoptExit(SystemExit): - - """Exit in case user invoked program with incorrect arguments.""" - - usage = '' - - def __init__(self, message=''): - SystemExit.__init__(self, (message + '\n' + self.usage).strip()) - - -class Pattern(object): - - def __eq__(self, other): - return repr(self) == repr(other) - - def __hash__(self): - return hash(repr(self)) - - def fix(self): - self.fix_identities() - self.fix_repeating_arguments() - return self - - def fix_identities(self, uniq=None): - """Make pattern-tree tips point to same object if they are equal.""" - if not hasattr(self, 'children'): - return self - uniq = list(set(self.flat())) if uniq is None else uniq - for i, child in enumerate(self.children): - if not hasattr(child, 'children'): - assert child in uniq - self.children[i] = uniq[uniq.index(child)] - else: - child.fix_identities(uniq) - - def fix_repeating_arguments(self): - """Fix elements that should accumulate/increment values.""" - either = [list(child.children) for child in transform(self).children] - for case in either: - for e in [child for child in case if case.count(child) > 1]: - if isinstance( - e, - Argument) or isinstance( - e, - Option) and e.argcount: - if e.value is None: - e.value = [] - elif not isinstance(e.value, list): - e.value = e.value.split() - if isinstance( - e, - Command) or isinstance( - e, - Option) and e.argcount == 0: - e.value = 0 - return self - - -def transform(pattern): - """Expand pattern into an (almost) equivalent one, but with single Either. - - Example: ((-a | -b) (-c | -d)) => (-a -c | -a -d | -b -c | -b -d) - Quirks: [-a] => (-a), (-a...) => (-a -a) - - """ - result = [] - groups = [[pattern]] - while groups: - children = groups.pop(0) - parents = [Required, Optional, OptionsShortcut, Either, OneOrMore] - if any(t in map(type, children) for t in parents): - child = [c for c in children if type(c) in parents][0] - children.remove(child) - if isinstance(child, Either): - for c in child.children: - groups.append([c] + children) - elif isinstance(child, OneOrMore): - groups.append(child.children * 2 + children) - else: - groups.append(child.children + children) - else: - result.append(children) - return Either(*[Required(*e) for e in result]) - - -class LeafPattern(Pattern): - - """Leaf/terminal node of a pattern tree.""" - - def __init__(self, name, value=None): - self.name, self.value = name, value - - def __repr__(self): - return '%s(%r, %r)' % (self.__class__.__name__, self.name, self.value) - - def flat(self, *types): - return [self] if not types or type(self) in types else [] - - def match(self, left, collected=None): - collected = [] if collected is None else collected - pos, match = self.single_match(left) - if match is None: - return False, left, collected - left_ = left[:pos] + left[pos + 1:] - same_name = [a for a in collected if a.name == self.name] - if type(self.value) in (int, list): - if isinstance(self.value, int): - increment = 1 - else: - increment = ([match.value] if isinstance(match.value, str) - else match.value) - if not same_name: - match.value = increment - return True, left_, collected + [match] - same_name[0].value += increment - return True, left_, collected - return True, left_, collected + [match] - - -class BranchPattern(Pattern): - - """Branch/inner node of a pattern tree.""" - - def __init__(self, *children): - self.children = list(children) - - def __repr__(self): - return '%s(%s)' % (self.__class__.__name__, - ', '.join(repr(a) for a in self.children)) - - def flat(self, *types): - if type(self) in types: - return [self] - return sum([child.flat(*types) for child in self.children], []) - - -class Argument(LeafPattern): - - def single_match(self, left): - for n, pattern in enumerate(left): - if isinstance(pattern, Argument): - return n, Argument(self.name, pattern.value) - return None, None - - @classmethod - def parse(class_, source): - name = re.findall('(<\S*?>)', source)[0] - value = re.findall('\[default: (.*)\]', source, flags=re.I) - return class_(name, value[0] if value else None) - - -class Command(Argument): - - def __init__(self, name, value=False): - self.name, self.value = name, value - - def single_match(self, left): - for n, pattern in enumerate(left): - if isinstance(pattern, Argument): - if pattern.value == self.name: - return n, Command(self.name, True) - else: - break - return None, None - - -class Option(LeafPattern): - - def __init__(self, short=None, long=None, argcount=0, value=False): - assert argcount in (0, 1) - self.short, self.long, self.argcount = short, long, argcount - self.value = None if value is False and argcount else value - - @classmethod - def parse(class_, option_description): - short, long, argcount, value = None, None, 0, False - options, _, description = option_description.strip().partition(' ') - options = options.replace(',', ' ').replace('=', ' ') - for s in options.split(): - if s.startswith('--'): - long = s - elif s.startswith('-'): - short = s - else: - argcount = 1 - if argcount: - matched = re.findall('\[default: (.*)\]', description, flags=re.I) - value = matched[0] if matched else None - return class_(short, long, argcount, value) - - def single_match(self, left): - for n, pattern in enumerate(left): - if self.name == pattern.name: - return n, pattern - return None, None - - @property - def name(self): - return self.long or self.short - - def __repr__(self): - return 'Option(%r, %r, %r, %r)' % (self.short, self.long, - self.argcount, self.value) - - -class Required(BranchPattern): - - def match(self, left, collected=None): - collected = [] if collected is None else collected - l = left - c = collected - for pattern in self.children: - matched, l, c = pattern.match(l, c) - if not matched: - return False, left, collected - return True, l, c - - -class Optional(BranchPattern): - - def match(self, left, collected=None): - collected = [] if collected is None else collected - for pattern in self.children: - m, left, collected = pattern.match(left, collected) - return True, left, collected - - -class OptionsShortcut(Optional): - - """Marker/placeholder for [options] shortcut.""" - - -class OneOrMore(BranchPattern): - - def match(self, left, collected=None): - assert len(self.children) == 1 - collected = [] if collected is None else collected - l = left - c = collected - l_ = None - matched = True - times = 0 - while matched: - # could it be that something didn't match but changed l or c? - matched, l, c = self.children[0].match(l, c) - times += 1 if matched else 0 - if l_ == l: - break - l_ = l - if times >= 1: - return True, l, c - return False, left, collected - - -class Either(BranchPattern): - - def match(self, left, collected=None): - collected = [] if collected is None else collected - outcomes = [] - for pattern in self.children: - matched, _, _ = outcome = pattern.match(left, collected) - if matched: - outcomes.append(outcome) - if outcomes: - return min(outcomes, key=lambda outcome: len(outcome[1])) - return False, left, collected - - -class Tokens(list): - - def __init__(self, source, error=DocoptExit): - self += source.split() if hasattr(source, 'split') else source - self.error = error - - @staticmethod - def from_pattern(source): - source = re.sub(r'([\[\]\(\)\|]|\.\.\.)', r' \1 ', source) - source = [s for s in re.split('\s+|(\S*<.*?>)', source) if s] - return Tokens(source, error=DocoptLanguageError) - - def move(self): - return self.pop(0) if len(self) else None - - def current(self): - return self[0] if len(self) else None - - -def parse_long(tokens, options): - """long ::= '--' chars [ ( ' ' | '=' ) chars ] ;""" - long, eq, value = tokens.move().partition('=') - assert long.startswith('--') - value = None if eq == value == '' else value - similar = [o for o in options if o.long == long] - if tokens.error is DocoptExit and similar == []: # if no exact match - similar = [o for o in options if o.long and o.long.startswith(long)] - if len(similar) > 1: # might be simply specified ambiguously 2+ times? - raise tokens.error('%s is not a unique prefix: %s?' % - (long, ', '.join(o.long for o in similar))) - elif len(similar) < 1: - argcount = 1 if eq == '=' else 0 - o = Option(None, long, argcount) - options.append(o) - if tokens.error is DocoptExit: - o = Option(None, long, argcount, value if argcount else True) - else: - o = Option(similar[0].short, similar[0].long, - similar[0].argcount, similar[0].value) - if o.argcount == 0: - if value is not None: - raise tokens.error('%s must not have an argument' % o.long) - else: - if value is None: - if tokens.current() in [None, '--']: - raise tokens.error('%s requires argument' % o.long) - value = tokens.move() - if tokens.error is DocoptExit: - o.value = value if value is not None else True - return [o] - - -def parse_shorts(tokens, options): - """shorts ::= '-' ( chars )* [ [ ' ' ] chars ] ;""" - token = tokens.move() - assert token.startswith('-') and not token.startswith('--') - left = token.lstrip('-') - parsed = [] - while left != '': - short, left = '-' + left[0], left[1:] - similar = [o for o in options if o.short == short] - if len(similar) > 1: - raise tokens.error('%s is specified ambiguously %d times' % - (short, len(similar))) - elif len(similar) < 1: - o = Option(short, None, 0) - options.append(o) - if tokens.error is DocoptExit: - o = Option(short, None, 0, True) - else: # why copying is necessary here? - o = Option(short, similar[0].long, - similar[0].argcount, similar[0].value) - value = None - if o.argcount != 0: - if left == '': - if tokens.current() in [None, '--']: - raise tokens.error('%s requires argument' % short) - value = tokens.move() - else: - value = left - left = '' - if tokens.error is DocoptExit: - o.value = value if value is not None else True - parsed.append(o) - return parsed - - -def parse_pattern(source, options): - tokens = Tokens.from_pattern(source) - result = parse_expr(tokens, options) - if tokens.current() is not None: - raise tokens.error('unexpected ending: %r' % ' '.join(tokens)) - return Required(*result) - - -def parse_expr(tokens, options): - """expr ::= seq ( '|' seq )* ;""" - seq = parse_seq(tokens, options) - if tokens.current() != '|': - return seq - result = [Required(*seq)] if len(seq) > 1 else seq - while tokens.current() == '|': - tokens.move() - seq = parse_seq(tokens, options) - result += [Required(*seq)] if len(seq) > 1 else seq - return [Either(*result)] if len(result) > 1 else result - - -def parse_seq(tokens, options): - """seq ::= ( atom [ '...' ] )* ;""" - result = [] - while tokens.current() not in [None, ']', ')', '|']: - atom = parse_atom(tokens, options) - if tokens.current() == '...': - atom = [OneOrMore(*atom)] - tokens.move() - result += atom - return result - - -def parse_atom(tokens, options): - """atom ::= '(' expr ')' | '[' expr ']' | 'options' - | long | shorts | argument | command ; - """ - token = tokens.current() - result = [] - if token in '([': - tokens.move() - matching, pattern = {'(': [')', Required], '[': [']', Optional]}[token] - result = pattern(*parse_expr(tokens, options)) - if tokens.move() != matching: - raise tokens.error("unmatched '%s'" % token) - return [result] - elif token == 'options': - tokens.move() - return [OptionsShortcut()] - elif token.startswith('--') and token != '--': - return parse_long(tokens, options) - elif token.startswith('-') and token not in ('-', '--'): - return parse_shorts(tokens, options) - elif token.startswith('<') and token.endswith('>') or token.isupper(): - return [Argument(tokens.move())] - else: - return [Command(tokens.move())] - - -def parse_argv(tokens, options, options_first=False): - """Parse command-line argument vector. - - If options_first: - argv ::= [ long | shorts ]* [ argument ]* [ '--' [ argument ]* ] ; - else: - argv ::= [ long | shorts | argument ]* [ '--' [ argument ]* ] ; - - """ - parsed = [] - while tokens.current() is not None: - if tokens.current() == '--': - return parsed + [Argument(None, v) for v in tokens] - elif tokens.current().startswith('--'): - parsed += parse_long(tokens, options) - elif tokens.current().startswith('-') and tokens.current() != '-': - parsed += parse_shorts(tokens, options) - elif options_first: - return parsed + [Argument(None, v) for v in tokens] - else: - parsed.append(Argument(None, tokens.move())) - return parsed - - -def parse_defaults(doc): - defaults = [] - for s in parse_section('options:', doc): - # FIXME corner case "bla: options: --foo" - _, _, s = s.partition(':') # get rid of "options:" - split = re.split('\n[ \t]*(-\S+?)', '\n' + s)[1:] - split = [s1 + s2 for s1, s2 in zip(split[::2], split[1::2])] - options = [Option.parse(s) for s in split if s.startswith('-')] - defaults += options - return defaults - - -def parse_section(name, source): - pattern = re.compile('^([^\n]*' + name + '[^\n]*\n?(?:[ \t].*?(?:\n|$))*)', - re.IGNORECASE | re.MULTILINE) - return [s.strip() for s in pattern.findall(source)] - - -def formal_usage(section): - _, _, section = section.partition(':') # drop "usage:" - pu = section.split() - return '( ' + ' '.join(') | (' if s == pu[0] else s for s in pu[1:]) + ' )' - - -def extras(help, version, options, doc): - if help and any((o.name in ('-h', '--help')) and o.value for o in options): - print(doc.strip("\n")) - sys.exit() - if version and any(o.name == '--version' and o.value for o in options): - print(version) - sys.exit() - - -class Dict(dict): - - def __repr__(self): - return '{%s}' % ',\n '.join('%r: %r' % i for i in sorted(self.items())) - - -def docopt(doc, argv=None, help=True, version=None, options_first=False): - """Parse `argv` based on command-line interface described in `doc`. - - `docopt` creates your command-line interface based on its - description that you pass as `doc`. Such description can contain - --options, , commands, which could be - [optional], (required), (mutually | exclusive) or repeated... - - Parameters - ---------- - doc : str - Description of your command-line interface. - argv : list of str, optional - Argument vector to be parsed. sys.argv[1:] is used if not - provided. - help : bool (default: True) - Set to False to disable automatic help on -h or --help - options. - version : any object - If passed, the object will be printed if --version is in - `argv`. - options_first : bool (default: False) - Set to True to require options precede positional arguments, - i.e. to forbid options and positional arguments intermix. - - Returns - ------- - args : dict - A dictionary, where keys are names of command-line elements - such as e.g. "--verbose" and "", and values are the - parsed values of those elements. - - Example - ------- - >>> from docopt import docopt - >>> doc = ''' - ... Usage: - ... my_program tcp [--timeout=] - ... my_program serial [--baud=] [--timeout=] - ... my_program (-h | --help | --version) - ... - ... Options: - ... -h, --help Show this screen and exit. - ... --baud= Baudrate [default: 9600] - ... ''' - >>> argv = ['tcp', '127.0.0.1', '80', '--timeout', '30'] - >>> docopt(doc, argv) - {'--baud': '9600', - '--help': False, - '--timeout': '30', - '--version': False, - '': '127.0.0.1', - '': '80', - 'serial': False, - 'tcp': True} - - See also - -------- - * For video introduction see http://docopt.org - * Full documentation is available in README.rst as well as online - at https://github.com/docopt/docopt#readme - - """ - argv = sys.argv[1:] if argv is None else argv - - usage_sections = parse_section('usage:', doc) - if len(usage_sections) == 0: - raise DocoptLanguageError('"usage:" (case-insensitive) not found.') - if len(usage_sections) > 1: - raise DocoptLanguageError('More than one "usage:" (case-insensitive).') - DocoptExit.usage = usage_sections[0] - - options = parse_defaults(doc) - pattern = parse_pattern(formal_usage(DocoptExit.usage), options) - # [default] syntax for argument is disabled - # for a in pattern.flat(Argument): - # same_name = [d for d in arguments if d.name == a.name] - # if same_name: - # a.value = same_name[0].value - argv = parse_argv(Tokens(argv), list(options), options_first) - pattern_options = set(pattern.flat(Option)) - for options_shortcut in pattern.flat(OptionsShortcut): - doc_options = parse_defaults(doc) - options_shortcut.children = list(set(doc_options) - pattern_options) - # if any_options: - # options_shortcut.children += [Option(o.short, o.long, o.argcount) - # for o in argv if type(o) is Option] - extras(help, version, argv, doc) - matched, left, collected = pattern.fix().match(argv) - if matched and left == []: # better error message if left? - return Dict((a.name, a.value) for a in (pattern.flat() + collected)) - raise DocoptExit() diff --git a/scripts/install_docopt.sh b/scripts/install_docopt.sh new file mode 100755 index 00000000..7edf2377 --- /dev/null +++ b/scripts/install_docopt.sh @@ -0,0 +1,21 @@ +#!/bin/bash +# +# Installs docopt +# lundi 27 avril 2015, 16:51:34 (UTC+0200) + +DOCOPT="docopt.py" +DOCOPT_URL="https://raw.githubusercontent.com/docopt/docopt/master/${DOCOPT}" + +if [[ -z ${QPACKAGE_ROOT} ]] +then + print "The QPACKAGE_ROOT environment variable is not set." + print "Please reload the quantum_package.rc file." + exit -1 +fi + +cd ${QPACKAGE_ROOT} + +rm -f -- scripts/${DOCOPT}{,c} +${QPACKAGE_ROOT}/scripts/fetch_from_web.py ${DOCOPT_URL} ${DOCOPT} + +mv ${DOCOPT} scripts/${DOCOPT} \ No newline at end of file diff --git a/setup_environment.sh b/setup_environment.sh index be4bae64..e650a273 100755 --- a/setup_environment.sh +++ b/setup_environment.sh @@ -57,6 +57,9 @@ ${QPACKAGE_ROOT}/scripts/install_curl.sh | tee install_curl.log echo "${BLUE}===== Installing M4 ===== ${BLACK}" ${QPACKAGE_ROOT}/scripts/install_m4.sh | tee install_m4.log +echo "${BLUE}===== Installing Docopt ===== ${BLACK}" +${QPACKAGE_ROOT}/scripts/install_docopt.sh | tee install_docopt.log + echo "${BLUE}===== Installing EMSL Basis set library ===== ${BLACK}" ${QPACKAGE_ROOT}/scripts/install_emsl.sh | tee install_emsl.log From 24c5e1aa57b7a5e2dd208453c7834b36c2f13508 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 27 Apr 2015 17:10:25 +0200 Subject: [PATCH 42/70] Change print into echo for install_* --- scripts/install_curl.sh | 4 ++-- scripts/install_docopt.sh | 4 ++-- scripts/install_emsl.sh | 4 ++-- scripts/install_ezfio.sh | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/scripts/install_curl.sh b/scripts/install_curl.sh index 20033f77..b2e47481 100755 --- a/scripts/install_curl.sh +++ b/scripts/install_curl.sh @@ -8,8 +8,8 @@ CURL_URL="http://qmcchem.ups-tlse.fr/files/scemama/${CURL}.tar.bz2" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_docopt.sh b/scripts/install_docopt.sh index 7edf2377..6f799c47 100755 --- a/scripts/install_docopt.sh +++ b/scripts/install_docopt.sh @@ -8,8 +8,8 @@ DOCOPT_URL="https://raw.githubusercontent.com/docopt/docopt/master/${DOCOPT}" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_emsl.sh b/scripts/install_emsl.sh index dff002a1..b01afb6e 100755 --- a/scripts/install_emsl.sh +++ b/scripts/install_emsl.sh @@ -8,8 +8,8 @@ URL="https://github.com/LCPQ/${BASE}/archive/master.tar.gz" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_ezfio.sh b/scripts/install_ezfio.sh index 0f7a6505..c0033ca8 100755 --- a/scripts/install_ezfio.sh +++ b/scripts/install_ezfio.sh @@ -8,8 +8,8 @@ URL="https://github.com/LCPQ/${BASE}/archive/master.tar.gz" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi From 185616f7e304ba0b493a54f973d2a37d3e363841 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 28 Apr 2015 14:03:44 +0200 Subject: [PATCH 43/70] Add capitzalise to EZFIO_convert_output for consitenciy --- .../qp_convert_output_to_ezfio.py | 2 +- src/MonoInts/README.rst | 25 +++++++++++-------- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 6b5c5fcd..9d67611e 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -105,7 +105,7 @@ def write_ezfio(res, filename): # Transformt H1 into H import re p = re.compile(ur'(\d*)$') - label = [p.sub("", x.name) for x in res.geometry] + label = [p.sub("", x.name).capitalize() for x in res.geometry] ezfio.set_nuclei_nucl_label(label) ezfio.set_nuclei_nucl_coord(coord_x + coord_y + coord_z) diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index 69da98ed..ffdcdc94 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -102,38 +102,41 @@ Documentation `ao_nucl_elec_integral `_ interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom -`give_polynom_mult_center_mono_elec `_ +`ao_nucl_elec_integral_pseudo `_ + interaction nuclear electron + +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented `mo_nucl_elec_integral `_ From be4db7c56d28505d3417fd7a1526a9cf3fb7247e Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 28 Apr 2015 17:08:59 +0200 Subject: [PATCH 44/70] delete the **** parameters --- src/MonoInts/int.f90 | 78 +++++++++++++++++++++++----------- src/MonoInts/pot_ao_ints.irp.f | 2 +- 2 files changed, 54 insertions(+), 26 deletions(-) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index 31b51c51..98247553 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -184,15 +184,10 @@ implicit none ! _|_ | | |_) |_| |_ ! | double precision, intent(in) :: a(3),g_a,b(3),g_b,c(3) - -integer kmax_max,lmax_max,ntot_max,nkl_max -parameter (kmax_max=2,lmax_max=2,nkl_max=4) -parameter (ntot_max=10) integer, intent(in) :: lmax,kmax,n_kl(kmax,0:lmax) integer, intent(in) :: n_a(3),n_b(3) double precision, intent(in) :: v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) - ! ! | _ _ _. | _ ! |_ (_) (_ (_| | (/_ @@ -204,35 +199,36 @@ double precision :: areal,freal,breal,t1,t2,int_prod_bessel, int_prod_bessel_num double precision :: arg integer :: ntot,ntotA,m,mu,mup,k1,k2,k3,ntotB,k1p,k2p,k3p,lambda,lambdap,ktot -integer :: l,k +integer :: l,k, nkl_max ! _ ! |_) o _ _. ._ ._ _. ! |_) | (_| (_| | | (_| \/ ! _| / -double precision array_coefs_A(0:ntot_max,0:ntot_max,0:ntot_max) -double precision array_coefs_B(0:ntot_max,0:ntot_max,0:ntot_max) +double precision, allocatable :: array_coefs_A(:,:,:) +double precision, allocatable :: array_coefs_B(:,:,:) double precision, allocatable :: array_R(:,:,:,:,:) double precision, allocatable :: array_I_A(:,:,:,:,:) double precision, allocatable :: array_I_B(:,:,:,:,:) -!=!=!=!=!=!=!=!=!=! -! A l l o c a t e ! -!=!=!=!=!=!=!=!=!=! - -allocate (array_R(0:ntot_max+nkl_max,kmax_max,0:lmax_max,0:lmax_max+ntot_max,0:lmax_max+ntot_max)) - -allocate (array_I_A(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) - -allocate (array_I_B(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) ! _ ! / _. | _ | ! \_ (_| | (_ |_| | ! + +print*, "lmax",lmax +print*, "kmax",kmax +print*, "n_kl",n_kl +print*, "n_a",n_a +print*, "n_b",n_b +print*, "v_kl",v_kl +print*, "dz_kl",dz_kl + + fourpi=4.d0*dacos(-1.d0) ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) bc=dsqrt((b(1)-c(1))**2+(b(2)-c(2))**2+(b(3)-c(3))**2) @@ -249,8 +245,21 @@ ntotA=n_a(1)+n_a(2)+n_a(3) ntotB=n_b(1)+n_b(2)+n_b(3) ntot=ntotA+ntotB -if(ntot.gt.ntot_max)stop 'increase ntot_max' +nkl_max=4 +!=!=!=!=!=!=!=!=!=! +! A l l o c a t e ! +!=!=!=!=!=!=!=!=!=! +allocate (array_coefs_A(0:ntot,0:ntot,0:ntot)) +allocate (array_coefs_B(0:ntot,0:ntot,0:ntot)) + +allocate (array_R(0:ntot+nkl_max,kmax,0:lmax,0:lmax+ntot,0:lmax+ntot)) + +allocate (array_I_A(0:lmax+ntot,-(lmax+ntot):lmax+ntot,0:ntot,0:ntot,0:ntot)) + +allocate (array_I_B(0:lmax+ntot,-(lmax+ntot):lmax+ntot,0:ntot,0:ntot,0:ntot)) + +print*, ac,bc if(ac.eq.0.d0.and.bc.eq.0.d0)then @@ -584,6 +593,7 @@ endif ! | | | | (_| | | _> (/_ ! deallocate (array_R, array_I_A, array_I_B) + deallocate (array_coefs_A, array_coefs_B) return end @@ -598,15 +608,33 @@ end double precision function Vpseudo_num(npts,rmax,lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) implicit none -integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) -integer lmax,kmax, n_kl(kmax_max,0:lmax_max),l,m,k,kk -double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -double precision a(3),g_a,b(3),g_b,c(3),ac(3),bc(3) -integer n_a(3),n_b(3),npts -double precision rmax,dr,sum,rC + + +! ___ +! | ._ ._ _|_ +! _|_ | | |_) |_| |_ +! | +double precision, intent(in) :: a(3),g_a,b(3),g_b,c(3) +integer, intent(in) :: lmax,kmax,npts +integer, intent(in) :: n_a(3),n_b(3), n_kl(kmax,0:lmax) +double precision, intent(in) :: v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) +double precision, intent(in) :: rmax + +! +! | _ _ _. | _ +! |_ (_) (_ (_| | (/_ +! + +integer :: l,m,k,kk +double precision ac(3),bc(3) +double precision dr,sum,rC double precision overlap_orb_ylm_brute +! _ +! / _. | _ | +! \_ (_| | (_ |_| | +! + do l=1,3 ac(l)=a(l)-c(l) bc(l)=b(l)-c(l) diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index 065785c2..da9f1d68 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -201,7 +201,7 @@ n_kl_dump = n_kl(k,1:kmax,0:lmax) v_kl_dump = v_kl(k,1:kmax,0:lmax) dz_kl_dump = dz_kl(k,1:kmax,0:lmax) - + c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) enddo From 1938425cfed0ef69498bb07a2906def6aee70687 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 28 Apr 2015 17:17:34 +0200 Subject: [PATCH 45/70] Add a return condition for kmax=1, lmax=1 and v_kl=0.d0 in vpseudo --- scripts/pseudo/put_pseudo_in_ezfio.py | 7 +++++++ src/MonoInts/int.f90 | 20 ++++++++------------ 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 0ba71b0c..68c16729 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -275,6 +275,13 @@ if __name__ == "__main__": # ~#~#~#~#~ # ezfio.pseudo_klocmax = len(v_k[0]) + + # Change all the array 'cause EZFIO + # v_kl (v, l) => v_kl(l,v) + # v_kl => zip(*_v_kl) + # [[7.0, 79.74474797, -49.45159098], [1.0, 5.41040609, -4.60151975]] + # [(7.0, 1.0), (79.74474797, 5.41040609), (-49.45159098, -4.60151975)] + ezfio.pseudo_v_k = zip(*v_k) ezfio.pseudo_n_k = zip(*n_k) ezfio.pseudo_dz_k = zip(*dz_k) diff --git a/src/MonoInts/int.f90 b/src/MonoInts/int.f90 index 98247553..be806b3f 100644 --- a/src/MonoInts/int.f90 +++ b/src/MonoInts/int.f90 @@ -219,24 +219,21 @@ double precision, allocatable :: array_I_B(:,:,:,:,:) ! \_ (_| | (_ |_| | ! - -print*, "lmax",lmax -print*, "kmax",kmax -print*, "n_kl",n_kl -print*, "n_a",n_a -print*, "n_b",n_b -print*, "v_kl",v_kl -print*, "dz_kl",dz_kl - +if (kmax.eq.1.and.lmax.eq.0.and.v_kl(1,0).eq.0.d0) then + Vpseudo=0.d0 + return +end if fourpi=4.d0*dacos(-1.d0) ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) bc=dsqrt((b(1)-c(1))**2+(b(2)-c(2))**2+(b(3)-c(3))**2) arg=g_a*ac**2+g_b*bc**2 + if(arg.gt.-dlog(1.d-20))then -Vpseudo=0.d0 -return + Vpseudo=0.d0 + return endif + freal=dexp(-arg) areal=2.d0*g_a*ac @@ -259,7 +256,6 @@ allocate (array_I_A(0:lmax+ntot,-(lmax+ntot):lmax+ntot,0:ntot,0:ntot,0:ntot)) allocate (array_I_B(0:lmax+ntot,-(lmax+ntot):lmax+ntot,0:ntot,0:ntot,0:ntot)) -print*, ac,bc if(ac.eq.0.d0.and.bc.eq.0.d0)then From 3badfe5a7fb0677135d203eb09969e6cd47e616b Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Wed, 29 Apr 2015 14:34:14 +0200 Subject: [PATCH 46/70] Solve put_pseudo_in_ezfio when len(v_kl) is not equal for all the atom --- scripts/pseudo/put_pseudo_in_ezfio.py | 54 +++++++++++++++++++++++---- 1 file changed, 46 insertions(+), 8 deletions(-) diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 68c16729..6a7aaef7 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -176,6 +176,36 @@ def get_zeff_alpha_beta(str_ele): return [z_eff, alpha, beta] + +def add_zero(array, size, type): + for add in xrange(len(array), size): + array.append([type(0)]) + + return array + + +def make_it_square(matrix, dim, type=float): + """ + matix the matrix to squate + dim array [lmax, kmax] + type the null value you want + [[[28.59107316], [19.37583724]], [[50.25646328]]] + => + [[[28.59107316], [19.37583724]], [[50.25646328], [0.0]]] + """ + + lmax = dim[0] + kmax = dim[1] + + for l_list in matrix: + + l_list = add_zero(l_list, lmax, type) + + for k_list in list_: + k_list = add_zero(k_list, kmax, type) + + return matrix + if __name__ == "__main__": arguments = docopt(__doc__) # ___ @@ -270,18 +300,19 @@ if __name__ == "__main__": ezfio.electrons_elec_alpha_num = alpha_tot ezfio.electrons_elec_beta_num = beta_tot - # ~#~#~#~#~ # - # L o c a l # - # ~#~#~#~#~ # - - ezfio.pseudo_klocmax = len(v_k[0]) - # Change all the array 'cause EZFIO # v_kl (v, l) => v_kl(l,v) # v_kl => zip(*_v_kl) # [[7.0, 79.74474797, -49.45159098], [1.0, 5.41040609, -4.60151975]] # [(7.0, 1.0), (79.74474797, 5.41040609), (-49.45159098, -4.60151975)] + # ~#~#~#~#~ # + # L o c a l # + # ~#~#~#~#~ # + + klocmax = max([len(i) for i in v_k]) + ezfio.pseudo_klocmax = klocmax + ezfio.pseudo_v_k = zip(*v_k) ezfio.pseudo_n_k = zip(*n_k) ezfio.pseudo_dz_k = zip(*dz_k) @@ -290,8 +321,15 @@ if __name__ == "__main__": # N o n _ L o c a l # # ~#~#~#~#~#~#~#~#~ # - ezfio.pseudo_lmaxpo = len(v_kl[0]) - ezfio.pseudo_kmax = len(v_kl[0][0]) + lmax = max([len(i) for i in v_kl]) + kmax = max([len(sublist) for list_ in v_kl for sublist in list_]) + + ezfio.pseudo_lmaxpo = lmax + ezfio.pseudo_kmax = kmax + + v_kl = make_it_square(v_kl, [lmax, kmax]) + n_kl = make_it_square(n_kl, [lmax, kmax], int) + dz_kl = make_it_square(dz_kl, [lmax, kmax]) ezfio.pseudo_v_kl = zip(*v_kl) ezfio.pseudo_n_kl = zip(*n_kl) From 24b4e1b7ca8ab87456c415cac6ef13ba051b5cdb Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 14:00:43 +0200 Subject: [PATCH 47/70] Move install script into install --- scripts/{ => install}/install_curl.sh | 0 scripts/{ => install}/install_emsl.sh | 0 scripts/{ => install}/install_ezfio.sh | 0 scripts/{ => install}/install_irpf90.sh | 0 scripts/{ => install}/install_m4.sh | 0 scripts/{ => install}/install_ocaml.sh | 0 scripts/{ => install}/install_resultsFile.sh | 0 scripts/{ => install}/install_zlib.sh | 0 scripts/upgrade_ezfio.sh | 2 +- scripts/upgrade_irpf90.sh | 2 +- setup_environment.sh | 16 ++++++++-------- 11 files changed, 10 insertions(+), 10 deletions(-) rename scripts/{ => install}/install_curl.sh (100%) rename scripts/{ => install}/install_emsl.sh (100%) rename scripts/{ => install}/install_ezfio.sh (100%) rename scripts/{ => install}/install_irpf90.sh (100%) rename scripts/{ => install}/install_m4.sh (100%) rename scripts/{ => install}/install_ocaml.sh (100%) rename scripts/{ => install}/install_resultsFile.sh (100%) rename scripts/{ => install}/install_zlib.sh (100%) diff --git a/scripts/install_curl.sh b/scripts/install/install_curl.sh similarity index 100% rename from scripts/install_curl.sh rename to scripts/install/install_curl.sh diff --git a/scripts/install_emsl.sh b/scripts/install/install_emsl.sh similarity index 100% rename from scripts/install_emsl.sh rename to scripts/install/install_emsl.sh diff --git a/scripts/install_ezfio.sh b/scripts/install/install_ezfio.sh similarity index 100% rename from scripts/install_ezfio.sh rename to scripts/install/install_ezfio.sh diff --git a/scripts/install_irpf90.sh b/scripts/install/install_irpf90.sh similarity index 100% rename from scripts/install_irpf90.sh rename to scripts/install/install_irpf90.sh diff --git a/scripts/install_m4.sh b/scripts/install/install_m4.sh similarity index 100% rename from scripts/install_m4.sh rename to scripts/install/install_m4.sh diff --git a/scripts/install_ocaml.sh b/scripts/install/install_ocaml.sh similarity index 100% rename from scripts/install_ocaml.sh rename to scripts/install/install_ocaml.sh diff --git a/scripts/install_resultsFile.sh b/scripts/install/install_resultsFile.sh similarity index 100% rename from scripts/install_resultsFile.sh rename to scripts/install/install_resultsFile.sh diff --git a/scripts/install_zlib.sh b/scripts/install/install_zlib.sh similarity index 100% rename from scripts/install_zlib.sh rename to scripts/install/install_zlib.sh diff --git a/scripts/upgrade_ezfio.sh b/scripts/upgrade_ezfio.sh index 4a9af403..c35a2dbd 100755 --- a/scripts/upgrade_ezfio.sh +++ b/scripts/upgrade_ezfio.sh @@ -12,7 +12,7 @@ fi cd -- ${QPACKAGE_ROOT} mv -- ${QPACKAGE_ROOT}/EZFIO ${QPACKAGE_ROOT}/EZFIO.old -${QPACKAGE_ROOT}/scripts/install_ezfio.sh +${QPACKAGE_ROOT}/scripts/install/install_ezfio.sh if [[ $? -eq 0 ]] then diff --git a/scripts/upgrade_irpf90.sh b/scripts/upgrade_irpf90.sh index 5735754f..dea48014 100755 --- a/scripts/upgrade_irpf90.sh +++ b/scripts/upgrade_irpf90.sh @@ -12,7 +12,7 @@ fi cd -- ${QPACKAGE_ROOT} mv -f -- ${QPACKAGE_ROOT}/irpf90 ${QPACKAGE_ROOT}/irpf90.old -${QPACKAGE_ROOT}/scripts/install_irpf90.sh +${QPACKAGE_ROOT}/scripts/install/install_irpf90.sh if [[ $? -eq 0 ]] then diff --git a/setup_environment.sh b/setup_environment.sh index 12fcf4a5..72d2834c 100755 --- a/setup_environment.sh +++ b/setup_environment.sh @@ -30,7 +30,7 @@ EOF source quantum_package.rc echo "${BLUE}===== Installing IRPF90 ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_irpf90.sh | tee install_irpf90.log +${QPACKAGE_ROOT}/scripts/install/install_irpf90.sh | tee install_irpf90.log if [[ ! -d ${QPACKAGE_ROOT}/irpf90 ]] then echo $RED "Error in IRPF90 installation" $BLACK @@ -51,16 +51,16 @@ fi echo "${BLUE}===== Installing Zlib ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_zlib.sh | tee install_zlib.log +${QPACKAGE_ROOT}/scripts/install/install_zlib.sh | tee install_zlib.log echo "${BLUE}===== Installing Curl ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_curl.sh | tee install_curl.log +${QPACKAGE_ROOT}/scripts/install/install_curl.sh | tee install_curl.log echo "${BLUE}===== Installing M4 ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_m4.sh | tee install_m4.log +${QPACKAGE_ROOT}/scripts/install/install_m4.sh | tee install_m4.log echo "${BLUE}===== Installing EMSL Basis set library ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_emsl.sh | tee install_emsl.log +${QPACKAGE_ROOT}/scripts/install/install_emsl.sh | tee install_emsl.log if [[ ! -d ${QPACKAGE_ROOT}/EMSL_Basis ]] then @@ -70,7 +70,7 @@ fi echo "${BLUE}===== Installing EZFIO ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_ezfio.sh | tee install_ezfio.log +${QPACKAGE_ROOT}/scripts/install/install_ezfio.sh | tee install_ezfio.log if [[ ! -d ${QPACKAGE_ROOT}/EZFIO ]] then echo $RED "Error in EZFIO installation" $BLACK @@ -80,7 +80,7 @@ fi echo "${BLUE}===== Installing Ocaml compiler and libraries ===== ${BLACK}" rm -f -- ocaml/Qptypes.ml -${QPACKAGE_ROOT}/scripts/install_ocaml.sh | tee install_ocaml.log +${QPACKAGE_ROOT}/scripts/install/install_ocaml.sh | tee install_ocaml.log if [[ ! -f ${QPACKAGE_ROOT}/ocaml/Qptypes.ml ]] then @@ -89,7 +89,7 @@ then fi echo "${BLUE}===== Installing resultsFile Python library ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_resultsFile.sh +${QPACKAGE_ROOT}/scripts/install/install_resultsFile.sh if [[ ! -d ${QPACKAGE_ROOT}/resultsFile ]] then echo $RED "Error in resultsFile installation" $BLACK From c1c3285ceca0bd0192ade4710c157cb7d31735d2 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 27 Apr 2015 17:10:25 +0200 Subject: [PATCH 48/70] Move install script into install folder --- scripts/{ => install}/install_curl.sh | 4 ++-- scripts/{ => install}/install_docopt.sh | 4 ++-- scripts/{ => install}/install_emsl.sh | 4 ++-- scripts/{ => install}/install_ezfio.sh | 4 ++-- scripts/{ => install}/install_irpf90.sh | 0 scripts/{ => install}/install_m4.sh | 0 scripts/{ => install}/install_ocaml.sh | 0 scripts/{ => install}/install_resultsFile.sh | 0 scripts/{ => install}/install_zlib.sh | 0 scripts/upgrade_ezfio.sh | 2 +- scripts/upgrade_irpf90.sh | 2 +- setup_environment.sh | 18 +++++++++--------- 12 files changed, 19 insertions(+), 19 deletions(-) rename scripts/{ => install}/install_curl.sh (83%) rename scripts/{ => install}/install_docopt.sh (70%) rename scripts/{ => install}/install_emsl.sh (79%) rename scripts/{ => install}/install_ezfio.sh (77%) rename scripts/{ => install}/install_irpf90.sh (100%) rename scripts/{ => install}/install_m4.sh (100%) rename scripts/{ => install}/install_ocaml.sh (100%) rename scripts/{ => install}/install_resultsFile.sh (100%) rename scripts/{ => install}/install_zlib.sh (100%) diff --git a/scripts/install_curl.sh b/scripts/install/install_curl.sh similarity index 83% rename from scripts/install_curl.sh rename to scripts/install/install_curl.sh index 20033f77..b2e47481 100755 --- a/scripts/install_curl.sh +++ b/scripts/install/install_curl.sh @@ -8,8 +8,8 @@ CURL_URL="http://qmcchem.ups-tlse.fr/files/scemama/${CURL}.tar.bz2" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_docopt.sh b/scripts/install/install_docopt.sh similarity index 70% rename from scripts/install_docopt.sh rename to scripts/install/install_docopt.sh index 7edf2377..6f799c47 100755 --- a/scripts/install_docopt.sh +++ b/scripts/install/install_docopt.sh @@ -8,8 +8,8 @@ DOCOPT_URL="https://raw.githubusercontent.com/docopt/docopt/master/${DOCOPT}" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_emsl.sh b/scripts/install/install_emsl.sh similarity index 79% rename from scripts/install_emsl.sh rename to scripts/install/install_emsl.sh index dff002a1..b01afb6e 100755 --- a/scripts/install_emsl.sh +++ b/scripts/install/install_emsl.sh @@ -8,8 +8,8 @@ URL="https://github.com/LCPQ/${BASE}/archive/master.tar.gz" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_ezfio.sh b/scripts/install/install_ezfio.sh similarity index 77% rename from scripts/install_ezfio.sh rename to scripts/install/install_ezfio.sh index 0f7a6505..c0033ca8 100755 --- a/scripts/install_ezfio.sh +++ b/scripts/install/install_ezfio.sh @@ -8,8 +8,8 @@ URL="https://github.com/LCPQ/${BASE}/archive/master.tar.gz" if [[ -z ${QPACKAGE_ROOT} ]] then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." + echo "The QPACKAGE_ROOT environment variable is not set." + echo "Please reload the quantum_package.rc file." exit -1 fi diff --git a/scripts/install_irpf90.sh b/scripts/install/install_irpf90.sh similarity index 100% rename from scripts/install_irpf90.sh rename to scripts/install/install_irpf90.sh diff --git a/scripts/install_m4.sh b/scripts/install/install_m4.sh similarity index 100% rename from scripts/install_m4.sh rename to scripts/install/install_m4.sh diff --git a/scripts/install_ocaml.sh b/scripts/install/install_ocaml.sh similarity index 100% rename from scripts/install_ocaml.sh rename to scripts/install/install_ocaml.sh diff --git a/scripts/install_resultsFile.sh b/scripts/install/install_resultsFile.sh similarity index 100% rename from scripts/install_resultsFile.sh rename to scripts/install/install_resultsFile.sh diff --git a/scripts/install_zlib.sh b/scripts/install/install_zlib.sh similarity index 100% rename from scripts/install_zlib.sh rename to scripts/install/install_zlib.sh diff --git a/scripts/upgrade_ezfio.sh b/scripts/upgrade_ezfio.sh index 4a9af403..c35a2dbd 100755 --- a/scripts/upgrade_ezfio.sh +++ b/scripts/upgrade_ezfio.sh @@ -12,7 +12,7 @@ fi cd -- ${QPACKAGE_ROOT} mv -- ${QPACKAGE_ROOT}/EZFIO ${QPACKAGE_ROOT}/EZFIO.old -${QPACKAGE_ROOT}/scripts/install_ezfio.sh +${QPACKAGE_ROOT}/scripts/install/install_ezfio.sh if [[ $? -eq 0 ]] then diff --git a/scripts/upgrade_irpf90.sh b/scripts/upgrade_irpf90.sh index 5735754f..dea48014 100755 --- a/scripts/upgrade_irpf90.sh +++ b/scripts/upgrade_irpf90.sh @@ -12,7 +12,7 @@ fi cd -- ${QPACKAGE_ROOT} mv -f -- ${QPACKAGE_ROOT}/irpf90 ${QPACKAGE_ROOT}/irpf90.old -${QPACKAGE_ROOT}/scripts/install_irpf90.sh +${QPACKAGE_ROOT}/scripts/install/install_irpf90.sh if [[ $? -eq 0 ]] then diff --git a/setup_environment.sh b/setup_environment.sh index e650a273..cc6dd570 100755 --- a/setup_environment.sh +++ b/setup_environment.sh @@ -28,7 +28,7 @@ EOF source quantum_package.rc echo "${BLUE}===== Installing IRPF90 ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_irpf90.sh | tee install_irpf90.log +${QPACKAGE_ROOT}/scripts/install/install_irpf90.sh | tee install_irpf90.log if [[ ! -d ${QPACKAGE_ROOT}/irpf90 ]] then echo $RED "Error in IRPF90 installation" $BLACK @@ -49,19 +49,19 @@ fi echo "${BLUE}===== Installing Zlib ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_zlib.sh | tee install_zlib.log +${QPACKAGE_ROOT}/scripts/install/install_zlib.sh | tee install_zlib.log echo "${BLUE}===== Installing Curl ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_curl.sh | tee install_curl.log +${QPACKAGE_ROOT}/scripts/install/install_curl.sh | tee install_curl.log echo "${BLUE}===== Installing M4 ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_m4.sh | tee install_m4.log +${QPACKAGE_ROOT}/scripts/install/install_m4.sh | tee install_m4.log echo "${BLUE}===== Installing Docopt ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_docopt.sh | tee install_docopt.log +${QPACKAGE_ROOT}/scripts/install/install_docopt.sh | tee install_docopt.log echo "${BLUE}===== Installing EMSL Basis set library ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_emsl.sh | tee install_emsl.log +${QPACKAGE_ROOT}/scripts/install/install_emsl.sh | tee install_emsl.log if [[ ! -d ${QPACKAGE_ROOT}/EMSL_Basis ]] then @@ -71,7 +71,7 @@ fi echo "${BLUE}===== Installing EZFIO ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_ezfio.sh | tee install_ezfio.log +${QPACKAGE_ROOT}/scripts/install/install_ezfio.sh | tee install_ezfio.log if [[ ! -d ${QPACKAGE_ROOT}/EZFIO ]] then echo $RED "Error in EZFIO installation" $BLACK @@ -81,7 +81,7 @@ fi echo "${BLUE}===== Installing Ocaml compiler and libraries ===== ${BLACK}" rm -f -- ocaml/Qptypes.ml -${QPACKAGE_ROOT}/scripts/install_ocaml.sh | tee install_ocaml.log +${QPACKAGE_ROOT}/scripts/install/install_ocaml.sh | tee install_ocaml.log if [[ ! -f ${QPACKAGE_ROOT}/ocaml/Qptypes.ml ]] then @@ -90,7 +90,7 @@ then fi echo "${BLUE}===== Installing resultsFile Python library ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install_resultsFile.sh +${QPACKAGE_ROOT}/scripts/install/install_resultsFile.sh if [[ ! -d ${QPACKAGE_ROOT}/resultsFile ]] then echo $RED "Error in resultsFile installation" $BLACK From 281dd89c25c76fd0408da6542b9d15d00150ebcb Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 14:10:41 +0200 Subject: [PATCH 49/70] Move create script into create folder --- ocaml/Makefile | 2 +- scripts/build_modules.sh | 4 ++-- scripts/{ => create}/create_Makefile.sh | 0 scripts/{ => create}/create_Makefile_depend.sh | 0 scripts/{ => create}/create_Needed_modules.sh | 0 scripts/{ => create}/create_executables_list.sh | 0 scripts/{ => create}/create_gitignore.sh | 0 scripts/{ => create}/create_module.sh | 6 +++--- scripts/{ => create}/create_rst_templates.sh | 0 scripts/run_Makefile_common.sh | 4 ++-- src/Makefile.common | 2 +- 11 files changed, 9 insertions(+), 9 deletions(-) rename scripts/{ => create}/create_Makefile.sh (100%) rename scripts/{ => create}/create_Makefile_depend.sh (100%) rename scripts/{ => create}/create_Needed_modules.sh (100%) rename scripts/{ => create}/create_executables_list.sh (100%) rename scripts/{ => create}/create_gitignore.sh (100%) rename scripts/{ => create}/create_module.sh (88%) rename scripts/{ => create}/create_rst_templates.sh (100%) diff --git a/ocaml/Makefile b/ocaml/Makefile index eaa8e382..ce932bfc 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -35,7 +35,7 @@ default: $(ALL_TESTS) $(ALL_EXE) .gitignore executables: $(QPACKAGE_ROOT)/data/executables $(QPACKAGE_ROOT)/data/executables: - $(QPACKAGE_ROOT)/scripts/create_executables_list.sh + $(QPACKAGE_ROOT)/scripts/create/create_executables_list.sh external_libs: opam install cryptokit core diff --git a/scripts/build_modules.sh b/scripts/build_modules.sh index c3e0cda5..44c8183a 100755 --- a/scripts/build_modules.sh +++ b/scripts/build_modules.sh @@ -30,7 +30,7 @@ Build failed for module $MODULE " fi fi - ${QPACKAGE_ROOT}/scripts/create_gitignore.sh + ${QPACKAGE_ROOT}/scripts/create/create_gitignore.sh cd ${OLDPWD} done -${QPACKAGE_ROOT}/scripts/create_executables_list.sh +${QPACKAGE_ROOT}/scripts/create/create_executables_list.sh diff --git a/scripts/create_Makefile.sh b/scripts/create/create_Makefile.sh similarity index 100% rename from scripts/create_Makefile.sh rename to scripts/create/create_Makefile.sh diff --git a/scripts/create_Makefile_depend.sh b/scripts/create/create_Makefile_depend.sh similarity index 100% rename from scripts/create_Makefile_depend.sh rename to scripts/create/create_Makefile_depend.sh diff --git a/scripts/create_Needed_modules.sh b/scripts/create/create_Needed_modules.sh similarity index 100% rename from scripts/create_Needed_modules.sh rename to scripts/create/create_Needed_modules.sh diff --git a/scripts/create_executables_list.sh b/scripts/create/create_executables_list.sh similarity index 100% rename from scripts/create_executables_list.sh rename to scripts/create/create_executables_list.sh diff --git a/scripts/create_gitignore.sh b/scripts/create/create_gitignore.sh similarity index 100% rename from scripts/create_gitignore.sh rename to scripts/create/create_gitignore.sh diff --git a/scripts/create_module.sh b/scripts/create/create_module.sh similarity index 88% rename from scripts/create_module.sh rename to scripts/create/create_module.sh index dbddc3d3..90c6586b 100755 --- a/scripts/create_module.sh +++ b/scripts/create/create_module.sh @@ -117,7 +117,7 @@ debug "Module directory is created." # Create the Makefile -"${QPACKAGE_ROOT}/scripts/create_Makefile.sh" || fail "Unable to create Makefile" +"${QPACKAGE_ROOT}/scripts/create/create_Makefile.sh" || fail "Unable to create Makefile" if [[ ! -f Makefile ]] then fail "Makefile was not created" @@ -125,7 +125,7 @@ fi debug "Makefile created" # Create the NEEDED_MODULES file -"${QPACKAGE_ROOT}/scripts/create_Needed_modules.sh" ${NEEDED_MODULES} || fail "Unable to create the NEEDED_MODULES file" +"${QPACKAGE_ROOT}/scripts/create/create_Needed_modules.sh" ${NEEDED_MODULES} || fail "Unable to create the NEEDED_MODULES file" if [[ ! -f NEEDED_MODULES ]] then fail "NEEDED_MODULES was not created" @@ -135,7 +135,7 @@ debug "NEEDED_MODULES created" # Create rst templates -"${QPACKAGE_ROOT}/scripts/create_rst_templates.sh" || fail "Unable to create rst templates" +"${QPACKAGE_ROOT}/scripts/create/create_rst_templates.sh" || fail "Unable to create rst templates" # Update module list in main NEEDED_MODULES diff --git a/scripts/create_rst_templates.sh b/scripts/create/create_rst_templates.sh similarity index 100% rename from scripts/create_rst_templates.sh rename to scripts/create/create_rst_templates.sh diff --git a/scripts/run_Makefile_common.sh b/scripts/run_Makefile_common.sh index 82e898ac..153fa948 100755 --- a/scripts/run_Makefile_common.sh +++ b/scripts/run_Makefile_common.sh @@ -28,7 +28,7 @@ fi # Check if README.rst exists if [[ ! -f README.rst ]] then - ${QPACKAGE_ROOT}/scripts/create_rst_templates.sh + ${QPACKAGE_ROOT}/scripts/create/create_rst_templates.sh error " README.rst was not present, so I created a default one for you. @@ -62,7 +62,7 @@ then fi # Update Makefile.depend -${QPACKAGE_ROOT}/scripts/create_Makefile_depend.sh +${QPACKAGE_ROOT}/scripts/create/create_Makefile_depend.sh # Update EZFIO interface ${QPACKAGE_ROOT}/scripts/ezfio_interface/ei_handler.py diff --git a/src/Makefile.common b/src/Makefile.common index eddaa481..4df805ce 100644 --- a/src/Makefile.common +++ b/src/Makefile.common @@ -45,7 +45,7 @@ include irpf90.make endif .gitignore: - $(QPACKAGE_ROOT)/scripts/create_gitignore.sh + $(QPACKAGE_ROOT)/scripts/create/create_gitignore.sh # Frequent typos clena: clean From 57f2050fb8404646d3b1f6da40dd62c7d220dac9 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 14:20:08 +0200 Subject: [PATCH 50/70] Move upgrade script into upgrade folder --- scripts/run_Makefile_global.sh | 4 ++-- scripts/{ => upgrade}/upgrade_ezfio.sh | 0 scripts/{ => upgrade}/upgrade_irpf90.sh | 0 3 files changed, 2 insertions(+), 2 deletions(-) rename scripts/{ => upgrade}/upgrade_ezfio.sh (100%) rename scripts/{ => upgrade}/upgrade_irpf90.sh (100%) diff --git a/scripts/run_Makefile_global.sh b/scripts/run_Makefile_global.sh index fc9e168a..869172a2 100755 --- a/scripts/run_Makefile_global.sh +++ b/scripts/run_Makefile_global.sh @@ -52,7 +52,7 @@ ${IRPF90_VERSION}. IRPF90 version >= ${IRPF90_REQUIRED_VERSION} is required. To upgrade IRPF90, run : - ${QPACKAGE_ROOT}/scripts/upgrade_irpf90.sh + ${QPACKAGE_ROOT}/scripts/upgrade/upgrade_irpf90.sh " else info "irpf90 version is OK" @@ -75,7 +75,7 @@ then Current EZFIO version : ${EZFIO_VERSION} EZFIO version >= ${EZFIO_REQUIRED_VERSION} is required. To upgrade EZFIO, run : - ${QPACKAGE_ROOT}/scripts/upgrade_ezfio.sh + ${QPACKAGE_ROOT}/scripts/upgrade/upgrade_ezfio.sh " else info "EZFIO version is OK" diff --git a/scripts/upgrade_ezfio.sh b/scripts/upgrade/upgrade_ezfio.sh similarity index 100% rename from scripts/upgrade_ezfio.sh rename to scripts/upgrade/upgrade_ezfio.sh diff --git a/scripts/upgrade_irpf90.sh b/scripts/upgrade/upgrade_irpf90.sh similarity index 100% rename from scripts/upgrade_irpf90.sh rename to scripts/upgrade/upgrade_irpf90.sh From 5d29f3c8d9e10a93304e3bf4d23199c8a96fd827 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 14:27:32 +0200 Subject: [PATCH 51/70] Put prepare_ezfio.sh in ezfio_interface/ --- scripts/{ => ezfio_interface}/prepare_ezfio.sh | 0 scripts/run_Makefile_common.sh | 2 +- src/Makefile | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) rename scripts/{ => ezfio_interface}/prepare_ezfio.sh (100%) diff --git a/scripts/prepare_ezfio.sh b/scripts/ezfio_interface/prepare_ezfio.sh similarity index 100% rename from scripts/prepare_ezfio.sh rename to scripts/ezfio_interface/prepare_ezfio.sh diff --git a/scripts/run_Makefile_common.sh b/scripts/run_Makefile_common.sh index 153fa948..c0e88a1e 100755 --- a/scripts/run_Makefile_common.sh +++ b/scripts/run_Makefile_common.sh @@ -65,4 +65,4 @@ fi ${QPACKAGE_ROOT}/scripts/create/create_Makefile_depend.sh # Update EZFIO interface - ${QPACKAGE_ROOT}/scripts/ezfio_interface/ei_handler.py +${QPACKAGE_ROOT}/scripts/ezfio_interface/ei_handler.py diff --git a/src/Makefile b/src/Makefile index 237b3ae4..0757825b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -26,7 +26,7 @@ $(ALL_MODULES): ezfio # Define the EZFIO rules $(EZFIO): $(wildcard $(QPACKAGE_ROOT)/src/*/*.ezfio_config) $(wildcard $(QPACKAGE_ROOT)/src/*/EZFIO.cfg) - $(QPACKAGE_ROOT)/scripts/prepare_ezfio.sh + $(QPACKAGE_ROOT)/scripts/ezfio_interface/prepare_ezfio.sh cd $(EZFIO_DIR);\ export FC="$(FC)" ; export FCFLAGS="$(FCFLAGS)" ; export IRPF90="$(IRPF90)" ;\ $(MAKE) ;\ From 08aa4d2a7511fa36332c36a7acfce73b92ed8d9b Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 14:36:40 +0200 Subject: [PATCH 52/70] Add recursif path into quantum_package.rc --- setup_environment.sh | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/setup_environment.sh b/setup_environment.sh index cc6dd570..ce522099 100755 --- a/setup_environment.sh +++ b/setup_environment.sh @@ -17,8 +17,10 @@ export QPACKAGE_ROOT=\$( cd \$(dirname "\${BASH_SOURCE}") ; pwd -P ) export LD_LIBRARY_PATH="\${QPACKAGE_ROOT}"/lib:\${LD_LIBRARY_PATH} export LIBRARY_PATH="\${QPACKAGE_ROOT}"/lib:\${LIBRARY_PATH} export C_INCLUDE_PATH="\${QPACKAGE_ROOT}"/include:\${C_INCLUDE_PATH} -export PYTHONPATH=\${PYTHONPATH}:"\${QPACKAGE_ROOT}"/scripts:"\${QPACKAGE_ROOT}"/scripts/ezfio_interface -export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/scripts:"\${QPACKAGE_ROOT}"/scripts/ezfio_interface + +export PYTHONPATH=${PYTHONPATH}$(find "${QPACKAGE_ROOT}"/scripts -type d -printf ":%p") + +export PATH=${PATH}$(find "${QPACKAGE_ROOT}"/scripts -type d -printf ":%p") export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/bin export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/ocaml source "\${QPACKAGE_ROOT}"/bin/irpman &> /dev/null From 013c9b9a0d774ab061ff47babab43f143314f74d Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 14:44:14 +0200 Subject: [PATCH 53/70] Cleaning --- setup_environment.sh | 38 +++++++++++++------------------------- 1 file changed, 13 insertions(+), 25 deletions(-) diff --git a/setup_environment.sh b/setup_environment.sh index ce522099..657573c0 100755 --- a/setup_environment.sh +++ b/setup_environment.sh @@ -18,9 +18,9 @@ export LD_LIBRARY_PATH="\${QPACKAGE_ROOT}"/lib:\${LD_LIBRARY_PATH} export LIBRARY_PATH="\${QPACKAGE_ROOT}"/lib:\${LIBRARY_PATH} export C_INCLUDE_PATH="\${QPACKAGE_ROOT}"/include:\${C_INCLUDE_PATH} -export PYTHONPATH=${PYTHONPATH}$(find "${QPACKAGE_ROOT}"/scripts -type d -printf ":%p") +export PYTHONPATH=\${PYTHONPATH}\$(find "${QPACKAGE_ROOT}"/scripts -type d -printf ":%p") -export PATH=${PATH}$(find "${QPACKAGE_ROOT}"/scripts -type d -printf ":%p") +export PATH=\${PATH}\$(find "${QPACKAGE_ROOT}"/scripts -type d -printf ":%p") export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/bin export PATH=\${PATH}:"\${QPACKAGE_ROOT}"/ocaml source "\${QPACKAGE_ROOT}"/bin/irpman &> /dev/null @@ -30,40 +30,29 @@ EOF source quantum_package.rc echo "${BLUE}===== Installing IRPF90 ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_irpf90.sh | tee install_irpf90.log -if [[ ! -d ${QPACKAGE_ROOT}/irpf90 ]] -then - echo $RED "Error in IRPF90 installation" $BLACK - exit 1 -fi - -if [[ ! -x ${QPACKAGE_ROOT}/bin/irpf90 ]] -then - echo $RED "Error in IRPF90 installation" $BLACK - exit 1 -fi - -if [[ ! -x ${QPACKAGE_ROOT}/bin/irpman ]] +${QPACKAGE_ROOT}/scripts/install/install_irpf90.sh | tee ${QPACKAGE_ROOT}/install_logs/install_irpf90.log +if [[ ! -d ${QPACKAGE_ROOT}/irpf90 ]] || [[ ! -x ${QPACKAGE_ROOT}/bin/irpf90 ]] || [[ ! -x ${QPACKAGE_ROOT}/bin/irpman ]] then echo $RED "Error in IRPF90 installation" $BLACK exit 1 fi +mkdir -p ${QPACKAGE_ROOT}/install_logs echo "${BLUE}===== Installing Zlib ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_zlib.sh | tee install_zlib.log +${QPACKAGE_ROOT}/scripts/install/install_zlib.sh | tee ${QPACKAGE_ROOT}/install_logs/install_zlib.log echo "${BLUE}===== Installing Curl ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_curl.sh | tee install_curl.log +${QPACKAGE_ROOT}/scripts/install/install_curl.sh | tee ${QPACKAGE_ROOT}/install_logs/install_curl.log echo "${BLUE}===== Installing M4 ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_m4.sh | tee install_m4.log +${QPACKAGE_ROOT}/scripts/install/install_m4.sh | tee ${QPACKAGE_ROOT}/install_logs/install_m4.log echo "${BLUE}===== Installing Docopt ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_docopt.sh | tee install_docopt.log +${QPACKAGE_ROOT}/scripts/install/install_docopt.sh | tee ${QPACKAGE_ROOT}/install_logs/install_docopt.log echo "${BLUE}===== Installing EMSL Basis set library ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_emsl.sh | tee install_emsl.log +${QPACKAGE_ROOT}/scripts/install/install_emsl.sh | tee ${QPACKAGE_ROOT}/install_logs/install_emsl.log if [[ ! -d ${QPACKAGE_ROOT}/EMSL_Basis ]] then @@ -73,7 +62,7 @@ fi echo "${BLUE}===== Installing EZFIO ===== ${BLACK}" -${QPACKAGE_ROOT}/scripts/install/install_ezfio.sh | tee install_ezfio.log +${QPACKAGE_ROOT}/scripts/install/install_ezfio.sh | tee ${QPACKAGE_ROOT}/install_logs/install_ezfio.log if [[ ! -d ${QPACKAGE_ROOT}/EZFIO ]] then echo $RED "Error in EZFIO installation" $BLACK @@ -83,7 +72,7 @@ fi echo "${BLUE}===== Installing Ocaml compiler and libraries ===== ${BLACK}" rm -f -- ocaml/Qptypes.ml -${QPACKAGE_ROOT}/scripts/install/install_ocaml.sh | tee install_ocaml.log +${QPACKAGE_ROOT}/scripts/install/install_ocaml.sh | tee ${QPACKAGE_ROOT}/install_logs/install_ocaml.log if [[ ! -f ${QPACKAGE_ROOT}/ocaml/Qptypes.ml ]] then @@ -111,8 +100,7 @@ source ${QPACKAGE_ROOT}/quantum_package.rc " $BLACK -mkdir -p ${QPACKAGE_ROOT}/install_logs -mv ${QPACKAGE_ROOT}/*.log ${QPACKAGE_ROOT}/install_logs/ + if [[ $1 == "--robot" ]] ; then From acb6b7b16af7a39924c3bc204fda4dd509e9f73c Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 17:36:36 +0200 Subject: [PATCH 54/70] Add NEED_CHILDREN_MODULE to replace NEEDED_MODULES --- scripts/check_dependencies.sh | 4 +- scripts/clean_modules.sh | 2 +- .../module/only_children_to_all_genealogy.py | 108 ++++++++++++++++++ scripts/qp_include.sh | 4 +- scripts/update_README.py | 2 +- src/AOs/NEEDED_CHILDREN_MODULES | 1 + src/AOs/NEEDED_MODULES | 2 - src/AOs/README.rst | 3 - src/Bielec_integrals/NEEDED_CHILDREN_MODULES | 1 + src/Bielec_integrals/NEEDED_MODULES | 1 - src/Bielec_integrals/README.rst | 9 +- src/Bitmask/NEEDED_CHILDREN_MODULES | 1 + src/Bitmask/NEEDED_MODULES | 1 - src/Bitmask/README.rst | 6 - src/CAS_SD/NEEDED_CHILDREN_MODULES | 1 + src/CAS_SD/NEEDED_MODULES | 2 - src/CAS_SD/README.rst | 16 +-- src/CID/NEEDED_CHILDREN_MODULES | 1 + src/CID/NEEDED_MODULES | 3 - src/CID/README.rst | 13 --- src/CID_SC2_selected/NEEDED_CHILDREN_MODULES | 1 + src/CID_SC2_selected/NEEDED_MODULES | 2 - src/CID_SC2_selected/README.rst | 20 +--- src/CID_selected/NEEDED_CHILDREN_MODULES | 1 + src/CID_selected/NEEDED_MODULES | 2 - src/CID_selected/README.rst | 18 +-- src/CIS/NEEDED_CHILDREN_MODULES | 1 + src/CIS/NEEDED_MODULES | 2 - src/CIS/README.rst | 13 --- src/CISD/NEEDED_CHILDREN_MODULES | 1 + src/CISD/NEEDED_MODULES | 2 - src/CISD/README.rst | 13 --- src/CISD_SC2_selected/NEEDED_CHILDREN_MODULES | 1 + src/CISD_SC2_selected/NEEDED_MODULES | 2 - src/CISD_SC2_selected/README.rst | 18 --- src/CISD_selected/NEEDED_CHILDREN_MODULES | 1 + src/CISD_selected/NEEDED_MODULES | 2 - src/CISD_selected/README.rst | 18 +-- src/DDCI_selected/NEEDED_CHILDREN_MODULES | 1 + src/DDCI_selected/NEEDED_MODULES | 2 - src/DDCI_selected/README.rst | 16 +-- src/Determinants/NEEDED_CHILDREN_MODULES | 1 + src/Determinants/NEEDED_MODULES | 1 - src/Determinants/README.rst | 9 -- src/Electrons/NEEDED_CHILDREN_MODULES | 1 + src/Electrons/NEEDED_MODULES | 1 - src/Electrons/README.rst | 2 - .../NEEDED_CHILDREN_MODULES} | 0 src/Ezfio_files/NEEDED_MODULES | 0 src/Ezfio_files/README.rst | 1 + src/FCIdump/NEEDED_CHILDREN_MODULES | 1 + src/FCIdump/NEEDED_MODULES | 1 - src/FCIdump/README.rst | 10 -- src/Full_CI/NEEDED_CHILDREN_MODULES | 1 + src/Full_CI/NEEDED_MODULES | 2 - src/Full_CI/README.rst | 16 +-- src/Generators_CAS/NEEDED_CHILDREN_MODULES | 1 + src/Generators_CAS/NEEDED_MODULES | 1 - src/Generators_CAS/README.rst | 10 -- src/Generators_full/NEEDED_CHILDREN_MODULES | 1 + src/Generators_full/NEEDED_MODULES | 2 - src/Generators_full/README.rst | 11 -- .../NEEDED_CHILDREN_MODULES | 1 + src/Generators_restart/NEEDED_MODULES | 1 - src/Hartree_Fock/NEEDED_CHILDREN_MODULES | 1 + src/Hartree_Fock/NEEDED_MODULES | 1 - src/Hartree_Fock/README.rst | 9 -- src/MOGuess/NEEDED_CHILDREN_MODULES | 1 + src/MOGuess/NEEDED_MODULES | 1 - src/MOGuess/README.rst | 7 -- src/MOs/NEEDED_CHILDREN_MODULES | 1 + src/MOs/NEEDED_MODULES | 3 - src/MOs/README.rst | 4 - src/MP2/NEEDED_CHILDREN_MODULES | 1 + src/MP2/NEEDED_MODULES | 2 - src/MP2/README.rst | 14 --- src/MRCC/NEEDED_CHILDREN_MODULES | 1 + src/MRCC/NEEDED_MODULES | 2 - src/MRCC/README.rst | 16 +-- src/Makefile.common | 8 +- src/Molden/NEEDED_CHILDREN_MODULES | 1 + src/Molden/NEEDED_MODULES | 1 - src/Molden/README.rst | 6 - src/MonoInts/NEEDED_CHILDREN_MODULES | 1 + src/MonoInts/NEEDED_MODULES | 1 - src/MonoInts/README.rst | 6 - src/Nuclei/NEEDED_CHILDREN_MODULES | 1 + src/Nuclei/NEEDED_MODULES | 1 - src/Nuclei/README.rst | 2 - src/Output/NEEDED_CHILDREN_MODULES | 1 + src/Output/NEEDED_MODULES | 1 - src/Output/README.rst | 2 +- src/Perturbation/NEEDED_CHILDREN_MODULES | 1 + src/Perturbation/NEEDED_MODULES | 2 - src/Properties/NEEDED_CHILDREN_MODULES | 1 + src/Properties/NEEDED_MODULES | 1 - src/Selectors_full/NEEDED_CHILDREN_MODULES | 1 + src/Selectors_full/NEEDED_MODULES | 2 - src/Selectors_full/README.rst | 11 -- .../NEEDED_CHILDREN_MODULES | 1 + src/Selectors_no_sorted/NEEDED_MODULES | 1 - src/SingleRefMethod/NEEDED_CHILDREN_MODULES | 1 + src/SingleRefMethod/NEEDED_MODULES | 1 - src/Utils/NEEDED_CHILDREN_MODULES | 1 + 104 files changed, 162 insertions(+), 351 deletions(-) create mode 100755 scripts/module/only_children_to_all_genealogy.py create mode 100644 src/AOs/NEEDED_CHILDREN_MODULES delete mode 100644 src/AOs/NEEDED_MODULES create mode 100644 src/Bielec_integrals/NEEDED_CHILDREN_MODULES delete mode 100644 src/Bielec_integrals/NEEDED_MODULES create mode 100644 src/Bitmask/NEEDED_CHILDREN_MODULES delete mode 100644 src/Bitmask/NEEDED_MODULES create mode 100644 src/CAS_SD/NEEDED_CHILDREN_MODULES delete mode 100644 src/CAS_SD/NEEDED_MODULES create mode 100644 src/CID/NEEDED_CHILDREN_MODULES delete mode 100644 src/CID/NEEDED_MODULES create mode 100644 src/CID_SC2_selected/NEEDED_CHILDREN_MODULES delete mode 100644 src/CID_SC2_selected/NEEDED_MODULES create mode 100644 src/CID_selected/NEEDED_CHILDREN_MODULES delete mode 100644 src/CID_selected/NEEDED_MODULES create mode 100644 src/CIS/NEEDED_CHILDREN_MODULES delete mode 100644 src/CIS/NEEDED_MODULES create mode 100644 src/CISD/NEEDED_CHILDREN_MODULES delete mode 100644 src/CISD/NEEDED_MODULES create mode 100644 src/CISD_SC2_selected/NEEDED_CHILDREN_MODULES delete mode 100644 src/CISD_SC2_selected/NEEDED_MODULES create mode 100644 src/CISD_selected/NEEDED_CHILDREN_MODULES delete mode 100644 src/CISD_selected/NEEDED_MODULES create mode 100644 src/DDCI_selected/NEEDED_CHILDREN_MODULES delete mode 100644 src/DDCI_selected/NEEDED_MODULES create mode 100644 src/Determinants/NEEDED_CHILDREN_MODULES delete mode 100644 src/Determinants/NEEDED_MODULES create mode 100644 src/Electrons/NEEDED_CHILDREN_MODULES delete mode 100644 src/Electrons/NEEDED_MODULES rename src/{Utils/NEEDED_MODULES => Ezfio_files/NEEDED_CHILDREN_MODULES} (100%) delete mode 100644 src/Ezfio_files/NEEDED_MODULES create mode 100644 src/FCIdump/NEEDED_CHILDREN_MODULES delete mode 100644 src/FCIdump/NEEDED_MODULES create mode 100644 src/Full_CI/NEEDED_CHILDREN_MODULES delete mode 100644 src/Full_CI/NEEDED_MODULES create mode 100644 src/Generators_CAS/NEEDED_CHILDREN_MODULES delete mode 100644 src/Generators_CAS/NEEDED_MODULES create mode 100644 src/Generators_full/NEEDED_CHILDREN_MODULES delete mode 100644 src/Generators_full/NEEDED_MODULES create mode 100644 src/Generators_restart/NEEDED_CHILDREN_MODULES delete mode 100644 src/Generators_restart/NEEDED_MODULES create mode 100644 src/Hartree_Fock/NEEDED_CHILDREN_MODULES delete mode 100644 src/Hartree_Fock/NEEDED_MODULES create mode 100644 src/MOGuess/NEEDED_CHILDREN_MODULES delete mode 100644 src/MOGuess/NEEDED_MODULES create mode 100644 src/MOs/NEEDED_CHILDREN_MODULES delete mode 100644 src/MOs/NEEDED_MODULES create mode 100644 src/MP2/NEEDED_CHILDREN_MODULES delete mode 100644 src/MP2/NEEDED_MODULES create mode 100644 src/MRCC/NEEDED_CHILDREN_MODULES delete mode 100644 src/MRCC/NEEDED_MODULES create mode 100644 src/Molden/NEEDED_CHILDREN_MODULES delete mode 100644 src/Molden/NEEDED_MODULES create mode 100644 src/MonoInts/NEEDED_CHILDREN_MODULES delete mode 100644 src/MonoInts/NEEDED_MODULES create mode 100644 src/Nuclei/NEEDED_CHILDREN_MODULES delete mode 100644 src/Nuclei/NEEDED_MODULES create mode 100644 src/Output/NEEDED_CHILDREN_MODULES delete mode 100644 src/Output/NEEDED_MODULES create mode 100644 src/Perturbation/NEEDED_CHILDREN_MODULES delete mode 100644 src/Perturbation/NEEDED_MODULES create mode 100644 src/Properties/NEEDED_CHILDREN_MODULES delete mode 100644 src/Properties/NEEDED_MODULES create mode 100644 src/Selectors_full/NEEDED_CHILDREN_MODULES delete mode 100644 src/Selectors_full/NEEDED_MODULES create mode 100644 src/Selectors_no_sorted/NEEDED_CHILDREN_MODULES delete mode 100644 src/Selectors_no_sorted/NEEDED_MODULES create mode 100644 src/SingleRefMethod/NEEDED_CHILDREN_MODULES delete mode 100644 src/SingleRefMethod/NEEDED_MODULES create mode 100644 src/Utils/NEEDED_CHILDREN_MODULES diff --git a/scripts/check_dependencies.sh b/scripts/check_dependencies.sh index f21dbc40..e1149d2d 100755 --- a/scripts/check_dependencies.sh +++ b/scripts/check_dependencies.sh @@ -25,7 +25,7 @@ fi if [[ $1 == "-" ]] then - COMMAND_LINE=$(cat NEEDED_MODULES) + COMMAND_LINE=$(only_children_to_all_genealogy.py NEEDED_MODULES) else COMMAND_LINE=$(unique_list $@) fi @@ -44,7 +44,7 @@ DEPS_LONG="" for i in $COMMAND_LINE do DEPS_LONG+=" $i " - DEPS_LONG+=$(cat "${QPACKAGE_ROOT}/src/${i}/NEEDED_MODULES") + DEPS_LONG+=$(only_children_to_all_genealogy.py "${QPACKAGE_ROOT}/src/${i}/NEEDED_MODULES") done DEPS=$(unique_list $DEPS_LONG) diff --git a/scripts/clean_modules.sh b/scripts/clean_modules.sh index 452724f2..e51bbede 100755 --- a/scripts/clean_modules.sh +++ b/scripts/clean_modules.sh @@ -13,7 +13,7 @@ source ${QPACKAGE_ROOT}/scripts/qp_include.sh function do_clean() { rm -rf -- \ - IRPF90_temp IRPF90_man Makefile.depend $(cat NEEDED_MODULES) include \ + IRPF90_temp IRPF90_man Makefile.depend $(only_children_to_all_genealogy.py) include \ ezfio_interface.irp.f irpf90.make irpf90_entities tags $(ls_exe) *.mod } diff --git a/scripts/module/only_children_to_all_genealogy.py b/scripts/module/only_children_to_all_genealogy.py new file mode 100755 index 00000000..ecc6054e --- /dev/null +++ b/scripts/module/only_children_to_all_genealogy.py @@ -0,0 +1,108 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +import os +import os.path + +dir_ = '/home/razoa/quantum_package/src' + + +def get_dict_genealogy(all_children=False): + + d_ref = dict() + + for o in os.listdir(dir_): + + try: + with open(os.path.join(dir_, o, "NEEDED_CHILDREN_MODULES"), "r") as f: + l_children = f.read().split() + except IOError: + pass + else: + d_ref[o] = l_children + + if all_children: + for module in d_ref: + d_ref[module] = get_all_children(d_ref, d_ref[module], []) + + return d_ref + + +def module_children_to_all(d_ref,path): + + if not path: + dir_ = os.getcwd() + path = os.path.join(dir_, "NEEDED_CHILDREN_MODULES") + + try: + with open(path, "r") as f: + l_children = f.read().split() + except IOError: + return [] + else: + needed_module = l_children + for module in l_children: + + for children in get_all_children(d_ref, d_ref[module], []): + if children not in needed_module: + needed_module.append(children) + + return needed_module + + +def get_all_children(d_ref, l_module, l=[]): + """ + From a d_ref (who containt all the data --flatter or not-- create + an flatten list who contain all the children + """ + for module in l_module: + if module not in l: + l.append(module) + get_all_children(d_ref, d_ref[module], l) + + return list(set(l)) + + +def reduce_(d_ref, name): + + """ + Take a big list and try to find the lower parent + available + """ + import itertools + + a = sorted(get_all_children(d_ref[name])) + + for i in xrange(len(d_ref)): + for c in itertools.combinations(d_ref, i): + + l = [] + b = sorted(get_all_children(c, l)) + + if a == b: + return c + +#for i in sorted(d_ref): +# print i, reduce_(i) +# + +if __name__ == '__main__': + import sys + + try: + path = sys.argv[1] + except IndexError: + path = None + + d_ref = get_dict_genealogy() + + l_all_needed_molule = module_children_to_all(d_ref, path) + print " ".join(sorted(l_all_needed_molule)) + +# print d_ref +# +# d_ref = get_dict_genealogy(True) +# +# print d_ref +# +# module_hl_to_ll(d_ref) diff --git a/scripts/qp_include.sh b/scripts/qp_include.sh index 467baca8..04cc6a17 100644 --- a/scripts/qp_include.sh +++ b/scripts/qp_include.sh @@ -35,9 +35,9 @@ function check_current_dir_is_module() exit -1 fi } -if [[ -f NEEDED_MODULES ]] +if [[ -f NEEDED_CHILDREN_MODULES ]] then - NEEDED_MODULES=$(cat NEEDED_MODULES) + NEEDED_MODULES=$(only_children_to_all_genealogy.py) fi # List of executables in the current directory diff --git a/scripts/update_README.py b/scripts/update_README.py index 0f32404d..177d57a4 100755 --- a/scripts/update_README.py +++ b/scripts/update_README.py @@ -83,7 +83,7 @@ def update_needed(data): """Read the NEEDED_MODULES file, and replace the data with it. Create the links to the GitHub pages.""" - file = open('NEEDED_MODULES', 'r') + file = open('NEEDED_CHILDREN_MODULES', 'r') modules = file.read() file.close() diff --git a/src/AOs/NEEDED_CHILDREN_MODULES b/src/AOs/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..2c80725f --- /dev/null +++ b/src/AOs/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Nuclei diff --git a/src/AOs/NEEDED_MODULES b/src/AOs/NEEDED_MODULES deleted file mode 100644 index 9f7ccbcc..00000000 --- a/src/AOs/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -Ezfio_files Nuclei Output Utils - diff --git a/src/AOs/README.rst b/src/AOs/README.rst index f9f81f5f..1507d56c 100644 --- a/src/AOs/README.rst +++ b/src/AOs/README.rst @@ -39,10 +39,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `Ezfio_files `_ * `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/Bielec_integrals/NEEDED_CHILDREN_MODULES b/src/Bielec_integrals/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..24979463 --- /dev/null +++ b/src/Bielec_integrals/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MonoInts Bitmask diff --git a/src/Bielec_integrals/NEEDED_MODULES b/src/Bielec_integrals/NEEDED_MODULES deleted file mode 100644 index 5f709ce4..00000000 --- a/src/Bielec_integrals/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bitmask Electrons Ezfio_files MOs Nuclei Output Utils MonoInts diff --git a/src/Bielec_integrals/README.rst b/src/Bielec_integrals/README.rst index 38dc9e96..6e17f2b7 100644 --- a/src/Bielec_integrals/README.rst +++ b/src/Bielec_integrals/README.rst @@ -16,15 +16,8 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bitmask `_ -* `Electrons `_ -* `Ezfio_files `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ * `MonoInts `_ +* `Bitmask `_ Documentation ============= diff --git a/src/Bitmask/NEEDED_CHILDREN_MODULES b/src/Bitmask/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..b936db90 --- /dev/null +++ b/src/Bitmask/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MOs diff --git a/src/Bitmask/NEEDED_MODULES b/src/Bitmask/NEEDED_MODULES deleted file mode 100644 index 190f8c6e..00000000 --- a/src/Bitmask/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Electrons Ezfio_files MOs Nuclei Output Utils diff --git a/src/Bitmask/README.rst b/src/Bitmask/README.rst index b8e3aa57..395efc52 100644 --- a/src/Bitmask/README.rst +++ b/src/Bitmask/README.rst @@ -40,13 +40,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Electrons `_ -* `Ezfio_files `_ * `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/CAS_SD/NEEDED_CHILDREN_MODULES b/src/CAS_SD/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..f7264a0f --- /dev/null +++ b/src/CAS_SD/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full Generators_CAS diff --git a/src/CAS_SD/NEEDED_MODULES b/src/CAS_SD/NEEDED_MODULES deleted file mode 100644 index f20d16a0..00000000 --- a/src/CAS_SD/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_CAS Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils - diff --git a/src/CAS_SD/README.rst b/src/CAS_SD/README.rst index 0b3293d5..2e56e56e 100644 --- a/src/CAS_SD/README.rst +++ b/src/CAS_SD/README.rst @@ -24,21 +24,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Generators_CAS `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ * `Selectors_full `_ -* `Utils `_ +* `Generators_CAS `_ diff --git a/src/CID/NEEDED_CHILDREN_MODULES b/src/CID/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..afc8cfd4 --- /dev/null +++ b/src/CID/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Selectors_full SingleRefMethod diff --git a/src/CID/NEEDED_MODULES b/src/CID/NEEDED_MODULES deleted file mode 100644 index f7a1831f..00000000 --- a/src/CID/NEEDED_MODULES +++ /dev/null @@ -1,3 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils - - diff --git a/src/CID/README.rst b/src/CID/README.rst index 47cbc40b..5d2fa851 100644 --- a/src/CID/README.rst +++ b/src/CID/README.rst @@ -15,21 +15,8 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Selectors_full `_ * `SingleRefMethod `_ -* `Utils `_ Documentation ============= diff --git a/src/CID_SC2_selected/NEEDED_CHILDREN_MODULES b/src/CID_SC2_selected/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..7be053d7 --- /dev/null +++ b/src/CID_SC2_selected/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +CID_selected diff --git a/src/CID_SC2_selected/NEEDED_MODULES b/src/CID_SC2_selected/NEEDED_MODULES deleted file mode 100644 index 67f77e87..00000000 --- a/src/CID_SC2_selected/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask CISD CISD_selected Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils - diff --git a/src/CID_SC2_selected/README.rst b/src/CID_SC2_selected/README.rst index 37680ebb..ec9e7a3f 100644 --- a/src/CID_SC2_selected/README.rst +++ b/src/CID_SC2_selected/README.rst @@ -19,23 +19,5 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `CISD `_ -* `CISD_selected `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Perturbation `_ -* `Properties `_ -* `Selectors_full `_ -* `SingleRefMethod `_ -* `Utils `_ +* `CID_selected `_ diff --git a/src/CID_selected/NEEDED_CHILDREN_MODULES b/src/CID_selected/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..1e0c52c2 --- /dev/null +++ b/src/CID_selected/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation CID diff --git a/src/CID_selected/NEEDED_MODULES b/src/CID_selected/NEEDED_MODULES deleted file mode 100644 index ca89c5f3..00000000 --- a/src/CID_selected/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask CISD Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils - diff --git a/src/CID_selected/README.rst b/src/CID_selected/README.rst index d8f054ac..50cc701f 100644 --- a/src/CID_selected/README.rst +++ b/src/CID_selected/README.rst @@ -22,22 +22,6 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `CISD `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ -* `Selectors_full `_ -* `SingleRefMethod `_ -* `Utils `_ +* `CID `_ diff --git a/src/CIS/NEEDED_CHILDREN_MODULES b/src/CIS/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..afc8cfd4 --- /dev/null +++ b/src/CIS/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Selectors_full SingleRefMethod diff --git a/src/CIS/NEEDED_MODULES b/src/CIS/NEEDED_MODULES deleted file mode 100644 index 5cdee2e5..00000000 --- a/src/CIS/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils - diff --git a/src/CIS/README.rst b/src/CIS/README.rst index 59558a31..e3b2478a 100644 --- a/src/CIS/README.rst +++ b/src/CIS/README.rst @@ -31,19 +31,6 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Selectors_full `_ * `SingleRefMethod `_ -* `Utils `_ diff --git a/src/CISD/NEEDED_CHILDREN_MODULES b/src/CISD/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..afc8cfd4 --- /dev/null +++ b/src/CISD/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Selectors_full SingleRefMethod diff --git a/src/CISD/NEEDED_MODULES b/src/CISD/NEEDED_MODULES deleted file mode 100644 index 5cdee2e5..00000000 --- a/src/CISD/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Selectors_full SingleRefMethod Utils - diff --git a/src/CISD/README.rst b/src/CISD/README.rst index bcf7aee2..68ab4cfb 100644 --- a/src/CISD/README.rst +++ b/src/CISD/README.rst @@ -15,21 +15,8 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Selectors_full `_ * `SingleRefMethod `_ -* `Utils `_ Documentation ============= diff --git a/src/CISD_SC2_selected/NEEDED_CHILDREN_MODULES b/src/CISD_SC2_selected/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..fa61747b --- /dev/null +++ b/src/CISD_SC2_selected/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +CISD_selected diff --git a/src/CISD_SC2_selected/NEEDED_MODULES b/src/CISD_SC2_selected/NEEDED_MODULES deleted file mode 100644 index 67f77e87..00000000 --- a/src/CISD_SC2_selected/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask CISD CISD_selected Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils - diff --git a/src/CISD_SC2_selected/README.rst b/src/CISD_SC2_selected/README.rst index 915c85f1..b4f4fac1 100644 --- a/src/CISD_SC2_selected/README.rst +++ b/src/CISD_SC2_selected/README.rst @@ -19,23 +19,5 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `CISD `_ * `CISD_selected `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Perturbation `_ -* `Properties `_ -* `Selectors_full `_ -* `SingleRefMethod `_ -* `Utils `_ diff --git a/src/CISD_selected/NEEDED_CHILDREN_MODULES b/src/CISD_selected/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..2b104007 --- /dev/null +++ b/src/CISD_selected/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation CISD diff --git a/src/CISD_selected/NEEDED_MODULES b/src/CISD_selected/NEEDED_MODULES deleted file mode 100644 index ca89c5f3..00000000 --- a/src/CISD_selected/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask CISD Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils - diff --git a/src/CISD_selected/README.rst b/src/CISD_selected/README.rst index e2b6989e..a72c5a21 100644 --- a/src/CISD_selected/README.rst +++ b/src/CISD_selected/README.rst @@ -28,22 +28,6 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `CISD `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ -* `Selectors_full `_ -* `SingleRefMethod `_ -* `Utils `_ +* `CISD `_ diff --git a/src/DDCI_selected/NEEDED_CHILDREN_MODULES b/src/DDCI_selected/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..f7264a0f --- /dev/null +++ b/src/DDCI_selected/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full Generators_CAS diff --git a/src/DDCI_selected/NEEDED_MODULES b/src/DDCI_selected/NEEDED_MODULES deleted file mode 100644 index f20d16a0..00000000 --- a/src/DDCI_selected/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_CAS Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils - diff --git a/src/DDCI_selected/README.rst b/src/DDCI_selected/README.rst index 2b5823c7..9cfdbefa 100644 --- a/src/DDCI_selected/README.rst +++ b/src/DDCI_selected/README.rst @@ -19,21 +19,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Generators_CAS `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ * `Selectors_full `_ -* `Utils `_ +* `Generators_CAS `_ diff --git a/src/Determinants/NEEDED_CHILDREN_MODULES b/src/Determinants/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..afc397de --- /dev/null +++ b/src/Determinants/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Bielec_integrals diff --git a/src/Determinants/NEEDED_MODULES b/src/Determinants/NEEDED_MODULES deleted file mode 100644 index 824c75ed..00000000 --- a/src/Determinants/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst index 445c8b5e..039238c8 100644 --- a/src/Determinants/README.rst +++ b/src/Determinants/README.rst @@ -32,16 +32,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ * `Bielec_integrals `_ -* `Bitmask `_ -* `Electrons `_ -* `Ezfio_files `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/Electrons/NEEDED_CHILDREN_MODULES b/src/Electrons/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..83260f86 --- /dev/null +++ b/src/Electrons/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Output diff --git a/src/Electrons/NEEDED_MODULES b/src/Electrons/NEEDED_MODULES deleted file mode 100644 index e9594555..00000000 --- a/src/Electrons/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -Ezfio_files Output Utils diff --git a/src/Electrons/README.rst b/src/Electrons/README.rst index ffd6d21b..e71a552d 100644 --- a/src/Electrons/README.rst +++ b/src/Electrons/README.rst @@ -24,9 +24,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `Ezfio_files `_ * `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/Utils/NEEDED_MODULES b/src/Ezfio_files/NEEDED_CHILDREN_MODULES similarity index 100% rename from src/Utils/NEEDED_MODULES rename to src/Ezfio_files/NEEDED_CHILDREN_MODULES diff --git a/src/Ezfio_files/NEEDED_MODULES b/src/Ezfio_files/NEEDED_MODULES deleted file mode 100644 index e69de29b..00000000 diff --git a/src/Ezfio_files/README.rst b/src/Ezfio_files/README.rst index 274eff11..e0ef23da 100644 --- a/src/Ezfio_files/README.rst +++ b/src/Ezfio_files/README.rst @@ -30,3 +30,4 @@ Documentation + diff --git a/src/FCIdump/NEEDED_CHILDREN_MODULES b/src/FCIdump/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/src/FCIdump/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/src/FCIdump/NEEDED_MODULES b/src/FCIdump/NEEDED_MODULES deleted file mode 100644 index c5e6c2d3..00000000 --- a/src/FCIdump/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/FCIdump/README.rst b/src/FCIdump/README.rst index bf39955b..8a467b16 100644 --- a/src/FCIdump/README.rst +++ b/src/FCIdump/README.rst @@ -21,15 +21,5 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ * `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ diff --git a/src/Full_CI/NEEDED_CHILDREN_MODULES b/src/Full_CI/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..04ce9e78 --- /dev/null +++ b/src/Full_CI/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full Generators_full diff --git a/src/Full_CI/NEEDED_MODULES b/src/Full_CI/NEEDED_MODULES deleted file mode 100644 index f225090c..00000000 --- a/src/Full_CI/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_full Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils - diff --git a/src/Full_CI/README.rst b/src/Full_CI/README.rst index 53fdc1d5..51bb05d2 100644 --- a/src/Full_CI/README.rst +++ b/src/Full_CI/README.rst @@ -24,21 +24,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Generators_full `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ * `Selectors_full `_ -* `Utils `_ +* `Generators_full `_ diff --git a/src/Generators_CAS/NEEDED_CHILDREN_MODULES b/src/Generators_CAS/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/src/Generators_CAS/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/src/Generators_CAS/NEEDED_MODULES b/src/Generators_CAS/NEEDED_MODULES deleted file mode 100644 index c5e6c2d3..00000000 --- a/src/Generators_CAS/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Generators_CAS/README.rst b/src/Generators_CAS/README.rst index 3fca0916..b729212c 100644 --- a/src/Generators_CAS/README.rst +++ b/src/Generators_CAS/README.rst @@ -43,15 +43,5 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ * `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ diff --git a/src/Generators_full/NEEDED_CHILDREN_MODULES b/src/Generators_full/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..54f54203 --- /dev/null +++ b/src/Generators_full/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Hartree_Fock diff --git a/src/Generators_full/NEEDED_MODULES b/src/Generators_full/NEEDED_MODULES deleted file mode 100644 index a848a687..00000000 --- a/src/Generators_full/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Utils - diff --git a/src/Generators_full/README.rst b/src/Generators_full/README.rst index 79f4037c..e558f48b 100644 --- a/src/Generators_full/README.rst +++ b/src/Generators_full/README.rst @@ -40,17 +40,6 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ * `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ * `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ diff --git a/src/Generators_restart/NEEDED_CHILDREN_MODULES b/src/Generators_restart/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/src/Generators_restart/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/src/Generators_restart/NEEDED_MODULES b/src/Generators_restart/NEEDED_MODULES deleted file mode 100644 index c5e6c2d3..00000000 --- a/src/Generators_restart/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Hartree_Fock/NEEDED_CHILDREN_MODULES b/src/Hartree_Fock/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..b779faec --- /dev/null +++ b/src/Hartree_Fock/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Bielec_integrals MOGuess diff --git a/src/Hartree_Fock/NEEDED_MODULES b/src/Hartree_Fock/NEEDED_MODULES deleted file mode 100644 index 8f7f21c6..00000000 --- a/src/Hartree_Fock/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Electrons Ezfio_files MonoInts MOGuess MOs Nuclei Output Utils diff --git a/src/Hartree_Fock/README.rst b/src/Hartree_Fock/README.rst index a1030e4a..2b470e9f 100644 --- a/src/Hartree_Fock/README.rst +++ b/src/Hartree_Fock/README.rst @@ -10,17 +10,8 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ * `Bielec_integrals `_ -* `Bitmask `_ -* `Electrons `_ -* `Ezfio_files `_ -* `MonoInts `_ * `MOGuess `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/MOGuess/NEEDED_CHILDREN_MODULES b/src/MOGuess/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..88d7352e --- /dev/null +++ b/src/MOGuess/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MonoInts diff --git a/src/MOGuess/NEEDED_MODULES b/src/MOGuess/NEEDED_MODULES deleted file mode 100644 index 59b334d4..00000000 --- a/src/MOGuess/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/MOGuess/README.rst b/src/MOGuess/README.rst index cb1702ab..771825ee 100644 --- a/src/MOGuess/README.rst +++ b/src/MOGuess/README.rst @@ -8,14 +8,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Electrons `_ -* `Ezfio_files `_ * `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/MOs/NEEDED_CHILDREN_MODULES b/src/MOs/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..4692ec21 --- /dev/null +++ b/src/MOs/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +AOs Electrons diff --git a/src/MOs/NEEDED_MODULES b/src/MOs/NEEDED_MODULES deleted file mode 100644 index 5ca73603..00000000 --- a/src/MOs/NEEDED_MODULES +++ /dev/null @@ -1,3 +0,0 @@ -AOs Electrons Ezfio_files Nuclei Output Utils - - diff --git a/src/MOs/README.rst b/src/MOs/README.rst index d7a15219..78d3d96e 100644 --- a/src/MOs/README.rst +++ b/src/MOs/README.rst @@ -24,10 +24,6 @@ Needed Modules * `AOs `_ * `Electrons `_ -* `Ezfio_files `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/MP2/NEEDED_CHILDREN_MODULES b/src/MP2/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..d26e4dee --- /dev/null +++ b/src/MP2/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full SingleRefMethod diff --git a/src/MP2/NEEDED_MODULES b/src/MP2/NEEDED_MODULES deleted file mode 100644 index b7a006c3..00000000 --- a/src/MP2/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full SingleRefMethod Utils - diff --git a/src/MP2/README.rst b/src/MP2/README.rst index 74db8039..f68d5936 100644 --- a/src/MP2/README.rst +++ b/src/MP2/README.rst @@ -19,21 +19,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ * `Selectors_full `_ * `SingleRefMethod `_ -* `Utils `_ diff --git a/src/MRCC/NEEDED_CHILDREN_MODULES b/src/MRCC/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..04ce9e78 --- /dev/null +++ b/src/MRCC/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full Generators_full diff --git a/src/MRCC/NEEDED_MODULES b/src/MRCC/NEEDED_MODULES deleted file mode 100644 index f225090c..00000000 --- a/src/MRCC/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Generators_full Hartree_Fock MOGuess MonoInts MOs Nuclei Output Perturbation Properties Selectors_full Utils - diff --git a/src/MRCC/README.rst b/src/MRCC/README.rst index f96f329f..38137667 100644 --- a/src/MRCC/README.rst +++ b/src/MRCC/README.rst @@ -8,23 +8,9 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ -* `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ -* `Generators_full `_ -* `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ * `Perturbation `_ -* `Properties `_ * `Selectors_full `_ -* `Utils `_ +* `Generators_full `_ Documentation ============= diff --git a/src/Makefile.common b/src/Makefile.common index 4df805ce..cd98329e 100644 --- a/src/Makefile.common +++ b/src/Makefile.common @@ -18,8 +18,8 @@ default: all .gitignore # Include the user's config include $(QPACKAGE_ROOT)/src/Makefile.config -# Create the NEEDED_MODULES variable, needed for IRPF90 -NEEDED_MODULES=$(shell cat NEEDED_MODULES) +# Create the NEEDED_CHILDREN_MODULES variable, needed for IRPF90 +NEEDED_CHILDREN_MODULES=$(shell only_children_to_all_genealogy.py) # Check and update dependencies include Makefile.depend @@ -28,7 +28,7 @@ include Makefile.depend # Define the Makefile common variables EZFIO_DIR=$(QPACKAGE_ROOT)/EZFIO EZFIO=$(EZFIO_DIR)/lib/libezfio_irp.a -INCLUDE_DIRS=$(NEEDED_MODULES) include +INCLUDE_DIRS=$(NEEDED_CHILDREN_MODULES) include clean_links: rm -f $(INCLUDE_DIRS) $$(basename $$PWD) @@ -36,7 +36,7 @@ clean_links: LIB+=$(EZFIO) $(MKL) IRPF90+=$(patsubst %, -I %, $(INCLUDE_DIRS)) $(IRPF90_FLAGS) -irpf90.make: $(filter-out IRPF90_temp/%, $(wildcard */*.irp.f)) $(wildcard *.irp.f) $(wildcard *.inc.f) Makefile $(EZFIO) NEEDED_MODULES $(wildcard *.py) +irpf90.make: $(filter-out IRPF90_temp/%, $(wildcard */*.irp.f)) $(wildcard *.irp.f) $(wildcard *.inc.f) Makefile $(EZFIO) NEEDED_CHILDREN_MODULES $(wildcard *.py) - $(IRPF90) - update_README.py diff --git a/src/Molden/NEEDED_CHILDREN_MODULES b/src/Molden/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..b936db90 --- /dev/null +++ b/src/Molden/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MOs diff --git a/src/Molden/NEEDED_MODULES b/src/Molden/NEEDED_MODULES deleted file mode 100644 index 190f8c6e..00000000 --- a/src/Molden/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Electrons Ezfio_files MOs Nuclei Output Utils diff --git a/src/Molden/README.rst b/src/Molden/README.rst index d0e2343d..128a020a 100644 --- a/src/Molden/README.rst +++ b/src/Molden/README.rst @@ -31,11 +31,5 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Electrons `_ -* `Ezfio_files `_ * `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ diff --git a/src/MonoInts/NEEDED_CHILDREN_MODULES b/src/MonoInts/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..b936db90 --- /dev/null +++ b/src/MonoInts/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MOs diff --git a/src/MonoInts/NEEDED_MODULES b/src/MonoInts/NEEDED_MODULES deleted file mode 100644 index 67230c44..00000000 --- a/src/MonoInts/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Electrons Ezfio_files MOs Nuclei Output Utils diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index fdbb086b..6ac65919 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -4,13 +4,7 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Electrons `_ -* `Ezfio_files `_ * `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ Documentation ============= diff --git a/src/Nuclei/NEEDED_CHILDREN_MODULES b/src/Nuclei/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..83260f86 --- /dev/null +++ b/src/Nuclei/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Output diff --git a/src/Nuclei/NEEDED_MODULES b/src/Nuclei/NEEDED_MODULES deleted file mode 100644 index 516a2a11..00000000 --- a/src/Nuclei/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -Ezfio_files Utils Output diff --git a/src/Nuclei/README.rst b/src/Nuclei/README.rst index b21d02ee..aaad706d 100644 --- a/src/Nuclei/README.rst +++ b/src/Nuclei/README.rst @@ -12,8 +12,6 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `Ezfio_files `_ -* `Utils `_ * `Output `_ Documentation diff --git a/src/Output/NEEDED_CHILDREN_MODULES b/src/Output/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..dcdb5f86 --- /dev/null +++ b/src/Output/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Ezfio_files Utils diff --git a/src/Output/NEEDED_MODULES b/src/Output/NEEDED_MODULES deleted file mode 100644 index f684b5aa..00000000 --- a/src/Output/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -Utils Ezfio_files diff --git a/src/Output/README.rst b/src/Output/README.rst index 7b510fc1..5fe93f50 100644 --- a/src/Output/README.rst +++ b/src/Output/README.rst @@ -31,8 +31,8 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `Utils `_ * `Ezfio_files `_ +* `Utils `_ Documentation ============= diff --git a/src/Perturbation/NEEDED_CHILDREN_MODULES b/src/Perturbation/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..e29a6721 --- /dev/null +++ b/src/Perturbation/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Properties Hartree_Fock diff --git a/src/Perturbation/NEEDED_MODULES b/src/Perturbation/NEEDED_MODULES deleted file mode 100644 index 4e0f218e..00000000 --- a/src/Perturbation/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Properties Utils - diff --git a/src/Properties/NEEDED_CHILDREN_MODULES b/src/Properties/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/src/Properties/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/src/Properties/NEEDED_MODULES b/src/Properties/NEEDED_MODULES deleted file mode 100644 index 62dbbe42..00000000 --- a/src/Properties/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/Selectors_full/NEEDED_CHILDREN_MODULES b/src/Selectors_full/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..54f54203 --- /dev/null +++ b/src/Selectors_full/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Hartree_Fock diff --git a/src/Selectors_full/NEEDED_MODULES b/src/Selectors_full/NEEDED_MODULES deleted file mode 100644 index a848a687..00000000 --- a/src/Selectors_full/NEEDED_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files Hartree_Fock MOGuess MonoInts MOs Nuclei Output Utils - diff --git a/src/Selectors_full/README.rst b/src/Selectors_full/README.rst index 2ca9380a..11286fce 100644 --- a/src/Selectors_full/README.rst +++ b/src/Selectors_full/README.rst @@ -165,17 +165,6 @@ Needed Modules .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -* `AOs `_ -* `Bielec_integrals `_ -* `Bitmask `_ * `Determinants `_ -* `Electrons `_ -* `Ezfio_files `_ * `Hartree_Fock `_ -* `MOGuess `_ -* `MonoInts `_ -* `MOs `_ -* `Nuclei `_ -* `Output `_ -* `Utils `_ diff --git a/src/Selectors_no_sorted/NEEDED_CHILDREN_MODULES b/src/Selectors_no_sorted/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/src/Selectors_no_sorted/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/src/Selectors_no_sorted/NEEDED_MODULES b/src/Selectors_no_sorted/NEEDED_MODULES deleted file mode 100644 index c5e6c2d3..00000000 --- a/src/Selectors_no_sorted/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bielec_integrals Bitmask Determinants Electrons Ezfio_files MonoInts MOs Nuclei Output Utils diff --git a/src/SingleRefMethod/NEEDED_CHILDREN_MODULES b/src/SingleRefMethod/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..bf459a13 --- /dev/null +++ b/src/SingleRefMethod/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Bitmask diff --git a/src/SingleRefMethod/NEEDED_MODULES b/src/SingleRefMethod/NEEDED_MODULES deleted file mode 100644 index bdcbdf7d..00000000 --- a/src/SingleRefMethod/NEEDED_MODULES +++ /dev/null @@ -1 +0,0 @@ -AOs Bitmask Electrons Ezfio_files MOs Nuclei Output Utils diff --git a/src/Utils/NEEDED_CHILDREN_MODULES b/src/Utils/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/src/Utils/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ + From 03af3bcf7302d52206c33fc91cc2a3963bcb5b86 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 30 Apr 2015 20:31:27 +0200 Subject: [PATCH 55/70] Update only_chidren_to_all_genealogy.py with relative path --- scripts/module/only_children_to_all_genealogy.py | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/module/only_children_to_all_genealogy.py b/scripts/module/only_children_to_all_genealogy.py index ecc6054e..f44d37d4 100755 --- a/scripts/module/only_children_to_all_genealogy.py +++ b/scripts/module/only_children_to_all_genealogy.py @@ -4,11 +4,11 @@ import os import os.path -dir_ = '/home/razoa/quantum_package/src' - - def get_dict_genealogy(all_children=False): + qpackage_root = os.environ['QPACKAGE_ROOT'] + dir_ = os.path.join(qpackage_root,'src') + d_ref = dict() for o in os.listdir(dir_): From a531fa6b298481d1111418fb37ef512d5e2c8371 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Sat, 2 May 2015 12:39:09 +0200 Subject: [PATCH 56/70] Add Pseudo_integrals folder --- scripts/get_basis.sh | 7 +- scripts/pseudo/create_ez.sh | 12 -- src/MonoInts/Makefile | 4 +- src/MonoInts/NEEDED_CHILDREN_MODULES | 2 +- src/MonoInts/README.rst | 62 ++---- src/MonoInts/pot_ao_ints.irp.f | 177 +--------------- src/MonoInts/test_michel.irp.f | 200 ------------------ src/NEEDED_MODULES | 2 +- src/Pseudo_integrals/ASSUMPTIONS.rst | 0 src/Pseudo_integrals/Makefile | 6 + src/Pseudo_integrals/NEEDED_CHILDREN_MODULES | 1 + src/Pseudo_integrals/README.rst | 28 +++ src/{MonoInts => Pseudo_integrals}/int.f90 | 0 src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f | 178 ++++++++++++++++ .../pseudo.ezfio_config | 0 src/Utils/README.rst | 33 +++ src/{MonoInts => Utils}/need.irp.f | 0 17 files changed, 269 insertions(+), 443 deletions(-) delete mode 100755 scripts/pseudo/create_ez.sh delete mode 100644 src/MonoInts/test_michel.irp.f create mode 100644 src/Pseudo_integrals/ASSUMPTIONS.rst create mode 100644 src/Pseudo_integrals/Makefile create mode 100644 src/Pseudo_integrals/NEEDED_CHILDREN_MODULES create mode 100644 src/Pseudo_integrals/README.rst rename src/{MonoInts => Pseudo_integrals}/int.f90 (100%) create mode 100644 src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f rename src/{MonoInts => Pseudo_integrals}/pseudo.ezfio_config (100%) rename src/{MonoInts => Utils}/need.irp.f (100%) diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index 7cfe8305..af493a3f 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -43,8 +43,5 @@ then exit 1 fi - - -#${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" - -${EMSL_API_ROOT}/EMSL_api.py get_basis_data --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" \ No newline at end of file +${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" +#${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" \ No newline at end of file diff --git a/scripts/pseudo/create_ez.sh b/scripts/pseudo/create_ez.sh deleted file mode 100755 index 65c12c5e..00000000 --- a/scripts/pseudo/create_ez.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/bash -# $1 name -# $2 mult - -echo "name" $1 -echo "basis" $2 -echo "mul" $3 -echo "\`get_basis.sh\` need to be changed" - -rm -R $1.ezfio -qp_create_ezfio_from_xyz $1.xyz -b $2 -m $3 -~/quantum_package/scripts/pseudo/put_pseudo_in_ezfio.py $1.ezfio \ No newline at end of file diff --git a/src/MonoInts/Makefile b/src/MonoInts/Makefile index 8ae5c9fb..b1f3b02c 100644 --- a/src/MonoInts/Makefile +++ b/src/MonoInts/Makefile @@ -1,6 +1,6 @@ # Define here all new external source files and objects.Don't forget to prefix the # object files with IRPF90_temp/ -SRC=int.f90 -OBJ=IRPF90_temp/int.o +SRC= +OBJ= include $(QPACKAGE_ROOT)/src/Makefile.common \ No newline at end of file diff --git a/src/MonoInts/NEEDED_CHILDREN_MODULES b/src/MonoInts/NEEDED_CHILDREN_MODULES index b936db90..be46a359 100644 --- a/src/MonoInts/NEEDED_CHILDREN_MODULES +++ b/src/MonoInts/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MOs +MOs Pseudo_integrals diff --git a/src/MonoInts/README.rst b/src/MonoInts/README.rst index 80bba2b0..ac4983a9 100644 --- a/src/MonoInts/README.rst +++ b/src/MonoInts/README.rst @@ -5,6 +5,7 @@ Needed Modules .. NEEDED_MODULES file. * `MOs `_ +* `Pseudo_integrals `_ Documentation ============= @@ -57,80 +58,44 @@ Documentation array of the mono electronic hamiltonian on the MOs basis : sum of the kinetic and nuclear electronic potential -`a_coef `_ - Undocumented - -`b_coef `_ - Undocumented - -`ddfact2 `_ - Undocumented - -`erf0 `_ - Undocumented - -`gammln `_ - Undocumented - -`gammp `_ - Undocumented - -`gcf `_ - Undocumented - -`gser `_ - Undocumented - -`rinteg `_ - Undocumented - -`rintgauss `_ - Undocumented - -`sabpartial `_ - Undocumented - `orthonormalize_mos `_ Undocumented `ao_nucl_elec_integral `_ interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom -`ao_nucl_elec_integral_pseudo `_ - interaction nuclear electron - -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented `mo_nucl_elec_integral `_ @@ -251,8 +216,5 @@ Documentation array of the integrals of MO_i * y^2 MO_j array of the integrals of MO_i * z^2 MO_j -`compute_integrals_pseudo `_ - Undocumented - diff --git a/src/MonoInts/pot_ao_ints.irp.f b/src/MonoInts/pot_ao_ints.irp.f index da9f1d68..87c66629 100644 --- a/src/MonoInts/pot_ao_ints.irp.f +++ b/src/MonoInts/pot_ao_ints.irp.f @@ -10,7 +10,11 @@ integer :: i,j,k,l,n_pt_in,m double precision ::overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult - ao_nucl_elec_integral = ao_nucl_elec_integral_pseudo ! 0.d0 + if (do_pseudo.eqv..TRUE.) then + ao_nucl_elec_integral = ao_nucl_elec_integral_pseudo + else + ao_nucl_elec_integral = 0.d0 + endif ! _ ! /| / |_) @@ -69,177 +73,6 @@ END_PROVIDER - BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral_pseudo, (ao_num_align,ao_num)] - BEGIN_DOC -! interaction nuclear electron - END_DOC - implicit none - double precision :: alpha, beta, gama, delta - integer :: num_A,num_B - double precision :: A_center(3),B_center(3),C_center(3) - integer :: power_A(3),power_B(3) - integer :: i,j,k,l,n_pt_in,m - double precision :: Vloc, Vpseudo - - double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 - integer :: thread_num - - ao_nucl_elec_integral_pseudo = 0.d0 - - ! - ! | _ _ _. | - ! |_ (_) (_ (_| | - ! - !! Parameters of the local part of pseudo: - - integer klocmax - integer, allocatable :: n_k(:,:) - double precision, allocatable :: v_k(:,:), dz_k(:,:) - - call ezfio_get_pseudo_klocmax(klocmax) - - allocate(n_k(nucl_num,klocmax),v_k(nucl_num,klocmax), dz_k(nucl_num,klocmax)) - - call ezfio_get_pseudo_v_k(v_k) - call ezfio_get_pseudo_n_k(n_k) - call ezfio_get_pseudo_dz_k(dz_k) - - !! Dump array - integer, allocatable :: n_k_dump(:) - double precision, allocatable :: v_k_dump(:), dz_k_dump(:) - - allocate(n_k_dump(1:klocmax), v_k_dump(1:klocmax), dz_k_dump(1:klocmax)) - - - ! - ! |\ | _ ._ | _ _ _. | - ! | \| (_) | | | (_) (_ (_| | - ! - !! Parameters of non local part of pseudo: - - integer :: kmax,lmax - integer, allocatable :: n_kl(:,:,:) - double precision, allocatable :: v_kl(:,:,:), dz_kl(:,:,:) - - call ezfio_get_pseudo_lmaxpo(lmax) - call ezfio_get_pseudo_kmax(kmax) - !lmax plus one -> lmax - lmax = lmax - 1 - - allocate(n_kl(nucl_num,kmax,0:lmax), v_kl(nucl_num,kmax,0:lmax), dz_kl(nucl_num,kmax,0:lmax)) - - call ezfio_get_pseudo_n_kl(n_kl) - call ezfio_get_pseudo_v_kl(v_kl) - call ezfio_get_pseudo_dz_kl(dz_kl) - - - !! Dump array - integer, allocatable :: n_kl_dump(:,:) - double precision, allocatable :: v_kl_dump(:,:), dz_kl_dump(:,:) - - allocate(n_kl_dump(kmax,0:lmax), v_kl_dump(kmax,0:lmax), dz_kl_dump(kmax,0:lmax)) - - ! _ - ! / _. | _ | - ! \_ (_| | (_ |_| | - ! - - write(output_monoints,*) 'Providing the nuclear electron pseudo integrals ' - - call wall_time(wall_1) - call cpu_time(cpu_1) - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & - !$OMP num_A,num_B,Z,c,n_pt_in, & - !$OMP v_k_dump,n_k_dump, dz_k_dump, n_kl_dump, v_kl_dump, dz_kl_dump, & - !$OMP wall_0,wall_2,thread_num, output_monoints) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & - !$OMP n_pt_max_integrals,ao_nucl_elec_integral_pseudo,nucl_num,nucl_charge, & - !$OMP klocmax,lmax,kmax,v_k,n_k, dz_k, n_kl, v_kl, dz_kl, & - !$OMP wall_1) - - n_pt_in = n_pt_max_integrals - - !$OMP DO SCHEDULE (guided) - - do j = 1, ao_num - - num_A = ao_nucl(j) - power_A(1:3)= ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - - num_B = ao_nucl(i) - power_B(1:3)= ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l=1,ao_prim_num(j) - alpha = ao_expo_transp(l,j) - - do m=1,ao_prim_num(i) - beta = ao_expo_transp(m,i) - double precision :: c - c = 0.d0 - - do k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) - - C_center(1:3) = nucl_coord(k,1:3) - - v_k_dump = v_k(k,1:klocmax) - n_k_dump = n_k(k,1:klocmax) - dz_k_dump = dz_k(k,1:klocmax) - - c = c + Vloc(klocmax, v_k_dump,n_k_dump, dz_k_dump, & - A_center,power_A,alpha,B_center,power_B,beta,C_center) - - - n_kl_dump = n_kl(k,1:kmax,0:lmax) - v_kl_dump = v_kl(k,1:kmax,0:lmax) - dz_kl_dump = dz_kl(k,1:kmax,0:lmax) - - c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) - - enddo - ao_nucl_elec_integral_pseudo(i,j) = ao_nucl_elec_integral_pseudo(i,j) + & - ao_coef_transp(l,j)*ao_coef_transp(m,i)*c - enddo - enddo - enddo - - call wall_time(wall_2) - if (thread_num == 0) then - if (wall_2 - wall_0 > 1.d0) then - wall_0 = wall_2 - write(output_monoints,*) 100.*float(j)/float(ao_num), '% in ', & - wall_2-wall_1, 's' - endif - endif - enddo - - !$OMP END DO - !$OMP END PARALLEL - - -! _ -! | \ _ _. | | _ _ _. _|_ _ -! |_/ (/_ (_| | | (_) (_ (_| |_ (/_ -! - - deallocate(n_k,v_k, dz_k) - deallocate(n_k_dump,v_k_dump, dz_k_dump) - - deallocate(n_kl,v_kl, dz_kl) - deallocate(n_kl_dump,v_kl_dump, dz_kl_dump) - - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral_per_atom, (ao_num_align,ao_num,nucl_num)] BEGIN_DOC ! ao_nucl_elec_integral_per_atom(i,j,k) = - diff --git a/src/MonoInts/test_michel.irp.f b/src/MonoInts/test_michel.irp.f deleted file mode 100644 index ef905479..00000000 --- a/src/MonoInts/test_michel.irp.f +++ /dev/null @@ -1,200 +0,0 @@ -!! -!! Computation of Vps, matrix element of the -!! pseudo-potential centered at point C -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Vps= < Phi_A | Vloc(C) + Vpp(C) | Phi_B> -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Phi_M (M=A,B) Cartesian gaussian orbital centered at point M : -!! Phi_M = (x-M_x)**n^M_x *(y-M_y)**n^M_y *(z-M_z)**n^M_z exp(-g_M rM**2) -!! with rM**2=(x-M_x)**2 + (y-M_y)**2 + (z-M_z)**2 -!! -!!** Vloc(C)= \sum_{k=1}^klocmax v_k rC**n_k exp(-dz_k rC**2) -!! -!!** Vpp(C)= \sum_{l=0}^lmax v_l(rC) \sum_{m=-l}^{m=l} |Y_lm> : -!! function Vpseudo(lmax,kmax,v_kl,n_kl,dz_kl,a,n_a,g_a,b,n_b,g_b,c) -!! lmax of formula above -!! kmax of formula above -!! v_kl = array v_kl(kmax_max,0:lmax_max) -!! n_kl = array n_kl(kmax_max,0:lmax_max) -!! dz_kl = array dz_kl(kmax_max,0:lmax_max) -!! n_a(1),n_a(2),n_a(3) -!! a(1),a(2),a(3) -!! g_a -!! n_b(1),n_b(2),n_b(3) -!! b(1),b(2),b(3) -!! g_b -!! c(1),c(2),c(3) -!! -!! Routine computing : -!! function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) -!! klocmax of formula above -!! v_k = array v_k(klocmax_max) -!! n_k = array n_k(klocmax_max) -!! dz_k= array dz_k(klocmax_max) -!! Routine total matrix element : -!! function Vps(a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) -!! -!! Routines Vps_num, Vpseudo_num, and Vloc_num = brute force numerical -!! estimations of the same integrals - - -program compute_integrals_pseudo - implicit none - integer n_a(3),n_b(3),npts - double precision g_a,g_b,a(3),b(3),c(3) - double precision Vpseudo,Vpseudo_num,Vloc,Vloc_num - double precision v3,v4 - - - double precision vps,vps_num - - ! PSEUDOS - integer nptsgridmax,nptsgrid - double precision coefs_pseudo,ptsgrid - - double precision rmax - double precision time_1,time_2,time_3,time_4,time_5 - integer kga,kgb,na1,na2,na3,nb1,nb2,nb3 - - CALL RANDOM_SEED() - - nptsgrid=50 - call initpseudos(nptsgrid) - - PROVIDE ezfio_filename - - ! - ! | _ _ _. | - ! |_ (_) (_ (_| | - ! - - integer klocmax - integer, allocatable :: n_k(:) - double precision, allocatable :: v_k(:), dz_k(:) - - call ezfio_get_pseudo_klocmax(klocmax) - - allocate(n_k(klocmax),v_k(klocmax), dz_k(klocmax)) - - call ezfio_get_pseudo_v_k(v_k) - call ezfio_get_pseudo_n_k(n_k) - call ezfio_get_pseudo_dz_k(dz_k) - - print*, "klocmax", klocmax - - print*, "n_k_ezfio", n_k - print*, "v_k_ezfio",v_k - print*, "dz_k_ezfio", dz_k - - ! - ! |\ | _ ._ | _ _ _. | - ! | \| (_) | | | (_) (_ (_| | - ! - - !! Parameters of non local part of pseudo: - - integer :: kmax,lmax - integer, allocatable :: n_kl(:,:) - double precision, allocatable :: v_kl(:,:), dz_kl(:,:) - - call ezfio_get_pseudo_lmaxpo(lmax) - call ezfio_get_pseudo_kmax(kmax) - lmax = lmax - 1 - - allocate(n_kl(kmax,0:lmax), v_kl(kmax,0:lmax), dz_kl(kmax,0:lmax)) - - call ezfio_get_pseudo_n_kl(n_kl) - call ezfio_get_pseudo_v_kl(v_kl) - call ezfio_get_pseudo_dz_kl(dz_kl) - - - print*, "lmax",lmax - print*, "kmax", kmax - - print*,"n_kl_ezfio", n_kl - print*,"v_kl_ezfio", v_kl - print*,"dz_kl_ezfio", dz_kl - - ! _ - ! / _. | _ | - ! \_ (_| | (_ |_| | - ! - -! write(*,*)'a?' -! read*,a(1),a(2),a(3) - !write(*,*)'b?' - !read*,b(1),b(2),b(3) -! b(1)=-0.1d0 -! b(2)=-0.2d0 -! b(3)=0.3d0 -! !write(*,*)'a?' -! !read*,c(1),c(2),c(3) -! c(1)=0.1d0 -! c(2)=0.2d0 -! c(3)=0.3d0 - - a(1)= 0.d0 - a(2)= 0.d0 - a(3)= 0.d0 - - b(1)= 0.d0 - b(2)= 0.d0 - b(3)= 0.d0 - - c(1)= 0.d0 - c(2)= 0.d0 - c(3)= 0.d0 - - print*,'ntps? rmax for brute force integration' - read*,npts,rmax - - do kga=0,5 - g_a=10.d0**kga - do kgb=0,5 - g_b=10.d0**kgb - - do na1=0,1 - do na2=0,1 - do na3=0,1 - do nb1=0,1 - do nb2=0,1 - do nb3=0,1 - n_a(1)=na1 - n_a(2)=na2 - n_a(3)=na3 - n_b(1)=nb1 - n_b(2)=nb2 - n_b(3)=nb3 - - v3=Vps(a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) - v4=Vps_num(npts,rmax,a,n_a,g_a,b,n_b,g_b,c,klocmax,v_k,n_k,dz_k,lmax,kmax,v_kl,n_kl,dz_kl) - print*,'Vps= ',v3,' Vps_num=',v4,' diff=',v4-v3 - write(33,'(3f10.6)')v3,v4,v4-v3 - - enddo - enddo - enddo - enddo - enddo - enddo - enddo - enddo - -end diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index 80176c68..4533ccfe 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Determinants Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC +AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Determinants Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC Pseudo_integrals diff --git a/src/Pseudo_integrals/ASSUMPTIONS.rst b/src/Pseudo_integrals/ASSUMPTIONS.rst new file mode 100644 index 00000000..e69de29b diff --git a/src/Pseudo_integrals/Makefile b/src/Pseudo_integrals/Makefile new file mode 100644 index 00000000..5cf11b78 --- /dev/null +++ b/src/Pseudo_integrals/Makefile @@ -0,0 +1,6 @@ +# Define here all new external source files and objects.Don't forget to prefix the +# object files with IRPF90_temp/ +SRC=int.f90 +OBJ=IRPF90_temp/int.o + +include $(QPACKAGE_ROOT)/src/Makefile.common diff --git a/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES b/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..4692ec21 --- /dev/null +++ b/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +AOs Electrons diff --git a/src/Pseudo_integrals/README.rst b/src/Pseudo_integrals/README.rst new file mode 100644 index 00000000..a62f9afc --- /dev/null +++ b/src/Pseudo_integrals/README.rst @@ -0,0 +1,28 @@ +======================= +Pseudo_integrals Module +======================= + +Documentation +============= + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +`ao_nucl_elec_integral_pseudo `_ + interaction nuclear electron + +`do_pseudo `_ + Using pseudo potential integral of not + If true, check all the {alpha,beta} electron and Z + + + +Needed Modules +============== + +.. Do not edit this section. It was auto-generated from the +.. NEEDED_MODULES file. + +* `AOs `_ +* `Electrons `_ + diff --git a/src/MonoInts/int.f90 b/src/Pseudo_integrals/int.f90 similarity index 100% rename from src/MonoInts/int.f90 rename to src/Pseudo_integrals/int.f90 diff --git a/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f b/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f new file mode 100644 index 00000000..eaa1d985 --- /dev/null +++ b/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f @@ -0,0 +1,178 @@ + BEGIN_PROVIDER [logical, do_pseudo] + BEGIN_DOC +! Using pseudo potential integral of not +! If true, check all the {alpha,beta} electron and Z + END_DOC + + call ezfio_get_pseudo_do_pseudo(do_pseudo) + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral_pseudo, (ao_num_align,ao_num)] + BEGIN_DOC +! interaction nuclear electron + END_DOC + implicit none + double precision :: alpha, beta, gama, delta + integer :: num_A,num_B + double precision :: A_center(3),B_center(3),C_center(3) + integer :: power_A(3),power_B(3) + integer :: i,j,k,l,n_pt_in,m + double precision :: Vloc, Vpseudo + + double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 + integer :: thread_num + + ao_nucl_elec_integral_pseudo = 0.d0 + + ! + ! | _ _ _. | + ! |_ (_) (_ (_| | + ! + !! Parameters of the local part of pseudo: + + integer klocmax + integer, allocatable :: n_k(:,:) + double precision, allocatable :: v_k(:,:), dz_k(:,:) + + call ezfio_get_pseudo_klocmax(klocmax) + + allocate(n_k(nucl_num,klocmax),v_k(nucl_num,klocmax), dz_k(nucl_num,klocmax)) + + call ezfio_get_pseudo_v_k(v_k) + call ezfio_get_pseudo_n_k(n_k) + call ezfio_get_pseudo_dz_k(dz_k) + + !! Dump array + integer, allocatable :: n_k_dump(:) + double precision, allocatable :: v_k_dump(:), dz_k_dump(:) + + allocate(n_k_dump(1:klocmax), v_k_dump(1:klocmax), dz_k_dump(1:klocmax)) + + + ! + ! |\ | _ ._ | _ _ _. | + ! | \| (_) | | | (_) (_ (_| | + ! + !! Parameters of non local part of pseudo: + + integer :: kmax,lmax + integer, allocatable :: n_kl(:,:,:) + double precision, allocatable :: v_kl(:,:,:), dz_kl(:,:,:) + + call ezfio_get_pseudo_lmaxpo(lmax) + call ezfio_get_pseudo_kmax(kmax) + !lmax plus one -> lmax + lmax = lmax - 1 + + allocate(n_kl(nucl_num,kmax,0:lmax), v_kl(nucl_num,kmax,0:lmax), dz_kl(nucl_num,kmax,0:lmax)) + + call ezfio_get_pseudo_n_kl(n_kl) + call ezfio_get_pseudo_v_kl(v_kl) + call ezfio_get_pseudo_dz_kl(dz_kl) + + + !! Dump array + integer, allocatable :: n_kl_dump(:,:) + double precision, allocatable :: v_kl_dump(:,:), dz_kl_dump(:,:) + + allocate(n_kl_dump(kmax,0:lmax), v_kl_dump(kmax,0:lmax), dz_kl_dump(kmax,0:lmax)) + + ! _ + ! / _. | _ | + ! \_ (_| | (_ |_| | + ! + + write(output_monoints,*) 'Providing the nuclear electron pseudo integrals ' + + call wall_time(wall_1) + call cpu_time(cpu_1) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & + !$OMP num_A,num_B,Z,c,n_pt_in, & + !$OMP v_k_dump,n_k_dump, dz_k_dump, n_kl_dump, v_kl_dump, dz_kl_dump, & + !$OMP wall_0,wall_2,thread_num, output_monoints) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_transp,ao_power,ao_nucl,nucl_coord,ao_coef_transp, & + !$OMP ao_nucl_elec_integral_pseudo,nucl_num,nucl_charge, & + !$OMP klocmax,lmax,kmax,v_k,n_k, dz_k, n_kl, v_kl, dz_kl, & + !$OMP wall_1) + + !$OMP DO SCHEDULE (guided) + + do j = 1, ao_num + + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_transp(l,j) + + do m=1,ao_prim_num(i) + beta = ao_expo_transp(m,i) + double precision :: c + c = 0.d0 + + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + v_k_dump = v_k(k,1:klocmax) + n_k_dump = n_k(k,1:klocmax) + dz_k_dump = dz_k(k,1:klocmax) + + c = c + Vloc(klocmax, v_k_dump,n_k_dump, dz_k_dump, & + A_center,power_A,alpha,B_center,power_B,beta,C_center) + + + n_kl_dump = n_kl(k,1:kmax,0:lmax) + v_kl_dump = v_kl(k,1:kmax,0:lmax) + dz_kl_dump = dz_kl(k,1:kmax,0:lmax) + + c = c + Vpseudo(lmax,kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + + enddo + ao_nucl_elec_integral_pseudo(i,j) = ao_nucl_elec_integral_pseudo(i,j) + & + ao_coef_transp(l,j)*ao_coef_transp(m,i)*c + enddo + enddo + enddo + + call wall_time(wall_2) + if (thread_num == 0) then + if (wall_2 - wall_0 > 1.d0) then + wall_0 = wall_2 + write(output_monoints,*) 100.*float(j)/float(ao_num), '% in ', & + wall_2-wall_1, 's' + endif + endif + enddo + + !$OMP END DO + !$OMP END PARALLEL + + +! _ +! | \ _ _. | | _ _ _. _|_ _ +! |_/ (/_ (_| | | (_) (_ (_| |_ (/_ +! + + deallocate(n_k,v_k, dz_k) + deallocate(n_k_dump,v_k_dump, dz_k_dump) + + deallocate(n_kl,v_kl, dz_kl) + deallocate(n_kl_dump,v_kl_dump, dz_kl_dump) + + +END_PROVIDER diff --git a/src/MonoInts/pseudo.ezfio_config b/src/Pseudo_integrals/pseudo.ezfio_config similarity index 100% rename from src/MonoInts/pseudo.ezfio_config rename to src/Pseudo_integrals/pseudo.ezfio_config diff --git a/src/Utils/README.rst b/src/Utils/README.rst index 68a4f080..ff16f3ed 100644 --- a/src/Utils/README.rst +++ b/src/Utils/README.rst @@ -160,6 +160,39 @@ Documentation `rint_sum `_ Needed for the calculation of two-electron integrals. +`a_coef `_ + Undocumented + +`b_coef `_ + Undocumented + +`ddfact2 `_ + Undocumented + +`erf0 `_ + Undocumented + +`gammln `_ + Undocumented + +`gammp `_ + Undocumented + +`gcf `_ + Undocumented + +`gser `_ + Undocumented + +`rinteg `_ + Undocumented + +`rintgauss `_ + Undocumented + +`sabpartial `_ + Undocumented + `overlap_a_b_c `_ Undocumented diff --git a/src/MonoInts/need.irp.f b/src/Utils/need.irp.f similarity index 100% rename from src/MonoInts/need.irp.f rename to src/Utils/need.irp.f From e5096621f26ba09f5bad5ecbe548e7c59748af50 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Sat, 2 May 2015 13:29:57 +0200 Subject: [PATCH 57/70] Fix set_pseudo_integrals_do_pseudo = False in test --- scripts/ezfio_interface/qp_convert_output_to_ezfio.py | 10 ++++++++++ src/Pseudo_integrals/README.rst | 6 +----- src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f | 11 ----------- src/Pseudo_integrals/pseudo.ezfio_config | 1 - tests/unit_test/unit_test.py | 2 ++ 5 files changed, 13 insertions(+), 17 deletions(-) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 9d67611e..400def37 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -265,6 +265,16 @@ def write_ezfio(res, filename): ezfio.set_mo_basis_mo_occ(OccNum) ezfio.set_mo_basis_mo_coef(MoMatrix) + # ______ _ + # | ___ \ | | + # | |_/ /__ ___ _ _ __| | ___ + # | __/ __|/ _ \ | | |/ _` |/ _ \ + # | | \__ \ __/ |_| | (_| | (_) | + # \_| |___/\___|\__,_|\__,_|\___/ + # + + ezfio.set_pseudo_integrals_do_pseudo(False) + def get_full_path(file_path): file_path = os.path.expanduser(file_path) diff --git a/src/Pseudo_integrals/README.rst b/src/Pseudo_integrals/README.rst index a62f9afc..08076556 100644 --- a/src/Pseudo_integrals/README.rst +++ b/src/Pseudo_integrals/README.rst @@ -8,13 +8,9 @@ Documentation .. Do not edit this section. It was auto-generated from the .. NEEDED_MODULES file. -`ao_nucl_elec_integral_pseudo `_ +`ao_nucl_elec_integral_pseudo `_ interaction nuclear electron -`do_pseudo `_ - Using pseudo potential integral of not - If true, check all the {alpha,beta} electron and Z - Needed Modules diff --git a/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f b/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f index eaa1d985..c8692e6d 100644 --- a/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f +++ b/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f @@ -1,14 +1,3 @@ - BEGIN_PROVIDER [logical, do_pseudo] - BEGIN_DOC -! Using pseudo potential integral of not -! If true, check all the {alpha,beta} electron and Z - END_DOC - - call ezfio_get_pseudo_do_pseudo(do_pseudo) - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, ao_nucl_elec_integral_pseudo, (ao_num_align,ao_num)] BEGIN_DOC ! interaction nuclear electron diff --git a/src/Pseudo_integrals/pseudo.ezfio_config b/src/Pseudo_integrals/pseudo.ezfio_config index db0da938..1cd11eb7 100644 --- a/src/Pseudo_integrals/pseudo.ezfio_config +++ b/src/Pseudo_integrals/pseudo.ezfio_config @@ -1,5 +1,4 @@ pseudo - do_pseudo logical klocmax integer v_k double precision (nuclei_nucl_num,pseudo_klocmax) n_k integer (nuclei_nucl_num,pseudo_klocmax) diff --git a/tests/unit_test/unit_test.py b/tests/unit_test/unit_test.py index c01b4974..f9049d82 100755 --- a/tests/unit_test/unit_test.py +++ b/tests/unit_test/unit_test.py @@ -187,6 +187,8 @@ def run_hf(geo, basis, mult=1): ezfio.hartree_fock_thresh_scf = 1.e-10 ezfio.hartree_fock_n_it_scf_max = 100 + ezfio.pseudo_integrals_do_pseudo = False + # ~#~#~ # # R u n # # ~#~#~ # From f17cccf38e01c0dc6c34475481ca5ea12788e24d Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Sat, 2 May 2015 13:43:59 +0200 Subject: [PATCH 58/70] Suport pseudo in qp_create --- scripts/get_basis.sh | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index af493a3f..5cd6543c 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -43,5 +43,13 @@ then exit 1 fi -${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" -#${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" \ No newline at end of file +pseudo="$1" +shift + +if [[ -z $pseudo ]] +then + ${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" +else + ${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" +fi + From b1ab3c5ce49ffb174fa67c8f6a84541aed319314 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Sat, 2 May 2015 13:53:45 +0200 Subject: [PATCH 59/70] Add EZFIO.cfg for Pseudo_integrals --- src/Pseudo_integrals/EZFIO.cfg | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 src/Pseudo_integrals/EZFIO.cfg diff --git a/src/Pseudo_integrals/EZFIO.cfg b/src/Pseudo_integrals/EZFIO.cfg new file mode 100644 index 00000000..f56bc325 --- /dev/null +++ b/src/Pseudo_integrals/EZFIO.cfg @@ -0,0 +1,5 @@ +[do_pseudo] +type: logical +doc: Using pseudo potential integral of not +interface: input +default: False \ No newline at end of file From cdc9f46428ace66d3f0b1328788e418c1a8853c5 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Sat, 2 May 2015 14:50:23 +0200 Subject: [PATCH 60/70] Suport pseudo in qp_create --- ocaml/qp_create_ezfio_from_xyz.ml | 21 +++++++++++++------ scripts/get_basis.sh | 2 +- scripts/pseudo/put_pseudo_in_ezfio.py | 20 ++++++++++-------- src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f | 18 ++++++++-------- src/Pseudo_integrals/pseudo.ezfio_config | 14 ++++++------- 5 files changed, 43 insertions(+), 32 deletions(-) diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index dfc9b4bd..3606d334 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -5,18 +5,20 @@ open Core.Std;; let spec = let open Command.Spec in empty - +> flag "o" (optional string) + +> flag "o" (optional string) ~doc:"file Name of the created EZFIO file." +> flag "b" (required string) ~doc:"string Name of basis set." +> flag "c" (optional_with_default 0 int) ~doc:"int Total charge of the molecule. Default is 0." - +> flag "m" (optional_with_default 1 int) + +> flag "m" (optional_with_default 1 int) ~doc:"int Spin multiplicity (2S+1) of the molecule. Default is 1." + +> flag "p" (optional_with_default 1 int) + ~doc:"Using pseudo potentiel or not" +> anon ("xyz_file" %: string) ;; -let run ?o b c m xyz_file = +let run ?o b c m p xyz_file = (* Read molecule *) let molecule = @@ -60,8 +62,12 @@ let run ?o b c m xyz_file = | None -> (* Principal basis *) let basis = elem_and_basis_name in let command = + if (p = 0) then Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename ^ "\" \"" ^ basis ^"\"" + else + Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename + ^ "\" \"" ^ basis ^"\" pseudo" in begin let filename = @@ -246,7 +252,10 @@ let run ?o b c m xyz_file = Ezfio.set_ao_basis_ao_expo(Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| ao_num ; ao_prim_num_max |] ~data:ao_expo) ; - + + (* Doesn't work... *) + (* if p = 1 then Qpackage.root ^ "scripts/pseudo/put_pseudo_in_ezfio.py" ezfio_file.to_string; *) + match Input.Ao_basis.read () with | None -> failwith "Error in basis" | Some x -> Input.Ao_basis.write x @@ -266,8 +275,8 @@ elements can be defined as follows: ") spec - (fun o b c m xyz_file () -> - run ?o b c m xyz_file ) + (fun o b c m p xyz_file () -> + run ?o b c m p xyz_file ) ;; let () = diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index 5cd6543c..a2f07e4e 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -50,6 +50,6 @@ if [[ -z $pseudo ]] then ${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" else - ${EMSL_API_ROOT}/EMSL_api.py get_basis_data --treat_l --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" + ${EMSL_API_ROOT}/EMSL_api.py get_basis_data --save --path="${tmpfile}" --basis="${basis}" --db_path="${EMSL_API_ROOT}/db/Pseudo.db" fi diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index 6a7aaef7..87db7845 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -311,11 +311,11 @@ if __name__ == "__main__": # ~#~#~#~#~ # klocmax = max([len(i) for i in v_k]) - ezfio.pseudo_klocmax = klocmax + ezfio.pseudo_intergrals_klocmax = klocmax - ezfio.pseudo_v_k = zip(*v_k) - ezfio.pseudo_n_k = zip(*n_k) - ezfio.pseudo_dz_k = zip(*dz_k) + ezfio.pseudo_intergrals_v_k = zip(*v_k) + ezfio.pseudo_intergrals_n_k = zip(*n_k) + ezfio.pseudo_intergrals_dz_k = zip(*dz_k) # ~#~#~#~#~#~#~#~#~ # # N o n _ L o c a l # @@ -324,13 +324,15 @@ if __name__ == "__main__": lmax = max([len(i) for i in v_kl]) kmax = max([len(sublist) for list_ in v_kl for sublist in list_]) - ezfio.pseudo_lmaxpo = lmax - ezfio.pseudo_kmax = kmax + ezfio.pseudo_intergrals_lmaxpo = lmax + ezfio.pseudo_intergrals_kmax = kmax v_kl = make_it_square(v_kl, [lmax, kmax]) n_kl = make_it_square(n_kl, [lmax, kmax], int) dz_kl = make_it_square(dz_kl, [lmax, kmax]) - ezfio.pseudo_v_kl = zip(*v_kl) - ezfio.pseudo_n_kl = zip(*n_kl) - ezfio.pseudo_dz_kl = zip(*dz_kl) + ezfio.pseudo_intergrals_v_kl = zip(*v_kl) + ezfio.pseudo_intergrals_n_kl = zip(*n_kl) + ezfio.pseudo_intergrals_dz_kl = zip(*dz_kl) + + ezfio.pseudo_intergrals_do_pseudo = True diff --git a/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f b/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f index c8692e6d..c101ea9c 100644 --- a/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f +++ b/src/Pseudo_integrals/pot_ao_ints_pseudo.irp.f @@ -25,13 +25,13 @@ integer, allocatable :: n_k(:,:) double precision, allocatable :: v_k(:,:), dz_k(:,:) - call ezfio_get_pseudo_klocmax(klocmax) + call ezfio_get_pseudo_integrals_klocmax(klocmax) allocate(n_k(nucl_num,klocmax),v_k(nucl_num,klocmax), dz_k(nucl_num,klocmax)) - call ezfio_get_pseudo_v_k(v_k) - call ezfio_get_pseudo_n_k(n_k) - call ezfio_get_pseudo_dz_k(dz_k) + call ezfio_get_pseudo_integrals_v_k(v_k) + call ezfio_get_pseudo_integrals_n_k(n_k) + call ezfio_get_pseudo_integrals_dz_k(dz_k) !! Dump array integer, allocatable :: n_k_dump(:) @@ -50,16 +50,16 @@ integer, allocatable :: n_kl(:,:,:) double precision, allocatable :: v_kl(:,:,:), dz_kl(:,:,:) - call ezfio_get_pseudo_lmaxpo(lmax) - call ezfio_get_pseudo_kmax(kmax) + call ezfio_get_pseudo_integrals_lmaxpo(lmax) + call ezfio_get_pseudo_integrals_kmax(kmax) !lmax plus one -> lmax lmax = lmax - 1 allocate(n_kl(nucl_num,kmax,0:lmax), v_kl(nucl_num,kmax,0:lmax), dz_kl(nucl_num,kmax,0:lmax)) - call ezfio_get_pseudo_n_kl(n_kl) - call ezfio_get_pseudo_v_kl(v_kl) - call ezfio_get_pseudo_dz_kl(dz_kl) + call ezfio_get_pseudo_integrals_n_kl(n_kl) + call ezfio_get_pseudo_integrals_v_kl(v_kl) + call ezfio_get_pseudo_integrals_dz_kl(dz_kl) !! Dump array diff --git a/src/Pseudo_integrals/pseudo.ezfio_config b/src/Pseudo_integrals/pseudo.ezfio_config index 1cd11eb7..a01bc2c0 100644 --- a/src/Pseudo_integrals/pseudo.ezfio_config +++ b/src/Pseudo_integrals/pseudo.ezfio_config @@ -1,10 +1,10 @@ -pseudo +pseudo_integrals klocmax integer - v_k double precision (nuclei_nucl_num,pseudo_klocmax) - n_k integer (nuclei_nucl_num,pseudo_klocmax) - dz_k double precision (nuclei_nucl_num,pseudo_klocmax) + v_k double precision (nuclei_nucl_num,pseudo_integrals_klocmax) + n_k integer (nuclei_nucl_num,pseudo_integrals_klocmax) + dz_k double precision (nuclei_nucl_num,pseudo_integrals_klocmax) lmaxpo integer kmax integer - v_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) - n_kl integer (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) - dz_kl double precision (nuclei_nucl_num,pseudo_kmax,pseudo_lmaxpo) + v_kl double precision (nuclei_nucl_num,pseudo_integrals_kmax,pseudo_integrals_lmaxpo) + n_kl integer (nuclei_nucl_num,pseudo_integrals_kmax,pseudo_integrals_lmaxpo) + dz_kl double precision (nuclei_nucl_num,pseudo_integrals_kmax,pseudo_integrals_lmaxpo) From ae4bc3d71b49cdf63a42472c6e85f37bda4e5e5b Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Sat, 2 May 2015 15:14:50 +0200 Subject: [PATCH 61/70] Don't use pseudo by default --- ocaml/qp_create_ezfio_from_xyz.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index 3606d334..8370fb1f 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -13,8 +13,8 @@ let spec = ~doc:"int Total charge of the molecule. Default is 0." +> flag "m" (optional_with_default 1 int) ~doc:"int Spin multiplicity (2S+1) of the molecule. Default is 1." - +> flag "p" (optional_with_default 1 int) - ~doc:"Using pseudo potentiel or not" + +> flag "p" (optional_with_default 0 int) + ~doc:"Using pseudo. Default is not (aka 0)" +> anon ("xyz_file" %: string) ;; From 6316d5a1fdb52b2eb915b7c927c4aa5562ea4839 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 10:30:22 +0200 Subject: [PATCH 62/70] Cleaning only_children_to_all_genealogy.py --- .../module/only_children_to_all_genealogy.py | 93 +++++++++++-------- src/Pseudo_integrals/NEEDED_CHILDREN_MODULES | 2 +- 2 files changed, 53 insertions(+), 42 deletions(-) diff --git a/scripts/module/only_children_to_all_genealogy.py b/scripts/module/only_children_to_all_genealogy.py index f44d37d4..719ee70e 100755 --- a/scripts/module/only_children_to_all_genealogy.py +++ b/scripts/module/only_children_to_all_genealogy.py @@ -3,13 +3,32 @@ import os import os.path +from functools import wraps -def get_dict_genealogy(all_children=False): + +def cache(func): + saved = {} + + @wraps(func) + def newfunc(*args): + if args in saved: + return saved[args] + + result = func(*args) + saved[args] = result + return result + return newfunc + + +@cache +def get_dict_genealogy(): + """Loop over MODULE in QPACKAGE_ROOT/src, open all the NEEDED_CHILDREN_MODULES + and create a dict[MODULE] = [sub module needed, ...] + """ + d_ref = dict() qpackage_root = os.environ['QPACKAGE_ROOT'] - dir_ = os.path.join(qpackage_root,'src') - - d_ref = dict() + dir_ = os.path.join(qpackage_root, 'src') for o in os.listdir(dir_): @@ -21,15 +40,14 @@ def get_dict_genealogy(all_children=False): else: d_ref[o] = l_children - if all_children: - for module in d_ref: - d_ref[module] = get_all_children(d_ref, d_ref[module], []) - return d_ref -def module_children_to_all(d_ref,path): - +def module_genealogy(path): + """ + Take a name of a NEEDED_CHILDREN_MODULES + and return a list of all the {sub, subsub, ...}children + """ if not path: dir_ = os.getcwd() path = os.path.join(dir_, "NEEDED_CHILDREN_MODULES") @@ -40,51 +58,54 @@ def module_children_to_all(d_ref,path): except IOError: return [] else: - needed_module = l_children - for module in l_children: - for children in get_all_children(d_ref, d_ref[module], []): - if children not in needed_module: - needed_module.append(children) + needed_module = get_it_and_children(l_children) return needed_module -def get_all_children(d_ref, l_module, l=[]): +def get_it_and_children(l_module): """ - From a d_ref (who containt all the data --flatter or not-- create - an flatten list who contain all the children + From a list of module return the module and all of the genealogy """ + d_ref = get_dict_genealogy() + + l = [] for module in l_module: if module not in l: l.append(module) - get_all_children(d_ref, d_ref[module], l) + l.extend(get_it_and_children(d_ref[module])) return list(set(l)) -def reduce_(d_ref, name): - +def get_all_children(l_module): """ - Take a big list and try to find the lower parent - available + From a list of module return all the genealogy + """ + + it_and_all = get_it_and_children(l_module) + return [children for children in it_and_all if children not in l_module] + + +def reduce_(l_module): + """ + Take a l_module and try to find the lower combinaitions + of module with the same genealogy """ import itertools + d_ref = get_dict_genealogy() - a = sorted(get_all_children(d_ref[name])) + target_genealogy = sorted(get_all_children(l_module)) for i in xrange(len(d_ref)): for c in itertools.combinations(d_ref, i): - l = [] - b = sorted(get_all_children(c, l)) + guess_genealogy = sorted(get_it_and_children(d_ref, c)) - if a == b: + if target_genealogy == guess_genealogy: return c -#for i in sorted(d_ref): -# print i, reduce_(i) -# if __name__ == '__main__': import sys @@ -94,15 +115,5 @@ if __name__ == '__main__': except IndexError: path = None - d_ref = get_dict_genealogy() - - l_all_needed_molule = module_children_to_all(d_ref, path) + l_all_needed_molule = module_genealogy(path) print " ".join(sorted(l_all_needed_molule)) - -# print d_ref -# -# d_ref = get_dict_genealogy(True) -# -# print d_ref -# -# module_hl_to_ll(d_ref) diff --git a/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES b/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES index 4692ec21..88c6f86b 100644 --- a/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES +++ b/src/Pseudo_integrals/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -AOs Electrons +AOs Electrons From 30ba1fb5c43c7443f527dccc522873a414d15945 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 12:30:31 +0200 Subject: [PATCH 63/70] Add dot file to only_children_to_all_genealogy.py --- .../module/only_children_to_all_genealogy.py | 81 +- scripts/module/pydot.py | 2125 +++++++++++++++++ 2 files changed, 2196 insertions(+), 10 deletions(-) create mode 100644 scripts/module/pydot.py diff --git a/scripts/module/only_children_to_all_genealogy.py b/scripts/module/only_children_to_all_genealogy.py index 719ee70e..f330cf97 100755 --- a/scripts/module/only_children_to_all_genealogy.py +++ b/scripts/module/only_children_to_all_genealogy.py @@ -1,12 +1,29 @@ #!/usr/bin/env python # -*- coding: utf-8 -*- +""" +Create the NEEDED_MODULE aka the genealogy (children module, subchildren module and so on), +of a NEEDED_CHILDREN_MODULES file + +Usage: + only_children_to_all_genealogy.py [--create_png] [] + +Help: + If NEEDED_CHILDREN_MODULES is not set, check the current pwd + Same for create_png. +""" + +from docopt import docopt + import os import os.path from functools import wraps def cache(func): + """ + A decorator for lazy evaluation off true function + """ saved = {} @wraps(func) @@ -48,10 +65,6 @@ def module_genealogy(path): Take a name of a NEEDED_CHILDREN_MODULES and return a list of all the {sub, subsub, ...}children """ - if not path: - dir_ = os.getcwd() - path = os.path.join(dir_, "NEEDED_CHILDREN_MODULES") - try: with open(path, "r") as f: l_children = f.read().split() @@ -107,13 +120,61 @@ def reduce_(l_module): return c -if __name__ == '__main__': - import sys +def create_png_from_path(path): + " Change a path like this into a module list" + "path = /home/razoa/quantum_package/src/Molden/NEEDED_CHILDREN_MODULES" - try: - path = sys.argv[1] - except IndexError: - path = None + l_module = os.path.split(path)[0].split("/")[-1] + create_png([l_module]) + + +def create_png(l_module): + """Create the png of the dependancy tree for a l_module""" + + # Init + import pydot + all_ready_done = [] + + def draw_module_edge(module, l_children): + "Draw all the module recursifly" + + if module not in all_ready_done: + for children in l_children: + # Add Edge + edge = pydot.Edge(module, children) + graph.add_edge(edge) + # Recurs + draw_module_edge(children, d_ref[children]) + all_ready_done.append(module) + + # Init + graph = pydot.Dot(graph_type='digraph') + d_ref = get_dict_genealogy() + + # Create all the edge + for module in l_module: + node_a = pydot.Node(module, fontcolor="red") + graph.add_node(node_a) + draw_module_edge(module, d_ref[module]) + + # Save + path = '{0}.png'.format("_".join(l_module)) + graph.write_png(path) + +if __name__ == '__main__': + + arguments = docopt(__doc__) + + if not arguments['']: + dir_ = os.getcwd() + path = os.path.join(dir_, "NEEDED_CHILDREN_MODULES") + else: + path = os.path.abspath(arguments['']) + path = os.path.expanduser(path) + path = os.path.expandvars(path) l_all_needed_molule = module_genealogy(path) print " ".join(sorted(l_all_needed_molule)) + + if arguments["--create_png"]: + create_png_from_path(path) diff --git a/scripts/module/pydot.py b/scripts/module/pydot.py new file mode 100644 index 00000000..c788c137 --- /dev/null +++ b/scripts/module/pydot.py @@ -0,0 +1,2125 @@ +# -*- coding: Latin-1 -*- +"""Graphviz's dot language Python interface. + +This module provides with a full interface to create handle modify +and process graphs in Graphviz's dot language. + +References: + +pydot Homepage: http://code.google.com/p/pydot/ +Graphviz: http://www.graphviz.org/ +DOT Language: http://www.graphviz.org/doc/info/lang.html + +Programmed and tested with Graphviz 2.26.3 and Python 2.6 on OSX 10.6.4 + +Copyright (c) 2005-2011 Ero Carrera + +Distributed under MIT license [http://opensource.org/licenses/mit-license.html]. +""" + +__author__ = 'Ero Carrera' +__version__ = '1.0.*' +__license__ = 'MIT' + +import os +import re +import subprocess +import tempfile +import copy +import sys + +try: + import dot_parser +except Exception as e: + print >> sys.stderr, "Couldn't import dot_parser, loading of dot files will not be possible." + + +GRAPH_ATTRIBUTES = set(['Damping', 'K', 'URL', 'aspect', 'bb', 'bgcolor', + 'center', 'charset', 'clusterrank', 'colorscheme', 'comment', 'compound', + 'concentrate', 'defaultdist', 'dim', 'dimen', 'diredgeconstraints', + 'dpi', 'epsilon', 'esep', 'fontcolor', 'fontname', 'fontnames', + 'fontpath', 'fontsize', 'id', 'label', 'labeljust', 'labelloc', + 'landscape', 'layers', 'layersep', 'layout', 'levels', 'levelsgap', + 'lheight', 'lp', 'lwidth', 'margin', 'maxiter', 'mclimit', 'mindist', + 'mode', 'model', 'mosek', 'nodesep', 'nojustify', 'normalize', 'nslimit', + 'nslimit1', 'ordering', 'orientation', 'outputorder', 'overlap', + 'overlap_scaling', 'pack', 'packmode', 'pad', 'page', 'pagedir', + 'quadtree', 'quantum', 'rankdir', 'ranksep', 'ratio', 'remincross', + 'repulsiveforce', 'resolution', 'root', 'rotate', 'searchsize', 'sep', + 'showboxes', 'size', 'smoothing', 'sortv', 'splines', 'start', + 'stylesheet', 'target', 'truecolor', 'viewport', 'voro_margin', + # for subgraphs + 'rank']) + + +EDGE_ATTRIBUTES = set(['URL', + 'arrowhead', + 'arrowsize', + 'arrowtail', + 'color', + 'colorscheme', + 'comment', + 'constraint', + 'decorate', + 'dir', + 'edgeURL', + 'edgehref', + 'edgetarget', + 'edgetooltip', + 'fontcolor', + 'fontname', + 'fontsize', + 'headURL', + 'headclip', + 'headhref', + 'headlabel', + 'headport', + 'headtarget', + 'headtooltip', + 'href', + 'id', + 'label', + 'labelURL', + 'labelangle', + 'labeldistance', + 'labelfloat', + 'labelfontcolor', + 'labelfontname', + 'labelfontsize', + 'labelhref', + 'labeltarget', + 'labeltooltip', + 'layer', + 'len', + 'lhead', + 'lp', + 'ltail', + 'minlen', + 'nojustify', + 'penwidth', + 'pos', + 'samehead', + 'sametail', + 'showboxes', + 'style', + 'tailURL', + 'tailclip', + 'tailhref', + 'taillabel', + 'tailport', + 'tailtarget', + 'tailtooltip', + 'target', + 'tooltip', + 'weight', + 'rank']) + + +NODE_ATTRIBUTES = set(['URL', 'color', 'colorscheme', 'comment', + 'distortion', 'fillcolor', 'fixedsize', 'fontcolor', 'fontname', + 'fontsize', 'group', 'height', 'id', 'image', 'imagescale', 'label', + 'labelloc', 'layer', 'margin', 'nojustify', 'orientation', 'penwidth', + 'peripheries', 'pin', 'pos', 'rects', 'regular', 'root', 'samplepoints', + 'shape', 'shapefile', 'showboxes', 'sides', 'skew', 'sortv', 'style', + 'target', 'tooltip', 'vertices', 'width', 'z', + # The following are attributes dot2tex + 'texlbl', 'texmode']) + + +CLUSTER_ATTRIBUTES = set(['K', + 'URL', + 'bgcolor', + 'color', + 'colorscheme', + 'fillcolor', + 'fontcolor', + 'fontname', + 'fontsize', + 'label', + 'labeljust', + 'labelloc', + 'lheight', + 'lp', + 'lwidth', + 'nojustify', + 'pencolor', + 'penwidth', + 'peripheries', + 'sortv', + 'style', + 'target', + 'tooltip']) + + +# +# Extented version of ASPN's Python Cookbook Recipe: +# Frozen dictionaries. +# http://aspn.activestate.com/ASPN/Cookbook/Python/Recipe/414283 +# +# This version freezes dictionaries used as values within dictionaries. +# +class frozendict(dict): + + def _blocked_attribute(obj): + raise AttributeError("A frozendict cannot be modified.") + _blocked_attribute = property(_blocked_attribute) + + __delitem__ = __setitem__ = clear = _blocked_attribute + pop = popitem = setdefault = update = _blocked_attribute + + def __new__(cls, *args, **kw): + new = dict.__new__(cls) + + args_ = [] + for arg in args: + if isinstance(arg, dict): + arg = copy.copy(arg) + for k, v in arg.iteritems(): + if isinstance(v, frozendict): + arg[k] = v + elif isinstance(v, dict): + arg[k] = frozendict(v) + elif isinstance(v, list): + v_ = list() + for elm in v: + if isinstance(elm, dict): + v_.append(frozendict(elm)) + else: + v_.append(elm) + arg[k] = tuple(v_) + args_.append(arg) + else: + args_.append(arg) + + dict.__init__(new, *args_, **kw) + return new + + def __init__(self, *args, **kw): + pass + + def __hash__(self): + try: + return self._cached_hash + except AttributeError: + h = self._cached_hash = hash(tuple(sorted(self.iteritems()))) + return h + + def __repr__(self): + return "frozendict(%s)" % dict.__repr__(self) + + +dot_keywords = ['graph', 'subgraph', 'digraph', 'node', 'edge', 'strict'] + +id_re_alpha_nums = re.compile('^[_a-zA-Z][a-zA-Z0-9_,]*$', re.UNICODE) +id_re_alpha_nums_with_ports = re.compile( + '^[_a-zA-Z][a-zA-Z0-9_,:\"]*[a-zA-Z0-9_,\"]+$', + re.UNICODE) +id_re_num = re.compile('^[0-9,]+$', re.UNICODE) +id_re_with_port = re.compile('^([^:]*):([^:]*)$', re.UNICODE) +id_re_dbl_quoted = re.compile('^\".*\"$', re.S | re.UNICODE) +id_re_html = re.compile('^<.*>$', re.S | re.UNICODE) + + +def needs_quotes(s): + """Checks whether a string is a dot language ID. + + It will check whether the string is solely composed + by the characters allowed in an ID or not. + If the string is one of the reserved keywords it will + need quotes too but the user will need to add them + manually. + """ + + # If the name is a reserved keyword it will need quotes but pydot + # can't tell when it's being used as a keyword or when it's simply + # a name. Hence the user needs to supply the quotes when an element + # would use a reserved keyword as name. This function will return + # false indicating that a keyword string, if provided as-is, won't + # need quotes. + if s in dot_keywords: + return False + + chars = [ord(c) for c in s if ord(c) > 0x7f or ord(c) == 0] + if chars and not id_re_dbl_quoted.match(s) and not id_re_html.match(s): + return True + + for test_re in [ + id_re_alpha_nums, + id_re_num, + id_re_dbl_quoted, + id_re_html, + id_re_alpha_nums_with_ports]: + if test_re.match(s): + return False + + m = id_re_with_port.match(s) + if m: + return needs_quotes(m.group(1)) or needs_quotes(m.group(2)) + + return True + + +def quote_if_necessary(s): + + if isinstance(s, bool): + if s is True: + return 'True' + return 'False' + + if not isinstance(s, basestring): + return s + + if not s: + return s + + if needs_quotes(s): + replace = {'"': r'\"', + "\n": r'\n', + "\r": r'\r'} + for (a, b) in replace.items(): + s = s.replace(a, b) + + return '"' + s + '"' + + return s + + +def graph_from_dot_data(data): + """Load graph as defined by data in DOT format. + + The data is assumed to be in DOT format. It will + be parsed and a Dot class will be returned, + representing the graph. + """ + + return dot_parser.parse_dot_data(data) + + +def graph_from_dot_file(path): + """Load graph as defined by a DOT file. + + The file is assumed to be in DOT format. It will + be loaded, parsed and a Dot class will be returned, + representing the graph. + """ + + fd = file(path, 'rb') + data = fd.read() + fd.close() + + return graph_from_dot_data(data) + + +def graph_from_edges(edge_list, node_prefix='', directed=False): + """Creates a basic graph out of an edge list. + + The edge list has to be a list of tuples representing + the nodes connected by the edge. + The values can be anything: bool, int, float, str. + + If the graph is undirected by default, it is only + calculated from one of the symmetric halves of the matrix. + """ + + if directed: + graph = Dot(graph_type='digraph') + + else: + graph = Dot(graph_type='graph') + + for edge in edge_list: + + if isinstance(edge[0], str): + src = node_prefix + edge[0] + else: + src = node_prefix + str(edge[0]) + + if isinstance(edge[1], str): + dst = node_prefix + edge[1] + else: + dst = node_prefix + str(edge[1]) + + e = Edge(src, dst) + graph.add_edge(e) + + return graph + + +def graph_from_adjacency_matrix(matrix, node_prefix=u'', directed=False): + """Creates a basic graph out of an adjacency matrix. + + The matrix has to be a list of rows of values + representing an adjacency matrix. + The values can be anything: bool, int, float, as long + as they can evaluate to True or False. + """ + + node_orig = 1 + + if directed: + graph = Dot(graph_type='digraph') + else: + graph = Dot(graph_type='graph') + + for row in matrix: + if not directed: + skip = matrix.index(row) + r = row[skip:] + else: + skip = 0 + r = row + node_dest = skip + 1 + + for e in r: + if e: + graph.add_edge( + Edge(node_prefix + node_orig, + node_prefix + node_dest)) + node_dest += 1 + node_orig += 1 + + return graph + + +def graph_from_incidence_matrix(matrix, node_prefix='', directed=False): + """Creates a basic graph out of an incidence matrix. + + The matrix has to be a list of rows of values + representing an incidence matrix. + The values can be anything: bool, int, float, as long + as they can evaluate to True or False. + """ + + node_orig = 1 + + if directed: + graph = Dot(graph_type='digraph') + else: + graph = Dot(graph_type='graph') + + for row in matrix: + nodes = [] + c = 1 + + for node in row: + if node: + nodes.append(c * node) + c += 1 + nodes.sort() + + if len(nodes) == 2: + graph.add_edge( + Edge(node_prefix + abs(nodes[0]), + node_prefix + nodes[1])) + + if not directed: + graph.set_simplify(True) + + return graph + + +def __find_executables(path): + """Used by find_graphviz + + path - single directory as a string + + If any of the executables are found, it will return a dictionary + containing the program names as keys and their paths as values. + + Otherwise returns None + """ + + success = False + progs = { + 'dot': '', + 'twopi': '', + 'neato': '', + 'circo': '', + 'fdp': '', + 'sfdp': ''} + + was_quoted = False + path = path.strip() + if path.startswith('"') and path.endswith('"'): + path = path[1:-1] + was_quoted = True + + if os.path.isdir(path): + + for prg in progs.iterkeys(): + + if progs[prg]: + continue + + if os.path.exists(os.path.join(path, prg)): + + if was_quoted: + progs[prg] = '"' + os.path.join(path, prg) + '"' + else: + progs[prg] = os.path.join(path, prg) + + success = True + + elif os.path.exists(os.path.join(path, prg + '.exe')): + + if was_quoted: + progs[prg] = '"' + os.path.join(path, prg + '.exe') + '"' + else: + progs[prg] = os.path.join(path, prg + '.exe') + + success = True + + if success: + + return progs + + else: + + return None + + +# The multi-platform version of this 'find_graphviz' function was +# contributed by Peter Cock +# +def find_graphviz(): + """Locate Graphviz's executables in the system. + + Tries three methods: + + First: Windows Registry (Windows only) + This requires Mark Hammond's pywin32 is installed. + + Secondly: Search the path + It will look for 'dot', 'twopi' and 'neato' in all the directories + specified in the PATH environment variable. + + Thirdly: Default install location (Windows only) + It will look for 'dot', 'twopi' and 'neato' in the default install + location under the "Program Files" directory. + + It will return a dictionary containing the program names as keys + and their paths as values. + + If this fails, it returns None. + """ + + # Method 1 (Windows only) + # + if os.sys.platform == 'win32': + + HKEY_LOCAL_MACHINE = 0x80000002 + KEY_QUERY_VALUE = 0x0001 + + RegOpenKeyEx = None + RegQueryValueEx = None + RegCloseKey = None + + try: + import win32api + import win32con + RegOpenKeyEx = win32api.RegOpenKeyEx + RegQueryValueEx = win32api.RegQueryValueEx + RegCloseKey = win32api.RegCloseKey + + except ImportError: + # Print a messaged suggesting they install these? + # + pass + + try: + import ctypes + + def RegOpenKeyEx(key, subkey, opt, sam): + result = ctypes.c_uint(0) + ctypes.windll.advapi32.RegOpenKeyExA( + key, + subkey, + opt, + sam, + ctypes.byref(result)) + return result.value + + def RegQueryValueEx(hkey, valuename): + data_type = ctypes.c_uint(0) + data_len = ctypes.c_uint(1024) + data = ctypes.create_string_buffer(1024) + + res = ctypes.windll.advapi32.RegQueryValueExA( + hkey, + valuename, + 0, + ctypes.byref(data_type), + data, + ctypes.byref(data_len)) + + return data.value + + RegCloseKey = ctypes.windll.advapi32.RegCloseKey + + except ImportError: + # Print a messaged suggesting they install these? + # + pass + + if RegOpenKeyEx is not None: + + # Get the GraphViz install path from the registry + # + hkey = None + potentialKeys = [ + "SOFTWARE\\ATT\\Graphviz", + "SOFTWARE\\AT&T Research Labs\\Graphviz", + ] + for potentialKey in potentialKeys: + + try: + hkey = RegOpenKeyEx(HKEY_LOCAL_MACHINE, + potentialKey, 0, KEY_QUERY_VALUE) + + if hkey is not None: + path = RegQueryValueEx(hkey, "InstallPath") + RegCloseKey(hkey) + + # The regitry variable might exist, left by old installations + # but with no value, in those cases we keep + # searching... + if not path: + continue + + # Now append the "bin" subdirectory: + # + path = os.path.join(path, "bin") + progs = __find_executables(path) + if progs is not None: + # print "Used Windows registry" + return progs + + except Exception as excp: + #raise excp + pass + else: + break + + # Method 2 (Linux, Windows etc) + # + if 'PATH' in os.environ: + + for path in os.environ['PATH'].split(os.pathsep): + progs = __find_executables(path) + if progs is not None: + # print "Used path" + return progs + + # Method 3 (Windows only) + # + if os.sys.platform == 'win32': + + # Try and work out the equivalent of "C:\Program Files" on this + # machine (might be on drive D:, or in a different language) + # + + if 'PROGRAMFILES' in os.environ: + + # Note, we could also use the win32api to get this + # information, but win32api may not be installed. + + path = os.path.join( + os.environ['PROGRAMFILES'], + 'ATT', + 'GraphViz', + 'bin') + + else: + + # Just in case, try the default... + path = r"C:\Program Files\att\Graphviz\bin" + + progs = __find_executables(path) + + if progs is not None: + + # print "Used default install location" + return progs + + for path in ( + '/usr/bin', '/usr/local/bin', + '/opt/local/bin', + '/opt/bin', '/sw/bin', '/usr/share', + '/Applications/Graphviz.app/Contents/MacOS/'): + + progs = __find_executables(path) + if progs is not None: + # print "Used path" + return progs + + # Failed to find GraphViz + # + return None + + +class Common: + + """Common information to several classes. + + Should not be directly used, several classes are derived from + this one. + """ + + def __getstate__(self): + + dict = copy.copy(self.obj_dict) + + return dict + + def __setstate__(self, state): + + self.obj_dict = state + + def __get_attribute__(self, attr): + """Look for default attributes for this node""" + + attr_val = self.obj_dict['attributes'].get(attr, None) + + if attr_val is None: + # get the defaults for nodes/edges + + default_node_name = self.obj_dict['type'] + + # The defaults for graphs are set on a node named 'graph' + if default_node_name in ('subgraph', 'digraph', 'cluster'): + default_node_name = 'graph' + + g = self.get_parent_graph() + if g is not None: + defaults = g.get_node(default_node_name) + else: + return None + + # Multiple defaults could be set by having repeated 'graph [...]' + # 'node [...]', 'edge [...]' statements. In such case, if the + # same attribute is set in different statements, only the first + # will be returned. In order to get all, one would call the + # get_*_defaults() methods and handle those. Or go node by node + # (of the ones specifying defaults) and modify the attributes + # individually. + # + if not isinstance(defaults, (list, tuple)): + defaults = [defaults] + + for default in defaults: + attr_val = default.obj_dict['attributes'].get(attr, None) + if attr_val: + return attr_val + else: + return attr_val + + return None + + def set_parent_graph(self, parent_graph): + + self.obj_dict['parent_graph'] = parent_graph + + def get_parent_graph(self): + + return self.obj_dict.get('parent_graph', None) + + def set(self, name, value): + """Set an attribute value by name. + + Given an attribute 'name' it will set its value to 'value'. + There's always the possibility of using the methods: + + set_'name'(value) + + which are defined for all the existing attributes. + """ + + self.obj_dict['attributes'][name] = value + + def get(self, name): + """Get an attribute value by name. + + Given an attribute 'name' it will get its value. + There's always the possibility of using the methods: + + get_'name'() + + which are defined for all the existing attributes. + """ + + return self.obj_dict['attributes'].get(name, None) + + def get_attributes(self): + """""" + + return self.obj_dict['attributes'] + + def set_sequence(self, seq): + + self.obj_dict['sequence'] = seq + + def get_sequence(self): + + return self.obj_dict['sequence'] + + def create_attribute_methods(self, obj_attributes): + + # for attr in self.obj_dict['attributes']: + for attr in obj_attributes: + + # Generate all the Setter methods. + # + self.__setattr__( + 'set_' + + attr, + lambda x, + a=attr: self.obj_dict['attributes'].__setitem__( + a, + x)) + + # Generate all the Getter methods. + # + self.__setattr__( + 'get_' + attr, + lambda a=attr: self.__get_attribute__(a)) + + +class Error(Exception): + + """General error handling class. + """ + + def __init__(self, value): + self.value = value + + def __str__(self): + return self.value + + +class InvocationException(Exception): + + """To indicate that a ploblem occurred while running any of the GraphViz executables. + """ + + def __init__(self, value): + self.value = value + + def __str__(self): + return self.value + + +class Node(object, Common): + + """A graph node. + + This class represents a graph's node with all its attributes. + + node(name, attribute=value, ...) + + name: node's name + + All the attributes defined in the Graphviz dot language should + be supported. + """ + + def __init__(self, name='', obj_dict=None, **attrs): + + # + # Nodes will take attributes of all other types because the defaults + # for any GraphViz object are dealt with as if they were Node definitions + # + + if obj_dict is not None: + + self.obj_dict = obj_dict + + else: + + self.obj_dict = dict() + + # Copy the attributes + # + self.obj_dict['attributes'] = dict(attrs) + self.obj_dict['type'] = 'node' + self.obj_dict['parent_graph'] = None + self.obj_dict['parent_node_list'] = None + self.obj_dict['sequence'] = None + + # Remove the compass point + # + port = None + if isinstance(name, basestring) and not name.startswith('"'): + idx = name.find(':') + if idx > 0 and idx + 1 < len(name): + name, port = name[:idx], name[idx:] + + if isinstance(name, (long, int)): + name = str(name) + + self.obj_dict['name'] = quote_if_necessary(name) + self.obj_dict['port'] = port + + self.create_attribute_methods(NODE_ATTRIBUTES) + + def set_name(self, node_name): + """Set the node's name.""" + + self.obj_dict['name'] = node_name + + def get_name(self): + """Get the node's name.""" + + return self.obj_dict['name'] + + def get_port(self): + """Get the node's port.""" + + return self.obj_dict['port'] + + def add_style(self, style): + + styles = self.obj_dict['attributes'].get('style', None) + if not styles and style: + styles = [style] + else: + styles = styles.split(',') + styles.append(style) + + self.obj_dict['attributes']['style'] = ','.join(styles) + + def to_string(self): + """Returns a string representation of the node in dot language. + """ + + # RMF: special case defaults for node, edge and graph properties. + # + node = quote_if_necessary(self.obj_dict['name']) + + node_attr = list() + + for attr, value in self.obj_dict['attributes'].iteritems(): + if value is not None: + node_attr.append('%s=%s' % (attr, quote_if_necessary(value))) + else: + node_attr.append(attr) + + # No point in having nodes setting any defaults if the don't set + # any attributes... + # + if node in ('graph', 'node', 'edge') and len(node_attr) == 0: + return '' + + node_attr = ', '.join(node_attr) + + if node_attr: + node += ' [' + node_attr + ']' + + return node + ';' + + +class Edge(object, Common): + + """A graph edge. + + This class represents a graph's edge with all its attributes. + + edge(src, dst, attribute=value, ...) + + src: source node's name + dst: destination node's name + + All the attributes defined in the Graphviz dot language should + be supported. + + Attributes can be set through the dynamically generated methods: + + set_[attribute name], i.e. set_label, set_fontname + + or directly by using the instance's special dictionary: + + Edge.obj_dict['attributes'][attribute name], i.e. + + edge_instance.obj_dict['attributes']['label'] + edge_instance.obj_dict['attributes']['fontname'] + + """ + + def __init__(self, src='', dst='', obj_dict=None, **attrs): + + if isinstance(src, (list, tuple)) and dst == '': + src, dst = src + + if obj_dict is not None: + + self.obj_dict = obj_dict + + else: + + self.obj_dict = dict() + + # Copy the attributes + # + self.obj_dict['attributes'] = dict(attrs) + self.obj_dict['type'] = 'edge' + self.obj_dict['parent_graph'] = None + self.obj_dict['parent_edge_list'] = None + self.obj_dict['sequence'] = None + + if isinstance(src, Node): + src = src.get_name() + + if isinstance(dst, Node): + dst = dst.get_name() + + points = (quote_if_necessary(src), quote_if_necessary(dst)) + + self.obj_dict['points'] = points + + self.create_attribute_methods(EDGE_ATTRIBUTES) + + def get_source(self): + """Get the edges source node name.""" + + return self.obj_dict['points'][0] + + def get_destination(self): + """Get the edge's destination node name.""" + + return self.obj_dict['points'][1] + + def __hash__(self): + + return hash(hash(self.get_source()) + hash(self.get_destination())) + + def __eq__(self, edge): + """Compare two edges. + + If the parent graph is directed, arcs linking + node A to B are considered equal and A->B != B->A + + If the parent graph is undirected, any edge + connecting two nodes is equal to any other + edge connecting the same nodes, A->B == B->A + """ + + if not isinstance(edge, Edge): + raise Error("Can't compare and edge to a non-edge object.") + + if self.get_parent_graph().get_top_graph_type() == 'graph': + + # If the graph is undirected, the edge has neither + # source nor destination. + # + if ((self.get_source() == edge.get_source() and self.get_destination() == edge.get_destination()) or ( + edge.get_source() == self.get_destination() and edge.get_destination() == self.get_source())): + return True + + else: + + if self.get_source() == edge.get_source( + ) and self.get_destination() == edge.get_destination(): + return True + + return False + + def parse_node_ref(self, node_str): + + if not isinstance(node_str, str): + return node_str + + if node_str.startswith('"') and node_str.endswith('"'): + + return node_str + + node_port_idx = node_str.rfind(':') + + if node_port_idx > 0 and node_str[0] == '"' and node_str[ + node_port_idx - + 1] == '"': + + return node_str + + if node_port_idx > 0: + + a = node_str[:node_port_idx] + b = node_str[node_port_idx + 1:] + + node = quote_if_necessary(a) + + node += ':' + quote_if_necessary(b) + + return node + + return node_str + + def to_string(self): + """Returns a string representation of the edge in dot language. + """ + + src = self.parse_node_ref(self.get_source()) + dst = self.parse_node_ref(self.get_destination()) + + if isinstance(src, frozendict): + edge = [Subgraph(obj_dict=src).to_string()] + elif isinstance(src, (int, long)): + edge = [str(src)] + else: + edge = [src] + + if (self.get_parent_graph() and + self.get_parent_graph().get_top_graph_type() and + self.get_parent_graph().get_top_graph_type() == 'digraph'): + + edge.append('->') + + else: + edge.append('--') + + if isinstance(dst, frozendict): + edge.append(Subgraph(obj_dict=dst).to_string()) + elif isinstance(dst, (int, long)): + edge.append(str(dst)) + else: + edge.append(dst) + + edge_attr = list() + + for attr, value in self.obj_dict['attributes'].iteritems(): + + if value is not None: + edge_attr.append('%s=%s' % (attr, quote_if_necessary(value))) + else: + edge_attr.append(attr) + + edge_attr = ', '.join(edge_attr) + + if edge_attr: + edge.append(' [' + edge_attr + ']') + + return ' '.join(edge) + ';' + + +class Graph(object, Common): + + """Class representing a graph in Graphviz's dot language. + + This class implements the methods to work on a representation + of a graph in Graphviz's dot language. + + graph( graph_name='G', graph_type='digraph', + strict=False, suppress_disconnected=False, attribute=value, ...) + + graph_name: + the graph's name + graph_type: + can be 'graph' or 'digraph' + suppress_disconnected: + defaults to False, which will remove from the + graph any disconnected nodes. + simplify: + if True it will avoid displaying equal edges, i.e. + only one edge between two nodes. removing the + duplicated ones. + + All the attributes defined in the Graphviz dot language should + be supported. + + Attributes can be set through the dynamically generated methods: + + set_[attribute name], i.e. set_size, set_fontname + + or using the instance's attributes: + + Graph.obj_dict['attributes'][attribute name], i.e. + + graph_instance.obj_dict['attributes']['label'] + graph_instance.obj_dict['attributes']['fontname'] + """ + + def __init__( + self, + graph_name='G', + obj_dict=None, + graph_type='digraph', + strict=False, + suppress_disconnected=False, + simplify=False, + **attrs): + + if obj_dict is not None: + self.obj_dict = obj_dict + + else: + + self.obj_dict = dict() + + self.obj_dict['attributes'] = dict(attrs) + + if graph_type not in ['graph', 'digraph']: + raise Error( + 'Invalid type "%s". Accepted graph types are: graph, digraph, subgraph' % + graph_type) + + self.obj_dict['name'] = quote_if_necessary(graph_name) + self.obj_dict['type'] = graph_type + + self.obj_dict['strict'] = strict + self.obj_dict['suppress_disconnected'] = suppress_disconnected + self.obj_dict['simplify'] = simplify + + self.obj_dict['current_child_sequence'] = 1 + self.obj_dict['nodes'] = dict() + self.obj_dict['edges'] = dict() + self.obj_dict['subgraphs'] = dict() + + self.set_parent_graph(self) + + self.create_attribute_methods(GRAPH_ATTRIBUTES) + + def get_graph_type(self): + + return self.obj_dict['type'] + + def get_top_graph_type(self): + + parent = self + while True: + parent_ = parent.get_parent_graph() + if parent_ == parent: + break + parent = parent_ + + return parent.obj_dict['type'] + + def set_graph_defaults(self, **attrs): + + self.add_node(Node('graph', **attrs)) + + def get_graph_defaults(self, **attrs): + + graph_nodes = self.get_node('graph') + + if isinstance(graph_nodes, (list, tuple)): + return [node.get_attributes() for node in graph_nodes] + + return graph_nodes.get_attributes() + + def set_node_defaults(self, **attrs): + + self.add_node(Node('node', **attrs)) + + def get_node_defaults(self, **attrs): + + graph_nodes = self.get_node('node') + + if isinstance(graph_nodes, (list, tuple)): + return [node.get_attributes() for node in graph_nodes] + + return graph_nodes.get_attributes() + + def set_edge_defaults(self, **attrs): + + self.add_node(Node('edge', **attrs)) + + def get_edge_defaults(self, **attrs): + + graph_nodes = self.get_node('edge') + + if isinstance(graph_nodes, (list, tuple)): + return [node.get_attributes() for node in graph_nodes] + + return graph_nodes.get_attributes() + + def set_simplify(self, simplify): + """Set whether to simplify or not. + + If True it will avoid displaying equal edges, i.e. + only one edge between two nodes. removing the + duplicated ones. + """ + + self.obj_dict['simplify'] = simplify + + def get_simplify(self): + """Get whether to simplify or not. + + Refer to set_simplify for more information. + """ + + return self.obj_dict['simplify'] + + def set_type(self, graph_type): + """Set the graph's type, 'graph' or 'digraph'.""" + + self.obj_dict['type'] = graph_type + + def get_type(self): + """Get the graph's type, 'graph' or 'digraph'.""" + + return self.obj_dict['type'] + + def set_name(self, graph_name): + """Set the graph's name.""" + + self.obj_dict['name'] = graph_name + + def get_name(self): + """Get the graph's name.""" + + return self.obj_dict['name'] + + def set_strict(self, val): + """Set graph to 'strict' mode. + + This option is only valid for top level graphs. + """ + + self.obj_dict['strict'] = val + + def get_strict(self, val): + """Get graph's 'strict' mode (True, False). + + This option is only valid for top level graphs. + """ + + return self.obj_dict['strict'] + + def set_suppress_disconnected(self, val): + """Suppress disconnected nodes in the output graph. + + This option will skip nodes in the graph with no incoming or outgoing + edges. This option works also for subgraphs and has effect only in the + current graph/subgraph. + """ + + self.obj_dict['suppress_disconnected'] = val + + def get_suppress_disconnected(self, val): + """Get if suppress disconnected is set. + + Refer to set_suppress_disconnected for more information. + """ + + return self.obj_dict['suppress_disconnected'] + + def get_next_sequence_number(self): + + seq = self.obj_dict['current_child_sequence'] + + self.obj_dict['current_child_sequence'] += 1 + + return seq + + def add_node(self, graph_node): + """Adds a node object to the graph. + + It takes a node object as its only argument and returns + None. + """ + + if not isinstance(graph_node, Node): + raise TypeError( + 'add_node() received a non node class object: ' + + str(graph_node)) + + node = self.get_node(graph_node.get_name()) + + if not node: + + self.obj_dict['nodes'][ + graph_node.get_name()] = [ + graph_node.obj_dict] + + #self.node_dict[graph_node.get_name()] = graph_node.attributes + graph_node.set_parent_graph(self.get_parent_graph()) + + else: + + self.obj_dict['nodes'][ + graph_node.get_name()].append( + graph_node.obj_dict) + + graph_node.set_sequence(self.get_next_sequence_number()) + + def del_node(self, name, index=None): + """Delete a node from the graph. + + Given a node's name all node(s) with that same name + will be deleted if 'index' is not specified or set + to None. + If there are several nodes with that same name and + 'index' is given, only the node in that position + will be deleted. + + 'index' should be an integer specifying the position + of the node to delete. If index is larger than the + number of nodes with that name, no action is taken. + + If nodes are deleted it returns True. If no action + is taken it returns False. + """ + + if isinstance(name, Node): + name = name.get_name() + + if name in self.obj_dict['nodes']: + + if index is not None and index < len(self.obj_dict['nodes'][name]): + del self.obj_dict['nodes'][name][index] + return True + else: + del self.obj_dict['nodes'][name] + return True + + return False + + def get_node(self, name): + """Retrieve a node from the graph. + + Given a node's name the corresponding Node + instance will be returned. + + If one or more nodes exist with that name a list of + Node instances is returned. + An empty list is returned otherwise. + """ + + match = list() + + if name in self.obj_dict['nodes']: + + match.extend([Node(obj_dict=obj_dict) + for obj_dict in self.obj_dict['nodes'][name]]) + + return match + + def get_nodes(self): + """Get the list of Node instances.""" + + return self.get_node_list() + + def get_node_list(self): + """Get the list of Node instances. + + This method returns the list of Node instances + composing the graph. + """ + + node_objs = list() + + for node, obj_dict_list in self.obj_dict['nodes'].iteritems(): + node_objs.extend([Node(obj_dict=obj_d) for obj_d in obj_dict_list]) + + return node_objs + + def add_edge(self, graph_edge): + """Adds an edge object to the graph. + + It takes a edge object as its only argument and returns + None. + """ + + if not isinstance(graph_edge, Edge): + raise TypeError( + 'add_edge() received a non edge class object: ' + + str(graph_edge)) + + edge_points = (graph_edge.get_source(), graph_edge.get_destination()) + + if edge_points in self.obj_dict['edges']: + + edge_list = self.obj_dict['edges'][edge_points] + edge_list.append(graph_edge.obj_dict) + + else: + + self.obj_dict['edges'][edge_points] = [graph_edge.obj_dict] + + graph_edge.set_sequence(self.get_next_sequence_number()) + + graph_edge.set_parent_graph(self.get_parent_graph()) + + def del_edge(self, src_or_list, dst=None, index=None): + """Delete an edge from the graph. + + Given an edge's (source, destination) node names all + matching edges(s) will be deleted if 'index' is not + specified or set to None. + If there are several matching edges and 'index' is + given, only the edge in that position will be deleted. + + 'index' should be an integer specifying the position + of the edge to delete. If index is larger than the + number of matching edges, no action is taken. + + If edges are deleted it returns True. If no action + is taken it returns False. + """ + + if isinstance(src_or_list, (list, tuple)): + if dst is not None and isinstance(dst, (int, long)): + index = dst + src, dst = src_or_list + else: + src, dst = src_or_list, dst + + if isinstance(src, Node): + src = src.get_name() + + if isinstance(dst, Node): + dst = dst.get_name() + + if (src, dst) in self.obj_dict['edges']: + + if index is not None and index < len( + self.obj_dict['edges'][ + (src, dst)]): + del self.obj_dict['edges'][(src, dst)][index] + return True + else: + del self.obj_dict['edges'][(src, dst)] + return True + + return False + + def get_edge(self, src_or_list, dst=None): + """Retrieved an edge from the graph. + + Given an edge's source and destination the corresponding + Edge instance(s) will be returned. + + If one or more edges exist with that source and destination + a list of Edge instances is returned. + An empty list is returned otherwise. + """ + + if isinstance(src_or_list, (list, tuple)) and dst is None: + edge_points = tuple(src_or_list) + edge_points_reverse = (edge_points[1], edge_points[0]) + else: + edge_points = (src_or_list, dst) + edge_points_reverse = (dst, src_or_list) + + match = list() + + if edge_points in self.obj_dict['edges'] or ( + self.get_top_graph_type() == 'graph' and edge_points_reverse in self.obj_dict['edges']): + + edges_obj_dict = self.obj_dict['edges'].get( + edge_points, + self.obj_dict['edges'].get(edge_points_reverse, None)) + + for edge_obj_dict in edges_obj_dict: + match.append( + Edge( + edge_points[0], + edge_points[1], + obj_dict=edge_obj_dict)) + + return match + + def get_edges(self): + return self.get_edge_list() + + def get_edge_list(self): + """Get the list of Edge instances. + + This method returns the list of Edge instances + composing the graph. + """ + + edge_objs = list() + + for edge, obj_dict_list in self.obj_dict['edges'].iteritems(): + edge_objs.extend([Edge(obj_dict=obj_d) for obj_d in obj_dict_list]) + + return edge_objs + + def add_subgraph(self, sgraph): + """Adds an subgraph object to the graph. + + It takes a subgraph object as its only argument and returns + None. + """ + + if not isinstance( + sgraph, + Subgraph) and not isinstance( + sgraph, + Cluster): + raise TypeError( + 'add_subgraph() received a non subgraph class object:' + + str(sgraph)) + + if sgraph.get_name() in self.obj_dict['subgraphs']: + + sgraph_list = self.obj_dict['subgraphs'][sgraph.get_name()] + sgraph_list.append(sgraph.obj_dict) + + else: + self.obj_dict['subgraphs'][sgraph.get_name()] = [sgraph.obj_dict] + + sgraph.set_sequence(self.get_next_sequence_number()) + + sgraph.set_parent_graph(self.get_parent_graph()) + + def get_subgraph(self, name): + """Retrieved a subgraph from the graph. + + Given a subgraph's name the corresponding + Subgraph instance will be returned. + + If one or more subgraphs exist with the same name, a list of + Subgraph instances is returned. + An empty list is returned otherwise. + """ + + match = list() + + if name in self.obj_dict['subgraphs']: + + sgraphs_obj_dict = self.obj_dict['subgraphs'].get(name) + + for obj_dict_list in sgraphs_obj_dict: + #match.extend( Subgraph( obj_dict = obj_d ) for obj_d in obj_dict_list ) + match.append(Subgraph(obj_dict=obj_dict_list)) + + return match + + def get_subgraphs(self): + + return self.get_subgraph_list() + + def get_subgraph_list(self): + """Get the list of Subgraph instances. + + This method returns the list of Subgraph instances + in the graph. + """ + + sgraph_objs = list() + + for sgraph, obj_dict_list in self.obj_dict['subgraphs'].iteritems(): + sgraph_objs.extend([Subgraph(obj_dict=obj_d) + for obj_d in obj_dict_list]) + + return sgraph_objs + + def set_parent_graph(self, parent_graph): + + self.obj_dict['parent_graph'] = parent_graph + + for obj_list in self.obj_dict['nodes'].itervalues(): + for obj in obj_list: + obj['parent_graph'] = parent_graph + + for obj_list in self.obj_dict['edges'].itervalues(): + for obj in obj_list: + obj['parent_graph'] = parent_graph + + for obj_list in self.obj_dict['subgraphs'].itervalues(): + for obj in obj_list: + Graph(obj_dict=obj).set_parent_graph(parent_graph) + + def to_string(self): + """Returns a string representation of the graph in dot language. + + It will return the graph and all its subelements in string from. + """ + + graph = list() + + if self.obj_dict.get('strict', None) is not None: + + if self == self.get_parent_graph() and self.obj_dict['strict']: + + graph.append('strict ') + + if self.obj_dict['name'] == '': + if 'show_keyword' in self.obj_dict and self.obj_dict[ + 'show_keyword']: + graph.append('subgraph {\n') + else: + graph.append('{\n') + else: + graph.append( + '%s %s {\n' % + (self.obj_dict['type'], self.obj_dict['name'])) + + for attr in self.obj_dict['attributes'].iterkeys(): + + if self.obj_dict['attributes'].get(attr, None) is not None: + + val = self.obj_dict['attributes'].get(attr) + if val is not None: + graph.append('%s=%s' % (attr, quote_if_necessary(val))) + else: + graph.append(attr) + + graph.append(';\n') + + edges_done = set() + + edge_obj_dicts = list() + for e in self.obj_dict['edges'].itervalues(): + edge_obj_dicts.extend(e) + + if edge_obj_dicts: + edge_src_set, edge_dst_set = zip( + *[obj['points'] for obj in edge_obj_dicts]) + edge_src_set, edge_dst_set = set(edge_src_set), set(edge_dst_set) + else: + edge_src_set, edge_dst_set = set(), set() + + node_obj_dicts = list() + for e in self.obj_dict['nodes'].itervalues(): + node_obj_dicts.extend(e) + + sgraph_obj_dicts = list() + for sg in self.obj_dict['subgraphs'].itervalues(): + sgraph_obj_dicts.extend(sg) + + obj_list = sorted([(obj['sequence'], obj) for obj in ( + edge_obj_dicts + node_obj_dicts + sgraph_obj_dicts)]) + + for idx, obj in obj_list: + + if obj['type'] == 'node': + + node = Node(obj_dict=obj) + + if self.obj_dict.get('suppress_disconnected', False): + + if (node.get_name() not in edge_src_set and + node.get_name() not in edge_dst_set): + + continue + + graph.append(node.to_string() + '\n') + + elif obj['type'] == 'edge': + + edge = Edge(obj_dict=obj) + + if self.obj_dict.get('simplify', False) and edge in edges_done: + continue + + graph.append(edge.to_string() + '\n') + edges_done.add(edge) + + else: + + sgraph = Subgraph(obj_dict=obj) + + graph.append(sgraph.to_string() + '\n') + + graph.append('}\n') + + return ''.join(graph) + + +class Subgraph(Graph): + + """Class representing a subgraph in Graphviz's dot language. + + This class implements the methods to work on a representation + of a subgraph in Graphviz's dot language. + + subgraph(graph_name='subG', suppress_disconnected=False, attribute=value, ...) + + graph_name: + the subgraph's name + suppress_disconnected: + defaults to false, which will remove from the + subgraph any disconnected nodes. + All the attributes defined in the Graphviz dot language should + be supported. + + Attributes can be set through the dynamically generated methods: + + set_[attribute name], i.e. set_size, set_fontname + + or using the instance's attributes: + + Subgraph.obj_dict['attributes'][attribute name], i.e. + + subgraph_instance.obj_dict['attributes']['label'] + subgraph_instance.obj_dict['attributes']['fontname'] + """ + + # RMF: subgraph should have all the attributes of graph so it can be passed + # as a graph to all methods + # + def __init__( + self, + graph_name='', + obj_dict=None, + suppress_disconnected=False, + simplify=False, + **attrs): + + Graph.__init__( + self, + graph_name=graph_name, + obj_dict=obj_dict, + suppress_disconnected=suppress_disconnected, + simplify=simplify, + **attrs) + + if obj_dict is None: + + self.obj_dict['type'] = 'subgraph' + + +class Cluster(Graph): + + """Class representing a cluster in Graphviz's dot language. + + This class implements the methods to work on a representation + of a cluster in Graphviz's dot language. + + cluster(graph_name='subG', suppress_disconnected=False, attribute=value, ...) + + graph_name: + the cluster's name (the string 'cluster' will be always prepended) + suppress_disconnected: + defaults to false, which will remove from the + cluster any disconnected nodes. + All the attributes defined in the Graphviz dot language should + be supported. + + Attributes can be set through the dynamically generated methods: + + set_[attribute name], i.e. set_color, set_fontname + + or using the instance's attributes: + + Cluster.obj_dict['attributes'][attribute name], i.e. + + cluster_instance.obj_dict['attributes']['label'] + cluster_instance.obj_dict['attributes']['fontname'] + """ + + def __init__( + self, + graph_name='subG', + obj_dict=None, + suppress_disconnected=False, + simplify=False, + **attrs): + + Graph.__init__( + self, + graph_name=graph_name, + obj_dict=obj_dict, + suppress_disconnected=suppress_disconnected, + simplify=simplify, + **attrs) + + if obj_dict is None: + + self.obj_dict['type'] = 'subgraph' + self.obj_dict['name'] = 'cluster_' + graph_name + + self.create_attribute_methods(CLUSTER_ATTRIBUTES) + + +class Dot(Graph): + + """A container for handling a dot language file. + + This class implements methods to write and process + a dot language file. It is a derived class of + the base class 'Graph'. + """ + + def __init__(self, *argsl, **argsd): + Graph.__init__(self, *argsl, **argsd) + + self.shape_files = list() + + self.progs = None + + self.formats = [ + 'canon', + 'cmap', + 'cmapx', + 'cmapx_np', + 'dia', + 'dot', + 'fig', + 'gd', + 'gd2', + 'gif', + 'hpgl', + 'imap', + 'imap_np', + 'ismap', + 'jpe', + 'jpeg', + 'jpg', + 'mif', + 'mp', + 'pcl', + 'pdf', + 'pic', + 'plain', + 'plain-ext', + 'png', + 'ps', + 'ps2', + 'svg', + 'svgz', + 'vml', + 'vmlz', + 'vrml', + 'vtx', + 'wbmp', + 'xdot', + 'xlib'] + + self.prog = 'dot' + + # Automatically creates all the methods enabling the creation + # of output in any of the supported formats. + for frmt in self.formats: + self.__setattr__( + 'create_' + frmt, + lambda f=frmt, + prog=self.prog: self.create( + format=f, + prog=prog)) + f = self.__dict__['create_' + frmt] + f.__doc__ = '''Refer to the docstring accompanying the 'create' method for more information.''' + + for frmt in self.formats + ['raw']: + self.__setattr__( + 'write_' + frmt, + lambda path, + f=frmt, + prog=self.prog: self.write( + path, + format=f, + prog=prog)) + + f = self.__dict__['write_' + frmt] + f.__doc__ = '''Refer to the docstring accompanying the 'write' method for more information.''' + + def __getstate__(self): + + dict = copy.copy(self.obj_dict) + + return dict + + def __setstate__(self, state): + + self.obj_dict = state + + def set_shape_files(self, file_paths): + """Add the paths of the required image files. + + If the graph needs graphic objects to be used as shapes or otherwise + those need to be in the same folder as the graph is going to be rendered + from. Alternatively the absolute path to the files can be specified when + including the graphics in the graph. + + The files in the location pointed to by the path(s) specified as arguments + to this method will be copied to the same temporary location where the + graph is going to be rendered. + """ + + if isinstance(file_paths, basestring): + self.shape_files.append(file_paths) + + if isinstance(file_paths, (list, tuple)): + self.shape_files.extend(file_paths) + + def set_prog(self, prog): + """Sets the default program. + + Sets the default program in charge of processing + the dot file into a graph. + """ + self.prog = prog + + def set_graphviz_executables(self, paths): + """This method allows to manually specify the location of the GraphViz executables. + + The argument to this method should be a dictionary where the keys are as follows: + + {'dot': '', 'twopi': '', 'neato': '', 'circo': '', 'fdp': ''} + + and the values are the paths to the corresponding executable, including the name + of the executable itself. + """ + + self.progs = paths + + def write(self, path, prog=None, format='raw'): + """Writes a graph to a file. + + Given a filename 'path' it will open/create and truncate + such file and write on it a representation of the graph + defined by the dot object and in the format specified by + 'format'. + The format 'raw' is used to dump the string representation + of the Dot object, without further processing. + The output can be processed by any of graphviz tools, defined + in 'prog', which defaults to 'dot' + Returns True or False according to the success of the write + operation. + + There's also the preferred possibility of using: + + write_'format'(path, prog='program') + + which are automatically defined for all the supported formats. + [write_ps(), write_gif(), write_dia(), ...] + """ + + if prog is None: + prog = self.prog + + dot_fd = file(path, "w+b") + if format == 'raw': + data = self.to_string() + if isinstance(data, basestring): + if not isinstance(data, unicode): + try: + data = unicode(data, 'utf-8') + except: + pass + + try: + data = data.encode('utf-8') + except: + pass + dot_fd.write(data) + else: + dot_fd.write(self.create(prog, format)) + dot_fd.close() + + return True + + def create(self, prog=None, format='ps'): + """Creates and returns a Postscript representation of the graph. + + create will write the graph to a temporary dot file and process + it with the program given by 'prog' (which defaults to 'twopi'), + reading the Postscript output and returning it as a string is the + operation is successful. + On failure None is returned. + + There's also the preferred possibility of using: + + create_'format'(prog='program') + + which are automatically defined for all the supported formats. + [create_ps(), create_gif(), create_dia(), ...] + + If 'prog' is a list instead of a string the fist item is expected + to be the program name, followed by any optional command-line + arguments for it: + + [ 'twopi', '-Tdot', '-s10' ] + """ + + if prog is None: + prog = self.prog + + if isinstance(prog, (list, tuple)): + prog, args = prog[0], prog[1:] + else: + args = [] + + if self.progs is None: + self.progs = find_graphviz() + if self.progs is None: + raise InvocationException( + 'GraphViz\'s executables not found') + + if prog not in self.progs: + raise InvocationException( + 'GraphViz\'s executable "%s" not found' % prog) + + if not os.path.exists( + self.progs[prog]) or not os.path.isfile( + self.progs[prog]): + raise InvocationException( + 'GraphViz\'s executable "%s" is not a file or doesn\'t exist' % + self.progs[prog]) + + tmp_fd, tmp_name = tempfile.mkstemp() + os.close(tmp_fd) + self.write(tmp_name) + tmp_dir = os.path.dirname(tmp_name) + + # For each of the image files... + # + for img in self.shape_files: + + # Get its data + # + f = file(img, 'rb') + f_data = f.read() + f.close() + + # And copy it under a file with the same name in the temporary directory + # + f = file(os.path.join(tmp_dir, os.path.basename(img)), 'wb') + f.write(f_data) + f.close() + + cmdline = [self.progs[prog], '-T' + format, tmp_name] + args + + p = subprocess.Popen( + cmdline, + cwd=tmp_dir, + stderr=subprocess.PIPE, stdout=subprocess.PIPE) + + stderr = p.stderr + stdout = p.stdout + + stdout_output = list() + while True: + data = stdout.read() + if not data: + break + stdout_output.append(data) + stdout.close() + + stdout_output = ''.join(stdout_output) + + if not stderr.closed: + stderr_output = list() + while True: + data = stderr.read() + if not data: + break + stderr_output.append(data) + stderr.close() + + if stderr_output: + stderr_output = ''.join(stderr_output) + + #pid, status = os.waitpid(p.pid, 0) + status = p.wait() + + if status != 0: + raise InvocationException( + 'Program terminated with status: %d. stderr follows: %s' % ( + status, stderr_output)) + elif stderr_output: + print stderr_output + + # For each of the image files... + # + for img in self.shape_files: + + # remove it + # + os.unlink(os.path.join(tmp_dir, os.path.basename(img))) + + os.unlink(tmp_name) + + return stdout_output From 0199fc1374b8871b48f93e070a96ad9514a9d299 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 14:44:30 +0200 Subject: [PATCH 64/70] Add error message to only_children_to... --- scripts/module/only_children_to_all_genealogy.py | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/scripts/module/only_children_to_all_genealogy.py b/scripts/module/only_children_to_all_genealogy.py index f330cf97..564bbe4b 100755 --- a/scripts/module/only_children_to_all_genealogy.py +++ b/scripts/module/only_children_to_all_genealogy.py @@ -6,7 +6,8 @@ Create the NEEDED_MODULE aka the genealogy (children module, subchildren module of a NEEDED_CHILDREN_MODULES file Usage: - only_children_to_all_genealogy.py [--create_png] [] + only_children_to_all_genealogy.py [] + [--create_png] Help: If NEEDED_CHILDREN_MODULES is not set, check the current pwd @@ -16,6 +17,7 @@ Help: from docopt import docopt import os +import sys import os.path from functools import wraps @@ -87,7 +89,12 @@ def get_it_and_children(l_module): for module in l_module: if module not in l: l.append(module) - l.extend(get_it_and_children(d_ref[module])) + try: + l.extend(get_it_and_children(d_ref[module])) + except KeyError: + print >> sys.stderr, "`{0}` in not a good submodule name".format(module) + print >> sys.stderr, "Check the corresponding NEEDED_CHILDREN_MODULES" + sys.exit(1) return list(set(l)) From fdc415b4a2245c0218fa54c0ef27f24f529af9c2 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 15:03:53 +0200 Subject: [PATCH 65/70] Rename only_children... into module_handler.py --- scripts/check_dependencies.sh | 5 +++-- scripts/clean_modules.sh | 3 ++- ..._to_all_genealogy.py => module_handler.py} | 22 +++++++++++-------- scripts/qp_include.sh | 3 ++- src/Makefile.common | 2 +- 5 files changed, 21 insertions(+), 14 deletions(-) rename scripts/module/{only_children_to_all_genealogy.py => module_handler.py} (86%) diff --git a/scripts/check_dependencies.sh b/scripts/check_dependencies.sh index e1149d2d..37e9ba00 100755 --- a/scripts/check_dependencies.sh +++ b/scripts/check_dependencies.sh @@ -25,7 +25,8 @@ fi if [[ $1 == "-" ]] then - COMMAND_LINE=$(only_children_to_all_genealogy.py NEEDED_MODULES) + + COMMAND_LINE=$(module_handler.py print_genealogy NEEDED_MODULES) else COMMAND_LINE=$(unique_list $@) fi @@ -44,7 +45,7 @@ DEPS_LONG="" for i in $COMMAND_LINE do DEPS_LONG+=" $i " - DEPS_LONG+=$(only_children_to_all_genealogy.py "${QPACKAGE_ROOT}/src/${i}/NEEDED_MODULES") + DEPS_LONG+=$(module_handler.py print_genealogy "${QPACKAGE_ROOT}/src/${i}/NEEDED_MODULES") done DEPS=$(unique_list $DEPS_LONG) diff --git a/scripts/clean_modules.sh b/scripts/clean_modules.sh index e51bbede..608e0161 100755 --- a/scripts/clean_modules.sh +++ b/scripts/clean_modules.sh @@ -13,7 +13,8 @@ source ${QPACKAGE_ROOT}/scripts/qp_include.sh function do_clean() { rm -rf -- \ - IRPF90_temp IRPF90_man Makefile.depend $(only_children_to_all_genealogy.py) include \ + IRPF90_temp IRPF90_man Makefile.depend \ + $(module_handler.py print_genealogy) include \ ezfio_interface.irp.f irpf90.make irpf90_entities tags $(ls_exe) *.mod } diff --git a/scripts/module/only_children_to_all_genealogy.py b/scripts/module/module_handler.py similarity index 86% rename from scripts/module/only_children_to_all_genealogy.py rename to scripts/module/module_handler.py index 564bbe4b..1bb91253 100755 --- a/scripts/module/only_children_to_all_genealogy.py +++ b/scripts/module/module_handler.py @@ -2,16 +2,19 @@ # -*- coding: utf-8 -*- """ -Create the NEEDED_MODULE aka the genealogy (children module, subchildren module and so on), +Create the NEEDED_MODULE + aka the genealogy (children module, subchildren module and so on), of a NEEDED_CHILDREN_MODULES file Usage: - only_children_to_all_genealogy.py [] - [--create_png] + module_handler.py print_genealogy [] + module_handler.py create_png [] -Help: - If NEEDED_CHILDREN_MODULES is not set, check the current pwd - Same for create_png. +Options: + print_genealogy Print the genealogy of the NEEDED_CHILDREN_MODULES + aka (children, subchildren, etc) + if NEEDED_CHILDREN_MODULES + try to open it in the current path """ from docopt import docopt @@ -180,8 +183,9 @@ if __name__ == '__main__': path = os.path.expanduser(path) path = os.path.expandvars(path) - l_all_needed_molule = module_genealogy(path) - print " ".join(sorted(l_all_needed_molule)) + if arguments['print_genealogy']: + l_all_needed_molule = module_genealogy(path) + print " ".join(sorted(l_all_needed_molule)) - if arguments["--create_png"]: + if arguments["create_png"]: create_png_from_path(path) diff --git a/scripts/qp_include.sh b/scripts/qp_include.sh index 04cc6a17..8e2d4f9f 100644 --- a/scripts/qp_include.sh +++ b/scripts/qp_include.sh @@ -35,9 +35,10 @@ function check_current_dir_is_module() exit -1 fi } + if [[ -f NEEDED_CHILDREN_MODULES ]] then - NEEDED_MODULES=$(only_children_to_all_genealogy.py) + NEEDED_MODULES=$(module_handler.py print_genealogy NEEDED_CHILDREN_MODULES) fi # List of executables in the current directory diff --git a/src/Makefile.common b/src/Makefile.common index cd98329e..606e6f7c 100644 --- a/src/Makefile.common +++ b/src/Makefile.common @@ -19,7 +19,7 @@ default: all .gitignore include $(QPACKAGE_ROOT)/src/Makefile.config # Create the NEEDED_CHILDREN_MODULES variable, needed for IRPF90 -NEEDED_CHILDREN_MODULES=$(shell only_children_to_all_genealogy.py) +NEEDED_CHILDREN_MODULES=$(shell module_handler.py print_genealogy) # Check and update dependencies include Makefile.depend From df086e5eddaf275e01824de6f155d6f6d2bec504 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 15:36:58 +0200 Subject: [PATCH 66/70] Remove check_dependencies.sh, is no handle by module_handler.py --- scripts/.gitignore | 1 + scripts/check_dependencies.sh | 64 ------------------------- scripts/create/create_Needed_modules.sh | 6 +-- scripts/create/create_module.sh | 2 +- scripts/module/module_handler.py | 29 +++++++---- scripts/run_Makefile_common.sh | 2 +- src/NEEDED_MODULES | 2 +- 7 files changed, 26 insertions(+), 80 deletions(-) delete mode 100755 scripts/check_dependencies.sh diff --git a/scripts/.gitignore b/scripts/.gitignore index 52e4e611..e456a8d3 100644 --- a/scripts/.gitignore +++ b/scripts/.gitignore @@ -1,2 +1,3 @@ *.pyc *.pyo +docopt.py \ No newline at end of file diff --git a/scripts/check_dependencies.sh b/scripts/check_dependencies.sh deleted file mode 100755 index 37e9ba00..00000000 --- a/scripts/check_dependencies.sh +++ /dev/null @@ -1,64 +0,0 @@ -#!/bin/bash -# -# usage: -# check_dependencies.sh MOs AOs Electrons -# -# Checks that the list of dependencies given in -# argument is consistent. If the dependencies -# are OK the exit code is 0, otherwise it is 1. -# If no argument is given, the dependencies are -# read in the Makefile. -# Thu Apr 3 01:44:23 CEST 2014 - -if [[ -z ${QPACKAGE_ROOT} ]] -then - print "The QPACKAGE_ROOT environment variable is not set." - print "Please reload the quantum_package.rc file." - exit -1 -fi -source ${QPACKAGE_ROOT}/scripts/qp_include.sh - -if [[ -z $1 ]] -then - exit 0 -fi - -if [[ $1 == "-" ]] -then - - COMMAND_LINE=$(module_handler.py print_genealogy NEEDED_MODULES) -else - COMMAND_LINE=$(unique_list $@) -fi - -for d in $COMMAND_LINE -do - if [[ ! -d ${QPACKAGE_ROOT}/src/$d ]] - then - echo Error: Directory $d does not exist - exit 2 - fi - -done - -DEPS_LONG="" -for i in $COMMAND_LINE -do - DEPS_LONG+=" $i " - DEPS_LONG+=$(module_handler.py print_genealogy "${QPACKAGE_ROOT}/src/${i}/NEEDED_MODULES") -done - -DEPS=$(unique_list $DEPS_LONG) - -if [[ ! "$COMMAND_LINE" == "$DEPS" ]] -then - DEPS=$(${QPACKAGE_ROOT}/scripts/check_dependencies.sh ${DEPS}) -fi -echo "$DEPS" - -if [[ "$COMMAND_LINE" == "$DEPS" ]] -then - exit 0 -else - exit 1 -fi diff --git a/scripts/create/create_Needed_modules.sh b/scripts/create/create_Needed_modules.sh index 026eadab..1158058c 100755 --- a/scripts/create/create_Needed_modules.sh +++ b/scripts/create/create_Needed_modules.sh @@ -14,7 +14,5 @@ source ${QPACKAGE_ROOT}/scripts/qp_include.sh check_current_dir_is_module -OUTPUT=$(${QPACKAGE_ROOT}/scripts/check_dependencies.sh $@) -echo ${OUTPUT} > NEEDED_MODULES - - +OUTPUT=$(module_handler.py check_dependencies $@) +echo $@ > NEEDED_CHILDREN_MODULES \ No newline at end of file diff --git a/scripts/create/create_module.sh b/scripts/create/create_module.sh index 90c6586b..a30c1484 100755 --- a/scripts/create/create_module.sh +++ b/scripts/create/create_module.sh @@ -126,7 +126,7 @@ debug "Makefile created" # Create the NEEDED_MODULES file "${QPACKAGE_ROOT}/scripts/create/create_Needed_modules.sh" ${NEEDED_MODULES} || fail "Unable to create the NEEDED_MODULES file" -if [[ ! -f NEEDED_MODULES ]] +if [[ ! -f NEEDED_CHILDREN_MODULES ]] then fail "NEEDED_MODULES was not created" fi diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 1bb91253..3bc1d0e4 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -7,14 +7,16 @@ Create the NEEDED_MODULE of a NEEDED_CHILDREN_MODULES file Usage: - module_handler.py print_genealogy [] - module_handler.py create_png [] + module_handler.py print_genealogy [] + module_handler.py check_dependencies [...] + module_handler.py create_png [] Options: - print_genealogy Print the genealogy of the NEEDED_CHILDREN_MODULES - aka (children, subchildren, etc) - if NEEDED_CHILDREN_MODULES - try to open it in the current path + print_genealogy Print the genealogy of the NEEDED_CHILDREN_MODULES + aka (children, subchildren, etc) + create_png Create a png of the file + NEEDED_CHILDREN_MODULES The path of NEEDED_CHILDREN_MODULES + by default try to open the file in the current path """ from docopt import docopt @@ -73,8 +75,9 @@ def module_genealogy(path): try: with open(path, "r") as f: l_children = f.read().split() - except IOError: - return [] + except IOError as e: + print >> sys.stderr, e + sys.exit(1) else: needed_module = get_it_and_children(l_children) @@ -169,6 +172,7 @@ def create_png(l_module): # Save path = '{0}.png'.format("_".join(l_module)) + print "png saved in {0}".format(path) graph.write_png(path) if __name__ == '__main__': @@ -187,5 +191,12 @@ if __name__ == '__main__': l_all_needed_molule = module_genealogy(path) print " ".join(sorted(l_all_needed_molule)) - if arguments["create_png"]: + elif arguments["check_dependencies"]: + l_module = arguments[''] + if l_module: + l_all_needed_molule = get_it_and_children(l_module) + else: + l_all_needed_molule = module_genealogy(path) + + elif arguments["create_png"]: create_png_from_path(path) diff --git a/scripts/run_Makefile_common.sh b/scripts/run_Makefile_common.sh index c0e88a1e..a92507e2 100755 --- a/scripts/run_Makefile_common.sh +++ b/scripts/run_Makefile_common.sh @@ -14,7 +14,7 @@ check_current_dir_is_module # Check if the NEEDED_MODULES file is consistent INCLUDE_DIRS="${NEEDED_MODULES} include" -NEEDED_MODULES_OK=$( ${QPACKAGE_ROOT}/scripts/check_dependencies.sh ${NEEDED_MODULES} ) +NEEDED_MODULES_OK=$(module_handler.py check_dependencies ${NEEDED_MODULES} ) if [[ $? -ne 0 ]] then error " diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index 4533ccfe..b4c717a9 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Determinants Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC Pseudo_integrals +AOs Bielec_integrals Bitmask CAS_SD CID CID_SC2_selected CID_selected CIS CISD CISD_SC2_selected CISD_selected DDCI_selected Determinants Electrons Ezfio_files FCIdump Full_CI Generators_CAS Generators_full Hartree_Fock MOGuess MOs MP2 MRCC Molden MonoInts Nuclei Output Perturbation Properties Pseudo_integrals Selectors_full SingleRefMethod Utils Toto From c283e6b6888a5415719eb0e6970b9b8303c2d357 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 15:54:51 +0200 Subject: [PATCH 67/70] Change create_module.sh into qp_create_module.sh and so on --- scripts/{ => module}/build_modules.sh | 4 ++-- scripts/{ => module}/clean_modules.sh | 0 scripts/{create => module}/create_Makefile.sh | 0 scripts/{create => module}/create_Makefile_depend.sh | 0 scripts/{create => module}/create_Needed_modules.sh | 0 scripts/{create => module}/create_executables_list.sh | 0 scripts/{create => module}/create_gitignore.sh | 0 scripts/{create => module}/create_rst_templates.sh | 0 .../create_module.sh => module/qp_create_module.sh} | 6 +++--- scripts/run_Makefile_common.sh | 4 ++-- src/Makefile | 8 ++++---- 11 files changed, 11 insertions(+), 11 deletions(-) rename scripts/{ => module}/build_modules.sh (84%) rename scripts/{ => module}/clean_modules.sh (100%) rename scripts/{create => module}/create_Makefile.sh (100%) rename scripts/{create => module}/create_Makefile_depend.sh (100%) rename scripts/{create => module}/create_Needed_modules.sh (100%) rename scripts/{create => module}/create_executables_list.sh (100%) rename scripts/{create => module}/create_gitignore.sh (100%) rename scripts/{create => module}/create_rst_templates.sh (100%) rename scripts/{create/create_module.sh => module/qp_create_module.sh} (93%) diff --git a/scripts/build_modules.sh b/scripts/module/build_modules.sh similarity index 84% rename from scripts/build_modules.sh rename to scripts/module/build_modules.sh index 44c8183a..1b69a920 100755 --- a/scripts/build_modules.sh +++ b/scripts/module/build_modules.sh @@ -30,7 +30,7 @@ Build failed for module $MODULE " fi fi - ${QPACKAGE_ROOT}/scripts/create/create_gitignore.sh + ${QPACKAGE_ROOT}/scripts/module/create_gitignore.sh cd ${OLDPWD} done -${QPACKAGE_ROOT}/scripts/create/create_executables_list.sh +${QPACKAGE_ROOT}/scripts/module/create_executables_list.sh diff --git a/scripts/clean_modules.sh b/scripts/module/clean_modules.sh similarity index 100% rename from scripts/clean_modules.sh rename to scripts/module/clean_modules.sh diff --git a/scripts/create/create_Makefile.sh b/scripts/module/create_Makefile.sh similarity index 100% rename from scripts/create/create_Makefile.sh rename to scripts/module/create_Makefile.sh diff --git a/scripts/create/create_Makefile_depend.sh b/scripts/module/create_Makefile_depend.sh similarity index 100% rename from scripts/create/create_Makefile_depend.sh rename to scripts/module/create_Makefile_depend.sh diff --git a/scripts/create/create_Needed_modules.sh b/scripts/module/create_Needed_modules.sh similarity index 100% rename from scripts/create/create_Needed_modules.sh rename to scripts/module/create_Needed_modules.sh diff --git a/scripts/create/create_executables_list.sh b/scripts/module/create_executables_list.sh similarity index 100% rename from scripts/create/create_executables_list.sh rename to scripts/module/create_executables_list.sh diff --git a/scripts/create/create_gitignore.sh b/scripts/module/create_gitignore.sh similarity index 100% rename from scripts/create/create_gitignore.sh rename to scripts/module/create_gitignore.sh diff --git a/scripts/create/create_rst_templates.sh b/scripts/module/create_rst_templates.sh similarity index 100% rename from scripts/create/create_rst_templates.sh rename to scripts/module/create_rst_templates.sh diff --git a/scripts/create/create_module.sh b/scripts/module/qp_create_module.sh similarity index 93% rename from scripts/create/create_module.sh rename to scripts/module/qp_create_module.sh index a30c1484..0e7e8013 100755 --- a/scripts/create/create_module.sh +++ b/scripts/module/qp_create_module.sh @@ -117,7 +117,7 @@ debug "Module directory is created." # Create the Makefile -"${QPACKAGE_ROOT}/scripts/create/create_Makefile.sh" || fail "Unable to create Makefile" +"${QPACKAGE_ROOT}/scripts/module/create_Makefile.sh" || fail "Unable to create Makefile" if [[ ! -f Makefile ]] then fail "Makefile was not created" @@ -125,7 +125,7 @@ fi debug "Makefile created" # Create the NEEDED_MODULES file -"${QPACKAGE_ROOT}/scripts/create/create_Needed_modules.sh" ${NEEDED_MODULES} || fail "Unable to create the NEEDED_MODULES file" +"${QPACKAGE_ROOT}/scripts/module/create_Needed_modules.sh" ${NEEDED_MODULES} || fail "Unable to create the NEEDED_MODULES file" if [[ ! -f NEEDED_CHILDREN_MODULES ]] then fail "NEEDED_MODULES was not created" @@ -135,7 +135,7 @@ debug "NEEDED_MODULES created" # Create rst templates -"${QPACKAGE_ROOT}/scripts/create/create_rst_templates.sh" || fail "Unable to create rst templates" +"${QPACKAGE_ROOT}/scripts/module/create_rst_templates.sh" || fail "Unable to create rst templates" # Update module list in main NEEDED_MODULES diff --git a/scripts/run_Makefile_common.sh b/scripts/run_Makefile_common.sh index a92507e2..859cc8d0 100755 --- a/scripts/run_Makefile_common.sh +++ b/scripts/run_Makefile_common.sh @@ -28,7 +28,7 @@ fi # Check if README.rst exists if [[ ! -f README.rst ]] then - ${QPACKAGE_ROOT}/scripts/create/create_rst_templates.sh + ${QPACKAGE_ROOT}/scripts/module/create_rst_templates.sh error " README.rst was not present, so I created a default one for you. @@ -62,7 +62,7 @@ then fi # Update Makefile.depend -${QPACKAGE_ROOT}/scripts/create/create_Makefile_depend.sh +${QPACKAGE_ROOT}/scripts/module/create_Makefile_depend.sh # Update EZFIO interface ${QPACKAGE_ROOT}/scripts/ezfio_interface/ei_handler.py diff --git a/src/Makefile b/src/Makefile index 0757825b..93b5234f 100644 --- a/src/Makefile +++ b/src/Makefile @@ -12,17 +12,17 @@ EZFIO=$(EZFIO_DIR)/lib/libezfio_irp.a default: ezfio - $(QPACKAGE_ROOT)/scripts/build_modules.sh $(ALL_MODULES) + $(QPACKAGE_ROOT)/scripts/module/build_modules.sh $(ALL_MODULES) veryclean: - $(QPACKAGE_ROOT)/scripts/clean_modules.sh $(ALL_MODULES) + $(QPACKAGE_ROOT)/scripts/module/clean_modules.sh $(ALL_MODULES) # Define the dict [type in EZFIO.cfg] = ocaml type , f90 type # If you change the qptypes_generator.ml, you need to rm this # For simplicity add this to the veryclean rule - rm $(QPACKAGE_ROOT)/scripts/ezfio_interface/fancy_type.p + rm -f $(QPACKAGE_ROOT)/scripts/ezfio_interface/fancy_type.p $(ALL_MODULES): ezfio - $(QPACKAGE_ROOT)/scripts/build_modules.sh $@ + $(QPACKAGE_ROOT)/scripts/module/build_modules.sh $@ # Define the EZFIO rules $(EZFIO): $(wildcard $(QPACKAGE_ROOT)/src/*/*.ezfio_config) $(wildcard $(QPACKAGE_ROOT)/src/*/EZFIO.cfg) From 851f7df243cc35ef7890d4594481485ed87c3526 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 16:07:53 +0200 Subject: [PATCH 68/70] Change veryclean to delete resultfile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index ec555670..4aa24d00 100644 --- a/Makefile +++ b/Makefile @@ -45,5 +45,5 @@ ocaml: veryclean: rm -rf EZFIO - $(MAKE) EZFIO + rm -rf resultsFile $(MAKE) -C src veryclean From ed02c317bfe5c7241ea4c2614de80c0f529b75f3 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 17:26:41 +0200 Subject: [PATCH 69/70] Fix NEEDED_MODULE --- scripts/module/create_Needed_modules.sh | 6 +++++- src/NEEDED_MODULES | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/scripts/module/create_Needed_modules.sh b/scripts/module/create_Needed_modules.sh index 1158058c..44dc4baa 100755 --- a/scripts/module/create_Needed_modules.sh +++ b/scripts/module/create_Needed_modules.sh @@ -15,4 +15,8 @@ source ${QPACKAGE_ROOT}/scripts/qp_include.sh check_current_dir_is_module OUTPUT=$(module_handler.py check_dependencies $@) -echo $@ > NEEDED_CHILDREN_MODULES \ No newline at end of file + +if [[ $? -eq 0]] +then + echo $@ > NEEDED_CHILDREN_MODULES +fi \ No newline at end of file diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index b4c717a9..4533ccfe 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CAS_SD CID CID_SC2_selected CID_selected CIS CISD CISD_SC2_selected CISD_selected DDCI_selected Determinants Electrons Ezfio_files FCIdump Full_CI Generators_CAS Generators_full Hartree_Fock MOGuess MOs MP2 MRCC Molden MonoInts Nuclei Output Perturbation Properties Pseudo_integrals Selectors_full SingleRefMethod Utils Toto +AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Determinants Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC Pseudo_integrals From d916fb0b1b5c4b10ffb9e524d15b2bf7b092432c Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 4 May 2015 17:26:41 +0200 Subject: [PATCH 70/70] Fix NEEDED_MODULE and qp_create_module --- scripts/module/create_Needed_modules.sh | 6 +++++- scripts/module/qp_create_module.sh | 2 +- src/NEEDED_MODULES | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/scripts/module/create_Needed_modules.sh b/scripts/module/create_Needed_modules.sh index 1158058c..61ea5839 100755 --- a/scripts/module/create_Needed_modules.sh +++ b/scripts/module/create_Needed_modules.sh @@ -15,4 +15,8 @@ source ${QPACKAGE_ROOT}/scripts/qp_include.sh check_current_dir_is_module OUTPUT=$(module_handler.py check_dependencies $@) -echo $@ > NEEDED_CHILDREN_MODULES \ No newline at end of file + +if [[ $? -eq 0 ]] +then + echo $@ > NEEDED_CHILDREN_MODULES +fi \ No newline at end of file diff --git a/scripts/module/qp_create_module.sh b/scripts/module/qp_create_module.sh index 0e7e8013..1a456e67 100755 --- a/scripts/module/qp_create_module.sh +++ b/scripts/module/qp_create_module.sh @@ -71,7 +71,7 @@ debug "Module does not already exist: OK" # Set up dependencies -ALL_MODULES="${NEEDED_MODULES}" +ALL_MODULES="$(cat NEEDED_MODULES)" echo "Select which modules you are sure you will need: (press q to quit)" NEEDED_MODULES="" select M in ${ALL_MODULES} diff --git a/src/NEEDED_MODULES b/src/NEEDED_MODULES index b4c717a9..4533ccfe 100644 --- a/src/NEEDED_MODULES +++ b/src/NEEDED_MODULES @@ -1 +1 @@ -AOs Bielec_integrals Bitmask CAS_SD CID CID_SC2_selected CID_selected CIS CISD CISD_SC2_selected CISD_selected DDCI_selected Determinants Electrons Ezfio_files FCIdump Full_CI Generators_CAS Generators_full Hartree_Fock MOGuess MOs MP2 MRCC Molden MonoInts Nuclei Output Perturbation Properties Pseudo_integrals Selectors_full SingleRefMethod Utils Toto +AOs Bielec_integrals Bitmask CID CID_SC2_selected CID_selected CIS CISD CISD_selected CISD_SC2_selected Determinants Electrons Ezfio_files Full_CI Generators_full Hartree_Fock MOGuess MonoInts MOs MP2 Nuclei Output Selectors_full Utils Molden FCIdump Generators_CAS CAS_SD DDCI_selected MRCC Pseudo_integrals