diff --git a/docs/source/research.bib b/docs/source/research.bib index 67a40766..03ffb39f 100644 --- a/docs/source/research.bib +++ b/docs/source/research.bib @@ -22,6 +22,20 @@ %%%% PUBLISHED PAPERS +@article{Ferte_2019, + doi = {10.1063/1.5082638}, + url = {https://doi.org/10.1063%2F1.5082638}, + year = 2019, + month = {feb}, + publisher = {{AIP} Publishing}, + volume = {150}, + number = {8}, + pages = {084103}, + author = {Anthony Fert{\'{e}} and Emmanuel Giner and Julien Toulouse}, + title = {Range-separated multideterminant density-functional theory with a short-range correlation functional of the on-top pair density}, + journal = {The Journal of Chemical Physics} +} + @article{Loos_2019, doi = {10.1021/acs.jpclett.9b01176}, url = {https://doi.org/10.1021%2Facs.jpclett.9b01176}, diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index c35a2bac..dee01980 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -363,6 +363,12 @@ let () = |> Zmq.Socket.send socket_in in + Printf.printf "On remote hosts, create ssh tunnel using: +ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s\n%!" + (port ) localhost (localport ) + (port+1) localhost (localport+1) + (port+9) localhost (localport+9) + (Unix.gethostname ()); Printf.printf "Ready\n%!"; while !run_status do diff --git a/src/bitmask/bitmasks_routines.irp.f b/src/bitmask/bitmasks_routines.irp.f index 378a3dcd..5c4bf347 100644 --- a/src/bitmask/bitmasks_routines.irp.f +++ b/src/bitmask/bitmasks_routines.irp.f @@ -33,7 +33,7 @@ subroutine bitstring_to_list( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the inidices(+1) of the bits set to 1 in the bit string + ! Gives the indices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) @@ -213,3 +213,34 @@ subroutine print_spindet(string,Nint) print *, trim(output(1)) end + +logical function is_integer_in_string(bite,string,Nint) + use bitmasks + implicit none + integer, intent(in) :: bite,Nint + integer(bit_kind), intent(in) :: string(Nint) + integer(bit_kind) :: string_bite(Nint) + integer :: i,itot,itot_and + character*(2048) :: output(1) + string_bite = 0_bit_kind + call set_bit_to_integer(bite,string_bite,Nint) + itot = 0 + itot_and = 0 + is_integer_in_string = .False. +!print*,'' +!print*,'' +!print*,'bite = ',bite +!call bitstring_to_str( output(1), string_bite, Nint ) +! print *, trim(output(1)) +!call bitstring_to_str( output(1), string, Nint ) +! print *, trim(output(1)) + do i = 1, Nint + itot += popcnt(string(i)) + itot_and += popcnt(ior(string(i),string_bite(i))) + enddo +!print*,'itot,itot_and',itot,itot_and + if(itot == itot_and)then + is_integer_in_string = .True. + endif +!pause +end diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index f830da4e..177c3df5 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -141,6 +141,10 @@ END_PROVIDER n_act_orb_tmp = 0 n_virt_orb_tmp = 0 n_del_orb_tmp = 0 + core_bitmask = 0_bit_kind + inact_bitmask = 0_bit_kind + act_bitmask = 0_bit_kind + virt_bitmask = 0_bit_kind do i = 1, mo_num if(mo_class(i) == 'Core')then n_core_orb_tmp += 1 diff --git a/src/casscf/EZFIO.cfg b/src/casscf/EZFIO.cfg new file mode 100644 index 00000000..d5526673 --- /dev/null +++ b/src/casscf/EZFIO.cfg @@ -0,0 +1,13 @@ +[energy] +type: double precision +doc: Calculated Selected |FCI| energy +interface: ezfio +size: (determinants.n_states) + +[energy_pt2] +type: double precision +doc: Calculated |FCI| energy + |PT2| +interface: ezfio +size: (determinants.n_states) + + diff --git a/src/casscf/NEED b/src/casscf/NEED new file mode 100644 index 00000000..c12b531e --- /dev/null +++ b/src/casscf/NEED @@ -0,0 +1,4 @@ +cipsi +selectors_full +generators_cas +two_body_rdm diff --git a/src/casscf/README.rst b/src/casscf/README.rst new file mode 100644 index 00000000..08bfd95b --- /dev/null +++ b/src/casscf/README.rst @@ -0,0 +1,5 @@ +====== +casscf +====== + +|CASSCF| program with the CIPSI algorithm. diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f new file mode 100644 index 00000000..402e67ec --- /dev/null +++ b/src/casscf/bavard.irp.f @@ -0,0 +1,6 @@ +! -*- F90 -*- +BEGIN_PROVIDER [logical, bavard] +! bavard=.true. + bavard=.false. +END_PROVIDER + diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f new file mode 100644 index 00000000..74351760 --- /dev/null +++ b/src/casscf/bielec.irp.f @@ -0,0 +1,148 @@ + BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] + BEGIN_DOC + ! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num,mo_num)) + + bielec_PQxx = 0.d0 + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j)=integrals_array(p,q) + bielec_PQxx(p,q,j,i)=integrals_array(p,q) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j3)=integrals_array(p,q) + bielec_PQxx(p,q,j3,i)=integrals_array(p,q) + end do + end do + end do + end do + + + ! (ij|pq) + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i3,j3)=integrals_array(p,q) + bielec_PQxx(p,q,j3,i3)=integrals_array(p,q) + end do + end do + end do + end do + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] + BEGIN_DOC + ! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num,mo_num)) + + bielec_PxxQ = 0.d0 + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PxxQ(p,i,j,q)=integrals_array(p,q) + bielec_PxxQ(p,j,i,q)=integrals_array(q,p) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PxxQ(p,i,j3,q)=integrals_array(p,q) + bielec_PxxQ(p,j3,i,q)=integrals_array(q,p) + end do + end do + end do + end do + + + ! (ip|qj) + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q) + bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p) + end do + end do + end do + end do +END_PROVIDER + + +BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] + BEGIN_DOC + ! bielecCI : integrals (tu|vp) with p arbitrary, tuv active + ! index p runs over the whole basis, t,u,v only over the active orbitals + END_DOC + implicit none + integer :: i,j,k,p,t,u,v + double precision, allocatable :: integrals_array(:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num)) + + do i=1,n_act_orb + t=list_act(i) + do j=1,n_act_orb + u=list_act(j) + do k=1,n_act_orb + v=list_act(k) + ! (tu|vp) + call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + bielecCI(i,k,j,p)=integrals_array(p) + end do + end do + end do + end do +END_PROVIDER + diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f new file mode 100644 index 00000000..ca1c8e9d --- /dev/null +++ b/src/casscf/bielec_natorb.irp.f @@ -0,0 +1,270 @@ + BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] + BEGIN_DOC + ! integral (pq|xx) in the basis of natural MOs + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb) + + bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:) + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(list_act(q),j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(list_act(p),j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,list_act(q),k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,list_act(p),k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,k,n_core_orb+q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,k,n_core_orb+p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,k,l,n_core_orb+q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,k,l,n_core_orb+p)=d(p) + end do + end do + end do + end do + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] + BEGIN_DOC + ! integral (px|xq) in the basis of natural MOs + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb) + + bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(list_act(q),k,l,j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(list_act(p),k,l,j)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,n_core_orb+q,l,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,n_core_orb+p,l,k)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,l,n_core_orb+q,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,l,n_core_orb+p,k)=d(p) + end do + end do + end do + end do + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] + BEGIN_DOC + ! integrals (tu|vp) in the basis of natural MOs + ! index p runs over the whole basis, t,u,v only over the active orbitals + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb) + + bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) + + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(p,j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,p,k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,k,p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + +END_PROVIDER + diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f new file mode 100644 index 00000000..4270a9fb --- /dev/null +++ b/src/casscf/casscf.irp.f @@ -0,0 +1,48 @@ +program casscf + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + no_vvvv_integrals = .True. + pt2_max = 0.02 + SOFT_TOUCH no_vvvv_integrals pt2_max + call run +end + +subroutine run + implicit none + double precision :: energy_old, energy + logical :: converged + integer :: iteration + converged = .False. + + energy = 0.d0 + mo_label = "MCSCF" + iteration = 1 + do while (.not.converged) + call run_stochastic_cipsi + energy_old = energy + energy = eone+etwo+ecore + + call write_time(6) + call write_int(6,iteration,'CAS-SCF iteration') + call write_double(6,energy,'CAS-SCF energy') + call write_double(6,energy_improvement, 'Predicted energy improvement') + + converged = dabs(energy_improvement) < thresh_scf + pt2_max = dabs(energy_improvement / pt2_relative_error) + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + iteration += 1 + N_det = N_det/2 + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + read_wf = .True. + FREE mo_integrals_map mo_two_e_integrals_in_map + SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef + + enddo + +end diff --git a/src/casscf/class.irp.f b/src/casscf/class.irp.f new file mode 100644 index 00000000..7360a661 --- /dev/null +++ b/src/casscf/class.irp.f @@ -0,0 +1,12 @@ + BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] +&BEGIN_PROVIDER [ logical, do_ddci ] + implicit none + BEGIN_DOC + ! In the CAS case, all those are always false except do_only_cas + END_DOC + do_only_cas = .True. + do_only_1h1p = .False. + do_ddci = .False. +END_PROVIDER + diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f new file mode 100644 index 00000000..3cfd7583 --- /dev/null +++ b/src/casscf/densities.irp.f @@ -0,0 +1,66 @@ +use bitmasks + +BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] + implicit none + BEGIN_DOC + ! the first-order density matrix in the basis of the starting MOs. + ! matrix is state averaged. + END_DOC + integer :: t,u + + do u=1,n_act_orb + do t=1,n_act_orb + D0tu(t,u) = one_e_dm_mo_alpha_average( list_act(t), list_act(u) ) + & + one_e_dm_mo_beta_average ( list_act(t), list_act(u) ) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] + BEGIN_DOC + ! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS + ! The values are state averaged + ! + ! We use the spin-free generators of mono-excitations + ! E_pq destroys q and creates p + ! D_pq = <0|E_pq|0> = D_qp + ! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0> + ! + ! P0tuvx(p,q,r,s) = chemist notation : 1/2 <0|E_pq E_rs - delta_qr E_ps|0> + END_DOC + implicit none + integer :: t,u,v,x + integer :: tt,uu,vv,xx + integer :: mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + real*8 :: phase1,phase11,phase12,phase2,phase21,phase22 + integer :: nu1,nu2,nu11,nu12,nu21,nu22 + integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22 + real*8 :: cI_mu(N_states),term + integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex + integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12 + integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22 + + if (bavard) then + write(6,*) ' providing the 2 body RDM on the active part' + endif + + P0tuvx= 0.d0 + do istate=1,N_states + do x = 1, n_act_orb + xx = list_act(x) + do v = 1, n_act_orb + vv = list_act(v) + do u = 1, n_act_orb + uu = list_act(u) + do t = 1, n_act_orb + tt = list_act(t) + P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x) + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f new file mode 100644 index 00000000..d8c309a4 --- /dev/null +++ b/src/casscf/det_manip.irp.f @@ -0,0 +1,125 @@ +use bitmasks + +subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & + ispin,phase,ierr) + BEGIN_DOC + ! we create the mono-excitation, and determine, if possible, + ! the phase and the number in the list of determinants + END_DOC + implicit none + integer(bit_kind) :: key1(N_int,2),key2(N_int,2) + integer(bit_kind), allocatable :: keytmp(:,:) + integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin + real*8 :: phase + logical :: found + allocate(keytmp(N_int,2)) + + nu=-1 + phase=1.D0 + ierr=0 + call det_copy(key1,key2,N_int) + ! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin + ! call print_det(key2,N_int) + call do_single_excitation(key2,ihole,ipart,ispin,ierr) + ! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin + ! call print_det(key2,N_int) + ! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr + if (ierr.eq.1) then + ! excitation is possible + ! get the phase + call get_single_excitation(key1,key2,exc,phase,N_int) + ! get the number in the list + found=.false. + nu=0 + + !TODO BOTTLENECK + do while (.not.found) + nu+=1 + if (nu.gt.N_det) then + ! the determinant is possible, but not in the list + found=.true. + nu=-1 + else + call det_extract(keytmp,nu,N_int) + integer :: i,ii + found=.true. + do ii=1,2 + do i=1,N_int + if (keytmp(i,ii).ne.key2(i,ii)) then + found=.false. + end if + end do + end do + end if + end do + end if + ! + ! we found the new string, the phase, and possibly the number in the list + ! +end subroutine do_signed_mono_excitation + +subroutine det_extract(key,nu,Nint) + BEGIN_DOC + ! extract a determinant from the list of determinants + END_DOC + implicit none + integer :: ispin,i,nu,Nint + integer(bit_kind) :: key(Nint,2) + do ispin=1,2 + do i=1,Nint + key(i,ispin)=psi_det(i,ispin,nu) + end do + end do +end subroutine det_extract + +subroutine det_copy(key1,key2,Nint) + use bitmasks ! you need to include the bitmasks_module.f90 features + BEGIN_DOC + ! copy a determinant from key1 to key2 + END_DOC + implicit none + integer :: ispin,i,Nint + integer(bit_kind) :: key1(Nint,2),key2(Nint,2) + do ispin=1,2 + do i=1,Nint + key2(i,ispin)=key1(i,ispin) + end do + end do +end subroutine det_copy + +subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 & + ,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr) + BEGIN_DOC + ! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q) + ! we may create two determinants as result + ! + END_DOC + implicit none + integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2) + integer(bit_kind) :: key_out2(N_int,2) + integer :: ihole,ipart,ierr,jerr,nu1,nu2 + integer :: ispin + real*8 :: phase1,phase2 + + ! write(6,*) ' applying E_',ipart,ihole,' on determinant ' + ! call print_det(key_in,N_int) + + ! spin alpha + ispin=1 + call do_signed_mono_excitation(key_in,key_out1,nu1,ihole & + ,ipart,ispin,phase1,ierr) + ! if (ierr.eq.1) then + ! write(6,*) ' 1 result is ',nu1,phase1 + ! call print_det(key_out1,N_int) + ! end if + ! spin beta + ispin=2 + call do_signed_mono_excitation(key_in,key_out2,nu2,ihole & + ,ipart,ispin,phase2,jerr) + ! if (jerr.eq.1) then + ! write(6,*) ' 2 result is ',nu2,phase2 + ! call print_det(key_out2,N_int) + ! end if + +end subroutine do_spinfree_mono_excitation + diff --git a/src/casscf/driver_optorb.irp.f b/src/casscf/driver_optorb.irp.f new file mode 100644 index 00000000..2e3e02dc --- /dev/null +++ b/src/casscf/driver_optorb.irp.f @@ -0,0 +1,3 @@ +subroutine driver_optorb + implicit none +end diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f new file mode 100644 index 00000000..0a5cfb49 --- /dev/null +++ b/src/casscf/get_energy.irp.f @@ -0,0 +1,36 @@ +program print_2rdm + implicit none + BEGIN_DOC + ! get the active part of the bielectronic energy on a given wave function. + ! + ! useful to test the active part of the spin trace 2 rdms + END_DOC + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + integer :: i,j,k,l + integer :: ii,jj,kk,ll + double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral + thr = 1.d-10 + + + accu = 0.d0 + do ll = 1, n_act_orb + l = list_act(ll) + do kk = 1, n_act_orb + k = list_act(kk) + do jj = 1, n_act_orb + j = list_act(jj) + do ii = 1, n_act_orb + i = list_act(ii) + integral = get_two_e_integral(i,j,k,l,mo_integrals_map) + accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral + enddo + enddo + enddo + enddo + print*,'accu = ',accu(1) +end diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f new file mode 100644 index 00000000..883a4665 --- /dev/null +++ b/src/casscf/gradient.irp.f @@ -0,0 +1,246 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, nMonoEx ] + BEGIN_DOC + ! Number of single excitations + END_DOC + implicit none + nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb +END_PROVIDER + + BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] +&BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)] + BEGIN_DOC + ! a list of the orbitals involved in the excitation + END_DOC + + implicit none + integer :: i,t,a,ii,tt,aa,indx + indx=0 + do ii=1,n_core_orb + i=list_core(ii) + do tt=1,n_act_orb + t=list_act(tt) + indx+=1 + excit(1,indx)=i + excit(2,indx)=t + excit_class(indx)='c-a' + end do + end do + + do ii=1,n_core_orb + i=list_core(ii) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=i + excit(2,indx)=a + excit_class(indx)='c-v' + end do + end do + + do tt=1,n_act_orb + t=list_act(tt) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=t + excit(2,indx)=a + excit_class(indx)='a-v' + end do + end do + + if (bavard) then + write(6,*) ' Filled the table of the Monoexcitations ' + do indx=1,nMonoEx + write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' & + ,excit(2,indx),' ',excit_class(indx) + end do + end if + +END_PROVIDER + +BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)] + BEGIN_DOC + ! calculate the orbital gradient by hand, i.e. for + ! each determinant I we determine the string E_pq |I> (alpha and beta + ! separately) and generate + ! sum_I c_I is then the pq component of the orbital + ! gradient + ! E_pq = a^+_pa_q + a^+_Pa_Q + END_DOC + implicit none + integer :: ii,tt,aa,indx,ihole,ipart,istate + real*8 :: res + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + call calc_grad_elem(ihole,ipart,res) + gradvec(indx)=res + end do + + real*8 :: norm_grad + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec(indx)*gradvec(indx) + end do + norm_grad=sqrt(norm_grad) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + endif + + +END_PROVIDER + +subroutine calc_grad_elem(ihole,ipart,res) + BEGIN_DOC + ! eq 18 of Siegbahn et al, Physica Scripta 1980 + ! we calculate 2 , q=hole, p=particle + END_DOC + implicit none + integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:) + real*8 :: i_H_psi_array(N_states),phase + allocate(det_mu(N_int,2)) + allocate(det_mu_ex(N_int,2)) + + res=0.D0 + + do mu=1,n_det + ! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 + ! do the monoexcitation on it + call det_copy(det_mu,det_mu_ex,N_int) + call do_signed_mono_excitation(det_mu,det_mu_ex,nu & + ,ihole,ipart,ispin,phase,ierr) + if (ierr.eq.1) then + call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase + end do + end if + end do + end do + + ! state-averaged gradient + res*=2.D0/dble(N_states) + +end subroutine calc_grad_elem + +BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] + BEGIN_DOC + ! calculate the orbital gradient from density + ! matrices and integrals; Siegbahn et al, Phys Scr 1980 + ! eqs 14 a,b,c + END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: gradvec_it,gradvec_ia,gradvec_ta + real*8 :: norm_grad + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + gradvec2(indx)=gradvec_it(i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ia(i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ta(t,a) + end do + end do + + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec2(indx)*gradvec2(indx) + end do + norm_grad=sqrt(norm_grad) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + endif + +END_PROVIDER + +real*8 function gradvec_it(i,t) + BEGIN_DOC + ! the orbital gradient core -> active + ! we assume natural orbitals + END_DOC + implicit none + integer :: i,t + + integer :: ii,tt,v,vv,x,y + integer :: x3,y3 + + ii=list_core(i) + tt=list_act(t) + gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) + gradvec_it-=occnum(tt)*Fipq(ii,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + x3=x+n_core_orb + do y=1,n_act_orb + y3=y+n_core_orb + gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3) + end do + end do + end do + gradvec_it*=2.D0 +end function gradvec_it + +real*8 function gradvec_ia(i,a) + BEGIN_DOC + ! the orbital gradient core -> virtual + END_DOC + implicit none + integer :: i,a,ii,aa + + ii=list_core(i) + aa=list_virt(a) + gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) + gradvec_ia*=2.D0 + +end function gradvec_ia + +real*8 function gradvec_ta(t,a) + BEGIN_DOC + ! the orbital gradient active -> virtual + ! we assume natural orbitals + END_DOC + implicit none + integer :: t,a,tt,aa,v,vv,x,y + + tt=list_act(t) + aa=list_virt(a) + gradvec_ta=0.D0 + gradvec_ta+=occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa) + end do + end do + end do + gradvec_ta*=2.D0 + +end function gradvec_ta + diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f new file mode 100644 index 00000000..e047c5fd --- /dev/null +++ b/src/casscf/hessian.irp.f @@ -0,0 +1,630 @@ +use bitmasks + +BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] + BEGIN_DOC + ! calculate the orbital hessian 2 + ! + + by hand, + ! determinant per determinant, as for the gradient + ! + ! we assume that we have natural active orbitals + END_DOC + implicit none + integer :: indx,ihole,ipart + integer :: jndx,jhole,jpart + character*3 :: iexc,jexc + real*8 :: res + + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + endif + + do indx=1,nMonoEx + do jndx=1,nMonoEx + hessmat(indx,jndx)=0.D0 + end do + end do + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + iexc=excit_class(indx) + do jndx=indx,nMonoEx + jhole=excit(1,jndx) + jpart=excit(2,jndx) + jexc=excit_class(jndx) + call calc_hess_elem(ihole,ipart,jhole,jpart,res) + hessmat(indx,jndx)=res + hessmat(jndx,indx)=res + end do + end do + +END_PROVIDER + +subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res) + BEGIN_DOC + ! eq 19 of Siegbahn et al, Physica Scripta 1980 + ! we calculate 2 + ! + + + ! average over all states is performed. + ! no transition between states. + END_DOC + implicit none + integer :: ihole,ipart,ispin,mu,istate + integer :: jhole,jpart,jspin + integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:) + integer(bit_kind), allocatable :: det_nu(:,:) + integer(bit_kind), allocatable :: det_mu_pq(:,:) + integer(bit_kind), allocatable :: det_mu_rs(:,:) + integer(bit_kind), allocatable :: det_nu_rs(:,:) + integer(bit_kind), allocatable :: det_mu_pqrs(:,:) + integer(bit_kind), allocatable :: det_mu_rspq(:,:) + real*8 :: i_H_psi_array(N_states),phase,phase2,phase3 + real*8 :: i_H_j_element + allocate(det_mu(N_int,2)) + allocate(det_nu(N_int,2)) + allocate(det_mu_pq(N_int,2)) + allocate(det_mu_rs(N_int,2)) + allocate(det_nu_rs(N_int,2)) + allocate(det_mu_pqrs(N_int,2)) + allocate(det_mu_rspq(N_int,2)) + integer :: mu_pq_possible + integer :: mu_rs_possible + integer :: nu_rs_possible + integer :: mu_pqrs_possible + integer :: mu_rspq_possible + + res=0.D0 + + ! the terms <0|E E H |0> + do mu=1,n_det + ! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 + ! do the monoexcitation pq on it + call det_copy(det_mu,det_mu_pq,N_int) + call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq & + ,ihole,ipart,ispin,phase,mu_pq_possible) + if (mu_pq_possible.eq.1) then + ! possible, but not necessarily in the list + ! do the second excitation + do jspin=1,2 + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs& + ,jhole,jpart,jspin,phase2,mu_pqrs_possible) + ! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + end do + end if + ! try the de-excitation with opposite sign + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs& + ,jpart,jhole,jspin,phase2,mu_pqrs_possible) + phase2=-phase2 + ! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + end do + end if + end do + end if + ! exchange the notion of pq and rs + ! do the monoexcitation rs on the initial determinant + call det_copy(det_mu,det_mu_rs,N_int) + call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs & + ,jhole,jpart,ispin,phase2,mu_rs_possible) + if (mu_rs_possible.eq.1) then + ! do the second excitation + do jspin=1,2 + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq& + ,ihole,ipart,jspin,phase3,mu_rspq_possible) + ! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + ! we may try the de-excitation, with opposite sign + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq& + ,ipart,ihole,jspin,phase3,mu_rspq_possible) + phase3=-phase3 + ! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + end do + end if + ! + ! the operator E H E, we have to do a double loop over the determinants + ! we still have the determinant mu_pq and the phase in memory + if (mu_pq_possible.eq.1) then + do nu=1,N_det + call det_extract(det_nu,nu,N_int) + do jspin=1,2 + call det_copy(det_nu,det_nu_rs,N_int) + call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs & + ,jhole,jpart,jspin,phase2,nu_rs_possible) + ! excitation possible ? + if (nu_rs_possible.eq.1) then + call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element) + do istate=1,N_states + res+=2.D0*i_H_j_element*psi_coef(mu,istate) & + *psi_coef(nu,istate)*phase*phase2 + end do + end if + end do + end do + end if + end do + end do + + ! state-averaged Hessian + res*=1.D0/dble(N_states) + +end subroutine calc_hess_elem + +BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] + BEGIN_DOC + ! explicit hessian matrix from density matrices and integrals + ! of course, this will be used for a direct Davidson procedure later + ! we will not store the matrix in real life + ! formulas are broken down as functions for the 6 classes of matrix elements + ! + END_DOC + implicit none + integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart + + real*8 :: hessmat_itju + real*8 :: hessmat_itja + real*8 :: hessmat_itua + real*8 :: hessmat_iajb + real*8 :: hessmat_iatb + real*8 :: hessmat_taub + + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + endif + + indx=1 + do i=1,n_core_orb + do t=1,n_act_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + ustart=t + else + ustart=1 + end if + do u=ustart,n_act_orb + hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do j=1,n_core_orb + do a=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do u=1,n_act_orb + do a=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do t=1,n_act_orb + do b=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + jndx=indx + do u=t,n_act_orb + if (t.eq.u) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_taub(t,a,u,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + +END_PROVIDER + +real*8 function hessmat_itju(i,t,j,u) + BEGIN_DOC + ! the orbital hessian for core->act,core->act + ! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu + ! + ! we assume natural orbitals + END_DOC + implicit none + integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj + real*8 :: term,t2 + + ii=list_core(i) + tt=list_act(t) + if (i.eq.j) then + if (t.eq.u) then + ! diagonal element + term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) & + -2.D0*(Fipq(ii,ii)+Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq_no(tt,i,i,tt)-bielec_pqxx_no(tt,tt,i,i)) + term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq_no(tt,i,i,tt) & + -bielec_pqxx_no(tt,tt,i,i)) + term-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(vv,xx,i,i) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) + end do + end do + end do + else + ! it/iu, t != u + uu=list_act(u) + term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu)) + term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(tt,uu,i,j)) + term-=occnum(tt)*Fipq(uu,tt) + term-=(occnum(tt)+occnum(uu)) & + *(3.D0*bielec_PxxQ_no(tt,i,i,uu)-bielec_PQxx_no(uu,tt,i,i)) + do v=1,n_act_orb + vv=list_act(v) + ! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,i) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq_no(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(u,v,y,xx) + end do + end do + end do + end if + else + ! it/ju + jj=list_core(j) + uu=list_act(u) + if (t.eq.u) then + term=occnum(tt)*Fipq(ii,jj) + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + else + term=0.D0 + end if + term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(tt,uu,i,j)) + term-=(occnum(tt)+occnum(uu))* & + (4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(uu,tt,i,j)) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,j) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq_no(vv,i,j,xx)) + end do + end do + end if + + term*=2.D0 + hessmat_itju=term + +end function hessmat_itju + +real*8 function hessmat_itja(i,t,j,a) + BEGIN_DOC + ! the orbital hessian for core->act,core->virt + END_DOC + implicit none + integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y + real*8 :: term + + ! it/ja + ii=list_core(i) + tt=list_act(t) + jj=list_core(j) + aa=list_virt(a) + term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) & + -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) + term-=occnum(tt)*(4.D0*bielec_pxxq_no(aa,j,i,tt) & + -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) + if (i.eq.j) then + term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt)) + term-=0.5D0*occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa) + end do + end do + end do + end if + term*=2.D0 + hessmat_itja=term + +end function hessmat_itja + +real*8 function hessmat_itua(i,t,u,a) + BEGIN_DOC + ! the orbital hessian for core->act,act->virt + END_DOC + implicit none + integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 + real*8 :: term + + ii=list_core(i) + tt=list_act(t) + t3=t+n_core_orb + uu=list_act(u) + u3=u+n_core_orb + aa=list_virt(a) + if (t.eq.u) then + term=-occnum(tt)*Fipq(aa,ii) + else + term=0.D0 + end if + term-=occnum(uu)*(bielec_pqxx_no(aa,ii,t3,u3)-4.D0*bielec_pqxx_no(aa,uu,t3,i)& + +bielec_pxxq_no(aa,t3,u3,ii)) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + integer :: x3 + xx=list_act(x) + x3=x+n_core_orb + term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) & + +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & + *bielec_pqxx_no(aa,xx,v3,i)) + end do + end do + if (t.eq.u) then + term+=Fipq(aa,ii)+Fapq(aa,ii) + end if + term*=2.D0 + hessmat_itua=term + +end function hessmat_itua + +real*8 function hessmat_iajb(i,a,j,b) + BEGIN_DOC + ! the orbital hessian for core->virt,core->virt + END_DOC + implicit none + integer :: i,a,j,b,ii,aa,jj,bb + real*8 :: term + + ii=list_core(i) + aa=list_virt(a) + if (i.eq.j) then + if (a.eq.b) then + ! ia/ia + term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,aa)-bielec_pqxx_no(aa,aa,i,i)) + else + bb=list_virt(b) + ! ia/ib + term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb)) + term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,bb)-bielec_pqxx_no(aa,bb,i,i)) + end if + else + ! ia/jb + jj=list_core(j) + bb=list_virt(b) + term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) & + -bielec_pxxq_no(aa,j,i,bb)) + if (a.eq.b) then + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + end if + end if + term*=2.D0 + hessmat_iajb=term + +end function hessmat_iajb + +real*8 function hessmat_iatb(i,a,t,b) + BEGIN_DOC + ! the orbital hessian for core->virt,act->virt + END_DOC + implicit none + integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 + real*8 :: term + + ii=list_core(i) + aa=list_virt(a) + tt=list_act(t) + bb=list_virt(b) + t3=t+n_core_orb + term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)& + -bielec_pqxx_no(aa,bb,i,t3)) + if (a.eq.b) then + term-=Fipq(tt,ii)+Fapq(tt,ii) + term-=0.5D0*occnum(tt)*Fipq(tt,ii) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,ii) + end do + end do + end do + end if + term*=2.D0 + hessmat_iatb=term + +end function hessmat_iatb + +real*8 function hessmat_taub(t,a,u,b) + BEGIN_DOC + ! the orbital hessian for act->virt,act->virt + END_DOC + implicit none + integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y + integer :: v3,x3 + real*8 :: term,t1,t2,t3 + + tt=list_act(t) + aa=list_virt(a) + if (t.eq.u) then + if (a.eq.b) then + ! ta/ta + t1=occnum(tt)*Fipq(aa,aa) + t2=0.D0 + t3=0.D0 + t1-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(aa,x3,v3,aa)) + do y=1,n_act_orb + t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) + end do + end do + end do + term=t1+t2+t3 + else + bb=list_virt(b) + ! ta/tb b/=a + term=occnum(tt)*Fipq(aa,bb) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq_no(aa,x3,v3,bb)) + end do + end do + end if + else + ! ta/ub t/=u + uu=list_act(u) + bb=list_virt(b) + term=0.D0 + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & + *bielec_pxxq_no(aa,x3,v3,bb)) + end do + end do + if (a.eq.b) then + term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu) + term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt) + end do + end do + end do + end if + + end if + + term*=2.D0 + hessmat_taub=term + +end function hessmat_taub + +BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)] + BEGIN_DOC + ! the diagonal of the Hessian, needed for the Davidson procedure + END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + hessdiag(indx)=hessmat_itju(i,t,i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_iajb(i,a,i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_taub(t,a,t,a) + end do + end do + +END_PROVIDER diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f new file mode 100644 index 00000000..84b87248 --- /dev/null +++ b/src/casscf/mcscf_fock.irp.f @@ -0,0 +1,80 @@ +BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] + BEGIN_DOC + ! the inactive Fock matrix, in molecular orbitals + END_DOC + implicit none + integer :: p,q,k,kk,t,tt,u,uu + + do q=1,mo_num + do p=1,mo_num + Fipq(p,q)=one_ints_no(p,q) + end do + end do + + ! the inactive Fock matrix + do k=1,n_core_orb + kk=list_core(k) + do q=1,mo_num + do p=1,mo_num + Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q) + end do + end do + end do + + if (bavard) then + integer :: i + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + end if + + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] + BEGIN_DOC + ! the active active Fock matrix, in molecular orbitals + ! we create them in MOs, quite expensive + ! + ! for an implementation in AOs we need first the natural orbitals + ! for forming an active density matrix in AOs + ! + END_DOC + implicit none + integer :: p,q,k,kk,t,tt,u,uu + + Fapq = 0.d0 + + ! the active Fock matrix, D0tu is diagonal + do t=1,n_act_orb + tt=list_act(t) + do q=1,mo_num + do p=1,mo_num + Fapq(p,q)+=occnum(tt) & + *(bielec_pqxx_no(p,q,tt,tt)-0.5D0*bielec_pxxq_no(p,tt,tt,q)) + end do + end do + end do + + if (bavard) then + integer :: i + write(6,*) + write(6,*) ' the effective Fock matrix over MOs' + write(6,*) + + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + write(6,*) + write(6,*) ' the diagonal of the active Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num) + write(6,*) + end if + + +END_PROVIDER + + diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f new file mode 100644 index 00000000..52cd3747 --- /dev/null +++ b/src/casscf/natorb.irp.f @@ -0,0 +1,228 @@ + BEGIN_PROVIDER [real*8, occnum, (mo_num)] + implicit none + BEGIN_DOC + ! MO occupation numbers + END_DOC + + integer :: i + occnum=0.D0 + do i=1,n_core_orb + occnum(list_core(i))=2.D0 + end do + + do i=1,n_act_orb + occnum(list_act(i))=occ_act(n_act_orb-i+1) + end do + + if (bavard) then + write(6,*) ' occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + endif + +END_PROVIDER + + + BEGIN_PROVIDER [ real*8, natorbsCI, (n_act_orb,n_act_orb) ] +&BEGIN_PROVIDER [ real*8, occ_act, (n_act_orb) ] + implicit none + BEGIN_DOC + ! Natural orbitals of CI + END_DOC + integer :: i, j + + call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) + + if (bavard) then + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,occ_act(i) + end do + + integer :: nmx + real*8 :: xmx + do i=1,n_act_orb + ! largest element of the eigenvector should be positive + xmx=0.D0 + nmx=0 + do j=1,n_act_orb + if (abs(natOrbsCI(j,i)).gt.xmx) then + nmx=j + xmx=abs(natOrbsCI(j,i)) + end if + end do + xmx=sign(1.D0,natOrbsCI(nmx,i)) + do j=1,n_act_orb + natOrbsCI(j,i)*=xmx + end do + + write(6,*) ' Eigenvector No ',i + write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb) + end do + end if + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC + ! 4-index transformation of 2part matrices + END_DOC + integer :: i,j,k,l,p,q,pp + real*8 :: d(n_act_orb) + + ! index per index + ! first quarter + P0tuvx_no(:,:,:,:) = P0tuvx(:,:,:,:) + + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(p,j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,p,k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,k,p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,k,l,p)=d(p) + end do + end do + end do + end do + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] + implicit none + BEGIN_DOC + ! Transformed one-e integrals + END_DOC + integer :: i,j, p, pp, q + real*8 :: d(n_act_orb) + one_ints_no(:,:)=mo_one_e_integrals(:,:) + + ! 1st half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=one_ints_no(list_act(q),j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + one_ints_no(list_act(p),j)=d(p) + end do + end do + + ! 2nd half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=one_ints_no(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + one_ints_no(j,list_act(p))=d(p) + end do + end do +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] + implicit none + BEGIN_DOC +! FCI natural orbitals + END_DOC + integer :: i,j, p, pp, q + real*8 :: d(n_act_orb) + + NatOrbsFCI(:,:)=mo_coef(:,:) + + do j=1,ao_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + NatOrbsFCI(j,list_act(p))=d(p) + end do + end do +END_PROVIDER + diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f new file mode 100644 index 00000000..f4319485 --- /dev/null +++ b/src/casscf/neworbs.irp.f @@ -0,0 +1,178 @@ +BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] + implicit none + BEGIN_DOC + ! Single-excitation matrix + END_DOC + + integer :: i,j + + do i=1,nMonoEx+1 + do j=1,nMonoEx+1 + SXmatrix(i,j)=0.D0 + end do + end do + + do i=1,nMonoEx + SXmatrix(1,i+1)=gradvec2(i) + SXmatrix(1+i,1)=gradvec2(i) + end do + + do i=1,nMonoEx + do j=1,nMonoEx + SXmatrix(i+1,j+1)=hessmat2(i,j) + SXmatrix(j+1,i+1)=hessmat2(i,j) + end do + end do + + if (bavard) then + do i=2,nMonoEx + write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) + end do + end if + + +END_PROVIDER + + BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)] +&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)] + implicit none + BEGIN_DOC + ! Eigenvectors/eigenvalues of the single-excitation matrix + END_DOC + call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) +END_PROVIDER + + BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)] +&BEGIN_PROVIDER [real*8, energy_improvement] + implicit none + BEGIN_DOC + ! Best eigenvector of the single-excitation matrix + END_DOC + integer :: ierr,matz,i + real*8 :: c0 + + if (bavard) then + write(6,*) ' SXdiag : lowest 5 eigenvalues ' + write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) + write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) + write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) + write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) + write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) + write(6,*) + write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) + endif + energy_improvement = SXeigenval(1) + + integer :: best_vector + real*8 :: best_overlap + best_overlap=0.D0 + do i=1,nMonoEx+1 + if (SXeigenval(i).lt.0.D0) then + if (abs(SXeigenvec(1,i)).gt.best_overlap) then + best_overlap=abs(SXeigenvec(1,i)) + best_vector=i + end if + end if + end do + + energy_improvement = SXeigenval(best_vector) + + c0=SXeigenvec(1,best_vector) + + if (bavard) then + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + write(6,*) ' weight of the 1st element ',c0 + endif + + do i=1,nMonoEx+1 + SXvector(i)=SXeigenvec(i,best_vector)/c0 + end do + + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] + implicit none + BEGIN_DOC + ! Updated orbitals + END_DOC + integer :: i,j,ialph + + call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, & + NatOrbsFCI, size(NatOrbsFCI,1), & + Umat, size(Umat,1), 0.d0, & + NewOrbs, size(NewOrbs,1)) + +END_PROVIDER + +BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] + implicit none + BEGIN_DOC + ! Orbital rotation matrix + END_DOC + integer :: i,j,indx,k,iter,t,a,ii,tt,aa + logical :: converged + + real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num) + real*8 :: Tmat(mo_num,mo_num) + real*8 :: f + + ! the orbital rotation matrix T + Tmat(:,:)=0.D0 + indx=1 + do i=1,n_core_orb + ii=list_core(i) + do t=1,n_act_orb + tt=list_act(t) + indx+=1 + Tmat(ii,tt)= SXvector(indx) + Tmat(tt,ii)=-SXvector(indx) + end do + end do + do i=1,n_core_orb + ii=list_core(i) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(ii,aa)= SXvector(indx) + Tmat(aa,ii)=-SXvector(indx) + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(tt,aa)= SXvector(indx) + Tmat(aa,tt)=-SXvector(indx) + end do + end do + + ! Form the exponential + + Tpotmat(:,:)=0.D0 + Umat(:,:) =0.D0 + do i=1,mo_num + Tpotmat(i,i)=1.D0 + Umat(i,i) =1.d0 + end do + iter=0 + converged=.false. + do while (.not.converged) + iter+=1 + f = 1.d0 / dble(iter) + Tpotmat2(:,:) = Tpotmat(:,:) * f + call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, & + Tpotmat2, size(Tpotmat2,1), & + Tmat, size(Tmat,1), 0.d0, & + Tpotmat, size(Tpotmat,1)) + Umat(:,:) = Umat(:,:) + Tpotmat(:,:) + + converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30) + end do +END_PROVIDER + + + diff --git a/src/casscf/save_energy.irp.f b/src/casscf/save_energy.irp.f new file mode 100644 index 00000000..8729c5af --- /dev/null +++ b/src/casscf/save_energy.irp.f @@ -0,0 +1,9 @@ +subroutine save_energy(E,pt2) + implicit none + BEGIN_DOC +! Saves the energy in |EZFIO|. + END_DOC + double precision, intent(in) :: E(N_states), pt2(N_states) + call ezfio_set_casscf_energy(E(1:N_states)) + call ezfio_set_casscf_energy_pt2(E(1:N_states)+pt2(1:N_states)) +end diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f new file mode 100644 index 00000000..ce787232 --- /dev/null +++ b/src/casscf/tot_en.irp.f @@ -0,0 +1,101 @@ + BEGIN_PROVIDER [real*8, etwo] +&BEGIN_PROVIDER [real*8, eone] +&BEGIN_PROVIDER [real*8, eone_bis] +&BEGIN_PROVIDER [real*8, etwo_bis] +&BEGIN_PROVIDER [real*8, etwo_ter] +&BEGIN_PROVIDER [real*8, ecore] +&BEGIN_PROVIDER [real*8, ecore_bis] + implicit none + integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3 + real*8 :: e_one_all,e_two_all + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & + -bielec_PQxx(tt,ii,i,u3)) + end do + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do u=1,n_act_orb + uu=list_act(u) + e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3) + end do + end do + end do + end do + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*mo_one_e_integrals(ii,ii) + ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii) + end do + end do + eone =0.D0 + eone_bis=0.D0 + etwo =0.D0 + etwo_bis=0.D0 + etwo_ter=0.D0 + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu) + eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do i=1,n_core_orb + ii=list_core(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & + -bielec_PQxx(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) & + -bielec_PxxQ(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + real*8 :: h1,h2,h3 + h1=bielec_PQxx(tt,uu,v3,x3) + h2=bielec_PxxQ(tt,u3,v3,xx) + h3=bielecCI(t,u,v,xx) + etwo +=P0tuvx(t,u,v,x)*h1 + etwo_bis+=P0tuvx(t,u,v,x)*h2 + etwo_ter+=P0tuvx(t,u,v,x)*h3 + if ((h1.ne.h2).or.(h1.ne.h3)) then + write(6,9901) t,u,v,x,h1,h2,h3 + 9901 format('aie: ',4I4,3E20.12) + end if + end do + end do + end do + end do + +END_PROVIDER + + diff --git a/src/cipsi/cipsi.irp.f b/src/cipsi/cipsi.irp.f index 7e292d6e..ba922c49 100644 --- a/src/cipsi/cipsi.irp.f +++ b/src/cipsi/cipsi.irp.f @@ -13,6 +13,7 @@ subroutine run_cipsi rss = memory_of_double(N_states)*4.d0 call check_mem(rss,irp_here) + N_iter = 1 allocate (pt2(N_states), zeros(N_states), rpt2(N_states), norm(N_states), variance(N_states)) double precision :: hf_energy_ref diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index 9f891320..7825d24c 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -135,7 +135,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in) PROVIDE psi_occ_pattern_hii det_to_occ_pattern endif - if (N_det < max(4,N_states)) then + if (N_det <= max(4,N_states)) then pt2=0.d0 variance=0.d0 norm=0.d0 @@ -719,6 +719,15 @@ END_PROVIDER double precision :: rss double precision, external :: memory_of_double, memory_of_int + if (N_det_generators == 1) then + pt2_w = 1.d0 + pt2_cw = 1.d0 + pt2_W_T = 1.d0 + pt2_u_0 = 1.d0 + pt2_n_0 = 1 + return + endif + rss = memory_of_double(2*N_det_generators+1) call check_mem(rss,irp_here) @@ -754,7 +763,7 @@ END_PROVIDER end if pt2_n_0(1) += 1 if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then - stop "teeth building failed" + print *, "teeth building failed" end if end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index df31bc39..062b44bf 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -683,6 +683,16 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + if (do_ddci) then logical, external :: is_a_two_holes_two_particles if (is_a_two_holes_two_particles(det)) then diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index ae2b7519..4f968ef7 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -12,6 +12,7 @@ subroutine run_stochastic_cipsi double precision, external :: memory_of_double PROVIDE H_apply_buffer_allocated N_generators_bitmask + N_iter = 1 threshold_generators = 1.d0 SOFT_TOUCH threshold_generators diff --git a/src/determinants/create_excitations.irp.f b/src/determinants/create_excitations.irp.f index ddb9ae0f..cec87901 100644 --- a/src/determinants/create_excitations.irp.f +++ b/src/determinants/create_excitations.irp.f @@ -12,6 +12,7 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok) integer(bit_kind), intent(inout) :: key_in(N_int,2) integer, intent(out) :: i_ok integer :: k,j,i + integer(bit_kind) :: mask use bitmasks ASSERT (i_hole > 0 ) ASSERT (i_particle <= mo_num) @@ -19,31 +20,66 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok) ! hole k = shiftr(i_hole-1,bit_kind_shift)+1 j = i_hole-shiftl(k-1,bit_kind_shift)-1 + mask = ibset(0_bit_kind,j) ! check whether position j is occupied - if (ibits(key_in(k,ispin),j,1).eq.1) then + if (iand(key_in(k,ispin),mask) /= 0_bit_kind) then key_in(k,ispin) = ibclr(key_in(k,ispin),j) else i_ok= -1 + return end if ! particle k = shiftr(i_particle-1,bit_kind_shift)+1 j = i_particle-shiftl(k-1,bit_kind_shift)-1 - key_in(k,ispin) = ibset(key_in(k,ispin),j) + mask = ibset(0_bit_kind,j) + if (iand(key_in(k,ispin),mask) == 0_bit_kind) then + key_in(k,ispin) = ibset(key_in(k,ispin),j) + else + i_ok= -1 + return + end if - 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 - !print*, n_elec_tmp,elec_num - !call debug_det(key_in,N_int) - i_ok = -1 - endif +! 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 +! print*, n_elec_tmp,elec_num +! call debug_det(key_in,N_int) +! stop -1 +! endif end +subroutine build_singly_excited_wavefunction(i_hole,i_particle,ispin,det_out,coef_out) + implicit none + BEGIN_DOC + ! Applies the single excitation operator : a^{dager}_(i_particle) a_(i_hole) of + ! spin = ispin to the current wave function (psi_det, psi_coef) + END_DOC + integer, intent(in) :: i_hole,i_particle,ispin + integer(bit_kind), intent(out) :: det_out(N_int,2,N_det) + double precision, intent(out) :: coef_out(N_det,N_states) + + integer :: k + integer :: i_ok + double precision :: phase + do k=1,N_det + coef_out(k,:) = psi_coef(k,:) + det_out(:,:,k) = psi_det(:,:,k) + call do_single_excitation(det_out(1,1,k),i_hole,i_particle,ispin,i_ok) + if (i_ok == 1) then + call get_phase(psi_det(1,1,k), det_out(1,1,k),phase,N_int) + coef_out(k,:) = phase * coef_out(k,:) + else + coef_out(k,:) = 0.d0 + det_out(:,:,k) = psi_det(:,:,k) + endif + enddo +end + logical function is_spin_flip_possible(key_in,i_flip,ispin) implicit none BEGIN_DOC diff --git a/src/determinants/occ_pattern.irp.f b/src/determinants/occ_pattern.irp.f index d5f458a0..5f37b289 100644 --- a/src/determinants/occ_pattern.irp.f +++ b/src/determinants/occ_pattern.irp.f @@ -53,7 +53,17 @@ 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 + ! Generate all possible determinants for a given occ_pattern + ! + ! Input : + ! o : occupation pattern : (doubly occupied, singly occupied) + ! sze : Number of produced determinants, computed by `occ_pattern_to_dets_size` + ! n_alpha : Number of $\alpha$ electrons + ! Nint : N_int + ! + ! Output: + ! d : determinants + ! END_DOC integer ,intent(in) :: Nint integer ,intent(in) :: n_alpha ! Number of alpha electrons diff --git a/src/determinants/two_e_density_matrix.irp.pouet b/src/determinants/two_e_density_matrix.irp.pouet new file mode 100644 index 00000000..7f8f4896 --- /dev/null +++ b/src/determinants/two_e_density_matrix.irp.pouet @@ -0,0 +1,609 @@ + + BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_bod_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_bod_alpha_beta_mo = 0.d0 + print*,'providing two_bod_alpha_beta ...' + call wall_time(cpu_0) + call two_body_dm_nstates_openmp(two_bod_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(cpu_1) + print*,'two_bod_alpha_beta provided in',dabs(cpu_1-cpu_0) + + integer :: ii,jj,i,j,k,l + if(no_core_density .EQ. "no_core_dm")then + print*,'USING THE VALENCE ONLY TWO BODY DENSITY' + + do ii = 1, n_core_orb ! 1 + i = list_core(ii) + do j = 1, mo_num ! 2 + do k = 1, mo_num ! 1 + do l = 1, mo_num ! 2 + ! 2 2 1 1 + two_bod_alpha_beta_mo(l,j,k,i,:) = 0.d0 + two_bod_alpha_beta_mo(j,l,k,i,:) = 0.d0 + two_bod_alpha_beta_mo(l,j,i,k,:) = 0.d0 + two_bod_alpha_beta_mo(j,l,i,k,:) = 0.d0 + + two_bod_alpha_beta_mo(k,i,l,j,:) = 0.d0 + two_bod_alpha_beta_mo(k,i,j,l,:) = 0.d0 + two_bod_alpha_beta_mo(i,k,l,j,:) = 0.d0 + two_bod_alpha_beta_mo(i,k,j,l,:) = 0.d0 + enddo + enddo + enddo + enddo + + + endif + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_bod_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_bod_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_bod_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_bod_alpha_beta_mo_physicist(l,k,i,j,istate) = two_bod_alpha_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo + enddo + enddo + call wall_time(cpu_1) + print*,'two_bod_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + + END_PROVIDER + + + subroutine two_body_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + + end + + + subroutine two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call two_body_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_body_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_body_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_body_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call two_body_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + BEGIN_TEMPLATE + + subroutine two_body_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + double precision :: hij, sij + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!!!!!!!!!!!!!!!! ALPHA BETA + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_body_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + + + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!! MONO SPIN + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + + enddo + + + !! Compute Hij for all alpha doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_a = doubles(i) + ! ASSERT (l_a <= N_det) + + ! lrow = psi_bilinear_matrix_rows(l_a) + ! ASSERT (lrow <= N_det_alpha_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + enddo + ! + !! Compute Hij for all beta doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_b = doubles(i) + ! ASSERT (l_b <= N_det) + + ! lcol = psi_bilinear_matrix_transp_columns(l_b) + ! ASSERT (lcol <= N_det_beta_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + ! l_a = psi_bilinear_matrix_transp_order(l_b) + ! ASSERT (l_a <= N_det) + + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_two_body_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) + + end do + deallocate(buffer, singles_a, singles_b, doubles, idx) + + end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + + subroutine diagonal_contrib_to_two_body_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + enddo + end + + subroutine diagonal_contrib_to_all_two_body_dm(det_1,c_1,big_array_ab,big_array_aa,big_array_bb,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_ab(h1,h1,h2,h2,istate) += c_1_bis + enddo + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array_aa(h1,h2,h1,h2,istate) -= c_1_bis + big_array_aa(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_bb(h1,h1,h2,h2,istate) += c_1_bis + big_array_bb(h1,h2,h1,h2,istate) -= c_1_bis + enddo + enddo + enddo + end + + + subroutine off_diagonal_double_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) +! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_single_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end diff --git a/src/fci/class.irp.f b/src/fci/class.irp.f index 425691ae..b4a68ac2 100644 --- a/src/fci/class.irp.f +++ b/src/fci/class.irp.f @@ -1,10 +1,12 @@ BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] &BEGIN_PROVIDER [ logical, do_ddci ] implicit none BEGIN_DOC ! In the FCI case, all those are always false END_DOC do_only_1h1p = .False. + do_only_cas = .False. do_ddci = .False. END_PROVIDER diff --git a/src/generators_cas/generators.irp.f b/src/generators_cas/generators.irp.f index c22eab51..b2f58202 100644 --- a/src/generators_cas/generators.irp.f +++ b/src/generators_cas/generators.irp.f @@ -55,6 +55,7 @@ END_PROVIDER nongen(inongen) = i endif enddo + ASSERT (m == N_det_generators) psi_det_sorted_gen(:,:,:N_det_generators) = psi_det_generators(:,:,:N_det_generators) psi_coef_sorted_gen(:N_det_generators, :) = psi_coef_generators(:N_det_generators, :) diff --git a/src/tools/print_ci_vectors.irp.f b/src/tools/print_ci_vectors.irp.f index 9ba06d9a..97dfdc0b 100644 --- a/src/tools/print_ci_vectors.irp.f +++ b/src/tools/print_ci_vectors.irp.f @@ -24,6 +24,7 @@ subroutine routine implicit none integer :: i,k integer :: degree + call print_energy_components do i = 1, N_det print *, 'Determinant ', i call debug_det(psi_det(1,1,i),N_int) diff --git a/src/two_body_rdm/NEED b/src/two_body_rdm/NEED new file mode 100644 index 00000000..711fbf96 --- /dev/null +++ b/src/two_body_rdm/NEED @@ -0,0 +1 @@ +davidson_undressed diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst new file mode 100644 index 00000000..978240c9 --- /dev/null +++ b/src/two_body_rdm/README.rst @@ -0,0 +1,8 @@ +============ +two_body_rdm +============ + +Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as +arrays, with pysicists notation, consistent with the two-electron integrals in the +MO basis. + diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f new file mode 100644 index 00000000..9041c753 --- /dev/null +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -0,0 +1,402 @@ + + subroutine two_rdm_ab_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + + end + + + subroutine two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the alpha/beta part of the two-body density matrix + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call two_rdm_ab_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_rdm_ab_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_rdm_ab_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_rdm_ab_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call two_rdm_ab_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + BEGIN_TEMPLATE + + subroutine two_rdm_ab_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + double precision :: hij, sij + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!!!!!!!!!!!!!!!! ALPHA BETA + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + + + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!! MONO SPIN + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + + enddo + + + !! Compute Hij for all alpha doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_a = doubles(i) + ! ASSERT (l_a <= N_det) + + ! lrow = psi_bilinear_matrix_rows(l_a) + ! ASSERT (lrow <= N_det_alpha_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + enddo + ! + !! Compute Hij for all beta doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_b = doubles(i) + ! ASSERT (l_b <= N_det) + + ! lcol = psi_bilinear_matrix_transp_columns(l_b) + ! ASSERT (lcol <= N_det_beta_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + ! l_a = psi_bilinear_matrix_transp_order(l_b) + ! ASSERT (l_a <= N_det) + + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_two_rdm_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) + + end do + deallocate(buffer, singles_a, singles_b, doubles, idx) + + end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f new file mode 100644 index 00000000..3f08b18f --- /dev/null +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -0,0 +1,442 @@ +subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the alpha/alpha, beta/beta and alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + + +subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call all_two_rdm_dm_nstates_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + BEGIN_TEMPLATE + +subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$ + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + ! !$OMP END DO + + ! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the alpha/alpha part for single excitations + call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + enddo + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the beta /beta part for single excitations + call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + + enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f new file mode 100644 index 00000000..c40c46d2 --- /dev/null +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -0,0 +1,83 @@ + + + + BEGIN_PROVIDER [double precision, act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + act_two_rdm_alpha_alpha_mo = 0.D0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + act_two_rdm_beta_beta_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'providint act_two_rdm_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + act_two_rdm_alpha_beta_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC +! act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! The active part of the two-electron energy can be computed as: +! +! \sum_{i,j,k,l = 1, n_act_orb} act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! +! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) + END_DOC + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 4 + act_two_rdm_spin_trace_mo = 0.d0 + integer :: i + + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f new file mode 100644 index 00000000..0157c46b --- /dev/null +++ b/src/two_body_rdm/orb_range_routines.irp.f @@ -0,0 +1,496 @@ +subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st) + + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + + integer :: k + + PROVIDE N_int + + select case (N_int) + case (1) + call orb_range_two_rdm_dm_nstates_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call orb_range_two_rdm_dm_nstates_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call orb_range_two_rdm_dm_nstates_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call orb_range_two_rdm_dm_nstates_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call orb_range_two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + + + + BEGIN_TEMPLATE +subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the two rdm for the N_st vectors |u_t> + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb + ! In any cases, the state average weights will be used with an array state_weights + ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + double precision :: c_average + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + integer(bit_kind) :: orb_bitmask($N_int) + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + else + print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_openmp_work' + print*,'ispin = ',ispin + stop + endif + + PROVIDE N_int + + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + if(alpha_beta.or.spin_trace)then + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + enddo + endif + + enddo + + enddo + ! !$OMP END DO + + ! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta.or.spin_trace.or.alpha_alpha)then + ! increment the alpha/beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ! increment the alpha/alpha part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + endif + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + if(alpha_alpha.or.spin_trace)then + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + enddo + endif + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta.or.spin_trace.or.beta_beta)then + ! increment the alpha/beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ! increment the beta /beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + endif + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + if(beta_beta.or.spin_trace)then + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ASSERT (l_a <= N_det) + + enddo + endif + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + c_average = 0.d0 + do l = 1, N_states + c_1(l) = u_t(l,k_a) + c_average += c_1(l) * c_1(l) * state_weights(l) + enddo + + call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + diff --git a/src/two_body_rdm/routines_compute_2rdm.irp.f b/src/two_body_rdm/routines_compute_2rdm.irp.f new file mode 100644 index 00000000..112d2e36 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm.irp.f @@ -0,0 +1,269 @@ + + + subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + enddo + end + + + subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of ALL THREE two body rdm IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_ab(h1,h1,h2,h2,istate) += c_1_bis + enddo + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array_aa(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis + big_array_aa(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis + enddo + enddo + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_bb(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis + big_array_bb(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis + enddo + enddo + enddo + end + + + subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) +! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end + + subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + + big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + return + endif + end + + subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + + big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end + + + subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) +!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + + big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) +!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + + big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + enddo + end + diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f new file mode 100644 index 00000000..a3c7a76d --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -0,0 +1,674 @@ + + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,orb_bitmask) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals +! c_1 is supposed to be a scalar quantity, such as state averaged coef + END_DOC + implicit none + integer, intent(in) :: dim1 + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1 + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h2,h1,h2) += c_1 + enddo + enddo + end + + + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm + END_DOC + implicit none + integer, intent(in) :: dim1,ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + integer(bit_kind) :: det_1_act(N_int,2) + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + do i = 1, N_int + det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) + det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) + enddo + +!print*,'ahah' +!call debug_det(det_1_act,N_int) +!pause + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) + logical :: is_integer_in_string + integer :: i1,i2 + if(alpha_beta)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += c_1 + enddo + enddo + else if (alpha_alpha)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(1) + i2 = occ(j,1) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + else if (beta_beta)then + do i = 1, n_occ_ab(2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 ) + big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 ) + enddo + enddo + !stop + do i = 1, n_occ_ab(1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(1) + i2 = occ(j,1) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + do i = 1, n_occ_ab(2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle + do j = 1, n_occ_ab(2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif +!print*,'' +!do i = 1, mo_num +! print*,'list_orb',i,list_orb_reverse(i) +!enddo + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) +!print*,'h1',h1 + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) +!print*,'passed h1 = ',h1 + h2 = exc(1,1,2) +!print*,'h2',h2 + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) +!print*,'passed h2 = ',h2 + p1 = exc(1,2,1) +!print*,'p1',p1 + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) +!print*,'passed p1 = ',p1 + p2 = exc(1,2,2) +!print*,'p2',p2 + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) +!print*,'passed p2 = ',p2 + if(alpha_beta)then + big_array(h1,h2,p1,p2) += c_1 * phase + else if(spin_trace)then + big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase + big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase + !print*,'h1,h2,p1,p2',h1,h2,p1,p2 + !print*,'',big_array(h1,h2,p1,p2) + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_beta)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2) += c_1 * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h2,h1,h2,p1) += c_1 * phase + enddo + endif + else if(spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + enddo + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 1 or 4 will do something + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_alpha.or.spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(beta_beta.or.spin_trace)then + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase + enddo + enddo + endif + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 1 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) + if(alpha_alpha.or.spin_trace)then + do istate = 1, N_states + big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase + big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase + enddo + endif + end + + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + + integer, intent(in) :: dim1,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) + if(beta_beta.or.spin_trace)then + big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase + big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase + + big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase + big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase + endif + end + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f new file mode 100644 index 00000000..06a8e1e6 --- /dev/null +++ b/src/two_body_rdm/two_rdm.irp.f @@ -0,0 +1,62 @@ + BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_rdm_alpha_beta_mo = 0.d0 + two_rdm_alpha_alpha_mo= 0.d0 + two_rdm_beta_beta_mo = 0.d0 + print*,'providing two_rdm_alpha_beta ...' + call wall_time(cpu_0) + call all_two_rdm_dm_nstates_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_rdm_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_rdm_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate) + two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate) + two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo + enddo + enddo + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER + diff --git a/src/zmq/utils.irp.f b/src/zmq/utils.irp.f index 2a0c1d2e..70f0830b 100644 --- a/src/zmq/utils.irp.f +++ b/src/zmq/utils.irp.f @@ -748,10 +748,11 @@ integer function add_task_to_taskserver(zmq_to_qp_run_socket,task) character*(*), intent(in) :: task integer :: rc, sze - character(len=:), allocatable :: message + character(len=:), allocatable :: message add_task_to_taskserver = 0 + allocate(character(len=len(task)+10+len(zmq_state)) :: message) message='add_task '//trim(zmq_state)//' '//trim(task) sze = len(message) rc = f77_zmq_send(zmq_to_qp_run_socket, message, sze, 0)